git.iko.soy/elk
on master help sign in
Start switching over to an AST that uses patterns in lambdas and
69ed763Evan Czaplicki
compiler/Parse/Expression.hs+12−5
compare with master
unifiedsplit
@@ -81,25 +81,32 @@ parensTerm = parens $ choice
81recordTerm :: IParser (LExpr t v)
81recordTerm :: IParser (LExpr t v)
82recordTerm = brackets $ choice [ misc, addLocation record ]
82recordTerm = brackets $ choice [ misc, addLocation record ]
83 where field = do
83 where field = do
84+ label <- rLabel
84− fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix Pattern.term
85+ patterns <- spacePrefix Pattern.term
85 whitespace
86 whitespace
86 e <- string "=" >> whitespace >> expr
87 e <- string "=" >> whitespace >> expr
87− n <- sourceLine <$> getPosition
88+ return (label, foldr Lambda e patterns)
88− runAt (1000 * n) $ Pattern.flatten fDefs e
89+
89− extract [ FnDef f args exp ] = return (f,args,exp)
90+ extract [ Def f args exp ] = return (f,args,exp)
90 extract _ = fail "Improperly formed record field."
91 extract _ = fail "Improperly formed record field."
92+
91 record = Record <$> (mapM extract =<< commaSep field)
93 record = Record <$> (mapM extract =<< commaSep field)
94+
92 change = do
95 change = do
93 lbl <- rLabel
96 lbl <- rLabel
94 whitespace >> string "<-" >> whitespace
97 whitespace >> string "<-" >> whitespace
95 (,) lbl <$> expr
98 (,) lbl <$> expr
99+
96 remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
100 remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
101+
97 insert r = addLocation $ do
102 insert r = addLocation $ do
98 string "|" >> whitespace
103 string "|" >> whitespace
99 Insert r <$> rLabel <*>
104 Insert r <$> rLabel <*>
100 (whitespace >> string "=" >> whitespace >> expr)
105 (whitespace >> string "=" >> whitespace >> expr)
106+
101 modify r = addLocation
107 modify r = addLocation
102 (string "|" >> whitespace >> Modify r <$> commaSep1 change)
108 (string "|" >> whitespace >> Modify r <$> commaSep1 change)
109+
103 misc = try $ do
110 misc = try $ do
104 record <- addLocation (Var <$> rLabel)
111 record <- addLocation (Var <$> rLabel)
105 whitespace
112 whitespace
@@ -152,7 +159,7 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
152 pats <- spaceSep1 Pattern.term
159 pats <- spaceSep1 Pattern.term
153 whitespace ; arrow ; whitespace
160 whitespace ; arrow ; whitespace
154 e <- expr
161 e <- expr
155− return . run $ Pattern.makeLambda pats e
162+ return (foldr Lambda pats e)
156
163
157defSet :: IParser [Def t v]
164defSet :: IParser [Def t v]
158defSet = concat <$> block (do d <- anyDef ; whitespace ; return d)
165defSet = concat <$> block (do d <- anyDef ; whitespace ; return d)
compiler/Parse/Pattern.hs+3−8
@@ -1,5 +1,5 @@
1
1
2−module Parse.Pattern (term, expr, makeLambda, flatten) where
2+module Parse.Pattern (term, expr) where
3
3
4import Control.Applicative ((<$>),(<*>),pure)
4import Control.Applicative ((<$>),(<*>),pure)
5import Control.Monad
5import Control.Monad
@@ -64,13 +64,7 @@ expr = do
64 patterns <- consSep1 (patternConstructor <|> term)
64 patterns <- consSep1 (patternConstructor <|> term)
65 asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
65 asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
66
66
67−makeLambda :: [Pattern] -> LExpr t v -> Unique (LExpr t v)
67+{--
68−makeLambda pats body = go (reverse pats) body
69− where go [] body = return body
70− go (p:ps) body@(L t s _) = do
71− (x,e) <- extract p body
72− go ps (L t s $ Lambda x e)
73−
74extract :: Pattern -> LExpr t v -> Unique (String, LExpr t v)
68extract :: Pattern -> LExpr t v -> Unique (String, LExpr t v)
75extract pattern body@(L t s _) =
69extract pattern body@(L t s _) =
76 let loc = L t s in
70 let loc = L t s in
@@ -136,3 +130,4 @@ matchSingle pat exp@(L t s _) p =
136 return (FnDef a [] exp : map toDef fs)
130 return (FnDef a [] exp : map toDef fs)
137
131
138 PAnything -> return []
132 PAnything -> return []
133+--}
compiler/Parse/Type.hs+4−3
@@ -89,13 +89,14 @@ typeAlias = do
89 _ -> []
89 _ -> []
90
90
91toConstructor start end alias Nothing kvs =
91toConstructor start end alias Nothing kvs =
92− Definition (FnDef alias args (loc (Record rec)))
92+ Definition (Def alias args (loc (Record rec)))
93 where
93 where
94 loc = Located.at start end
94 loc = Located.at start end
95 args = map fst kvs
95 args = map fst kvs
96− rec = map (\a -> (a, [], loc (Var a))) args
96+ rec = map (\a -> (a, loc (Var a))) args
97+
97toConstructor start end alias (Just _) kvs =
98toConstructor start end alias (Just _) kvs =
98− Definition (FnDef alias (args++["_ext_"]) (loc rec))
99+ Definition (Def alias (args++["_ext_"]) (loc rec))
99 where
100 where
100 loc = Located.at start end
101 loc = Located.at start end
101 args = map fst kvs
102 args = map fst kvs
compiler/SourceSyntax/Expression.hs+5−10
@@ -27,12 +27,12 @@ data Expr t v
27 | Remove (LExpr t v) String
27 | Remove (LExpr t v) String
28 | Insert (LExpr t v) String (LExpr t v)
28 | Insert (LExpr t v) String (LExpr t v)
29 | Modify (LExpr t v) [(String, LExpr t v)]
29 | Modify (LExpr t v) [(String, LExpr t v)]
30− | Record [(String, [String], LExpr t v)] -- [Def t v]
30+ | Record [(String, LExpr t v)]
31 | Markdown Pandoc.Pandoc
31 | Markdown Pandoc.Pandoc
32 deriving (Eq, Data, Typeable)
32 deriving (Eq, Data, Typeable)
33
33
34data Def tipe var
34data Def tipe var
35− = Def String [String] (LExpr tipe var)
35+ = Def Pattern.Pattern (LExpr tipe var)
36 | TypeAnnotation String Type
36 | TypeAnnotation String Type
37 deriving (Eq, Data, Typeable)
37 deriving (Eq, Data, Typeable)
38
38
@@ -71,7 +71,7 @@ instance Show (Expr t v) where
71 Modify e fs -> Help.brkt (show e ++" | "++ intercalate ", " (map field fs))
71 Modify e fs -> Help.brkt (show e ++" | "++ intercalate ", " (map field fs))
72 where field (x,e) = x ++ " <- " ++ show e
72 where field (x,e) = x ++ " <- " ++ show e
73 Record r -> Help.brkt (intercalate ", " (map fields r))
73 Record r -> Help.brkt (intercalate ", " (map fields r))
74− where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e
74+ where fields (f,e) = f ++ " = " ++ show e
75 Markdown _ -> "[markdown| ... |]"
75 Markdown _ -> "[markdown| ... |]"
76
76
77
77
@@ -79,13 +79,8 @@ instance Show (Def t v) where
79 show e =
79 show e =
80 case e of
80 case e of
81 TypeAnnotation n t -> n ++ " : " ++ show t
81 TypeAnnotation n t -> n ++ " : " ++ show t
82− Def name@(c:_) args e ->
82+ Def pattern e ->
83− value ++ " = " ++ show e
83+ show pattern ++ " = " ++ show e
84− where
85− value = if not (Help.isOp c) then name ++ concatMap (' ':) args else
86− case args of
87− [] -> parens name
88− [a,b] -> a ++ " " ++ name ++ " " ++ b
89
84
90getLambdas (Location.L _ _ (Lambda x e)) = (show x:xs,e')
85getLambdas (Location.L _ _ (Lambda x e)) = (show x:xs,e')
91 where (xs,e') = getLambdas e
86 where (xs,e') = getLambdas e
compiler/SourceSyntax/Rename.hs+42−36
@@ -7,7 +7,7 @@ import Control.Monad.State (evalState, State, get, put)
7import Data.Char (isLower,isDigit)
7import Data.Char (isLower,isDigit)
8import qualified Data.Map as Map
8import qualified Data.Map as Map
9import Unique
9import Unique
10−import SourceSyntax.Location
10+import SourceSyntax.Location as Loc
11import SourceSyntax.Pattern
11import SourceSyntax.Pattern
12import SourceSyntax.Expression
12import SourceSyntax.Expression
13import SourceSyntax.Declaration hiding (Assoc(..))
13import SourceSyntax.Declaration hiding (Assoc(..))
@@ -30,17 +30,17 @@ class Rename a where
30 rename :: Env -> a -> Unique a
30 rename :: Env -> a -> Unique a
31
31
32instance Rename (Module t v) where
32instance Rename (Module t v) where
33− rename env (Module name ex im stmts) = do stmts' <- renameStmts env stmts
33+ rename env (Module name ex im decls) = do decls' <- renameDecls env decls
34− return (Module name ex im stmts')
34+ return (Module name ex im decls')
35
35
36instance Rename (Def t v) where
36instance Rename (Def t v) where
37− rename env (OpDef op a1 a2 e) =
37+ rename env def =
38− do env' <- extends env [a1,a2]
38+ case def of
39− OpDef op (replace env' a1) (replace env' a2) `liftM` rename env' e
39+ Def p e ->
40− rename env (FnDef f args e) =
40+ do (p', e', _) <- patternRename env (p,e)
41− do env' <- extends env args
41+ return (Def p' e')
42− FnDef (replace env f) (map (replace env') args) `liftM` rename env' e
42+ TypeAnnotation n t ->
43− rename env (TypeAnnotation n t) = return (TypeAnnotation (replace env n) t)
43+ return (TypeAnnotation (replace env n) t)
44
44
45
45
46instance Rename (Declaration t v) where
46instance Rename (Declaration t v) where
@@ -56,10 +56,11 @@ instance Rename (Declaration t v) where
56 ExportEvent js elm tipe ->
56 ExportEvent js elm tipe ->
57 return $ ExportEvent js (replace env elm) tipe
57 return $ ExportEvent js (replace env elm) tipe
58
58
59+renameDecls env decls =
59−renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts
60+ do env' <- extends env $ concatMap getNames decls
60− mapM (rename env') stmts
61+ mapM (rename env') decls
61 where getNames stmt = case stmt of
62 where getNames stmt = case stmt of
62− Definition (FnDef n _ _) -> [n]
63+ --Definition (Def n _) -> [n]
63 Datatype _ _ tcs -> map fst tcs
64 Datatype _ _ tcs -> map fst tcs
64 ImportEvent _ _ n _ -> [n]
65 ImportEvent _ _ n _ -> [n]
65 _ -> []
66 _ -> []
@@ -87,10 +88,8 @@ instance Rename (Expr t v) where
87 `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
88 `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
88
89
89 Record fs -> Record `liftM` mapM frnm fs
90 Record fs -> Record `liftM` mapM frnm fs
90− where frnm (f,as,e) = do
91+ where
91− env' <- extends env as
92− e' <- rename env' e
92+ frnm (f,e) = (,) f `liftM` rename env e
93− return (f, map (replace env') as, e')
94
93
95 Binop op@(h:_) e1 e2 ->
94 Binop op@(h:_) e1 e2 ->
96 let rop = if isLower h || '_' == h
95 let rop = if isLower h || '_' == h
@@ -99,9 +98,9 @@ instance Rename (Expr t v) where
99 in Binop rop `liftM` rnm e1
98 in Binop rop `liftM` rnm e1
100 `ap` rnm e2
99 `ap` rnm e2
101
100
102− Lambda x e -> do
101+ Lambda pattern e -> do
103− (rx, env') <- extend env x
102+ (pattern', env') <- patternExtend env pattern
104− Lambda rx `liftM` rename env' e
103+ Lambda pattern' `liftM` rename env' e
105
104
106 App e1 e2 -> App `liftM` rnm e1
105 App e1 e2 -> App `liftM` rnm e1
107 `ap` rnm e2
106 `ap` rnm e2
@@ -119,7 +118,9 @@ instance Rename (Expr t v) where
119 ExplicitList es -> ExplicitList `liftM` mapM rnm es
118 ExplicitList es -> ExplicitList `liftM` mapM rnm es
120
119
121 Case e cases -> Case `liftM` rnm e
120 Case e cases -> Case `liftM` rnm e
122− `ap` mapM (patternRename env) cases
121+ `ap` mapM (liftM drop3rd . patternRename env) cases
122+ where
123+ drop3rd (a,b,c) = (a,b)
123
124
124 _ -> return expr
125 _ -> return expr
125
126
@@ -134,31 +135,36 @@ extend env x = do
134extends :: Env -> [String] -> Unique Env
135extends :: Env -> [String] -> Unique Env
135extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
136extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
136
137
137−patternExtend :: Pattern -> Env -> Unique (Pattern, Env)
138+patternExtend :: Env -> Pattern -> Unique (Pattern, Env)
138−patternExtend pattern env =
139+patternExtend env pattern =
139 case pattern of
140 case pattern of
140 PLiteral _ -> return (pattern, env)
141 PLiteral _ -> return (pattern, env)
141 PAnything -> return (pattern, env)
142 PAnything -> return (pattern, env)
142 PVar x -> first PVar `liftM` extend env x
143 PVar x -> first PVar `liftM` extend env x
143 PAlias x p -> do
144 PAlias x p -> do
144 (x', env') <- extend env x
145 (x', env') <- extend env x
145− (p', env'') <- patternExtend p env'
146+ (p', env'') <- patternExtend env' p
146 return (PAlias x' p', env'')
147 return (PAlias x' p', env'')
147 PData name ps ->
148 PData name ps ->
148 first (PData name . reverse) `liftM` foldM f ([], env) ps
149 first (PData name . reverse) `liftM` foldM f ([], env) ps
149− where f (rps,env') p = do (rp,env'') <- patternExtend p env'
150+ where f (rps,env') p = do (rp,env'') <- patternExtend env' p
150 return (rp:rps, env'')
151 return (rp:rps, env'')
151 PRecord fs ->
152 PRecord fs ->
152 return (pattern, Map.union (Map.fromList $ map (\f -> (f,f)) fs) env)
153 return (pattern, Map.union (Map.fromList $ map (\f -> (f,f)) fs) env)
153
154
154−patternRename :: Env -> (Pattern, LExpr t v) -> Unique (Pattern, LExpr t v)
155+patternRename :: Env -> (Pattern, LExpr t v) -> Unique (Pattern, LExpr t v, Env)
155−patternRename env (p,e) = do
156+patternRename env (pattern,expr) = do
156− (rp,env') <- patternExtend p env
157+ (pattern',env') <- patternExtend env pattern
157− re <- rename env' e
158+ expr' <- rename env' expr
158− return (rp,re)
159+ return (pattern', expr', env')
159−
160+
160−renameLet env defs e = do env' <- extends env $ concatMap getNames defs
161+renameLet env defs e =
162+ do (env', ps') <- foldM addPattern (env, []) (map fst defPairs)
161− defs' <- mapM (rename env') defs
163+ bodies <- mapM (rename env') (map snd defPairs)
162− Let defs' `liftM` rename env' e
164+ Let (zipWith Def ps' bodies) `liftM` rename env' e
163− where getNames (FnDef n _ _) = [n]
165+ where
164− getNames _ = []
166+ defPairs = map (\(Def p e) -> (p,e)) defs
167+
168+ addPattern (env,ps) pattern =
169+ do (pattern', _, env') <- patternRename env (pattern, Loc.none (Var ""))
170+ return (env', pattern' : ps)