git.iko.soy/elk
on 9b0c310 help sign in
elk/src/Type/Constrain/Expression.hs
310 lines 10 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.Constrain.Expression where
4import Control.Applicative ((<$>))
5import qualified Control.Monad as Monad
6import qualified Data.List as List
7import qualified Data.Map as Map
9import qualified AST.Expression.General as E
10import qualified AST.Expression.Canonical as Canonical
11import qualified AST.Literal as Lit
12import qualified AST.Pattern as P
13import qualified AST.Type as ST
14import qualified AST.Variable as V
15import qualified Reporting.Annotation as A
16import qualified Type.Constrain.Literal as Literal
17import qualified Type.Constrain.Pattern as Pattern
18import qualified Type.Environment as Env
19import qualified Type.Fragment as Fragment
20import Type.Type hiding (Descriptor(..))
23constrain
24 :: Env.Environment
25 -> Canonical.Expr
26 -> Type
27 -> IO TypeConstraint
28constrain env (A.A region expression) tipe =
29 let list t = Env.get env Env.types "List" <| t
30 (===) = CEqual region
31 (<?) = CInstance region
32 in
33 case expression of
34 E.Literal lit ->
35 Literal.constrain env region lit tipe
37 E.GLShader _uid _src gltipe ->
38 exists $ \attr ->
39 exists $ \unif ->
40 let
41 shaderTipe a u v =
42 Env.get env Env.types "WebGL.Shader" <| a <| u <| v
44 glTipe =
45 Env.get env Env.types . Lit.glTipeName
47 makeRec accessor baseRec =
48 let decls = accessor gltipe
49 in
50 if Map.size decls == 0
51 then baseRec
52 else record (Map.map (\t -> [glTipe t]) decls) baseRec
54 attribute = makeRec Lit.attribute attr
55 uniform = makeRec Lit.uniform unif
56 varying = makeRec Lit.varying (termN EmptyRecord1)
57 in
58 return (tipe === shaderTipe attribute uniform varying)
60 E.Var var ->
61 let name = V.toString var
62 in
63 return (if name == E.saveEnvName then CSaveEnv else name <? tipe)
65 E.Range lo hi ->
66 existsNumber $ \n ->
67 do clo <- constrain env lo n
68 chi <- constrain env hi n
69 return $ CAnd [clo, chi, list n === tipe]
71 E.ExplicitList exprs ->
72 exists $ \x ->
73 do constraints <- mapM (\e -> constrain env e x) exprs
74 return $ CAnd (list x === tipe : constraints)
76 E.Binop op e1 e2 ->
77 exists $ \t1 ->
78 exists $ \t2 ->
79 do c1 <- constrain env e1 t1
80 c2 <- constrain env e2 t2
81 return $ CAnd [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]
83 E.Lambda pattern body ->
84 exists $ \t1 ->
85 exists $ \t2 ->
86 do fragment <- Pattern.constrain env pattern t1
87 c2 <- constrain env body t2
88 let c = ex (Fragment.vars fragment)
89 (CLet [monoscheme (Fragment.typeEnv fragment)]
90 (Fragment.typeConstraint fragment /\ c2)
91 )
92 return $ c /\ tipe === (t1 ==> t2)
94 E.App e1 e2 ->
95 exists $ \t ->
96 do c1 <- constrain env e1 (t ==> tipe)
97 c2 <- constrain env e2 t
98 return $ c1 /\ c2
100 E.MultiIf branches ->
101 CAnd <$> mapM constrain' branches
102 where
103 bool = Env.get env Env.types "Bool"
105 constrain' (cond, expr) =
106 do cb <- constrain env cond bool
107 ce <- constrain env expr tipe
108 return (cb /\ ce)
110 E.Case expr branches ->
111 exists $ \t ->
112 do exprConstraint <- constrain env expr t
113 branchConstraints <- mapM (branch t) branches
114 return (CAnd (exprConstraint : branchConstraints))
115 where
116 branch t (pattern, branchExpr) =
117 do fragment <- Pattern.constrain env pattern t
118 CLet [Fragment.toScheme fragment] <$> constrain env branchExpr tipe
120 E.Data name exprs ->
121 do vars <- Monad.forM exprs $ \_ -> variable Flexible
122 let pairs = zip exprs (map varN vars)
123 (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)
124 return $ ex vars (cs /\ name <? ctipe)
125 where
126 step (t,c) (e,x) =
127 do c' <- constrain env e x
128 return (x ==> t, c /\ c')
130 E.Access expr label ->
131 exists $ \t ->
132 constrain env expr (record (Map.singleton label [tipe]) t)
134 E.Remove expr label ->
135 exists $ \t ->
136 constrain env expr (record (Map.singleton label [t]) tipe)
138 E.Insert expr label value ->
139 exists $ \tVal ->
140 exists $ \tRec ->
141 do cVal <- constrain env value tVal
142 cRec <- constrain env expr tRec
143 let c = tipe === record (Map.singleton label [tVal]) tRec
144 return (CAnd [cVal, cRec, c])
146 E.Modify expr fields ->
147 exists $ \t ->
148 do oldVars <- Monad.forM fields $ \_ -> variable Flexible
149 let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))
150 cOld <- ex oldVars <$> constrain env expr (record oldFields t)
152 newVars <- Monad.forM fields $ \_ -> variable Flexible
153 let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))
154 let cNew = tipe === record newFields t
156 cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN newVars)
158 return $ cOld /\ ex newVars (CAnd (cNew : cs))
160 E.Record fields ->
161 do vars <- Monad.forM fields $ \_ -> variable Flexible
162 cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN vars)
163 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))
164 let recordType = record fields' (termN EmptyRecord1)
165 return . ex vars . CAnd $ tipe === recordType : cs
167 E.Let defs body ->
168 do c <- constrain env body tipe
170 (Info schemes rqs fqs headers c2 c1) <-
171 Monad.foldM
172 (constrainDef env)
173 (Info [] [] [] Map.empty CTrue CTrue)
174 (concatMap expandPattern defs)
176 let letScheme = [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
178 return $ CLet schemes (CLet letScheme (c1 /\ c))
180 E.Port impl ->
181 case impl of
182 E.In _ _ ->
183 return CTrue
185 E.Out _ expr _ ->
186 constrain env expr tipe
188 E.Task _ expr _ ->
189 constrain env expr tipe
192expandPattern :: Canonical.Def -> [Canonical.Def]
193expandPattern def@(Canonical.Definition lpattern expr maybeType) =
194 let (A.A patternRegion pattern) = lpattern
195 in
196 case pattern of
197 P.Var _ ->
198 [def]
200 _ ->
201 mainDef : map toDef vars
202 where
203 vars = P.boundVarList lpattern
205 combinedName = "$" ++ concat vars
207 pvar name =
208 A.A patternRegion (P.Var name)
210 localVar name =
211 A.A patternRegion (E.localVar name)
213 mainDef = Canonical.Definition (pvar combinedName) expr maybeType
215 toDef name =
216 let extract =
217 E.Case (localVar combinedName) [(lpattern, localVar name)]
218 in
219 Canonical.Definition (pvar name) (A.A patternRegion extract) Nothing
222-- CONSTRAIN DEFINITIONS
224data Info = Info
225 { iSchemes :: [TypeScheme]
226 , iRigid :: [Variable]
227 , iFlex :: [Variable]
228 , iHeaders :: Map.Map String Type
229 , iC2 :: TypeConstraint
230 , iC1 :: TypeConstraint
231 }
234constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info
235constrainDef env info (Canonical.Definition (A.A _ pattern) expr maybeTipe) =
236 let qs = [] -- should come from the def, but I'm not sure what would live there...
237 in
238 case (pattern, maybeTipe) of
239 (P.Var name, Just tipe) ->
240 constrainAnnotatedDef env info qs name expr tipe
242 (P.Var name, Nothing) ->
243 constrainUnannotatedDef env info qs name expr
245 _ -> error ("problem in constrainDef with " ++ show pattern)
248constrainAnnotatedDef
249 :: Env.Environment
250 -> Info
251 -> [String]
252 -> String
253 -> Canonical.Expr
254 -> ST.Canonical
255 -> IO Info
256constrainAnnotatedDef env info qs name expr tipe =
257 do -- Some mistake may be happening here. Currently, qs is always [].
258 rigidVars <- Monad.forM qs (\_ -> variable Rigid)
260 flexiVars <- Monad.forM qs (\_ -> variable Flexible)
262 let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars
264 let env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
266 (vars, typ) <- Env.instantiateType env tipe Map.empty
268 let scheme =
269 Scheme
270 { rigidQuantifiers = []
271 , flexibleQuantifiers = flexiVars ++ vars
272 , constraint = CTrue
273 , header = Map.singleton name typ
274 }
276 c <- constrain env' expr typ
278 return $ info
279 { iSchemes = scheme : iSchemes info
280 , iC1 = fl rigidVars c /\ iC1 info
281 }
284constrainUnannotatedDef
285 :: Env.Environment
286 -> Info
287 -> [String]
288 -> String
289 -> Canonical.Expr
290 -> IO Info
291constrainUnannotatedDef env info qs name expr =
292 do -- Some mistake may be happening here. Currently, qs is always [].
293 rigidVars <- Monad.forM qs (\_ -> variable Rigid)
295 v <- variable Flexible
297 let tipe = varN v
299 let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars
301 let env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
303 c <- constrain env' expr tipe
305 return $ info
306 { iRigid = rigidVars ++ iRigid info
307 , iFlex = v : iFlex info
308 , iHeaders = Map.insert name tipe (iHeaders info)
309 , iC2 = c /\ iC2 info
310 }