git.iko.soy/elk
on ea05fbe help sign in
elk/src/Types/Constrain.hs
77 lines 2.4 kB history raw
2module Constrain where
4import Ast
5import Types
6import Data.List (foldl')
7import qualified Data.Set as Set
8import qualified Data.Map as Map
9import Control.Monad (liftM,mapM)
10import Control.Monad.State (evalState)
11import Guid
13data Constraint = Type :=: Type
14 | Type :<: Type
15 | Type :<<: Scheme
16 deriving (Eq, Ord, Show)
18beta = VarT `liftM` guid
19unionA = Map.unionWith (++)
20unionsA = Map.unionsWith (++)
22constrain hints expr = do
23 (as,cs,t) <- inference expr
24 hs <- hints
25 let cMap = Map.intersectionWith (\t -> map (:<: t)) (Map.fromList hs) as
26 return $ Set.toList cs ++ (concat . map snd $ Map.toList cMap)
28inference (Var x) =
29 do b <- beta
30 return (Map.singleton x [b], Set.empty, b)
31inference (App e1 e2) =
32 do (a1,c1,t1) <- inference e1
33 (a2,c2,t2) <- inference e2
34 b <- beta
35 return ( unionA a1 a2
36 , Set.unions [c1,c2,Set.singleton $ t1 :=: (LambdaT t2 b)]
37 , b )
38inference (Lambda x e) =
39 do (a,c,t) <- inference e
40 b <- beta
41 return ( Map.delete x a
42 , Set.union c . Set.fromList . map (:=: b) $
43 Map.findWithDefault [] x a
44 , LambdaT b t )
45inference (Let defs e) =
46 do (a,c,t) <- inference e
47 let (xs,es) = unzip defs
48 (as,cs,ts) <- unzip3 `liftM` mapM inference es
49 let assumptions = unionsA (a:as)
50 let f x t = map (:<: t) $ Map.findWithDefault [] x assumptions
51 let constraints = Set.fromList . concat $ zipWith f xs ts
52 return ( foldr Map.delete assumptions xs
53 , Set.unions $ c:constraints:cs
54 , t )
56inference (If e1 e2 e3) =
57 do (a1,c1,t1) <- inference e1
58 (a2,c2,t2) <- inference e2
59 (a3,c3,t3) <- inference e3
60 return ( unionsA [a1,a2,a3]
61 , Set.unions [c1,c2,c3, Set.fromList [ t1 :=: BoolT, t2 :=: t3 ] ]
62 , t2 )
64inference (Data name es) = inference $ foldl' App (Var name) es
65inference (Binop op e1 e2) = inference (Var op `App` e1 `App` e2)
66inference (Access (Var x) y) = inference . Var $ x ++ "." ++ y
67inference (Range e1 e2) = inference (Var "elmRange" `App` e1 `App` e2)
69inference other =
70 case other of
71 Number _ -> primitive IntT
72 Chr _ -> primitive CharT
73 Str _ -> primitive string
74 Boolean _ -> primitive BoolT
75 _ -> beta >>= primitive
77primitive t = return (Map.empty, Set.empty, t)