Skip to content

Commit 47d547d

Browse files
garybgaryb
committed
Merge pull request purescript#1890 from purescript/dctor-operator-aliases
Operator aliases for data constructors
2 parents 291ff0b + 9a377c4 commit 47d547d

File tree

21 files changed

+451
-120
lines changed

21 files changed

+451
-120
lines changed

‎examples/failing/DctorOperatorAliasExport.purs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
-- @shouldFailWith TransitiveDctorExportError
2+
module Data.List (List, (:)) where
3+
4+
data List a = Cons a (List a) | Nil
5+
6+
infixr 6 Cons as :

‎examples/failing/InvalidOperatorInBinder.purs‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
-- @shouldFailWith InvalidOperatorInBinder
2+
module Main where
3+
4+
data List a = Cons a (List a) | Nil
5+
6+
cons ∷ ∀ a. a → List a → List a
7+
cons = Cons
8+
9+
infixl 6 cons as :
10+
11+
get ∷ ∀ a. List a → a
12+
get (_ : x : _) = x

‎examples/passing/DctorOperatorAlias.purs‎

Lines changed: 35 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,35 @@
1+
module Data.List where
2+
3+
data List a = Cons a (List a) | Nil
4+
5+
infixr 6 Cons as :
6+
7+
module Main where
8+
9+
import Prelude (Unit, bind, (==))
10+
import Control.Monad.Eff (Eff)
11+
import Control.Monad.Eff.Console (CONSOLE, log)
12+
import Test.Assert (ASSERT, assert')
13+
import Data.List (List(..), (:))
14+
15+
infixl 6 Cons as !
16+
17+
get1 ∷ ∀ a. a → List a → a
18+
get1 y xs = case xs of
19+
_ : x : _ → x
20+
_ → y
21+
22+
get2 ∷ ∀ a. a → List a → a
23+
get2 _ (_ : x : _) = x
24+
get2 y _ = y
25+
26+
get3 ∷ ∀ a. a → List a → a
27+
get3 _ (_ ! (x ! _)) = x
28+
get3 y _ = y
29+
30+
main ∷ Eff (assert ∷ ASSERT, console ∷ CONSOLE) Unit
31+
main = do
32+
assert' "Incorrect result!" (get1 0 (1 : 2 : 3 : Nil) == 2)
33+
assert' "Incorrect result!" (get2 0 (1 ! (2 ! (3 ! Nil))) == 2)
34+
assert' "Incorrect result!" (get3 0.0 (1.0 : 2.0 : (3.0 ! Nil)) == 2.0)
35+
log "Done"

‎purescript.cabal‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -149,6 +149,9 @@ library
149149
Language.PureScript.Sugar.Names.Exports
150150
Language.PureScript.Sugar.ObjectWildcards
151151
Language.PureScript.Sugar.Operators
152+
Language.PureScript.Sugar.Operators.Common
153+
Language.PureScript.Sugar.Operators.Expr
154+
Language.PureScript.Sugar.Operators.Binders
152155
Language.PureScript.Sugar.TypeClasses
153156
Language.PureScript.Sugar.TypeClasses.Deriving
154157
Language.PureScript.Sugar.TypeDeclarations

‎src/Language/PureScript/AST/Binders.hs‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,24 @@ data Binder
4141
--
4242
| ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder]
4343
-- |
44+
-- A operator alias binder. During the rebracketing phase of desugaring,
45+
-- this data constructor will be removed.
46+
--
47+
| OpBinder (Qualified Ident)
48+
-- |
49+
-- Binary operator application. During the rebracketing phase of desugaring,
50+
-- this data constructor will be removed.
51+
--
52+
| BinaryNoParensBinder Binder Binder Binder
53+
-- |
54+
-- Explicit parentheses. During the rebracketing phase of desugaring, this
55+
-- data constructor will be removed.
56+
--
57+
-- Note: although it seems this constructor is not used, it _is_ useful,
58+
-- since it prevents certain traversals from matching.
59+
--
60+
| ParensInBinder Binder
61+
-- |
4462
-- A binder which matches a record and binds its properties
4563
--
4664
| ObjectBinder [(String, Binder)]
@@ -70,6 +88,8 @@ binderNames = go []
7088
where
7189
go ns (VarBinder name) = name : ns
7290
go ns (ConstructorBinder _ bs) = foldl go ns bs
91+
go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3]
92+
go ns (ParensInBinder b) = go ns b
7393
go ns (ObjectBinder bs) = foldl go ns (map snd bs)
7494
go ns (ArrayBinder bs) = foldl go ns bs
7595
go ns (NamedBinder name b) = go (name : ns) b

‎src/Language/PureScript/AST/Declarations.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -189,7 +189,7 @@ data Declaration
189189
-- |
190190
-- A fixity declaration (fixity data, operator name, value the operator is an alias for)
191191
--
192-
| FixityDeclaration Fixity String (Maybe (Qualified Ident))
192+
| FixityDeclaration Fixity String (Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))))
193193
-- |
194194
-- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
195195
-- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)

‎src/Language/PureScript/AST/Traversals.hs‎

Lines changed: 15 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -69,6 +69,8 @@ everywhereOnValues f g h = (f', g', h')
6969

7070
h' :: Binder -> Binder
7171
h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))
72+
h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))
73+
h' (ParensInBinder b) = h (ParensInBinder (h' b))
7274
h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))
7375
h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))
7476
h' (NamedBinder name b) = h (NamedBinder name (h' b))
@@ -124,6 +126,8 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
124126
g' other = g other
125127

126128
h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs
129+
h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')
130+
h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')
127131
h' (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h' <=< h)) bs
128132
h' (ArrayBinder bs) = ArrayBinder <$> traverse (h' <=< h) bs
129133
h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
@@ -175,6 +179,8 @@ everywhereOnValuesM f g h = (f', g', h')
175179
g' other = g other
176180

177181
h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h
182+
h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h
183+
h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h
178184
h' (ObjectBinder bs) = (ObjectBinder <$> traverse (sndM h') bs) >>= h
179185
h' (ArrayBinder bs) = (ArrayBinder <$> traverse h' bs) >>= h
180186
h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
@@ -229,6 +235,8 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
229235
g' v = g v
230236

231237
h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)
238+
h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3
239+
h' b@(ParensInBinder b1) = h b <> h' b1
232240
h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)
233241
h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)
234242
h' b@(NamedBinder _ b1) = h b <> h' b1
@@ -296,6 +304,8 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
296304
h'' s b = let (s', r) = h s b in r <> h' s' b
297305

298306
h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)
307+
h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3
308+
h' s (ParensInBinder b) = h'' s b
299309
h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)
300310
h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)
301311
h' s (NamedBinder _ b1) = h'' s b1
@@ -364,6 +374,8 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
364374
h'' s = uncurry h' <=< h s
365375

366376
h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs
377+
h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3
378+
h' s (ParensInBinder b) = ParensInBinder <$> h'' s b
367379
h' s (ObjectBinder bs) = ObjectBinder <$> traverse (sndM (h'' s)) bs
368380
h' s (ArrayBinder bs) = ArrayBinder <$> traverse (h'' s) bs
369381
h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
@@ -451,11 +463,11 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
451463
h'' s a = h s a <> h' s a
452464

453465
h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs
466+
h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]
467+
h' s (ParensInBinder b) = h'' s b
454468
h' s (ObjectBinder bs) = foldMap (h'' s . snd) bs
455469
h' s (ArrayBinder bs) = foldMap (h'' s) bs
456-
h' s (NamedBinder name b1) =
457-
let s' = S.insert name s
458-
in h'' s' b1
470+
h' s (NamedBinder name b1) = h'' (S.insert name s) b1
459471
h' s (PositionedBinder _ _ b1) = h'' s b1
460472
h' s (TypedBinder _ b1) = h'' s b1
461473
h' _ _ = mempty

‎src/Language/PureScript/CoreFn/Desugar.hs‎

Lines changed: 18 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -55,7 +55,9 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
5555
declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =
5656
[NonRec name (exprToCoreFn ss com Nothing e)]
5757
declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =
58-
[NonRec (Op name) (Var (ss, com, Nothing, getValueMeta alias) alias)]
58+
let meta = either getValueMeta (Just . getConstructorMeta) alias
59+
alias' = either id (fmap properToIdent) alias
60+
in [NonRec (Op name) (Var (ss, com, Nothing, meta) alias')]
5961
declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
6062
[Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]
6163
declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =
@@ -157,6 +159,12 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
157159
binderToCoreFn (Just ss) (com ++ com1) b
158160
binderToCoreFn ss com (A.TypedBinder _ b) =
159161
binderToCoreFn ss com b
162+
binderToCoreFn _ _ A.OpBinder{} =
163+
internalError "OpBinder should have been desugared before binderToCoreFn"
164+
binderToCoreFn _ _ A.BinaryNoParensBinder{} =
165+
internalError "BinaryNoParensBinder should have been desugared before binderToCoreFn"
166+
binderToCoreFn _ _ A.ParensInBinder{} =
167+
internalError "ParensInBinder should have been desugared before binderToCoreFn"
160168

161169
-- |
162170
-- Gets metadata for values.
@@ -201,19 +209,23 @@ findQualModules decls =
201209
in f `concatMap` decls
202210
where
203211
fqDecls :: A.Declaration -> [ModuleName]
204-
fqDecls (A.TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]
205-
fqDecls (A.FixityDeclaration _ _ (Just (Qualified (Just mn) _))) = [mn]
212+
fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q
213+
fqDecls (A.FixityDeclaration _ _ (Just eq)) = either getQual getQual eq
206214
fqDecls _ = []
207215

208216
fqValues :: A.Expr -> [ModuleName]
209-
fqValues (A.Var (Qualified (Just mn) _)) = [mn]
210-
fqValues (A.Constructor (Qualified (Just mn) _)) = [mn]
217+
fqValues (A.Var q) = getQual q
218+
fqValues (A.Constructor q) = getQual q
211219
fqValues _ = []
212220

213221
fqBinders :: A.Binder -> [ModuleName]
214-
fqBinders (A.ConstructorBinder (Qualified (Just mn) _) _) = [mn]
222+
fqBinders (A.ConstructorBinder q _) = getQual q
215223
fqBinders _ = []
216224

225+
getQual :: Qualified a -> [ModuleName]
226+
getQual (Qualified (Just mn) _) = [mn]
227+
getQual _ = []
228+
217229
-- |
218230
-- Desugars import declarations from AST to CoreFn representation.
219231
--

‎src/Language/PureScript/Docs/Render.hs‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -61,7 +61,11 @@ renderDeclarationWithOptions opts Declaration{..} =
6161
AliasDeclaration for (P.Fixity associativity precedence) ->
6262
[ keywordFixity associativity
6363
, syntax $ show precedence
64-
, ident $ P.showQualified P.runIdent $ dequalifyCurrentModule for
64+
, ident $
65+
either
66+
(P.showQualified P.runIdent . dequalifyCurrentModule)
67+
(P.showQualified P.runProperName . dequalifyCurrentModule)
68+
for
6569
, keyword "as"
6670
, ident . tail . init $ declTitle
6771
]

‎src/Language/PureScript/Docs/Types.hs‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -133,7 +133,7 @@ data DeclarationInfo
133133
-- An operator alias declaration, with the member the alias is for and the
134134
-- operator's fixity.
135135
--
136-
| AliasDeclaration (P.Qualified P.Ident) P.Fixity
136+
| AliasDeclaration (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName))) P.Fixity
137137
deriving (Show, Eq, Ord)
138138

139139
declInfoToString :: DeclarationInfo -> String
@@ -406,11 +406,14 @@ asDeclarationInfo = do
406406
TypeClassDeclaration <$> key "arguments" asTypeArguments
407407
<*> key "superclasses" (eachInArray asConstraint)
408408
"alias" ->
409-
AliasDeclaration <$> key "for" asQualifiedIdent
409+
AliasDeclaration <$> key "for" asAliasFor
410410
<*> key "fixity" asFixity
411411
other ->
412412
throwCustomError (InvalidDeclarationType other)
413413

414+
asAliasFor :: Parse e (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName)))
415+
asAliasFor = fromAesonParser
416+
414417
asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)]
415418
asTypeArguments = eachInArray asTypeArgument
416419
where

0 commit comments

Comments
 (0)