@@ -0,0 +1,89 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+module Constrain where
3+
4+import Ast
5+import Types
6+import qualified Data.Set as Set
7+import qualified Data.Map as Map
8+import Control.Monad (liftM,mapM)
9+import Control.Monad.State (evalState, State, get, put)
10+
11+data Constraint = Type :=: Type
12+ | Type :<: Type
13+ | Type :<<: Scheme
14+ deriving (Eq, Ord, Show)
15+
16+-- Wrapper around State monad.
17+newtype GuidCounter a = GC { runGC :: State Int a }
18+ deriving (Monad)
19+
20+-- Get the next GUID, incrementing the counter.
21+guid :: GuidCounter Int
22+guid = GC $ do n <- get
23+ put (n + 1)
24+ return n
25+
26+beta = VarT `liftM` guid
27+unionA = Map.unionWith (++)
28+unionsA = Map.unionsWith (++)
29+
30+constrain expr = Set.toList cs
31+ where (as,cs,t) = evalState (runGC $ inference expr) 0
32+
33+inference (Var x) =
34+ do b <- beta
35+ return (Map.singleton x [b], Set.empty, b)
36+inference (App e1 e2) =
37+ do (a1,c1,t1) <- inference e1
38+ (a2,c2,t2) <- inference e2
39+ b <- beta
40+ return ( unionA a1 a2
41+ , Set.unions [c1,c2,Set.singleton $ t1 :=: (LambdaT t2 b)]
42+ , b )
43+inference (Lambda x e) =
44+ do (a,c,t) <- inference e
45+ b <- beta
46+ return ( Map.delete x a
47+ , Set.union c . Set.fromList . map (:=: b) $
48+ Map.findWithDefault [] x a
49+ , LambdaT b t )
50+inference (Let defs e) =
51+ do (a,c,t) <- inference e
52+ let (xs,es) = unzip defs
53+ (as,cs,ts) <- unzip3 `liftM` mapM inference es
54+ let assumptions = unionsA (a:as)
55+ let f x t = map (:<: t) $ Map.findWithDefault [] x assumptions
56+ let constraints = Set.fromList . concat $ zipWith f xs ts
57+ return ( foldr Map.delete assumptions xs
58+ , Set.unions $ c:constraints:cs
59+ , t )
60+
61+inference (If e1 e2 e3) =
62+ do (a1,c1,t1) <- inference e1
63+ (a2,c2,t2) <- inference e2
64+ (a3,c3,t3) <- inference e3
65+ return ( unionsA [a1,a2,a3]
66+ , Set.unions [c1,c2,c3, Set.fromList [ t1 :=: BoolT, t2 :=: t3 ] ]
67+ , t2 )
68+
69+inference (Data name es) =
70+ do (as,cs,ts) <- unzip3 `liftM` mapM inference es
71+ return ( unionsA as, Set.unions cs, ADT name ts )
72+
73+inference other =
74+ case other of
75+ Number _ -> primitive IntT
76+ Chr _ -> primitive CharT
77+ Boolean _ -> primitive BoolT
78+ _ -> beta >>= primitive
79+
80+primitive t = return (Map.empty, Set.empty, t)
81+{--
82+ Let x e1 e2 ->
83+ do (a1,c1,t1) <- inference e1
84+ (a2,c2,t2) <- inference e2
85+ let ts = Map.findWithDefault (error "inference") x a
86+ return ( unionA a1 $ Map.delete x a2
87+ , Set.unions [ c1, c2, Set.fromList $ map (:<: t1) ts ]
88+ , t2 )
89+--}