git.iko.soy/elk
on a3801ac help sign in
elk/compiler/Types/Constrain.hs
339 lines 13 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.Char (isDigit)
8import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf)
9import qualified Data.Map as Map
10import qualified Data.Set as Set
12import Ast
13import Located
14import Guid
16import Types.Types
17import qualified Types.Substitutions as Subs
19import System.IO.Unsafe
21beta = VarT `liftM` guid
22unionA = Map.unionWith (++)
23unionsA = Map.unionsWith (++)
25getAliases :: [(String,ImportMethod)] -> [(String,Scheme)] -> [(String,Scheme)]
26getAliases imports hints = concatMap aliasesFrom imports
27 where
28 -- Get the names of values that are now in scope after a particular
29 -- import statement.
30 aliasesFrom :: (String,ImportMethod) -> [(String,Scheme)]
31 aliasesFrom (name,method) =
32 let values = concatMap (getValue name) hints
33 prefixed name = map (\(n,t) -> (name ++ "." ++ n, t)) values
34 in case method of
35 As alias -> prefixed alias
36 Hiding vs -> prefixed name ++ filter (\(n,t) -> n `notElem` vs) values
37 Importing vs -> prefixed name ++ filter (\(n,t) -> n `elem` vs) values
39 -- Take a module name and a type annotation. Return the unprefxed
40 -- type annotation: getValue "List" ("List.map",t) == [("map",t)]
41 getValue :: String -> (String,Scheme) -> [(String,Scheme)]
42 getValue inModule (name,tipe) =
43 case inModule `isPrefixOf` name of
44 True -> [ (drop (length inModule + 1) name, tipe) ]
45 False -> []
47findAmbiguous hints assumptions continue =
48 let potentialDups = map head . filter (\g -> length g > 1) . group . sort $
49 filter (elem '.') hints
50 dups = filter (\k -> Map.member k assumptions) potentialDups
51 in case dups of
52 n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++
53 "' could refer to " ++
54 intercalate ", " (filter (isSuffixOf n) hints)
55 _ -> continue
57mergeSchemes :: [Map.Map String Scheme]
58 -> GuidCounter (TVarMap, Constraints, Map.Map String Scheme)
59mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs
60 return (Map.unions ass, concat css, Map.unions sss)
61 where
62 kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss)
63 split (k,vs) =
64 let ps = zipWith (\s v -> (s++k,v)) (map (flip replicate '_') [0..]) vs
65 eq t u = L (Just $ msg ++ k) NoSpan (VarT t :=: VarT u)
66 msg = "the definition of "
67 in do xs <- mapM (\_ -> guid) vs
68 return ( Map.fromList $ zip (map fst ps) (map (:[]) xs)
69 , case xs of
70 t:ts -> zipWith eq xs ts
71 [] -> []
72 , Map.fromList ps )
74--constrain :: Map.Map String Scheme
75-- -> Module
76-- -> GuidCounter (Either String Constraints)
77constrain typeHints (Module _ _ imports stmts) = do
78 (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts
79 aliasHints <- getAliases imports `liftM` typeHints
80 (as', cs', schemes) <- mergeSchemes schemess
81 let constraints = concat (cs':css)
82 as = unionsA (as':ass)
83 allHints = Map.union schemes (Map.fromList aliasHints)
84 insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
85 assumptions <- foldM insert as (Map.keys schemes)
86 findAmbiguous (map fst aliasHints) assumptions $ do
87 let f k s vs = map (\v -> L (Just k) NoSpan $ v :<<: s) vs
88 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
89 escapees = Map.keys $ Map.difference assumptions allHints
90 msg = "Warning! Type-checker could not find variables:\n" ++ intercalate ", " escapees
91 return $ case escapees of
92 [] -> Right (schemess, constraints ++ cs)
93 _ -> unsafePerformIO (putStrLn msg) `seq` Right (schemess, constraints ++ cs)
94 --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)
96type TVarMap = Map.Map String [X]
97type Constraints = [Located Constraint]
99loc e span = L (Just $ show e) span
101gen :: CExpr -> GuidCounter (TVarMap, Constraints, Type)
102gen (L _ span expr) =
103 let loc' = L (Just $ show expr) span in
104 case expr of
105 Var x ->
106 do b <- guid
107 return (Map.singleton x [b], [], VarT b)
109 App e1 e2 ->
110 do (a1,c1,t1) <- gen e1
111 (a2,c2,t2) <- gen e2
112 b <- beta
113 return ( unionA a1 a2
114 , c1 ++ c2 ++ [loc' $ t1 :=: (LambdaT t2 b)]
115 , b )
117 Lambda x e ->
118 do (a,c,t) <- gen e
119 b <- beta
120 v <- guid
121 return ( Map.delete x a
122 , (++) c . map (\x -> loc' $ VarT x :=: b) $
123 Map.findWithDefault [v] x a
124 , LambdaT b t )
126 Let defs e ->
127 do (as,cs,t) <- gen e
128 (ass, schemes) <- liftM unzip (mapM defScheme defs)
129 let assumptions = unionsA (as:ass)
130 getName d = case d of FnDef f _ _ -> f
131 OpDef op _ _ _ -> op
132 TypeAnnotation n _ -> n
133 names = map getName defs
134 genCs name s = do
135 v <- guid
136 let vs = Map.findWithDefault [v] name assumptions
137 return $ map (\x -> loc name span $ x :<<: s) vs
138 cs' <- zipWithM genCs names schemes
139 return ( foldr Map.delete assumptions names
140 , concat cs' ++ cs
141 , t )
143 Case e cases ->
144 do (as,cs,t) <- gen e
145 (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases
146 return ( unionsA $ as:ass
147 , let cases' = map snd cases
148 locs = zipWith epos cases' (tail cases')
149 csts = zipWith (:=:) ts (tail ts)
150 cs' = zipWith ($) locs csts
151 in concat $ cs' : cs : css
152 , head ts)
154 If e1 e2 e3 ->
155 do (a1,c1,t1) <- gen e1
156 (a2,c2,t2) <- gen e2
157 (a3,c3,t3) <- gen e3
158 return ( unionsA [a1,a2,a3]
159 , c1 ++ c2 ++ c3 ++ [ loc e1 span (t1 :=: bool), loc' (t2 :=: t3) ]
160 , t2 )
162 Data name es ->
163 gen $ foldl' (\f x -> epos f x $ App f x) (loc' $ Var name) es
165 Binop op e1 e2 ->
166 gen $ loc' (App (loc' $ App (loc' $ Var op) e1) e2)
168 Access e label ->
169 do (as,cs,rtype) <- gen e
170 t <- beta
171 rtype' <- beta
172 let fs = Map.singleton label [t]
173 c = (loc' (RecordT fs rtype' :=: rtype))
174 return (as, c:cs, t)
176 Remove e x ->
177 do (as,cs,rtype) <- gen e
178 t <- beta
179 rtype' <- beta
180 let c = (loc' (RecordT (Map.singleton x [t]) rtype' :=: rtype))
181 return (as, c:cs, rtype')
183 Insert e x v ->
184 do (eas,ecs,etype) <- gen e
185 (vas,vcs,vtype) <- gen v
186 return ( unionA eas vas
187 , ecs ++ vcs
188 , RecordT (Map.singleton x [vtype]) etype )
190 Modify record fields ->
191 do (ras,rcs,rtype) <- gen record
192 (ass,css,newTs) <- unzip3 `liftM` mapM gen (map snd fields)
193 oldTs <- mapM (\_ -> beta) fields
194 rtype' <- beta
195 let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype'
196 c = [ loc' (rtype :=: rT oldTs) ]
197 return ( unionsA (ras:ass), concat (c : rcs : css), rT newTs )
199 Record fields ->
200 let insert label tipe = Map.insertWith (++) label [tipe]
201 getScheme (f,args,e) = do
202 (as, _, (label, Forall _ cs tipe)) <- defGenHelp f args e
203 return (as, cs, insert label tipe)
204 in do (ass, css, fs) <- unzip3 `liftM` mapM getScheme fields
205 return ( unionsA ass
206 , concat css
207 , RecordT (foldr ($) Map.empty fs) EmptyRecord )
209 Range e1@(L w1 s1 _) e2@(L w2 s2 _) ->
210 do (a1,c1,t1) <- gen e1
211 (a2,c2,t2) <- gen e2
212 return ( unionsA [a1,a2]
213 , c1 ++ c2 ++ [ L w1 s1 (t1 :=: int), L w1 s2 (t2 :=: int) ]
214 , listOf int )
216 MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
217 let cs = map (loc' . (t :=:)) ts
218 return (unionsA ass, concat (cs:css), t)
219 where genPair (b@(L t s _),e) = do
220 (a1,c1,t1) <- gen b
221 (a2,c2,t2) <- gen e
222 return ( unionsA [a1,a2]
223 , c1 ++ c2 ++ [ L t s (t1 :=: bool) ]
224 , t2 )
226 IntNum _ -> do t <- beta
227 return (Map.empty, [loc' $ t :<: number], t)
229 FloatNum _ -> primitive float
230 Chr _ -> primitive char
231 Str _ -> primitive string
232 Boolean _ -> primitive bool
233 Markdown _ -> primitive element
236primitive :: Type -> GuidCounter (TVarMap, Constraints, Type)
237primitive t = return (Map.empty, [], t)
239caseGen :: Type
240 -> (Pattern, CExpr)
241 -> GuidCounter (TVarMap, Constraints, Type)
242caseGen tipe (p, ce@(L _ span e)) = do
243 (as ,cs ,t) <- gen ce
244 (as',cs',_) <- patternGen (loc p span) tipe as p
245 return ( as', cs ++ cs', t )
247patternGen :: (Constraint -> Located Constraint)
248 -> Type -- Type of e in `case e of ...`
249 -> TVarMap
250 -> Pattern
251 -> GuidCounter (TVarMap, Constraints, Type)
252patternGen loc tipe as pattern =
253 case pattern of
254 PAnything -> do b <- beta ; return ( as, [], b )
256 PVar v -> do
257 b <- beta
258 let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
259 return ( Map.delete v as, loc (b :=: tipe) : cs, b )
261 PAsVar v p -> do
262 b <- beta
263 let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
264 (as', cs', tipe') <- patternGen loc b as p
265 return (Map.delete v as',
266 cs' ++ [ loc (b :=: tipe), loc (b :=: tipe') ] ++ cs,
267 b)
269 PData name ps -> do
270 constr <- guid
271 output <- beta
272 let step (as,cs,tipe) p = do b <- beta
273 (as',cs',t) <- patternGen loc b as p
274 return (as', cs ++ cs', t ==> tipe)
275 (as',cs, t) <- foldM step (as,[],tipe) (reverse ps)
276 return ( Map.insert name [constr] as'
277 , loc (VarT constr :=: t) : cs
278 , output )
279 PRecord fs ->
280 do pairs <- mapM (\f -> do b <- beta; return (f,b)) fs
281 b <- beta
282 let t = RecordT (Map.fromList $ map (second (:[])) pairs) b
283 mkCs (name,tipe) = map (loc . (tipe :=:) . VarT)
284 (Map.findWithDefault [] name as)
285 return ( foldr Map.delete as fs
286 , loc (t :=: tipe) : concatMap mkCs pairs
287 , t )
290defScheme :: Def -> GuidCounter (Map.Map String [X], Scheme)
291defScheme def = do (as,cs,hint) <- defGen def
292 return ( as, snd hint )
294defGen def = case def of
295 FnDef f args e -> defGenHelp f args e
296 OpDef op a1 a2 e -> defGenHelp op [a1,a2] e
297 TypeAnnotation name tipe -> do
298 schm <- Subs.generalize [] =<< Subs.superize name tipe
299 return (Map.empty, [], (name, schm))
301defGenHelp name args e = do
302 argDict <- mapM (\a -> liftM ((,) a) guid) args
303 (as,cs,t) <- gen e
304 let as' = foldr Map.delete as args
305 tipe = foldr (==>) t $ map (VarT . snd) argDict
306 genCs (arg,x) = do
307 v <- guid
308 let as' = Map.findWithDefault [v] arg as
309 return $ map (\y -> loc arg NoSpan $ VarT x :=: VarT y) as'
310 cs' <- concat `liftM` mapM genCs argDict
311 scheme <- Subs.generalize (concat $ Map.elems as') $
312 Forall (map snd argDict) (cs' ++ cs) tipe
313 return ( as', [], (name, scheme) )
316stmtGen :: Statement
317 -> GuidCounter (TVarMap, Constraints, Map.Map String Scheme)
318stmtGen stmt =
319 case stmt of
320 Definition def -> do (as,cs,hint) <- defGen def
321 return ( as, cs, uncurry Map.singleton hint )
323 Datatype name xs tcs ->
324 let toScheme ts = Forall xs [] (foldr (==>) (ADT name $ map VarT xs) ts)
325 in return (Map.empty, [], Map.fromList (map (second toScheme) tcs))
327 ExportEvent js elm tipe ->
328 do x <- guid
329 return ( Map.singleton elm [x]
330 , [ loc elm NoSpan $ VarT x :=: tipe ]
331 , Map.empty )
333 ImportEvent js e@(L txt span base) elm tipe ->
334 do (as,cs,t) <- gen e
335 return ( as
336 , L txt span (signalOf t :=: tipe) : cs
337 , Map.singleton elm (Forall [] [] tipe) )
339 TypeAlias _ _ _ -> return (Map.empty, [], Map.empty)