git.iko.soy/elk
on master help sign in
Create way to crawl over all lets in a program, transforming defs and ports
49fc0b6Evan Czaplicki
compiler/Transform/Declaration.hsnew file+65
compare with master
unifiedsplit
@@ -0,0 +1,65 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Transform.Declaration where
3+
4+import Control.Applicative ((<$>))
5+import qualified SourceSyntax.Pattern as P
6+import SourceSyntax.Expression as E
7+import SourceSyntax.Declaration as D
8+
9+import qualified Transform.Expression as Expr
10+import qualified Transform.Definition as Def
11+
12+
13+combineAnnotations :: [ParseDeclaration] -> Either String [Declaration]
14+combineAnnotations = go
15+ where
16+ msg x = "Syntax Error: The type annotation for '" ++ x ++
17+ "' must be directly above its definition."
18+
19+ go decls =
20+ case decls of
21+ -- simple cases, pass them through with no changes
22+ [] -> return []
23+
24+ Datatype name tvars ctors ds : rest ->
25+ (:) (Datatype name tvars ctors ds) <$> go rest
26+
27+ TypeAlias name tvars alias ds : rest ->
28+ (:) (TypeAlias name tvars alias ds) <$> go rest
29+
30+ Fixity assoc prec op : rest ->
31+ (:) (Fixity assoc prec op) <$> go rest
32+
33+ -- combine definitions
34+ D.Definition def : defRest ->
35+ case def of
36+ Def pat expr ->
37+ do expr' <- Expr.crawl Def.combineAnnotations expr
38+ let def' = E.Definition pat expr' Nothing
39+ (:) (D.Definition def') <$> go defRest
40+
41+ TypeAnnotation name tipe ->
42+ case defRest of
43+ D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' ->
44+ do expr' <- Expr.crawl Def.combineAnnotations expr
45+ let def' = E.Definition pat expr' (Just tipe)
46+ (:) (D.Definition def') <$> go rest
47+
48+ _ -> Left (msg name)
49+
50+ -- combine ports
51+ Port port : portRest ->
52+ case port of
53+ SendDefinition name _ -> Left (msg name)
54+ RecvDefinition name _ -> Left (msg name)
55+ PortAnnotation name tipe ->
56+ case portRest of
57+ Port (SendDefinition name' expr) : rest | name == name' ->
58+ do expr' <- Expr.crawl Def.combineAnnotations expr
59+ (:) (Port (Send name expr' tipe)) <$> go rest
60+
61+ Port (RecvDefinition name' expr) : rest | name == name' ->
62+ do expr' <- Expr.crawl Def.combineAnnotations expr
63+ (:) (Port (Send name expr' tipe)) <$> go rest
64+
65+ _ -> Left (msg name)
compiler/Transform/Definition.hsnew file+29
@@ -0,0 +1,29 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Transform.Definition where
3+
4+import Control.Applicative ((<$>))
5+import qualified SourceSyntax.Pattern as P
6+import SourceSyntax.Expression
7+import qualified Transform.Expression as Expr
8+
9+combineAnnotations :: [ParseDef] -> Either String [Def]
10+combineAnnotations = go
11+ where
12+ msg x = "Syntax Error: The type annotation for '" ++ x ++
13+ "' must be directly above its definition."
14+
15+ go defs =
16+ case defs of
17+ TypeAnnotation name tipe : Def pat@(P.PVar name') expr : rest | name == name' ->
18+ do expr' <- Expr.crawl combineAnnotations expr
19+ let def = Definition pat expr' (Just tipe)
20+ (:) def <$> go rest
21+
22+ TypeAnnotation name _ : _ -> Left (msg name)
23+
24+ Def pat expr : rest ->
25+ do expr' <- Expr.crawl combineAnnotations expr
26+ let def = Definition pat expr' Nothing
27+ (:) def <$> go rest
28+
29+ [] -> return []
compiler/Transform/Expression.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Transform.Expression where
3+
4+import Control.Applicative ((<$>),(<*>))
5+import SourceSyntax.Expression
6+import SourceSyntax.Location
7+
8+crawl :: ([def] -> Either a [def']) -> (LExpr' def) -> Either a (LExpr' def')
9+crawl transform = go
10+ where
11+ go (L srcSpan expr) =
12+ L srcSpan <$>
13+ case expr of
14+ Var x -> return (Var x)
15+ Lambda p e -> Lambda p <$> go e
16+ Binop op e1 e2 -> Binop op <$> go e1 <*> go e2
17+ Case e cases -> Case <$> go e <*> mapM (\(p,b) -> (,) p <$> go b) cases
18+ Data name es -> Data name <$> mapM go es
19+ Literal lit -> return (Literal lit)
20+ Range e1 e2 -> Range <$> go e1 <*> go e2
21+ ExplicitList es -> ExplicitList <$> mapM go es
22+ App e1 e2 -> App <$> go e1 <*> go e2
23+ MultiIf branches -> MultiIf <$> mapM (\(b,e) -> (,) <$> go b <*> go e) branches
24+ Access e lbl -> Access <$> go e <*> return lbl
25+ Remove e lbl -> Remove <$> go e <*> return lbl
26+ Insert e lbl v -> Insert <$> go e <*> return lbl <*> go v
27+ Modify e fields -> Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fields
28+ Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields
29+ Markdown uid md es -> Markdown uid md <$> mapM go es
30+ Let defs body -> Let <$> transform defs <*> go body
31+