@@ -0,0 +1,146 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Canonicalize.Body (flatten) where
3+
4+import qualified AST.Declaration as D
5+import qualified AST.Expression.General as E
6+import qualified AST.Expression.Canonical as Canonical
7+import qualified AST.Module as Module
8+import qualified AST.Module.Name as ModuleName
9+import qualified AST.Pattern as P
10+import qualified AST.Type as T
11+import qualified AST.Variable as Var
12+import qualified Canonicalize.Sort as Sort
13+import qualified Reporting.Annotation as A
14+import qualified Reporting.Region as R
15+
16+
17+
18+flatten :: ModuleName.Canonical -> [D.Canonical] -> Module.ValidEffects -> Canonical.Expr
19+flatten moduleName decls effects =
20+ let
21+ declDefs =
22+ concatMap (declToDefs moduleName) decls
23+
24+ effectDefs =
25+ effectsToDefs moduleName effects
26+ in
27+ Sort.definitions (E.dummyLet (declDefs ++ effectDefs))
28+
29+
30+
31+-- DECLARATIONS
32+
33+
34+declToDefs :: ModuleName.Canonical -> D.Canonical -> [Canonical.Def]
35+declToDefs moduleName (A.A (region,_) decl) =
36+ let
37+ typeVar =
38+ Var.fromModule moduleName
39+
40+ loc expr =
41+ A.A region expr
42+ in
43+ case decl of
44+ D.Def def ->
45+ [def]
46+
47+ D.Union name tvars constructors ->
48+ let
49+ tagToDef (ctor, tipes) =
50+ let
51+ vars =
52+ take (length tipes) infiniteArgs
53+
54+ tbody =
55+ T.App (T.Type (typeVar name)) (map T.Var tvars)
56+
57+ body =
58+ loc . E.Data ctor $ map (loc . E.localVar) vars
59+ in
60+ definition ctor (buildFunction body vars) region (foldr T.Lambda tbody tipes)
61+ in
62+ map tagToDef constructors
63+
64+ D.Alias name tvars tipe@(T.Record fields Nothing) ->
65+ [ definition name (buildFunction record vars) region (foldr T.Lambda result args) ]
66+ where
67+ result =
68+ T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe)
69+
70+ args =
71+ map snd fields
72+
73+ vars =
74+ take (length args) infiniteArgs
75+
76+ record =
77+ loc (E.Record (zip (map fst fields) (map (loc . E.localVar) vars)))
78+
79+ -- Type aliases must be added to an extended equality dictionary,
80+ -- but they do not require any basic constraints.
81+ D.Alias _ _ _ ->
82+ []
83+
84+ -- no constraints are needed for fixity declarations
85+ D.Fixity _ _ _ ->
86+ []
87+
88+
89+infiniteArgs :: [String]
90+infiniteArgs =
91+ map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
92+
93+
94+buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
95+buildFunction body@(A.A ann _) vars =
96+ foldr
97+ (\pattern expr -> A.A ann (E.Lambda pattern expr))
98+ body
99+ (map (A.A ann . P.Var) vars)
100+
101+
102+definition :: String -> Canonical.Expr -> R.Region -> T.Canonical -> Canonical.Def
103+definition name expr@(A.A ann _) region tipe =
104+ Canonical.Definition
105+ Canonical.dummyFacts
106+ (A.A ann (P.Var name))
107+ expr
108+ (Just (A.A region tipe))
109+
110+
111+
112+-- EFFECTS
113+
114+
115+effectsToDefs :: ModuleName.Canonical -> Module.ValidEffects -> [Canonical.Def]
116+effectsToDefs moduleName effects =
117+ case effects of
118+ Module.ValidNormal ->
119+ []
120+
121+ Module.ValidEffect maybeCmd maybeSub ->
122+ effectsToDefsHelp "command" (E.Cmd moduleName) maybeCmd
123+ ++ effectsToDefsHelp "subscription" (E.Sub moduleName) maybeSub
124+
125+ Module.ValidForeign ->
126+ []
127+
128+
129+effectsToDefsHelp
130+ :: String
131+ -> (String -> Canonical.Expr')
132+ -> Maybe (A.Located String)
133+ -> [Canonical.Def]
134+effectsToDefsHelp name toExpr' maybeEffect =
135+ case maybeEffect of
136+ Nothing ->
137+ []
138+
139+ Just (A.A region typeName) ->
140+ [ Canonical.Definition
141+ Canonical.dummyFacts
142+ (A.A region (P.Var name))
143+ (A.A region (toExpr' typeName))
144+ Nothing
145+ ]
146+