git.iko.soy/elk
on 577fc17 help sign in
elk/compiler/Type/Constrain/Expression.hs
231 lines 9.3 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Type.Constrain.Expression where
4import Control.Applicative ((<$>))
5import qualified Control.Monad as Monad
6import Control.Monad.Error
7import qualified Data.List as List
8import qualified Data.Map as Map
9import qualified Text.PrettyPrint as PP
11import AST.Literal as Lit
12import AST.Annotation as Ann
13import AST.Expression.General
14import qualified AST.Expression.Canonical as Canonical
15import qualified AST.Pattern as P
16import qualified AST.Type as ST
17import qualified AST.Variable as V
18import Type.Type hiding (Descriptor(..))
19import Type.Fragment
20import qualified Type.Environment as Env
21import qualified Type.Constrain.Literal as Literal
22import qualified Type.Constrain.Pattern as Pattern
24constrain :: Env.Environment -> Canonical.Expr -> Type
25 -> ErrorT [PP.Doc] IO TypeConstraint
26constrain env (A region expr) tipe =
27 let list t = Env.get env Env.types "_List" <| t
28 and = A region . CAnd
29 true = A region CTrue
30 t1 === t2 = A region (CEqual t1 t2)
31 x <? t = A region (CInstance x t)
32 clet schemes c = A region (CLet schemes c)
33 in
34 case expr of
35 Literal lit -> liftIO $ Literal.constrain env region lit tipe
37 GLShader _uid _src gltipe ->
38 exists $ \attr ->
39 exists $ \unif ->
40 let
41 shaderTipe a u v = Env.get env Env.types "Graphics.WebGL.Shader" <| a <| u <| v
42 glTipe = Env.get env Env.types . Lit.glTipeName
43 makeRec accessor baseRec =
44 let decls = accessor gltipe
45 in if Map.size decls == 0
46 then baseRec
47 else record (Map.map (\t -> [glTipe t]) decls) baseRec
48 attribute = makeRec Lit.attribute attr
49 uniform = makeRec Lit.uniform unif
50 varying = makeRec Lit.varying (termN EmptyRecord1)
51 in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)
53 Var var
54 | name == saveEnvName -> return (A region CSaveEnv)
55 | otherwise -> return (name <? tipe)
56 where
57 name = V.toString var
59 Range lo hi ->
60 existsNumber $ \n -> do
61 clo <- constrain env lo n
62 chi <- constrain env hi n
63 return $ and [clo, chi, list n === tipe]
65 ExplicitList exprs ->
66 exists $ \x -> do
67 cs <- mapM (\e -> constrain env e x) exprs
68 return . and $ list x === tipe : cs
70 Binop op e1 e2 ->
71 exists $ \t1 ->
72 exists $ \t2 -> do
73 c1 <- constrain env e1 t1
74 c2 <- constrain env e2 t2
75 return $ and [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]
77 Lambda p e ->
78 exists $ \t1 ->
79 exists $ \t2 -> do
80 fragment <- try region $ Pattern.constrain env p t1
81 c2 <- constrain env e t2
82 let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
83 (typeConstraint fragment /\ c2 ))
84 return $ c /\ tipe === (t1 ==> t2)
86 App e1 e2 ->
87 exists $ \t -> do
88 c1 <- constrain env e1 (t ==> tipe)
89 c2 <- constrain env e2 t
90 return $ c1 /\ c2
92 MultiIf branches -> and <$> mapM constrain' branches
93 where
94 bool = Env.get env Env.types "Bool"
95 constrain' (b,e) = do
96 cb <- constrain env b bool
97 ce <- constrain env e tipe
98 return (cb /\ ce)
100 Case exp branches ->
101 exists $ \t -> do
102 ce <- constrain env exp t
103 let branch (p,e) = do
104 fragment <- try region $ Pattern.constrain env p t
105 clet [toScheme fragment] <$> constrain env e tipe
106 and . (:) ce <$> mapM branch branches
108 Data name exprs ->
109 do vars <- forM exprs $ \_ -> liftIO (variable Flexible)
110 let pairs = zip exprs (map varN vars)
111 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)
112 return $ ex vars (cs /\ name <? ctipe)
113 where
114 step (t,c) (e,x) = do
115 c' <- constrain env e x
116 return (x ==> t, c /\ c')
118 Access e label ->
119 exists $ \t ->
120 constrain env e (record (Map.singleton label [tipe]) t)
122 Remove e label ->
123 exists $ \t ->
124 constrain env e (record (Map.singleton label [t]) tipe)
126 Insert e label value ->
127 exists $ \tVal ->
128 exists $ \tRec -> do
129 cVal <- constrain env value tVal
130 cRec <- constrain env e tRec
131 let c = tipe === record (Map.singleton label [tVal]) tRec
132 return (and [cVal, cRec, c])
134 Modify e fields ->
135 exists $ \t -> do
136 oldVars <- forM fields $ \_ -> liftIO (variable Flexible)
137 let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))
138 cOld <- ex oldVars <$> constrain env e (record oldFields t)
140 newVars <- forM fields $ \_ -> liftIO (variable Flexible)
141 let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))
142 let cNew = tipe === record newFields t
144 cs <- zipWithM (constrain env) (map snd fields) (map varN newVars)
146 return $ cOld /\ ex newVars (and (cNew : cs))
148 Record fields ->
149 do vars <- forM fields $ \_ -> liftIO (variable Flexible)
150 cs <- zipWithM (constrain env) (map snd fields) (map varN vars)
151 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))
152 recordType = record fields' (termN EmptyRecord1)
153 return . ex vars . and $ tipe === recordType : cs
155 Markdown _ _ es ->
156 do vars <- forM es $ \_ -> liftIO (variable Flexible)
157 let tvars = map varN vars
158 cs <- zipWithM (constrain env) es tvars
159 return . ex vars $ and ("Text.markdown" <? tipe : cs)
161 Let defs body ->
162 do c <- constrain env body tipe
163 (schemes, rqs, fqs, header, c2, c1) <-
164 Monad.foldM (constrainDef env)
165 ([], [], [], Map.empty, true, true)
166 (concatMap expandPattern defs)
167 return $ clet schemes
168 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]
169 (c1 /\ c))
171 PortIn _ _ -> return true
173 PortOut _ _ signal ->
174 constrain env signal tipe
176constrainDef env info (Canonical.Definition pattern expr maybeTipe) =
177 let qs = [] -- should come from the def, but I'm not sure what would live there...
178 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info
179 in
180 do rigidVars <- forM qs (\_ -> liftIO $ variable Rigid) -- Some mistake may be happening here.
181 -- Currently, qs is always [].
182 case (pattern, maybeTipe) of
183 (P.Var name, Just tipe) -> do
184 flexiVars <- forM qs (\_ -> liftIO $ variable Flexible)
185 let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars
186 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
187 (vars, typ) <- Env.instantiateType env tipe Map.empty
188 let scheme = Scheme { rigidQuantifiers = [],
189 flexibleQuantifiers = flexiVars ++ vars,
190 constraint = Ann.noneNoDocs CTrue,
191 header = Map.singleton name typ }
192 c <- constrain env' expr typ
193 return ( scheme : schemes
194 , rigidQuantifiers
195 , flexibleQuantifiers
196 , headers
197 , c2
198 , fl rigidVars c /\ c1 )
200 (P.Var name, Nothing) -> do
201 v <- liftIO $ variable Flexible
202 let tipe = varN v
203 inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars
204 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
205 c <- constrain env' expr tipe
206 return ( schemes
207 , rigidVars ++ rigidQuantifiers
208 , v : flexibleQuantifiers
209 , Map.insert name tipe headers
210 , c /\ c2
211 , c1 )
213 _ -> error ("problem in constrainDef with " ++ show pattern)
215expandPattern :: Canonical.Def -> [Canonical.Def]
216expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) =
217 case pattern of
218 P.Var _ -> [def]
219 _ -> Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars
220 where
221 vars = P.boundVarList pattern
222 x = "$" ++ concat vars
223 mkVar = A r . localVar
224 toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
226try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
227try region computation = do
228 result <- liftIO $ runErrorT computation
229 case result of
230 Left err -> throwError [err region]
231 Right value -> return value