@@ -28,14 +28,14 @@ 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.Function (on)
3535import Data.Functor.Identity
36−import Data.List (groupBy, sortBy)
36+import Data.List (sort, groupBy, sortBy)
3737
38−import qualified Data.Map as M
38+import qualified Data.Data as D
3939import qualified Data.Generics as G
4040import qualified Data.Generics.Extras as G
4141
@@ -47,28 +47,41 @@ import qualified Text.Parsec.Expr as P
4747-- Remove explicit parentheses and reorder binary operator applications
4848--
4949rebracket :: [Module] -> Either String [Module]
50−rebracket = go M.empty []
50+rebracket ms = do
51+ let fixities = concatMap collectFixities ms
52+ ensureNoDuplicates $ map fst fixities
53+ let opTable = customOperatorTable fixities
54+ mapM (rebracketModule opTable) ms
55+
56+rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either String Module
57+rebracketModule opTable (Module mn ds exts) = Module mn <$> (removeParens <$> G.everywhereM' (G.mkM (matchOperators opTable)) ds) <*> pure exts
58+
59+removeParens :: (D.Data d) => d -> d
60+removeParens = G.everywhere (G.mkT go)
61+ where
62+ go (Parens val) = val
63+ go val = val
64+
65+collectFixities :: Module -> [(Qualified Ident, Fixity)]
66+collectFixities (Module moduleName ds _) = concatMap collect ds
5167 where
52− go _ rb [] = return . reverse $ rb
53− go m rb (Module name ds exps : ms) = do
54− m' <- M.union m <$> collectFixities m name ds
55− let opTable = customOperatorTable m'
56− ds' <- G.everywhereM' (G.mkM (matchOperators name opTable)) ds
57− go m' (Module name (G.everywhere (G.mkT removeParens) ds') exps : rb) ms
58−
59−removeParens :: Value -> Value
60−removeParens (Parens val) = val
61−removeParens val = val
62−
63−customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
68+ collect :: Declaration -> [(Qualified Ident, Fixity)]
69+ collect (FixityDeclaration fixity name) = [(Qualified (Just moduleName) (Op name), fixity)]
70+ collect _ = []
71+
72+ensureNoDuplicates :: [Qualified Ident] -> Either String ()
73+ensureNoDuplicates m = go $ sort m
74+ where
75+ go [] = return ()
76+ go [_] = return ()
77+ go (x : y : _) | x == y = throwError $ "Redefined fixity for " ++ show x
78+ go (_ : rest) = go rest
79+
80+customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
6481customOperatorTable fixities =
6582 let
66− -- We make the assumption here that infix operators are not qualified. The parser currently enforces this.
67− -- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name
68− -- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to
69− -- make sure that the generated code is correct.
70− applyUserOp (Qualified _ name) t1 = App (App (Var (Qualified Nothing name)) t1)
71− userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities
83+ applyUserOp ident t1 = App (App (Var ident) t1)
84+ userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities
7285 sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps
7386 groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
7487 in
@@ -76,8 +89,8 @@ customOperatorTable fixities =
7689
7790type Chain = [Either Value (Qualified Ident)]
7891
79−matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
80−matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains)
92+matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
93+matchOperators ops = parseChains
8194 where
8295 parseChains :: Value -> Either String Value
8396 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
@@ -88,7 +101,7 @@ matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains)
88101 bracketChain :: Chain -> Either String Value
89102 bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
90103 opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]
91− : map (map (\(name, f, a) -> P.Infix (P.try (matchOp moduleName name) >> return f) (toAssoc a))) ops
104+ : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
92105 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
93106
94107toAssoc :: Associativity -> P.Assoc
@@ -113,20 +126,8 @@ parseTicks = token (either (const Nothing) fromOp) P.<?> "infix function"
113126 fromOp q@(Qualified _ (Ident _)) = Just q
114127 fromOp _ = Nothing
115128
116−matchOp :: ModuleName -> Qualified Ident -> P.Parsec Chain () ()
117−matchOp moduleName op = do
129+matchOp :: Qualified Ident -> P.Parsec Chain () ()
130+matchOp op = do
118131 ident <- parseOp
119− guard (qualify moduleName ident == qualify moduleName op)
120−
121−collectFixities :: M.Map (Qualified Ident) Fixity -> ModuleName -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)
122−collectFixities m _ [] = return m
123−collectFixities m moduleName (FixityDeclaration fixity name : rest) = do
124− let qual = Qualified (Just moduleName) (Op name)
125− when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)
126− collectFixities (M.insert qual fixity m) moduleName rest
127−collectFixities m moduleName (ImportDeclaration importedModule _ _ : rest) = do
128− let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule ]
129− let m' = M.fromList (map (first (Qualified (Just moduleName))) fs)
130− collectFixities (m' `M.union` m) moduleName rest
131−collectFixities m moduleName (_:ds) = collectFixities m moduleName ds
132+ guard $ ident == op
132133