@@ -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)