git.iko.soy/elk
on master help sign in
Start switching over to an AST that uses patterns in lambdas and

pulls the arguments out of Definitions (placing them in lambdas).

commit69ed7631fed88b356db92ebd866052c892fcfcbb authorEvan Czaplicki <evan@Evans-MacBook-Air.local> dateThu 4 Jul 2013, 11:36 (13 years ago) parent351c33c
5 files changed+66−62
compare with master
unifiedsplit
compiler/Parse/Expression.hs+12−5 compiler/Parse/Pattern.hs+3−8 compiler/Parse/Type.hs+4−3 compiler/SourceSyntax/Expression.hs+5−10 compiler/SourceSyntax/Rename.hs+42−36
compiler/Parse/Expression.hs+12−5
@@ -81,25 +81,32 @@ parensTerm = parens $ choice
8181recordTerm :: IParser (LExpr t v)
8282recordTerm = brackets $ choice [ misc, addLocation record ]
8383 where field = do
84− fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix Pattern.term
84+ label <- rLabel
85+ patterns <- spacePrefix Pattern.term
8586 whitespace
8687 e <- string "=" >> whitespace >> expr
87− n <- sourceLine <$> getPosition
88− runAt (1000 * n) $ Pattern.flatten fDefs e
89− extract [ FnDef f args exp ] = return (f,args,exp)
88+ return (label, foldr Lambda e patterns)
89+
90+ extract [ Def f args exp ] = return (f,args,exp)
9091 extract _ = fail "Improperly formed record field."
92+
9193 record = Record <$> (mapM extract =<< commaSep field)
94+
9295 change = do
9396 lbl <- rLabel
9497 whitespace >> string "<-" >> whitespace
9598 (,) lbl <$> expr
99+
96100 remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
101+
97102 insert r = addLocation $ do
98103 string "|" >> whitespace
99104 Insert r <$> rLabel <*>
100105 (whitespace >> string "=" >> whitespace >> expr)
106+
101107 modify r = addLocation
102108 (string "|" >> whitespace >> Modify r <$> commaSep1 change)
109+
103110 misc = try $ do
104111 record <- addLocation (Var <$> rLabel)
105112 whitespace
@@ -152,7 +159,7 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
152159 pats <- spaceSep1 Pattern.term
153160 whitespace ; arrow ; whitespace
154161 e <- expr
155− return . run $ Pattern.makeLambda pats e
162+ return (foldr Lambda pats e)
156163
157164defSet :: IParser [Def t v]
158165defSet = concat <$> block (do d <- anyDef ; whitespace ; return d)
compiler/Parse/Pattern.hs+3−8
@@ -1,5 +1,5 @@
11
2−module Parse.Pattern (term, expr, makeLambda, flatten) where
2+module Parse.Pattern (term, expr) where
33
44import Control.Applicative ((<$>),(<*>),pure)
55import Control.Monad
@@ -64,13 +64,7 @@ expr = do
6464 patterns <- consSep1 (patternConstructor <|> term)
6565 asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
6666
67−makeLambda :: [Pattern] -> LExpr t v -> Unique (LExpr t v)
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−
67+{--
7468extract :: Pattern -> LExpr t v -> Unique (String, LExpr t v)
7569extract pattern body@(L t s _) =
7670 let loc = L t s in
@@ -136,3 +130,4 @@ matchSingle pat exp@(L t s _) p =
136130 return (FnDef a [] exp : map toDef fs)
137131
138132 PAnything -> return []
133+--}
compiler/Parse/Type.hs+4−3
@@ -89,13 +89,14 @@ typeAlias = do
8989 _ -> []
9090
9191toConstructor start end alias Nothing kvs =
92− Definition (FnDef alias args (loc (Record rec)))
92+ Definition (Def alias args (loc (Record rec)))
9393 where
9494 loc = Located.at start end
9595 args = map fst kvs
96− rec = map (\a -> (a, [], loc (Var a))) args
96+ rec = map (\a -> (a, loc (Var a))) args
97+
9798toConstructor start end alias (Just _) kvs =
98− Definition (FnDef alias (args++["_ext_"]) (loc rec))
99+ Definition (Def alias (args++["_ext_"]) (loc rec))
99100 where
100101 loc = Located.at start end
101102 args = map fst kvs
compiler/SourceSyntax/Expression.hs+5−10
@@ -27,12 +27,12 @@ data Expr t v
2727 | Remove (LExpr t v) String
2828 | Insert (LExpr t v) String (LExpr t v)
2929 | Modify (LExpr t v) [(String, LExpr t v)]
30− | Record [(String, [String], LExpr t v)] -- [Def t v]
30+ | Record [(String, LExpr t v)]
3131 | Markdown Pandoc.Pandoc
3232 deriving (Eq, Data, Typeable)
3333
3434data Def tipe var
35− = Def String [String] (LExpr tipe var)
35+ = Def Pattern.Pattern (LExpr tipe var)
3636 | TypeAnnotation String Type
3737 deriving (Eq, Data, Typeable)
3838
@@ -71,7 +71,7 @@ instance Show (Expr t v) where
7171 Modify e fs -> Help.brkt (show e ++" | "++ intercalate ", " (map field fs))
7272 where field (x,e) = x ++ " <- " ++ show e
7373 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
7575 Markdown _ -> "[markdown| ... |]"
7676
7777
@@ -79,13 +79,8 @@ instance Show (Def t v) where
7979 show e =
8080 case e of
8181 TypeAnnotation n t -> n ++ " : " ++ show t
82− Def name@(c:_) args e ->
83− value ++ " = " ++ 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
82+ Def pattern e ->
83+ show pattern ++ " = " ++ show e
8984
9085getLambdas (Location.L _ _ (Lambda x e)) = (show x:xs,e')
9186 where (xs,e') = getLambdas e
compiler/SourceSyntax/Rename.hs+42−36
@@ -7,7 +7,7 @@ import Control.Monad.State (evalState, State, get, put)
77import Data.Char (isLower,isDigit)
88import qualified Data.Map as Map
99import Unique
10−import SourceSyntax.Location
10+import SourceSyntax.Location as Loc
1111import SourceSyntax.Pattern
1212import SourceSyntax.Expression
1313import SourceSyntax.Declaration hiding (Assoc(..))
@@ -30,17 +30,17 @@ class Rename a where
3030 rename :: Env -> a -> Unique a
3131
3232instance Rename (Module t v) where
33− rename env (Module name ex im stmts) = do stmts' <- renameStmts env stmts
34− return (Module name ex im stmts')
33+ rename env (Module name ex im decls) = do decls' <- renameDecls env decls
34+ return (Module name ex im decls')
3535
3636instance Rename (Def t v) where
37− rename env (OpDef op a1 a2 e) =
38− do env' <- extends env [a1,a2]
39− OpDef op (replace env' a1) (replace env' a2) `liftM` rename env' e
40− rename env (FnDef f args e) =
41− do env' <- extends env args
42− FnDef (replace env f) (map (replace env') args) `liftM` rename env' e
43− rename env (TypeAnnotation n t) = return (TypeAnnotation (replace env n) t)
37+ rename env def =
38+ case def of
39+ Def p e ->
40+ do (p', e', _) <- patternRename env (p,e)
41+ return (Def p' e')
42+ TypeAnnotation n t ->
43+ return (TypeAnnotation (replace env n) t)
4444
4545
4646instance Rename (Declaration t v) where
@@ -56,10 +56,11 @@ instance Rename (Declaration t v) where
5656 ExportEvent js elm tipe ->
5757 return $ ExportEvent js (replace env elm) tipe
5858
59−renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts
60− mapM (rename env') stmts
59+renameDecls env decls =
60+ do env' <- extends env $ concatMap getNames decls
61+ mapM (rename env') decls
6162 where getNames stmt = case stmt of
62− Definition (FnDef n _ _) -> [n]
63+ --Definition (Def n _) -> [n]
6364 Datatype _ _ tcs -> map fst tcs
6465 ImportEvent _ _ n _ -> [n]
6566 _ -> []
@@ -87,10 +88,8 @@ instance Rename (Expr t v) where
8788 `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs
8889
8990 Record fs -> Record `liftM` mapM frnm fs
90− where frnm (f,as,e) = do
91− env' <- extends env as
92− e' <- rename env' e
93− return (f, map (replace env') as, e')
91+ where
92+ frnm (f,e) = (,) f `liftM` rename env e
9493
9594 Binop op@(h:_) e1 e2 ->
9695 let rop = if isLower h || '_' == h
@@ -99,9 +98,9 @@ instance Rename (Expr t v) where
9998 in Binop rop `liftM` rnm e1
10099 `ap` rnm e2
101100
102− Lambda x e -> do
103− (rx, env') <- extend env x
104− Lambda rx `liftM` rename env' e
101+ Lambda pattern e -> do
102+ (pattern', env') <- patternExtend env pattern
103+ Lambda pattern' `liftM` rename env' e
105104
106105 App e1 e2 -> App `liftM` rnm e1
107106 `ap` rnm e2
@@ -119,7 +118,9 @@ instance Rename (Expr t v) where
119118 ExplicitList es -> ExplicitList `liftM` mapM rnm es
120119
121120 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)
123124
124125 _ -> return expr
125126
@@ -134,31 +135,36 @@ extend env x = do
134135extends :: Env -> [String] -> Unique Env
135136extends env xs = foldM (\e x -> liftM snd $ extend e x) env xs
136137
137−patternExtend :: Pattern -> Env -> Unique (Pattern, Env)
138−patternExtend pattern env =
138+patternExtend :: Env -> Pattern -> Unique (Pattern, Env)
139+patternExtend env pattern =
139140 case pattern of
140141 PLiteral _ -> return (pattern, env)
141142 PAnything -> return (pattern, env)
142143 PVar x -> first PVar `liftM` extend env x
143144 PAlias x p -> do
144145 (x', env') <- extend env x
145− (p', env'') <- patternExtend p env'
146+ (p', env'') <- patternExtend env' p
146147 return (PAlias x' p', env'')
147148 PData name ps ->
148149 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
150151 return (rp:rps, env'')
151152 PRecord fs ->
152153 return (pattern, Map.union (Map.fromList $ map (\f -> (f,f)) fs) env)
153154
154−patternRename :: Env -> (Pattern, LExpr t v) -> Unique (Pattern, LExpr t v)
155−patternRename env (p,e) = do
156− (rp,env') <- patternExtend p env
157− re <- rename env' e
158− return (rp,re)
159−
160−renameLet env defs e = do env' <- extends env $ concatMap getNames defs
161− defs' <- mapM (rename env') defs
162− Let defs' `liftM` rename env' e
163− where getNames (FnDef n _ _) = [n]
164− getNames _ = []
155+patternRename :: Env -> (Pattern, LExpr t v) -> Unique (Pattern, LExpr t v, Env)
156+patternRename env (pattern,expr) = do
157+ (pattern',env') <- patternExtend env pattern
158+ expr' <- rename env' expr
159+ return (pattern', expr', env')
160+
161+renameLet env defs e =
162+ do (env', ps') <- foldM addPattern (env, []) (map fst defPairs)
163+ bodies <- mapM (rename env') (map snd defPairs)
164+ Let (zipWith Def ps' bodies) `liftM` rename env' e
165+ where
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)