Skip to content

Commit fe18478

Browse files
garybgaryb
committed
Type operator aliases
1 parent 83896db commit fe18478

File tree

29 files changed

+586
-169
lines changed

29 files changed

+586
-169
lines changed

‎examples/passing/TypeOperators.purs‎

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
module A
2+
( Tuple(..)
3+
, type (/\)
4+
, (/\)
5+
, Natural
6+
, type (~>)
7+
) where
8+
9+
data Tuple a b = Tuple a b
10+
11+
infixl 6 Tuple as /\
12+
infixl 6 type Tuple as /\
13+
14+
type Natural f g = ∀ a. f a → g a
15+
16+
infixr 0 type Natural as ~>
17+
18+
tup ∷ ∀ a b. a → b → b /\ a
19+
tup a b = b /\ a
20+
21+
tupX ∷ ∀ a b c. a /\ b /\ c → c
22+
tupX (a /\ b /\ c) = c
23+
24+
module Main where
25+
26+
import A (type (~>), type (/\), (/\))
27+
28+
natty ∷ ∀ f. f ~> f
29+
natty x = x
30+
31+
swap ∷ ∀ a b. a /\ b → b /\ a
32+
swap (a /\ b) = b /\ a
33+
34+
main = Control.Monad.Eff.Console.log "Done"

‎psci/PSCi.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -253,8 +253,9 @@ handleShowImportedModules = do
253253

254254
showRef :: P.DeclarationRef -> String
255255
showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
256+
showRef (P.TypeOpRef ident) = "type (" ++ N.runIdent ident ++ ")"
256257
showRef (P.ValueRef ident) = N.runIdent ident
257-
showRef (P.TypeClassRef pn) = N.runProperName pn
258+
showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn
258259
showRef (P.ProperRef pn) = pn
259260
showRef (P.TypeInstanceRef ident) = N.runIdent ident
260261
showRef (P.ModuleRef name) = "module " ++ N.runModuleName name

‎purescript.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -163,6 +163,7 @@ library
163163
Language.PureScript.Sugar.Operators.Common
164164
Language.PureScript.Sugar.Operators.Expr
165165
Language.PureScript.Sugar.Operators.Binders
166+
Language.PureScript.Sugar.Operators.Types
166167
Language.PureScript.Sugar.TypeClasses
167168
Language.PureScript.Sugar.TypeClasses.Deriving
168169
Language.PureScript.Sugar.TypeDeclarations

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

Lines changed: 23 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -62,6 +62,10 @@ data DeclarationRef
6262
--
6363
= TypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName])
6464
-- |
65+
-- A type operator
66+
--
67+
| TypeOpRef Ident
68+
-- |
6569
-- A value
6670
--
6771
| ValueRef Ident
@@ -89,6 +93,7 @@ data DeclarationRef
8993

9094
instance Eq DeclarationRef where
9195
(TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
96+
(TypeOpRef name) == (TypeOpRef name') = name == name'
9297
(ValueRef name) == (ValueRef name') = name == name'
9398
(TypeClassRef name) == (TypeClassRef name') = name == name'
9499
(TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
@@ -190,7 +195,7 @@ data Declaration
190195
-- |
191196
-- A fixity declaration (fixity data, operator name, value the operator is an alias for)
192197
--
193-
| FixityDeclaration Fixity String (Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))))
198+
| FixityDeclaration Fixity String (Maybe (Qualified FixityAlias))
194199
-- |
195200
-- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
196201
-- TODO: also a boolean specifying whether the old `qualified` syntax was used, so a warning can be raised in desugaring (remove for 0.9)
@@ -211,6 +216,22 @@ data Declaration
211216
| PositionedDeclaration SourceSpan [Comment] Declaration
212217
deriving (Show, Read)
213218

219+
data FixityAlias
220+
= AliasValue Ident
221+
| AliasConstructor (ProperName 'ConstructorName)
222+
| AliasType (ProperName 'TypeName)
223+
deriving (Eq, Ord, Show, Read)
224+
225+
foldFixityAlias
226+
:: (Ident -> a)
227+
-> (ProperName 'ConstructorName -> a)
228+
-> (ProperName 'TypeName -> a)
229+
-> FixityAlias
230+
-> a
231+
foldFixityAlias f _ _ (AliasValue name) = f name
232+
foldFixityAlias _ g _ (AliasConstructor name) = g name
233+
foldFixityAlias _ _ h (AliasType name) = h name
234+
214235
-- | The members of a type class instance declaration
215236
data TypeInstanceBody
216237
-- | This is a derived instance
@@ -453,3 +474,4 @@ data DoNotationElement
453474

454475
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''DeclarationRef)
455476
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDeclarationType)
477+
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''FixityAlias)

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

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -127,7 +127,6 @@ isExported (Just exps) decl = any (matches decl) exps
127127
matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
128128
matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'
129129
matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident'
130-
matches (FixityDeclaration _ name _) (ValueRef ident') = name == runIdent ident'
131130
matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
132131
matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
133132
matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
@@ -136,6 +135,10 @@ isExported (Just exps) decl = any (matches decl) exps
136135
matches (DataDeclaration _ ident _ _) (ProperRef ident') = runProperName ident == ident'
137136
matches (TypeClassDeclaration ident _ _ _) (ProperRef ident') = runProperName ident == ident'
138137

138+
matches (FixityDeclaration _ name (Just (Qualified _ (AliasValue _)))) (ValueRef ident') = name == runIdent ident'
139+
matches (FixityDeclaration _ name (Just (Qualified _ (AliasConstructor _)))) (ValueRef ident') = name == runIdent ident'
140+
matches (FixityDeclaration _ name (Just (Qualified _ (AliasType _)))) (TypeOpRef ident') = name == runIdent ident'
141+
139142
matches (PositionedDeclaration _ _ d) r = d `matches` r
140143
matches d (PositionedDeclarationRef _ _ r) = d `matches` r
141144
matches _ _ = False

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

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -72,10 +72,12 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
7272
declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds
7373
declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =
7474
[NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]
75-
declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =
76-
let meta = either getValueMeta (Just . getConstructorMeta) alias
77-
alias' = either id (fmap properToIdent) alias
78-
in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) alias')]
75+
declToCoreFn ss com (A.FixityDeclaration _ name (Just (Qualified mn' (A.AliasValue name')))) =
76+
let meta = getValueMeta (Qualified mn' name')
77+
in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) (Qualified mn' name'))]
78+
declToCoreFn ss com (A.FixityDeclaration _ name (Just (Qualified mn' (A.AliasConstructor name')))) =
79+
let meta = Just $ getConstructorMeta (Qualified mn' name')
80+
in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) (Qualified mn' (properToIdent name')))]
7981
declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
8082
[Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds]
8183
declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =
@@ -208,7 +210,7 @@ findQualModules decls =
208210
where
209211
fqDecls :: A.Declaration -> [(Ann, ModuleName)]
210212
fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q
211-
fqDecls (A.FixityDeclaration _ _ (Just eq)) = either getQual getQual eq
213+
fqDecls (A.FixityDeclaration _ _ (Just q)) = getQual q
212214
fqDecls _ = []
213215

214216
fqValues :: A.Expr -> [(Ann, ModuleName)]

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

Lines changed: 10 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -61,20 +61,22 @@ renderDeclarationWithOptions opts Declaration{..} =
6161
AliasDeclaration for (P.Fixity associativity precedence) ->
6262
[ keywordFixity associativity
6363
, syntax $ show precedence
64-
, ident $
65-
either
66-
(P.showQualified P.runIdent . dequalifyCurrentModule)
67-
(P.showQualified P.runProperName . dequalifyCurrentModule)
68-
for
64+
, ident $ renderAlias for
6965
, keyword "as"
7066
, ident . tail . init $ declTitle
7167
]
7268

7369
where
7470
renderType' = renderTypeWithOptions opts
75-
dequalifyCurrentModule (P.Qualified mn a)
76-
| mn == currentModule opts = P.Qualified Nothing a
77-
| otherwise = P.Qualified mn a
71+
renderAlias (P.Qualified mn alias)
72+
| mn == currentModule opts =
73+
P.foldFixityAlias P.runIdent P.runProperName P.runProperName alias
74+
| otherwise =
75+
P.foldFixityAlias
76+
(P.showQualified P.runIdent . P.Qualified mn)
77+
(P.showQualified P.runProperName . P.Qualified mn)
78+
(P.showQualified P.runProperName . P.Qualified mn)
79+
alias
7880

7981
renderChildDeclaration :: ChildDeclaration -> RenderedCode
8082
renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions

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

Lines changed: 2 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 (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName))) P.Fixity
136+
| AliasDeclaration (P.Qualified P.FixityAlias) P.Fixity
137137
deriving (Show, Eq, Ord)
138138

139139
declInfoToString :: DeclarationInfo -> String
@@ -411,7 +411,7 @@ asDeclarationInfo = do
411411
other ->
412412
throwCustomError (InvalidDeclarationType other)
413413

414-
asAliasFor :: Parse e (Either (P.Qualified P.Ident) (P.Qualified (P.ProperName 'P.ConstructorName)))
414+
asAliasFor :: Parse e (P.Qualified P.FixityAlias)
415415
asAliasFor = fromAesonParser
416416

417417
asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)]

‎src/Language/PureScript/Errors.hs‎

Lines changed: 21 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -60,12 +60,15 @@ data SimpleErrorMessage
6060
| OverlappingNamesInLet
6161
| UnknownModule ModuleName
6262
| UnknownType (Qualified (ProperName 'TypeName))
63+
| UnknownTypeOp (Qualified Ident)
6364
| UnknownTypeClass (Qualified (ProperName 'ClassName))
6465
| UnknownValue (Qualified Ident)
6566
| UnknownDataConstructor (Qualified (ProperName 'ConstructorName)) (Maybe (Qualified (ProperName 'ConstructorName)))
6667
| UnknownTypeConstructor (Qualified (ProperName 'TypeName))
6768
| UnknownImportType ModuleName (ProperName 'TypeName)
6869
| UnknownExportType (ProperName 'TypeName)
70+
| UnknownImportTypeOp ModuleName Ident
71+
| UnknownExportTypeOp Ident
6972
| UnknownImportTypeClass ModuleName (ProperName 'ClassName)
7073
| UnknownExportTypeClass (ProperName 'ClassName)
7174
| UnknownImportValue ModuleName Ident
@@ -84,6 +87,7 @@ data SimpleErrorMessage
8487
| DuplicateModuleName ModuleName
8588
| DuplicateClassExport (ProperName 'ClassName)
8689
| DuplicateValueExport Ident
90+
| DuplicateTypeOpExport Ident
8791
| DuplicateTypeArgument String
8892
| InvalidDoBind
8993
| InvalidDoLet
@@ -244,12 +248,15 @@ errorCode em = case unwrapErrorMessage em of
244248
OverlappingNamesInLet -> "OverlappingNamesInLet"
245249
UnknownModule{} -> "UnknownModule"
246250
UnknownType{} -> "UnknownType"
251+
UnknownTypeOp{} -> "UnknownTypeOp"
247252
UnknownTypeClass{} -> "UnknownTypeClass"
248253
UnknownValue{} -> "UnknownValue"
249254
UnknownDataConstructor{} -> "UnknownDataConstructor"
250255
UnknownTypeConstructor{} -> "UnknownTypeConstructor"
251256
UnknownImportType{} -> "UnknownImportType"
257+
UnknownImportTypeOp{} -> "UnknownImportTypeOp"
252258
UnknownExportType{} -> "UnknownExportType"
259+
UnknownExportTypeOp{} -> "UnknownExportTypeOp"
253260
UnknownImportTypeClass{} -> "UnknownImportTypeClass"
254261
UnknownExportTypeClass{} -> "UnknownExportTypeClass"
255262
UnknownImportValue{} -> "UnknownImportValue"
@@ -268,6 +275,7 @@ errorCode em = case unwrapErrorMessage em of
268275
DuplicateModuleName{} -> "DuplicateModuleName"
269276
DuplicateClassExport{} -> "DuplicateClassExport"
270277
DuplicateValueExport{} -> "DuplicateValueExport"
278+
DuplicateTypeOpExport{} -> "DuplicateTypeOpExport"
271279
DuplicateTypeArgument{} -> "DuplicateTypeArgument"
272280
InvalidDoBind -> "InvalidDoBind"
273281
InvalidDoLet -> "InvalidDoLet"
@@ -595,6 +603,8 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
595603
line $ "Unknown module " ++ runModuleName mn
596604
renderSimpleErrorMessage (UnknownType name) =
597605
line $ "Unknown type " ++ showQualified runProperName name
606+
renderSimpleErrorMessage (UnknownTypeOp name) =
607+
line $ "Unknown type operator " ++ showQualified showIdent name
598608
renderSimpleErrorMessage (UnknownTypeClass name) =
599609
line $ "Unknown type class " ++ showQualified runProperName name
600610
renderSimpleErrorMessage (UnknownValue name) =
@@ -609,6 +619,12 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
609619
]
610620
renderSimpleErrorMessage (UnknownExportType name) =
611621
line $ "Cannot export unknown type " ++ runProperName name
622+
renderSimpleErrorMessage (UnknownImportTypeOp mn name) =
623+
paras [ line $ "Cannot import type operator " ++ showIdent name ++ " from module " ++ runModuleName mn
624+
, line "It either does not exist or the module does not export it."
625+
]
626+
renderSimpleErrorMessage (UnknownExportTypeOp name) =
627+
line $ "Cannot export unknown type operator " ++ showIdent name
612628
renderSimpleErrorMessage (UnknownImportTypeClass mn name) =
613629
paras [ line $ "Cannot import type class " ++ runProperName name ++ " from module " ++ runModuleName mn
614630
, line "It either does not exist or the module does not export it."
@@ -658,6 +674,8 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
658674
line $ "Duplicate export declaration for type class " ++ runProperName nm
659675
renderSimpleErrorMessage (DuplicateValueExport nm) =
660676
line $ "Duplicate export declaration for value " ++ showIdent nm
677+
renderSimpleErrorMessage (DuplicateTypeOpExport nm) =
678+
line $ "Duplicate export declaration for type operator " ++ showIdent nm
661679
renderSimpleErrorMessage (CycleInDeclaration nm) =
662680
line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed."
663681
renderSimpleErrorMessage (CycleInModules mns) =
@@ -996,8 +1014,8 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap
9961014

9971015
renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =
9981016
paras [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "."
999-
, line "Only aliases for data constructors may be used in patterns."
1000-
]
1017+
, line "Only aliases for data constructors may be used in patterns."
1018+
]
10011019

10021020
renderSimpleErrorMessage DeprecatedRequirePath =
10031021
line "The require-path option is deprecated and will be removed in PureScript 0.9."
@@ -1205,6 +1223,7 @@ prettyPrintRef :: DeclarationRef -> String
12051223
prettyPrintRef (TypeRef pn Nothing) = runProperName pn ++ "(..)"
12061224
prettyPrintRef (TypeRef pn (Just [])) = runProperName pn
12071225
prettyPrintRef (TypeRef pn (Just dctors)) = runProperName pn ++ "(" ++ intercalate ", " (map runProperName dctors) ++ ")"
1226+
prettyPrintRef (TypeOpRef ident) = "type " ++ showIdent ident
12081227
prettyPrintRef (ValueRef ident) = showIdent ident
12091228
prettyPrintRef (TypeClassRef pn) = "class " ++ runProperName pn
12101229
prettyPrintRef (ProperRef name) = name

‎src/Language/PureScript/Externs.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -73,7 +73,7 @@ data ExternsFixity = ExternsFixity
7373
-- | The operator symbol
7474
, efOperator :: String
7575
-- | The value the operator is an alias for
76-
, efAlias :: Maybe (Either (Qualified Ident) (Qualified (ProperName 'ConstructorName)))
76+
, efAlias :: Maybe (Qualified FixityAlias)
7777
} deriving (Show, Read)
7878

7979
-- | A type or value declaration appearing in an externs file
@@ -159,6 +159,7 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..}
159159
exportsOp :: DeclarationRef -> Bool
160160
exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r
161161
exportsOp (ValueRef ident') = ident' == Op op
162+
exportsOp (TypeOpRef ident') = ident' == Op op
162163
exportsOp _ = False
163164
fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d
164165
fixityDecl _ = Nothing

0 commit comments

Comments
 (0)