@@ -0,0 +1,128 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Operators
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE Rank2Types #-}
16+
17+module Language.PureScript.Operators (
18+ rebracket
19+) where
20+
21+import Language.PureScript.Names
22+import Language.PureScript.Declarations
23+import Language.PureScript.Values
24+
25+import qualified Data.Data as D
26+import Data.Function (on)
27+import Data.List (groupBy, sortBy)
28+import qualified Data.Map as M
29+import qualified Data.Generics as G
30+import qualified Data.Generics.Extras as G
31+import Control.Monad.State
32+import Control.Applicative
33+import qualified Text.Parsec as P
34+import qualified Text.Parsec.Pos as P
35+import qualified Text.Parsec.Expr as P
36+
37+rebracket :: [Declaration] -> Either String [Declaration]
38+rebracket ds = do
39+ m <- collectFixities ds
40+ let opTable = customOperatorTable m
41+ ds' <- G.everywhereM (G.mkM (matchOperators opTable)) ds
42+ return $ G.everywhere (G.mkT removeParens) ds'
43+
44+removeParens :: Value -> Value
45+removeParens (Parens val) = val
46+removeParens val = val
47+
48+customOperatorTable :: M.Map (Qualified Ident) Fixity -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
49+customOperatorTable fixities =
50+ let
51+ applyUserOp name t1 t2 = App (App (Var name) [t1]) [t2]
52+ userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities
53+ sorted = sortBy (compare `on` (\(_, _, p, _) -> p)) (userOps ++ builtIns)
54+ groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
55+ in
56+ map (map (\(name, f, _, a) -> (name, f, a))) groups
57+
58+type Chain = [Either Value (Qualified Ident)]
59+
60+matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value
61+matchOperators ops val = G.everywhereM' (G.mkM parseChains) val
62+ where
63+ parseChains :: Value -> Either String Value
64+ parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)
65+ parseChains val = return val
66+ extendChain :: Value -> Chain
67+ extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
68+ extendChain val = [Left val]
69+ bracketChain :: Chain -> Either String Value
70+ bracketChain = either (Left . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
71+ opTable = map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
72+ ++ [[P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) [t1]) [t2]))) P.AssocLeft]]
73+
74+toAssoc :: Associativity -> P.Assoc
75+toAssoc Infixl = P.AssocLeft
76+toAssoc Infixr = P.AssocRight
77+
78+parseValue :: P.Parsec Chain () Value
79+parseValue = P.token show (const (P.initialPos "")) (either Just (const Nothing)) P.<?> "expression"
80+
81+parseOp :: P.Parsec Chain () (Qualified Ident)
82+parseOp = P.token show (const (P.initialPos "")) (either (const Nothing) Just) P.<?> "operator"
83+
84+matchOp :: Qualified Ident -> P.Parsec Chain () ()
85+matchOp op = do
86+ ident <- parseOp
87+ guard (ident == op)
88+
89+collectFixities :: [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)
90+collectFixities = go M.empty global
91+ where
92+ go :: M.Map (Qualified Ident) Fixity -> ModulePath -> [Declaration] -> Either String (M.Map (Qualified Ident) Fixity)
93+ go m _ [] = return m
94+ go m p (FixityDeclaration fixity name : rest) = do
95+ let qual = Qualified p (Op name)
96+ when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)
97+ go (M.insert qual fixity m) p rest
98+ go m p (ModuleDeclaration name decls : rest) = do
99+ m' <- go m (subModule p name) decls
100+ go m' p rest
101+ go m p (_:ds) = go m p ds
102+
103+globalOp :: String -> Qualified Ident
104+globalOp = Qualified global . Op
105+
106+builtIns :: [(Qualified Ident, Value -> Value -> Value, Precedence, Associativity)]
107+builtIns = [ (globalOp "!!", flip Indexer, 3, Infixl)
108+ , (globalOp "&&", Binary And, 3, Infixr)
109+ , (globalOp "||", Binary Or, 3, Infixr)
110+ , (globalOp "<=", Binary LessThanOrEqualTo, 4, Infixl)
111+ , (globalOp ">=", Binary GreaterThanOrEqualTo, 4, Infixl)
112+ , (globalOp "<", Binary LessThan, 4, Infixl)
113+ , (globalOp ">", Binary GreaterThan, 4, Infixl)
114+ , (globalOp "==", Binary EqualTo, 4, Infixl)
115+ , (globalOp "!=", Binary NotEqualTo, 4, Infixl)
116+ , (globalOp "*", Binary Multiply, 7, Infixl)
117+ , (globalOp "/", Binary Divide, 7, Infixl)
118+ , (globalOp "%", Binary Modulus, 7, Infixl)
119+ , (globalOp "++", Binary Concat, 5, Infixr)
120+ , (globalOp "+", Binary Add, 6, Infixl)
121+ , (globalOp "-", Binary Subtract, 6, Infixl)
122+ , (globalOp "<<", Binary ShiftLeft, 7, Infixl)
123+ , (globalOp ">>>", Binary ZeroFillShiftRight, 7, Infixl)
124+ , (globalOp ">>", Binary ShiftRight, 7, Infixl)
125+ , (globalOp "&", Binary BitwiseAnd, 7, Infixl)
126+ , (globalOp "^", Binary BitwiseXor, 7, Infixl)
127+ , (globalOp "|", Binary BitwiseOr, 7, Infixl)
128+ ]