@@ -28,14 +28,14 @@ import Language.PureScript.Declarations
28import Language.PureScript.Values
28import Language.PureScript.Values
30import Control.Applicative
30import Control.Applicative
31−import Control.Arrow (first)
32import Control.Monad.State
31import Control.Monad.State
32+import Control.Monad.Error.Class
34import Data.Function (on)
34import Data.Function (on)
35import Data.Functor.Identity
35import Data.Functor.Identity
36−import Data.List (groupBy, sortBy)
36+import Data.List (sort, groupBy, sortBy)
38−import qualified Data.Map as M
38+import qualified Data.Data as D
39import qualified Data.Generics as G
39import qualified Data.Generics as G
40import qualified Data.Generics.Extras as G
40import qualified Data.Generics.Extras as G
@@ -47,28 +47,41 @@ import qualified Text.Parsec.Expr as P
47-- Remove explicit parentheses and reorder binary operator applications
47-- Remove explicit parentheses and reorder binary operator applications
49rebracket :: [Module] -> Either String [Module]
49rebracket :: [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
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
59+removeParens :: (D.Data d) => d -> d
60+removeParens = G.everywhere (G.mkT go)
62+ go (Parens val) = val
65+collectFixities :: Module -> [(Qualified Ident, Fixity)]
66+collectFixities (Module moduleName ds _) = concatMap collect ds
52− go _ rb [] = return . reverse $ rb
68+ collect :: Declaration -> [(Qualified Ident, Fixity)]
53− go m rb (Module name ds exps : ms) = do
69+ collect (FixityDeclaration fixity name) = [(Qualified (Just moduleName) (Op name), fixity)]
54− m' <- M.union m <$> collectFixities m name ds
70+ collect _ = []
55− let opTable = customOperatorTable m'
71+
56− ds' <- G.everywhereM' (G.mkM (matchOperators name opTable)) ds
72+ensureNoDuplicates :: [Qualified Ident] -> Either String ()
57− go m' (Module name (G.everywhere (G.mkT removeParens) ds') exps : rb) ms
73+ensureNoDuplicates m = go $ sort m
59−removeParens :: Value -> Value
75+ go [] = return ()
60−removeParens (Parens val) = val
76+ go [_] = return ()
61−removeParens val = val
77+ go (x : y : _) | x == y = throwError $ "Redefined fixity for " ++ show x
62−
78+ go (_ : rest) = go rest
63−customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
80+customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
64customOperatorTable fixities =
81customOperatorTable fixities =
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)
83+ applyUserOp ident t1 = App (App (Var ident) t1)
71− userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities
84+ userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities
72 sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps
85 sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps
73 groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
86 groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
@@ -76,8 +89,8 @@ customOperatorTable fixities =
77type Chain = [Either Value (Qualified Ident)]
90type Chain = [Either Value (Qualified Ident)]
79−matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
92+matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
80−matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains)
93+matchOperators ops = parseChains
82 parseChains :: Value -> Either String Value
95 parseChains :: Value -> Either String Value
83 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
96 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
@@ -88,7 +101,7 @@ matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains)
88 bracketChain :: Chain -> Either String Value
101 bracketChain :: Chain -> Either String Value
89 bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
102 bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
90 opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]
103 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
92 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
105 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
94toAssoc :: Associativity -> P.Assoc
107toAssoc :: Associativity -> P.Assoc
@@ -113,20 +126,8 @@ parseTicks = token (either (const Nothing) fromOp) P.<?> "infix function"
113 fromOp q@(Qualified _ (Ident _)) = Just q
126 fromOp q@(Qualified _ (Ident _)) = Just q
114 fromOp _ = Nothing
127 fromOp _ = Nothing
116−matchOp :: ModuleName -> Qualified Ident -> P.Parsec Chain () ()
129+matchOp :: Qualified Ident -> P.Parsec Chain () ()
117−matchOp moduleName op = do
130+matchOp op = do
118 ident <- parseOp
131 ident <- parseOp
119− guard (qualify moduleName ident == qualify moduleName op)
132+ guard $ ident == op
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