git.iko.soy/elk
on 294fdfd help sign in
elk/compiler/Types/Constrain.hs
309 lines 12 kB history raw
2module Types.Constrain (constrain) where
4import Control.Arrow (second)
5import Control.Monad (liftM,mapM,zipWithM,foldM)
6import Control.Monad.State (evalState)
7import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf)
8import qualified Data.Map as Map
9import qualified Data.Set as Set
11import Ast
12import Context
13import Guid
15import Types.Types
16import Types.Substitutions
18beta = VarT `liftM` guid
19unionA = Map.unionWith (++)
20unionsA = Map.unionsWith (++)
22getAliases imports hints = hints ++ concatMap aliasesFrom imports'
23 where imports' = map head . group $ sort imports
24 aliasesFrom (name,method) =
25 case method of
26 As alias -> concatMap (findAlias name alias) hints
27 _ -> []
28 findAlias mName' mAlias (name,tipe) =
29 let mName = mName' ++ "." in
30 case mName `isPrefixOf` name of
31 True -> [ (mAlias ++ drop (length mName) name, tipe) ]
32 False -> []
34findAmbiguous hints hints' assumptions continue =
35 let potentialDups = map head . filter (\g -> length g > 1) . group $ sort hints'
36 dups = filter (\k -> Map.member k assumptions) potentialDups
37 in case dups of
38 n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++ "' could refer to " ++
39 intercalate ", " (filter (isSuffixOf n) hints)
40 _ -> continue
42mergeSchemes :: [Map.Map String Scheme]
43 -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)
44mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs
45 return (Map.unions ass, Set.unions css, Map.unions sss)
46 where
47 kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss)
48 split (k,vs) =
49 let ps = zipWith (\s v -> (s++k,v)) (map (flip replicate '_') [0..]) vs
50 eq t u = C (Just $ msg ++ k) NoSpan (VarT t :=: VarT u)
51 msg = "the definition of "
52 in do xs <- mapM (\_ -> guid) vs
53 return ( Map.fromList $ zip (map fst ps) (map (:[]) xs)
54 , case xs of
55 t:ts -> Set.fromList $ zipWith eq (t:ts) ts
56 [] -> Set.empty
57 , Map.fromList ps )
59constrain typeHints (Module _ _ imports stmts) = do
60 (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts
61 hints <- typeHints
62 (as', cs', schemes) <- mergeSchemes schemess
63 let constraints = Set.unions (cs':css)
64 as = unionsA (as':ass)
65 extraImports = ("Time", Importing []) : map (\n -> (n, Importing []))
66 ["List","Signal","Text","Graphics","Color"]
67 aliasHints = getAliases (imports ++ extraImports) hints
68 allHints = Map.union schemes (Map.fromList aliasHints)
69 insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
70 assumptions <- foldM insert as (Map.keys schemes)
71 findAmbiguous (map fst hints) (map fst aliasHints) assumptions $ do
72 let f k s vs = map (\v -> C (Just k) NoSpan $ v :<<: s) vs
73 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
74 escapees = Map.keys $ Map.difference assumptions allHints
75 return $ case escapees of
76 _ -> Right (Set.toList constraints ++ cs)
77 --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)
79type TVarMap = Map.Map String [X]
80type ConstraintSet = Set.Set (Context Constraint)
82ctx e span = C (Just $ show e) span
84gen :: CExpr -> GuidCounter (TVarMap, ConstraintSet, Type)
85gen (C _ span expr) =
86 let ctx' = C (Just $ show expr) span in
87 case expr of
88 Var x ->
89 do b <- guid
90 return (Map.singleton x [b], Set.empty, VarT b)
92 App e1 e2 ->
93 do (a1,c1,t1) <- gen e1
94 (a2,c2,t2) <- gen e2
95 b <- beta
96 return ( unionA a1 a2
97 , Set.unions [c1,c2
98 ,Set.singleton . ctx' $ t1 :=: (LambdaT t2 b)]
99 , b )
101 Lambda x e ->
102 do (a,c,t) <- gen e
103 b <- beta
104 v <- guid
105 return ( Map.delete x a
106 , Set.union c . Set.fromList .
107 map (\x -> ctx' $ VarT x :=: b) $
108 Map.findWithDefault [v] x a
109 , LambdaT b t )
111 Let defs e ->
112 do (as,cs,t) <- gen e
113 (ass, schemes) <- liftM unzip (mapM defScheme defs)
114 let assumptions = unionsA (as:ass)
115 getName d = case d of FnDef f _ _ -> f
116 OpDef op _ _ _ -> op
117 names = map getName defs
118 genCs name s = do
119 v <- guid
120 let vs = Map.findWithDefault [v] name assumptions
121 return $ map (\x -> ctx name span $ x :<<: s) vs
122 cs' <- zipWithM genCs names schemes
123 return ( foldr Map.delete assumptions names
124 , Set.union (Set.fromList . concat $ cs') cs
125 , t )
127 Case e cases ->
128 do (as,cs,t) <- gen e
129 (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases
130 return ( unionsA $ as:ass
131 , let cases' = map snd cases
132 ctxs = zipWith epos cases' (tail cases')
133 csts = zipWith (:=:) ts (tail ts)
134 cs' = Set.fromList (zipWith ($) ctxs csts)
135 in Set.unions $ cs' : cs : css
136 , head ts)
138 If e1 e2 e3 ->
139 do (a1,c1,t1) <- gen e1
140 (a2,c2,t2) <- gen e2
141 (a3,c3,t3) <- gen e3
142 return ( unionsA [a1,a2,a3]
143 , let c4 = Set.fromList [ ctx e1 span (t1 :=: bool)
144 , ctx' (t2 :=: t3) ]
145 in Set.unions [c1,c2,c3,c4]
146 , t2 )
148 Data name es ->
149 gen $ foldl' (\f x -> epos f x $ App f x) (ctx' $ Var name) es
151 Binop op e1 e2 ->
152 gen $ ctx' (App (ctx' $ App (ctx' $ Var op) e1) e2)
154 Access e label ->
155 do (as,cs,rtype) <- gen e
156 t <- beta
157 rtype' <- beta
158 let fs = Map.singleton label [t]
159 c = (ctx' (RecordT fs rtype' :=: rtype))
160 return (as, Set.insert c cs, t)
162 Remove e x ->
163 do (as,cs,rtype) <- gen e
164 t <- beta
165 rtype' <- beta
166 let c = (ctx' (RecordT (Map.singleton x [t]) rtype' :=: rtype))
167 return (as, Set.insert c cs, rtype')
169 Insert e x v ->
170 do (eas,ecs,etype) <- gen e
171 (vas,vcs,vtype) <- gen v
172 return ( unionA eas vas
173 , Set.union ecs vcs
174 , RecordT (Map.singleton x [vtype]) etype )
176 Modify record fields ->
177 do (ras,rcs,rtype) <- gen record
178 (ass,css,newTs) <- unzip3 `liftM` mapM gen (map snd fields)
179 oldTs <- mapM (\_ -> beta) fields
180 rtype' <- beta
181 let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype'
182 c = Set.singleton (ctx' (rtype :=: rT oldTs))
183 return ( unionsA (ras:ass), Set.unions (c : rcs : css), rT newTs )
185 Record fields ->
186 let insert label tipe = Map.insertWith (++) label [tipe]
187 getScheme (f,args,e) = do
188 (as, _, (label, Forall _ cs tipe)) <- defGenHelp f args e
189 return (as, cs, insert label tipe)
190 in do (ass, css, fs) <- unzip3 `liftM` mapM getScheme fields
191 return ( unionsA ass
192 , Set.fromList (concat css)
193 , RecordT (foldr ($) Map.empty fs) EmptyRecord )
195 Range e1@(C w1 s1 _) e2@(C w2 s2 _) ->
196 do (a1,c1,t1) <- gen e1
197 (a2,c2,t2) <- gen e2
198 return ( unionsA [a1,a2]
199 , Set.unions [ c1, c2, Set.fromList [ C w1 s1 (t1 :=: int)
200 , C w1 s2 (t2 :=: int) ] ]
201 , listOf int )
203 MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
204 let cs = Set.fromList (map (ctx' . (t :=:)) ts)
205 return (unionsA ass, Set.unions (cs:css), t)
206 where genPair (b@(C t s _),e) = do
207 (a1,c1,t1) <- gen b
208 (a2,c2,t2) <- gen e
209 return ( unionsA [a1,a2]
210 , Set.unions [ c1, c2
211 , Set.singleton (C t s (t1 :=: bool)) ]
212 , t2 )
214 IntNum _ -> do t <- beta
215 return (Map.empty, Set.singleton (ctx' $ t :<: number), t)
217 FloatNum _ -> primitive float
218 Chr _ -> primitive char
219 Str _ -> primitive string
220 Boolean _ -> primitive bool
221 Markdown _ -> primitive element
224primitive :: Type -> GuidCounter (TVarMap, ConstraintSet, Type)
225primitive t = return (Map.empty, Set.empty, t)
227caseGen :: Type
228 -> (Pattern, CExpr)
229 -> GuidCounter (TVarMap, ConstraintSet, Type)
230caseGen tipe (p, ce@(C _ span e)) = do
231 (as ,cs ,t) <- gen ce
232 (as',cs',_) <- patternGen (ctx p span) tipe as p
233 return ( as', Set.union cs cs', t )
235patternGen :: (Constraint -> Context Constraint)
236 -> Type
237 -> TVarMap
238 -> Pattern
239 -> GuidCounter (TVarMap, ConstraintSet, Type)
240patternGen ctxt tipe as pattern =
241 case pattern of
242 PAnything -> do b <- beta ; return (Map.empty, Set.empty, b)
243 PVar v -> do
244 b <- beta
245 let cs = map (ctxt . (b :=:) . VarT) (Map.findWithDefault [] v as)
246 return ( Map.delete v as, Set.fromList (ctxt (b :=: tipe) : cs), b )
247 PData name ps -> do
248 constr <- guid
249 output <- beta
250 let step (as,cs,tipe) p = do b <- beta
251 (as',cs',t) <- patternGen ctxt b as p
252 return (as', Set.union cs cs', t ==> tipe)
253 (as',cs, t) <- foldM step (as,Set.empty,tipe) (reverse ps)
254 return ( Map.insert name [constr] as'
255 , Set.insert (ctxt (VarT constr :=: t)) cs
256 , output )
259defScheme :: Def -> GuidCounter (Map.Map String [X], Scheme)
260defScheme def = do (as,cs,hint) <- defGen def
261 return ( as, snd hint )
263defGen def = case def of
264 FnDef f args e -> defGenHelp f args e
265 OpDef op a1 a2 e -> defGenHelp op [a1,a2] e
267defGenHelp name args e = do
268 argDict <- mapM (\a -> liftM ((,) a) guid) args
269 (as,cs,t) <- gen e
270 let as' = foldr Map.delete as args
271 tipe = foldr (==>) t $ map (VarT . snd) argDict
272 genCs (arg,x) = do
273 v <- guid
274 let as' = Map.findWithDefault [v] arg as
275 return $ map (\y -> ctx arg NoSpan $ VarT x :=: VarT y) as'
276 cs' <- concat `liftM` mapM genCs argDict
277 scheme <- generalize (concat $ Map.elems as') $
278 Forall (map snd argDict) (cs' ++ Set.toList cs) tipe
279 return ( as', Set.empty, (name, scheme) )
282stmtGen :: Statement
283 -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)
284stmtGen stmt =
285 case stmt of
286 Definition def -> do (as,cs,hint) <- defGen def
287 return ( as, cs, uncurry Map.singleton hint )
289 Datatype name xs tcs ->
290 let toScheme ts = Forall xs [] (foldr (==>) (ADT name $ map VarT xs) ts)
291 in return (Map.empty, Set.empty, Map.fromList (map (second toScheme) tcs))
293 ExportEvent js elm tipe ->
294 do x <- guid
295 return ( Map.singleton elm [x]
296 , Set.singleton . ctx elm NoSpan $ VarT x :=: tipe
297 , Map.empty )
299 ImportEvent js e@(C txt span base) elm tipe ->
300 do (as,cs,t) <- gen e
301 return ( as
302 , Set.insert (C txt span (signalOf t :=: tipe)) cs
303 , Map.singleton elm (Forall [] [] tipe) )
305 TypeAnnotation name tipe ->
306 do schm <- generalize [] (Forall [] [] tipe)
307 return (Map.empty, Set.empty, Map.singleton name schm)
309 TypeAlias _ _ _ -> return (Map.empty, Set.empty, Map.empty)