@@ -20,51 +20,92 @@ module Language.PureScript.Sugar.Operators (
2020import Prelude ()
2121import Prelude.Compat
2222
23−import Language.PureScript.Crash
2423import Language.PureScript.AST
24+import Language.PureScript.Crash
2525import Language.PureScript.Errors
26−import Language.PureScript.Names
2726import Language.PureScript.Externs
27+import Language.PureScript.Names
28+import Language.PureScript.Sugar.Operators.Binders
29+import Language.PureScript.Sugar.Operators.Expr
30+import Language.PureScript.Traversals (defS)
2831
29−import Control.Monad.State
3032import Control.Monad.Error.Class (MonadError(..))
3133import Control.Monad.Supply.Class
3234
3335import Data.Function (on)
34−import Data.Functor.Identity
3536import Data.List (groupBy, sortBy)
36−import Data.Maybe (mapMaybe, fromMaybe)
37+import Data.Maybe (mapMaybe)
3738import qualified Data.Map as M
3839
39−import qualified Text.Parsec as P
40−import qualified Text.Parsec.Pos as P
41−import qualified Text.Parsec.Expr as P
42−
4340import qualified Language.PureScript.Constants as C
4441
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
43+
44+-- |
45+-- An operator associated with its declaration position, fixity, and the name
46+-- of the function or data constructor it is an alias for.
47+--
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))
54+
4555-- |
4656-- Remove explicit parentheses and reorder binary operator applications
4757--
48−rebracket :: (Applicative m, MonadError MultipleErrors m) => [ExternsFile] -> [Module] -> m [Module]
58+rebracket
59+ :: forall m
60+ . (Applicative m, MonadError MultipleErrors m)
61+ => [ExternsFile]
62+ -> [Module]
63+ -> m [Module]
4964rebracket externs ms = do
5065 let fixities = concatMap externsFixities externs ++ concatMap collectFixities ms
5166 ensureNoDuplicates $ map (\(i, pos, _, _) -> (i, pos)) fixities
5267 let opTable = customOperatorTable $ map (\(i, _, f, _) -> (i, f)) fixities
5368 ms' <- traverse (rebracketModule opTable) ms
5469 let aliased = M.fromList (mapMaybe makeLookupEntry fixities)
55− return $ renameAliasedOperators aliased `map` ms'
70+ mapM (renameAliasedOperators aliased) ms'
5671
5772 where
5873
59− makeLookupEntry :: (Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident)) -> Maybe (Qualified Ident, Qualified Ident)
74+ makeLookupEntry :: FixityRecord -> Maybe (Qualified Ident, AliasName)
6075 makeLookupEntry (qname, _, _, alias) = (qname, ) <$> alias
6176
62− renameAliasedOperators :: M.Map (Qualified Ident) (Qualified Ident) -> Module -> Module
63− renameAliasedOperators aliased (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts
77+ renameAliasedOperators :: M.Map (Qualified Ident) AliasName -> Module -> m Module
78+ renameAliasedOperators aliased (Module ss coms mn ds exts) =
79+ Module ss coms mn <$> mapM f' ds <*> pure exts
6480 where
65− (f', _, _) = everywhereOnValues id go id
66− go (Var name) = Var $ fromMaybe name (name `M.lookup` aliased)
67− go other = other
81+ (f', _, _, _, _) = everywhereWithContextOnValuesM Nothing goDecl goExpr goBinder defS defS
82+
83+ goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration)
84+ goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d)
85+ goDecl pos other = return (pos, other)
86+
87+ goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)
88+ 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)
93+ goExpr pos other = return (pos, other)
94+
95+ goBinder :: Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder)
96+ 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) ->
99+ 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 ->
104+ maybe id rethrowWithPosition pos $
105+ throwError . errorMessage $ UnknownValue name
106+ goBinder _ (BinaryNoParensBinder _ _ _) =
107+ internalError "BinaryNoParensBinder has no OpBinder"
108+ goBinder pos other = return (pos, other)
68109
69110removeSignedLiterals :: Module -> Module
70111removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds) exts
@@ -74,35 +115,46 @@ removeSignedLiterals (Module ss coms mn ds exts) = Module ss coms mn (map f' ds)
74115 go (UnaryMinus val) = App (Var (Qualified Nothing (Ident C.negate))) val
75116 go other = other
76117
77−rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module
118+rebracketModule
119+ :: (Applicative m, MonadError MultipleErrors m)
120+ => [[(Qualified Ident, Associativity)]]
121+ -> Module
122+ -> m Module
78123rebracketModule opTable (Module ss coms mn ds exts) =
79− let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
124+ let (f, _, _) = everywhereOnValuesTopDownM return (matchExprOperators opTable) (matchBinderOperators opTable)
80125 in Module ss coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
81126
82127removeParens :: Declaration -> Declaration
83128removeParens =
84− let (f, _, _) = everywhereOnValues id go id
129+ let (f, _, _) = everywhereOnValues id goExpr goBinder
85130 in f
86131 where
87− go (Parens val) = val
88− go val = val
89−
90−externsFixities :: ExternsFile -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]
132+ goExpr (Parens val) = val
133+ goExpr val = val
134+ goBinder (ParensInBinder b) = b
135+ goBinder b = b
136+
137+externsFixities
138+ :: ExternsFile
139+ -> [FixityRecord]
91140externsFixities ExternsFile{..} =
92141 [ (Qualified (Just efModuleName) (Op op), internalModuleSourceSpan "", Fixity assoc prec, alias)
93142 | ExternsFixity assoc prec op alias <- efFixities
94143 ]
95144
96−collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]
145+collectFixities :: Module -> [FixityRecord]
97146collectFixities (Module _ _ moduleName ds _) = concatMap collect ds
98147 where
99− collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity, Maybe (Qualified Ident))]
148+ collect :: Declaration -> [FixityRecord]
100149 collect (PositionedDeclaration pos _ (FixityDeclaration fixity name alias)) =
101150 [(Qualified (Just moduleName) (Op name), pos, fixity, alias)]
102151 collect FixityDeclaration{} = internalError "Fixity without srcpos info"
103152 collect _ = []
104153
105−ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()
154+ensureNoDuplicates
155+ :: MonadError MultipleErrors m
156+ => [(Qualified Ident, SourceSpan)]
157+ -> m ()
106158ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
107159 where
108160 go [] = return ()
@@ -113,63 +165,24 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
113165 throwError . errorMessage $ MultipleFixities name
114166 go (_ : rest) = go rest
115167
116−customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]
168+customOperatorTable
169+ :: [(Qualified Ident, Fixity)]
170+ -> [[(Qualified Ident, Associativity)]]
117171customOperatorTable fixities =
118172 let
119− applyUserOp ident t1 = App (App (Var ident) t1)
120− userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities
121− sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps
122− groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
173+ userOps = map (\(name, Fixity a p) -> (name, p, a)) fixities
174+ sorted = sortBy (flip compare `on` (\(_, p, _) -> p)) userOps
175+ groups = groupBy ((==) `on` (\(_, p, _) -> p)) sorted
123176 in
124− map (map (\(name, f, _, a) -> (name, f, a))) groups
125−
126−type Chain = [Either Expr Expr]
127−
128−matchOperators :: forall m. (MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> m Expr
129−matchOperators ops = parseChains
130− where
131− parseChains :: Expr -> m Expr
132− parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
133− parseChains other = return other
134− extendChain :: Expr -> Chain
135− extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r
136− extendChain other = [Left other]
137− bracketChain :: Chain -> m Expr
138− bracketChain = either (\_ -> internalError "matchOperators: cannot reorder operators") return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
139− opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]
140− : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
141− ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
142−
143−toAssoc :: Associativity -> P.Assoc
144−toAssoc Infixl = P.AssocLeft
145−toAssoc Infixr = P.AssocRight
146−toAssoc Infix = P.AssocNone
147−
148−token :: (P.Stream s Identity t) => (t -> Maybe a) -> P.Parsec s u a
149−token = P.token (const "") (const (P.initialPos ""))
150−
151−parseValue :: P.Parsec Chain () Expr
152−parseValue = token (either Just (const Nothing)) P.<?> "expression"
153−
154−parseOp :: P.Parsec Chain () (Qualified Ident)
155−parseOp = token (either (const Nothing) fromOp) P.<?> "operator"
156− where
157− fromOp (Var q@(Qualified _ (Op _))) = Just q
158− fromOp _ = Nothing
159−
160−parseTicks :: P.Parsec Chain () Expr
161−parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"
162− where
163− fromOther (Var (Qualified _ (Op _))) = Nothing
164− fromOther v = Just v
165−
166−matchOp :: Qualified Ident -> P.Parsec Chain () ()
167−matchOp op = do
168− ident <- parseOp
169− guard $ ident == op
170−
171−desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
172−desugarOperatorSections (Module ss coms mn ds exts) = Module ss coms mn <$> traverse goDecl ds <*> pure exts
177+ map (map (\(name, _, a) -> (name, a))) groups
178+
179+desugarOperatorSections
180+ :: forall m
181+ . (Applicative m, MonadSupply m, MonadError MultipleErrors m)
182+ => Module
183+ -> m Module
184+desugarOperatorSections (Module ss coms mn ds exts) =
185+ Module ss coms mn <$> traverse goDecl ds <*> pure exts
173186 where
174187
175188 goDecl :: Declaration -> m Declaration