git.iko.soy/elk
on master help sign in
Extend expression crawler to do checks on ports as well as on let expressions
5dd7b6bEvan Czaplicki
compiler/Transform/Check.hs+1−1
compare with master
unifiedsplit
@@ -52,7 +52,7 @@ duplicates decls =
52 getNames = Set.toList . Pattern.boundVars
52 getNames = Set.toList . Pattern.boundVars
53
53
54 exprDups :: E.LExpr -> Either String E.LExpr
54 exprDups :: E.LExpr -> Either String E.LExpr
55− exprDups expr = Expr.crawl defsDups expr
55+ exprDups expr = Expr.crawlLet defsDups expr
56
56
57 defsDups :: [E.Def] -> Either String [E.Def]
57 defsDups :: [E.Def] -> Either String [E.Def]
58 defsDups defs =
58 defsDups defs =
compiler/Transform/Declaration.hs+6−4
@@ -16,6 +16,8 @@ combineAnnotations = go
16 msg x = "Syntax Error: The type annotation for '" ++ x ++
16 msg x = "Syntax Error: The type annotation for '" ++ x ++
17 "' must be directly above its definition."
17 "' must be directly above its definition."
18
18
19+ exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations
20+
19 go decls =
21 go decls =
20 case decls of
22 case decls of
21 -- simple cases, pass them through with no changes
23 -- simple cases, pass them through with no changes
@@ -34,14 +36,14 @@ combineAnnotations = go
34 D.Definition def : defRest ->
36 D.Definition def : defRest ->
35 case def of
37 case def of
36 Def pat expr ->
38 Def pat expr ->
37− do expr' <- Expr.crawl Def.combineAnnotations expr
39+ do expr' <- exprCombineAnnotations expr
38 let def' = E.Definition pat expr' Nothing
40 let def' = E.Definition pat expr' Nothing
39 (:) (D.Definition def') <$> go defRest
41 (:) (D.Definition def') <$> go defRest
40
42
41 TypeAnnotation name tipe ->
43 TypeAnnotation name tipe ->
42 case defRest of
44 case defRest of
43 D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' ->
45 D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' ->
44− do expr' <- Expr.crawl Def.combineAnnotations expr
46+ do expr' <- exprCombineAnnotations expr
45 let def' = E.Definition pat expr' (Just tipe)
47 let def' = E.Definition pat expr' (Just tipe)
46 (:) (D.Definition def') <$> go rest
48 (:) (D.Definition def') <$> go rest
47
49
@@ -55,11 +57,11 @@ combineAnnotations = go
55 PortAnnotation name tipe ->
57 PortAnnotation name tipe ->
56 case portRest of
58 case portRest of
57 Port (SendDefinition name' expr) : rest | name == name' ->
59 Port (SendDefinition name' expr) : rest | name == name' ->
58− do expr' <- Expr.crawl Def.combineAnnotations expr
60+ do expr' <- exprCombineAnnotations expr
59 (:) (Port (Send name expr' tipe)) <$> go rest
61 (:) (Port (Send name expr' tipe)) <$> go rest
60
62
61 Port (RecvDefinition name' expr) : rest | name == name' ->
63 Port (RecvDefinition name' expr) : rest | name == name' ->
62− do expr' <- Expr.crawl Def.combineAnnotations expr
64+ do expr' <- exprCombineAnnotations expr
63 (:) (Port (Recv name expr' tipe)) <$> go rest
65 (:) (Port (Recv name expr' tipe)) <$> go rest
64
66
65 _ -> Left (msg name)
67 _ -> Left (msg name)
compiler/Transform/Definition.hs+4−2
@@ -12,17 +12,19 @@ combineAnnotations = go
12 msg x = "Syntax Error: The type annotation for '" ++ x ++
12 msg x = "Syntax Error: The type annotation for '" ++ x ++
13 "' must be directly above its definition."
13 "' must be directly above its definition."
14
14
15+ exprCombineAnnotations = Expr.crawlLet combineAnnotations
16+
15 go defs =
17 go defs =
16 case defs of
18 case defs of
17 TypeAnnotation name tipe : Def pat@(P.PVar name') expr : rest | name == name' ->
19 TypeAnnotation name tipe : Def pat@(P.PVar name') expr : rest | name == name' ->
18− do expr' <- Expr.crawl combineAnnotations expr
20+ do expr' <- exprCombineAnnotations expr
19 let def = Definition pat expr' (Just tipe)
21 let def = Definition pat expr' (Just tipe)
20 (:) def <$> go rest
22 (:) def <$> go rest
21
23
22 TypeAnnotation name _ : _ -> Left (msg name)
24 TypeAnnotation name _ : _ -> Left (msg name)
23
25
24 Def pat expr : rest ->
26 Def pat expr : rest ->
25− do expr' <- Expr.crawl combineAnnotations expr
27+ do expr' <- exprCombineAnnotations expr
26 let def = Definition pat expr' Nothing
28 let def = Definition pat expr' Nothing
27 (:) def <$> go rest
29 (:) def <$> go rest
28
30
compiler/Transform/Expression.hs+30−6
@@ -1,12 +1,32 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module Transform.Expression where
2+module Transform.Expression (crawlLet, checkPorts) where
3
3
4import Control.Applicative ((<$>),(<*>))
4import Control.Applicative ((<$>),(<*>))
5import SourceSyntax.Expression
5import SourceSyntax.Expression
6import SourceSyntax.Location
6import SourceSyntax.Location
7+import qualified SourceSyntax.Type as ST
8+import qualified Type.Type as TT
7
9
10+crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')
11+crawlLet = crawl (\_ _ _ -> return ()) (\_ _ -> return ())
12+
13+checkPorts :: (String -> ST.Type -> TT.Variable -> Either a ())
14+ -> (String -> ST.Type -> Either a ())
15+ -> LExpr
16+ -> Either a LExpr
17+checkPorts inCheck outCheck expr =
18+ crawl inCheck outCheck (mapM checkDef) expr
19+ where
20+ checkDef def@(Definition _ body _) =
21+ do _ <- checkPorts inCheck outCheck body
22+ return def
23+
24+crawl :: (String -> ST.Type -> TT.Variable -> Either a ())
25+ -> (String -> ST.Type -> Either a ())
26+ -> ([def] -> Either a [def'])
27+ -> LExpr' def
8−crawl :: ([def] -> Either a [def']) -> (LExpr' def) -> Either a (LExpr' def')
28+ -> Either a (LExpr' def')
9−crawl transform = go
29+crawl portInCheck portOutCheck defsTransform = go
10 where
30 where
11 go (L srcSpan expr) =
31 go (L srcSpan expr) =
12 L srcSpan <$>
32 L srcSpan <$>
@@ -27,6 +47,10 @@ crawl transform = go
27 Modify e fields -> Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fields
47 Modify e fields -> Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fields
28 Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields
48 Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields
29 Markdown uid md es -> Markdown uid md <$> mapM go es
49 Markdown uid md es -> Markdown uid md <$> mapM go es
30− Let defs body -> Let <$> transform defs <*> go body
50+ Let defs body -> Let <$> defsTransform defs <*> go body
51+ PortIn name st tt handler ->
52+ do portInCheck name st tt
31− PortIn name st tt handler -> PortIn name st tt <$> go handler
53+ PortIn name st tt <$> go handler
54+ PortOut name st signal ->
55+ do portOutCheck name st
32− PortOut name st signal -> PortOut name st <$> go signal
56+ PortOut name st <$> go signal