@@ -1,4 +1,3 @@
1−{-# LANGUAGE Rank2Types #-}
21{-# LANGUAGE FlexibleContexts #-}
32{-# LANGUAGE ScopedTypeVariables #-}
43{-# LANGUAGE RecordWildCards #-}
@@ -11,11 +10,11 @@
1110-- The value parser ignores fixity data when parsing binary operator applications, so
1211-- it is necessary to reorder them here.
1312--
14−module Language.PureScript.Sugar.Operators (
15− rebracket,
16− removeSignedLiterals,
17− desugarOperatorSections
18−) where
13+module Language.PureScript.Sugar.Operators
14+ ( rebracket
15+ , removeSignedLiterals
16+ , desugarOperatorSections
17+ ) where
1918
2019import Prelude ()
2120import Prelude.Compat
@@ -27,30 +26,29 @@ import Language.PureScript.Externs
2726import Language.PureScript.Names
2827import Language.PureScript.Sugar.Operators.Binders
2928import Language.PureScript.Sugar.Operators.Expr
30−import Language.PureScript.Traversals (defS)
29+import Language.PureScript.Sugar.Operators.Types
30+import Language.PureScript.Traversals (defS, sndM)
31+import Language.PureScript.Types
3132
33+import Control.Monad ((<=<))
3234import Control.Monad.Error.Class (MonadError(..))
3335import Control.Monad.Supply.Class
3436
3537import Data.Function (on)
36−import Data.List (groupBy, sortBy)
38+import Data.Functor.Identity
39+import Data.List (partition, groupBy, sortBy)
3740import Data.Maybe (mapMaybe)
3841import qualified Data.Map as M
3942
4043import qualified Language.PureScript.Constants as C
4144
42−-- TODO: in 0.9 operators names can have their own type rather than being in a sum with `Ident`, and `AliasName` no longer needs to be optional
45+-- TODO: in 0.9 operators names can have their own type rather than being in a sum with `Ident`, and `FixityAlias` no longer needs to be optional
4346
4447-- |
4548-- An operator associated with its declaration position, fixity, and the name
4649-- of the function or data constructor it is an alias for.
4750--
48−type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe AliasName)
49−
50−-- |
51−-- An operator can be an alias for a function or a data constructor.
52−--
53−type AliasName = Either (Qualified Ident) (Qualified (ProperName 'ConstructorName))
51+type FixityRecord = (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified FixityAlias))
5452
5553-- |
5654-- Remove explicit parentheses and reorder binary operator applications
@@ -62,23 +60,57 @@ rebracket
6260 -> [Module]
6361 -> m [Module]
6462rebracket externs ms = do
65− let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms
66− ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities
67− let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities
68− ms' <- traverse (rebracketModule opTable) ms
69− let aliased = M.fromList (mapMaybe makeLookupEntry fixities)
70− mapM (renameAliasedOperators aliased) ms'
63+ let (typeFixities, valueFixities) = partition isTypeFixity $
64+ concatMap externsFixities externs ++ concatMap collectFixities ms
65+
66+ ensureNoDuplicates' $ valueFixities
67+ ensureNoDuplicates' $ typeFixities
68+
69+ let valueOpTable = customOperatorTable' valueFixities
70+ typeOpTable = customOperatorTable' typeFixities
71+ ms' <- traverse (rebracketModule valueOpTable typeOpTable) ms
72+
73+ let valueAliased = M.fromList (mapMaybe makeLookupEntry valueFixities)
74+ typeAliased = M.fromList (mapMaybe makeLookupEntry typeFixities)
75+ mapM (renameAliasedOperators valueAliased typeAliased) ms'
7176
7277 where
7378
74− makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, AliasName)
79+ isTypeFixity :: FixityRecord -> Bool
80+ -- Nothing case for FixityAlias can only ever be a value fixity, as it's not
81+ -- possible to define types with operator names aside through aliasing.
82+ -- TODO: This comment is redundant after 0.9.
83+ isTypeFixity (_, _, _, Just (Qualified _ (AliasType _))) = True
84+ isTypeFixity _ = False
85+
86+ ensureNoDuplicates' :: [FixityRecord] -> m ()
87+ ensureNoDuplicates' =
88+ ensureNoDuplicates . map (\(i, pos, _, _) -> (i, pos))
89+
90+ customOperatorTable' :: [FixityRecord] -> [[(Qualified Ident, Associativity)]]
91+ customOperatorTable' =
92+ customOperatorTable . map (\(i, _, f, _) -> (i, f))
93+
94+ makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, Qualified FixityAlias)
7595 makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias
7696
77− renameAliasedOperators :: M.Map (Qualified Ident) AliasName -> Module -> m Module
78− renameAliasedOperators aliased (Module ss coms mn ds exts) =
97+ renameAliasedOperators
98+ :: M.Map (Qualified Ident) (Qualified FixityAlias)
99+ -> M.Map (Qualified Ident) (Qualified FixityAlias)
100+ -> Module
101+ -> m Module
102+ renameAliasedOperators valueAliased typeAliased (Module ss coms mn ds exts) =
79103 Module ss coms mn <$> mapM f' ds <*> pure exts
80104 where
81− (f', _, _, _, _) = everywhereWithContextOnValuesM Nothing goDecl goExpr goBinder defS defS
105+ (goDecl', goExpr') = updateTypes goType
106+ (f', _, _, _, _) =
107+ everywhereWithContextOnValuesM
108+ Nothing
109+ (\pos -> uncurry goDecl <=< goDecl' pos)
110+ (\pos -> uncurry goExpr <=< goExpr' pos)
111+ goBinder
112+ defS
113+ defS
82114
83115 goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration)
84116 goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d)
@@ -86,27 +118,39 @@ rebracket externs ms = do
86118
87119 goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)
88120 goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)
89− goExpr pos (Var name) = return (pos, case name `M.lookup` aliased of
90− Just (Left alias) -> Var alias
91− Just (Right alias) -> Constructor alias
92− Nothing -> Var name)
121+ goExpr pos (Var name) = return (pos, case name `M.lookup` valueAliased of
122+ Just (Qualified mn' (AliasValue alias)) -> Var (Qualified mn' alias)
123+ Just (Qualified mn' (AliasConstructor alias)) -> Constructor (Qualified mn' alias)
124+ _ -> Var name)
93125 goExpr pos other = return (pos, other)
94126
95127 goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder)
96128 goBinder _ b@(PositionedBinder pos _ _) = return (Just pos, b)
97− goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` aliased of
98− Just (Left alias) ->
129+ goBinder pos (BinaryNoParensBinder (OpBinder name) lhs rhs) = case name `M.lookup` valueAliased of
130+ Just (Qualified _ (AliasValue alias)) ->
99131 maybe id rethrowWithPosition pos $
100− throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) (disqualify alias)
101− Just (Right alias) ->
102− return (pos, ConstructorBinder alias [lhs, rhs])
103− Nothing ->
132+ throwError . errorMessage $ InvalidOperatorInBinder (disqualify name) alias
133+ Just (Qualified mn' (AliasConstructor alias)) ->
134+ return (pos, ConstructorBinder (Qualified mn' alias) [lhs, rhs])
135+ _ ->
104136 maybe id rethrowWithPosition pos $
105137 throwError . errorMessage $ UnknownValue name
106138 goBinder _ (BinaryNoParensBinder {}) =
107139 internalError "BinaryNoParensBinder has no OpBinder"
108140 goBinder pos other = return (pos, other)
109141
142+ goType :: Maybe SourceSpan -> Type -> m Type
143+ goType pos = everywhereOnTypesM go
144+ where
145+ go :: Type -> m Type
146+ go (BinaryNoParensType (TypeOp name) lhs rhs) = case name `M.lookup` typeAliased of
147+ Just (Qualified mn' (AliasType alias)) ->
148+ return $ TypeApp (TypeApp (TypeConstructor (Qualified mn' alias)) lhs) rhs
149+ _ ->
150+ maybe id rethrowWithPosition pos $
151+ throwError . errorMessage $ UnknownTypeOp name
152+ go other = return other
153+
110154removeSignedLiterals :: Module -> Module
111155removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts
112156 where
@@ -116,24 +160,64 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds)
116160 go other = other
117161
118162rebracketModule
119− :: (MonadError MultipleErrors m)
163+ :: forall m
164+ . (MonadError MultipleErrors m)
120165 => [[(Qualified Ident, Associativity)]]
166+ -> [[(Qualified Ident, Associativity)]]
121167 -> Module
122168 -> m Module
123−rebracketModule opTable (Module ss coms mn ds exts) =
124− let (f, _, _) = everywhereOnValuesTopDownM return (matchExprOperators opTable) (matchBinderOperators opTable)
125− in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
169+rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) =
170+ Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
171+ where
172+ (f, _, _) =
173+ everywhereOnValuesTopDownM
174+ (decontextify goDecl)
175+ (goExpr <=< decontextify goExpr')
176+ goBinder
177+
178+ (goDecl, goExpr') = updateTypes (\_ -> goType)
179+
180+ goExpr :: Expr -> m Expr
181+ goExpr = return . matchExprOperators valueOpTable
182+
183+ goBinder :: Binder -> m Binder
184+ goBinder = return . matchBinderOperators valueOpTable
185+
186+ goType :: Type -> m Type
187+ goType = return . matchTypeOperators typeOpTable
188+
189+ decontextify :: (Maybe SourceSpan -> a -> m (Maybe SourceSpan, a)) -> a -> m a
190+ decontextify ctxf = fmap snd . ctxf Nothing
126191
127192removeParens :: Declaration -> Declaration
128−removeParens =
129− let (f, _, _) = everywhereOnValues id goExpr goBinder
130− in f
193+removeParens = f
131194 where
195+ (f, _, _) =
196+ everywhereOnValues
197+ (decontextify goDecl)
198+ (goExpr . decontextify goExpr')
199+ goBinder
200+
201+ (goDecl, goExpr') = updateTypes (\_ -> return . goType)
202+
203+ goExpr :: Expr -> Expr
132204 goExpr (Parens val) = val
133205 goExpr val = val
206+
207+ goBinder :: Binder -> Binder
134208 goBinder (ParensInBinder b) = b
135209 goBinder b = b
136210
211+ goType :: Type -> Type
212+ goType (ParensInType t) = t
213+ goType t = t
214+
215+ decontextify
216+ :: (Maybe SourceSpan -> a -> Identity (Maybe SourceSpan, a))
217+ -> a
218+ -> a
219+ decontextify ctxf = snd . runIdentity . ctxf Nothing
220+
137221externsFixities
138222 :: ExternsFile
139223 -> [FixityRecord]
@@ -197,3 +281,52 @@ desugarOperatorSections (Module ss coms mn ds exts) =
197281 Left val -> f2 val var
198282 Right val -> f2 var val
199283 goExpr other = return other
284+
285+updateTypes
286+ :: forall m
287+ . Monad m
288+ => (Maybe SourceSpan -> Type -> m Type)
289+ -> ( Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration)
290+ , Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)
291+ )
292+updateTypes goType = (goDecl, goExpr)
293+ where
294+
295+ goType' :: Maybe SourceSpan -> Type -> m Type
296+ goType' = everywhereOnTypesM . goType
297+
298+ goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration)
299+ goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d)
300+ goDecl pos (DataDeclaration ddt name args dctors) = do
301+ dctors' <- traverse (sndM (traverse (goType' pos))) dctors
302+ return (pos, DataDeclaration ddt name args dctors')
303+ goDecl pos (ExternDeclaration name ty) = do
304+ ty' <- goType' pos ty
305+ return (pos, ExternDeclaration name ty')
306+ goDecl pos (TypeClassDeclaration name args implies decls) = do
307+ implies' <- traverse (sndM (traverse (goType' pos))) implies
308+ return (pos, TypeClassDeclaration name args implies' decls)
309+ goDecl pos (TypeInstanceDeclaration name cs className tys impls) = do
310+ cs' <- traverse (sndM (traverse (goType' pos))) cs
311+ tys' <- traverse (goType' pos) tys
312+ return (pos, TypeInstanceDeclaration name cs' className tys' impls)
313+ goDecl pos (TypeSynonymDeclaration name args ty) = do
314+ ty' <- goType' pos ty
315+ return (pos, TypeSynonymDeclaration name args ty')
316+ goDecl pos (TypeDeclaration expr ty) = do
317+ ty' <- goType' pos ty
318+ return (pos, TypeDeclaration expr ty')
319+ goDecl pos other = return (pos, other)
320+
321+ goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)
322+ goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)
323+ goExpr pos (TypeClassDictionary (name, tys) dicts) = do
324+ tys' <- traverse (goType' pos) tys
325+ return (pos, TypeClassDictionary (name, tys') dicts)
326+ goExpr pos (SuperClassDictionary cls tys) = do
327+ tys' <- traverse (goType' pos) tys
328+ return (pos, SuperClassDictionary cls tys')
329+ goExpr pos (TypedValue check v ty) = do
330+ ty' <- goType' pos ty
331+ return (pos, TypedValue check v ty')
332+ goExpr pos other = return (pos, other)