@@ -28,15 +28,15 @@ import Language.PureScript.Declarations
2828import Language.PureScript.Values
2929
3030import Control.Applicative
31−import Control.Arrow (first)
3231import Control.Monad.State
32+import Control.Monad.Error.Class
3333
3434import Data.Maybe (fromMaybe, mapMaybe)
3535import Data.Function (on)
3636import Data.Functor.Identity
37−import Data.List (groupBy, sortBy)
37+import Data.List (sort, groupBy, sortBy)
3838
39−import qualified Data.Map as M
39+import qualified Data.Data as D
4040import qualified Data.Generics as G
4141import qualified Data.Generics.Extras as G
4242
@@ -48,28 +48,41 @@ import qualified Text.Parsec.Expr as P
4848-- Remove explicit parentheses and reorder binary operator applications
4949--
5050rebracket :: [Module] -> Either String [Module]
51−rebracket = go M.empty []
51+rebracket ms = do
52+ let fixities = concatMap collectFixities ms
53+ ensureNoDuplicates $ map fst fixities
54+ let opTable = customOperatorTable fixities
55+ mapM (rebracketModule opTable) ms
56+
57+rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either String Module
58+rebracketModule opTable (Module mn ds exts) = Module mn <$> (removeParens <$> G.everywhereM' (G.mkM (matchOperators opTable)) ds) <*> pure exts
59+
60+removeParens :: (D.Data d) => d -> d
61+removeParens = G.everywhere (G.mkT go)
62+ where
63+ go (Parens val) = val
64+ go val = val
65+
66+collectFixities :: Module -> [(Qualified Ident, Fixity)]
67+collectFixities (Module moduleName ds _) = concatMap collect ds
68+ where
69+ collect :: Declaration -> [(Qualified Ident, Fixity)]
70+ collect (FixityDeclaration fixity name) = [(Qualified (Just moduleName) (Op name), fixity)]
71+ collect _ = []
72+
73+ensureNoDuplicates :: [Qualified Ident] -> Either String ()
74+ensureNoDuplicates m = go $ sort m
5275 where
53− go _ rb [] = return . reverse $ rb
54− go m rb (Module name ds exps : ms) = do
55− m' <- M.union m <$> collectFixities m name ds
56− let opTable = customOperatorTable m'
57− ds' <- G.everywhereM' (G.mkM (matchOperators name opTable)) ds
58− go m' (Module name (G.everywhere (G.mkT removeParens) ds') exps : rb) ms
59−
60−removeParens :: Value -> Value
61−removeParens (Parens val) = val
62−removeParens val = val
63−
64−customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
76+ go [] = return ()
77+ go [_] = return ()
78+ go (x : y : _) | x == y = throwError $ "Redefined fixity for " ++ show x
79+ go (_ : rest) = go rest
80+
81+customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
6582customOperatorTable fixities =
6683 let
67− -- We make the assumption here that infix operators are not qualified. The parser currently enforces this.
68− -- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name
69− -- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to
70− -- make sure that the generated code is correct.
71− applyUserOp (Qualified _ name) t1 = App (App (Var (Qualified Nothing name)) t1)
72− userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities
84+ applyUserOp ident t1 = App (App (Var ident) t1)
85+ userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities
7386 sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps
7487 groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
7588 in
@@ -77,8 +90,8 @@ customOperatorTable fixities =
7790
7891type Chain = [Either Value (Qualified Ident)]
7992
80−matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
81−matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains)
93+matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
94+matchOperators ops = parseChains
8295 where
8396 parseChains :: Value -> Either String Value
8497 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
@@ -89,7 +102,7 @@ matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains)
89102 bracketChain :: Chain -> Either String Value
90103 bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
91104 opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]
92− : map (map (\(name, f, a) -> P.Infix (P.try (matchOp moduleName name) >> return f) (toAssoc a))) ops
105+ : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
93106 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
94107
95108toAssoc :: Associativity -> P.Assoc
@@ -114,27 +127,8 @@ parseTicks = token (either (const Nothing) fromOp) P.<?> "infix function"
114127 fromOp q@(Qualified _ (Ident _)) = Just q
115128 fromOp _ = Nothing
116129
117−matchOp :: ModuleName -> Qualified Ident -> P.Parsec Chain () ()
118−matchOp moduleName op = do
130+matchOp :: Qualified Ident -> P.Parsec Chain () ()
131+matchOp op = do
119132 ident <- parseOp
120133 guard (qualify moduleName ident == qualify moduleName op)
121134
122−collectFixities :: M.Map (Qualified Ident) Fixity -> ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)
123−collectFixities m _ [] = return m
124−collectFixities m moduleName (FixityDeclaration fixity name : rest) = do
125− let qual = Qualified (Just moduleName) (Op name)
126− when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)
127− collectFixities (M.insert qual fixity m) moduleName rest
128−collectFixities m moduleName (ImportDeclaration importedModule explImports qual : rest) = do
129− let qualName = fromMaybe moduleName qual
130− let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule && isImported explImports i ]
131− let m' = M.fromList (map (first (Qualified (Just qualName))) fs)
132− collectFixities (m' `M.union` m) moduleName rest
133− where
134− isImported Nothing _ = True
135− isImported (Just imps) i = i `elem` (mapMaybe getExportedValue imps)
136− getExportedValue (ValueRef name) = Just name
137− getExportedValue _ = Nothing
138−
139−collectFixities m moduleName (_:ds) = collectFixities m moduleName ds
140−