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