@@ -19,74 +19,86 @@ import qualified Transform.Definition as Def
1919
2020
2121combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl]
22−combineAnnotations = go
23− where
24− msg x = "Syntax Error: The type annotation for '" ++ x ++
25− "' must be directly above its definition."
26−
27− exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations
28−
29− go decls =
30− case decls of
31− -- simple cases, pass them through with no changes
32− [] -> return []
33−
34− D.Datatype name tvars ctors : rest ->
35− (:) (D.Datatype name tvars ctors) <$> go rest
36−
37− D.TypeAlias name tvars alias : rest ->
38− (:) (D.TypeAlias name tvars alias) <$> go rest
39−
40− D.Fixity assoc prec op : rest ->
41− (:) (D.Fixity assoc prec op) <$> go rest
42−
43− -- combine definitions
44− D.Definition def : defRest ->
45− case def of
46− Source.Definition pat expr ->
47− do expr' <- exprCombineAnnotations expr
48− let def' = Valid.Definition pat expr' Nothing
49− (:) (D.Definition def') <$> go defRest
50−
51− Source.TypeAnnotation name tipe ->
52− case defRest of
53− D.Definition (Source.Definition pat@(P.Var name') expr) : rest
54− | name == name' ->
55− do expr' <- exprCombineAnnotations expr
56− let def' = Valid.Definition pat expr' (Just tipe)
57− (:) (D.Definition def') <$> go rest
58−
59− _ -> Left (msg name)
60−
61− -- combine ports
62− D.Port port : portRest ->
63− case port of
64− D.PPDef name _ -> Left (msg name)
65− D.PPAnnotation name tipe ->
66− case portRest of
67− D.Port (D.PPDef name' expr) : rest | name == name' ->
68− do expr' <- exprCombineAnnotations expr
69− (:) (D.Port (D.Out name expr' tipe)) <$> go rest
70−
71− _ -> (:) (D.Port (D.In name tipe)) <$> go portRest
22+combineAnnotations =
23+ go
24+ where
25+ msg x = "Syntax Error: The type annotation for '" ++ x ++
26+ "' must be directly above its definition."
27+
28+ exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations
29+
30+ go decls =
31+ case decls of
32+ -- simple cases, pass them through with no changes
33+ [] -> return []
34+
35+ D.Datatype name tvars ctors : rest ->
36+ (:) (D.Datatype name tvars ctors) <$> go rest
37+
38+ D.TypeAlias name tvars alias : rest ->
39+ (:) (D.TypeAlias name tvars alias) <$> go rest
40+
41+ D.Fixity assoc prec op : rest ->
42+ (:) (D.Fixity assoc prec op) <$> go rest
43+
44+ -- combine definitions
45+ D.Definition def : defRest ->
46+ case def of
47+ Source.Definition pat expr ->
48+ do expr' <- exprCombineAnnotations expr
49+ let def' = Valid.Definition pat expr' Nothing
50+ (:) (D.Definition def') <$> go defRest
51+
52+ Source.TypeAnnotation name tipe ->
53+ case defRest of
54+ D.Definition (Source.Definition pat@(P.Var name') expr) : rest
55+ | name == name' ->
56+ do expr' <- exprCombineAnnotations expr
57+ let def' = Valid.Definition pat expr' (Just tipe)
58+ (:) (D.Definition def') <$> go rest
59+
60+ _ -> Left (msg name)
61+
62+ -- combine ports
63+ D.Port port : portRest ->
64+ case port of
65+ D.InputAnnotation name tipe ->
66+ (:) (D.Port (D.In name tipe)) <$> go portRest
67+
68+ D.OutputDef name _ ->
69+ Left (msg name)
70+
71+ D.OutputAnnotation name tipe ->
72+ case portRest of
73+ D.Port (D.OutputDef name' expr) : rest | name == name' ->
74+ do expr' <- exprCombineAnnotations expr
75+ (:) (D.Port (D.Out name expr' tipe)) <$> go rest
76+
77+ _ ->
78+ Left (msg name)
7279
7380
7481toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]
75−toExpr moduleName = concatMap (toDefs moduleName)
82+toExpr moduleName =
83+ concatMap (toDefs moduleName)
84+
7685
7786toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def]
7887toDefs moduleName decl =
7988 let typeVar = Var.Canonical (Var.Module moduleName) in
8089 case decl of
81− D.Definition def -> [def]
90+ D.Definition def ->
91+ [def]
8292
83− D.Datatype name tvars constructors -> concatMap toDefs' constructors
93+ D.Datatype name tvars constructors ->
94+ concatMap toDefs' constructors
8495 where
8596 toDefs' (ctor, tipes) =
8697 let vars = take (length tipes) arguments
8798 tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)
8899 body = A.none . E.Data ctor $ map (A.none . E.localVar) vars
89− in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
100+ in
101+ [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
90102
91103 D.TypeAlias name _ tipe@(T.Record fields ext) ->
92104 [ definition name (buildFunction record vars) (foldr T.Lambda result args) ]
@@ -99,13 +111,16 @@ toDefs moduleName decl =
99111 vars = take (length args) arguments
100112
101113 efields = zip (map fst fields) (map var vars)
102− record = case ext of
103− Nothing -> A.none $ E.Record efields
104− Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
114+ record =
115+ case ext of
116+ Nothing -> A.none $ E.Record efields
117+ Just _ ->
118+ foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
105119
106120 -- Type aliases must be added to an extended equality dictionary,
107121 -- but they do not require any basic constraints.
108− D.TypeAlias _ _ _ -> []
122+ D.TypeAlias _ _ _ ->
123+ []
109124
110125 D.Port port ->
111126 case port of
@@ -115,15 +130,20 @@ toDefs moduleName decl =
115130 [ definition name (A.none $ E.PortIn name tipe) tipe ]
116131
117132 -- no constraints are needed for fixity declarations
118− D.Fixity _ _ _ -> []
133+ D.Fixity _ _ _ ->
134+ []
119135
120136
121137arguments :: [String]
122−arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
138+arguments =
139+ map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
140+
123141
124142buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
125143buildFunction body@(A.A s _) vars =
126− foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
144+ foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
145+
127146
128147definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def
129−definition name expr tipe = Canonical.Definition (P.Var name) expr (Just tipe)
148+definition name expr tipe =
149+ Canonical.Definition (P.Var name) expr (Just tipe)