git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Canonicalize/Body.hs
182 lines 4.7 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Body (flatten) where
5import qualified Data.Maybe as Maybe
6import qualified Data.Text as Text
7import Data.Text (Text)
9import qualified AST.Declaration as Decl
10import qualified AST.Effects as Effects
11import qualified AST.Expression.Canonical as C
12import qualified AST.Module.Name as ModuleName
13import qualified AST.Pattern as P
14import qualified AST.Type as Type
15import qualified AST.Variable as Var
16import qualified Canonicalize.Sort as Sort
17import qualified Reporting.Annotation as A
18import Reporting.Error.Canonicalize (Error)
19import Reporting.Region (Region)
20import Reporting.Result (Result)
24flatten
25 :: (Monoid i)
26 => ModuleName.Canonical
27 -> Decl.Canonical
28 -> Effects.Canonical
29 -> Result i w Error C.Expr
30flatten moduleName (Decl.Decls defs unions aliases _) effects =
31 let
32 allDefs =
33 concat
34 [ concatMap (unionToDefs moduleName) unions
35 , Maybe.mapMaybe (aliasToDefs moduleName) aliases
36 , effectsToDefs moduleName effects
37 , map A.drop defs
38 ]
40 loc =
41 A.A (error "this annotation should never be needed")
42 in
43 Sort.definitions $ loc $
44 C.Let allDefs (loc $ C.SaveEnv moduleName effects)
48-- TYPES TO DEFS
51unionToDefs :: ModuleName.Canonical -> A.Commented (Decl.Union Type.Canonical) -> [C.Def]
52unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =
53 let
54 tagToDef (tag, tipes) =
55 let
56 vars =
57 generateArgs (length tipes) []
59 tbody =
60 Type.App
61 (Type.Type (Var.fromModule moduleName name))
62 (map Type.Var tvars)
64 body =
65 A.A region $
66 C.Ctor (Var.fromModule moduleName tag) (map (A.A region . C.localVar) vars)
67 in
68 definition tag (buildFunction vars body) region (foldr Type.Lambda tbody tipes)
69 in
70 map tagToDef constructors
73aliasToDefs :: ModuleName.Canonical -> A.Commented (Decl.Alias Type.Canonical) -> Maybe C.Def
74aliasToDefs moduleName (A.A (region,_) (Decl.Type name tvars tipe)) =
75 case tipe of
76 Type.Record fields Nothing ->
77 let
78 resultType =
79 Type.Aliased
80 (Var.fromModule moduleName name)
81 (zip tvars (map Type.Var tvars))
82 (Type.Holey tipe)
84 args =
85 map snd fields
87 vars =
88 generateArgs (length args) []
90 record =
91 A.A region $
92 C.Record (zip (map fst fields) (map (A.A region . C.localVar) vars))
93 in
94 Just $ definition name (buildFunction vars record) region (foldr Type.Lambda resultType args)
96 _ ->
97 Nothing
100generateArgs :: Int -> [Text] -> [Text]
101generateArgs n args =
102 if n == 0 then
103 args
104 else
105 generateArgs (n - 1) (Text.pack ('v' : show n) : args)
108buildFunction :: [Text] -> C.Expr -> C.Expr
109buildFunction vars body@(A.A ann _) =
110 foldr
111 (\pattern expr -> A.A ann (C.Lambda pattern expr))
112 body
113 (map (A.A ann . P.Var) vars)
116definition :: Text -> C.Expr -> Region -> Type.Canonical -> C.Def
117definition name expr@(A.A ann _) region tipe =
118 C.Def
119 region
120 (A.A ann (P.Var name))
121 expr
122 (Just (A.A region tipe))
126-- EFFECTS
129effectsToDefs :: ModuleName.Canonical -> Effects.Canonical -> [C.Def]
130effectsToDefs moduleName effects =
131 case effects of
132 Effects.None ->
133 []
135 Effects.Port ports ->
136 map portToDef ports
138 Effects.Manager _ info ->
139 let
140 cmdToDef (A.A region name) managerType =
141 definition
142 "command"
143 (A.A region (C.Cmd moduleName managerType))
144 region
145 (Type.cmd moduleName name)
147 subToDef (A.A region name) managerType =
148 definition
149 "subscription"
150 (A.A region (C.Sub moduleName managerType))
151 region
152 (Type.sub moduleName name)
153 in
154 case Effects._managerType info of
155 Effects.CmdManager cmd ->
156 [ cmdToDef cmd Effects.Cmds
157 ]
159 Effects.SubManager sub ->
160 [ subToDef sub Effects.Subs
161 ]
163 Effects.FxManager cmd sub ->
164 [ cmdToDef cmd Effects.Both
165 , subToDef sub Effects.Both
166 ]
169portToDef :: A.Commented Effects.PortCanonical -> C.Def
170portToDef (A.A (region, _) (Effects.PortCanonical name kind tipe)) =
171 definition name (A.A region (toPortExpr name kind)) region tipe
174toPortExpr :: Text -> Effects.Kind -> C.Expr'
175toPortExpr name kind =
176 case kind of
177 Effects.Outgoing tipe ->
178 C.OutgoingPort name tipe
180 Effects.Incoming tipe ->
181 C.IncomingPort name tipe