git.iko.soy/elk
on a3801ac help sign in
elk/compiler/Types/Substitutions.hs
139 lines 4.7 kB history raw
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2module Types.Substitutions (subst,
3 occurs,
4 freeVars,
5 concretize,
6 rescheme,
7 generalize,
8 superize) where
10import Ast
11import Located
12import Control.Monad (liftM, liftM2)
13import Control.Monad.State (runState, State, get, put)
14import Data.List (nub)
15import qualified Data.Set as Set
16import qualified Data.Map as Map
17import Guid
18import Types.Types
20class Subst a where
21 subst :: [(X,Type)] -> a -> a
23instance Subst Type where
24 subst ss t =
25 case t of
26 VarT x -> case lookup x ss of
27 Nothing -> VarT x
28 Just (Super _) -> VarT x
29 Just t -> t
30 LambdaT t1 t2 -> LambdaT (subst ss t1) (subst ss t2)
31 ADT name ts -> ADT name (subst ss ts)
32 RecordT fs t -> RecordT (Map.map (subst ss) fs) (subst ss t)
33 EmptyRecord -> EmptyRecord
34 Super ts -> Super ts
36instance Subst Scheme where
37 subst ss (Forall vs cs t) = Forall vs (subst ss cs) (subst ss t)
39instance Subst Constraint where
40 subst ss (t1 :=: t2) = subst ss t1 :=: subst ss t2
41 subst ss (t :<: super) = subst ss t :<: super
42 subst ss (x :<<: poly) = (case lookup x ss of
43 Just (VarT y) -> y
44 _ -> x
45 ) :<<: subst ss poly
47instance Subst a => Subst (Located a) where
48 subst ss (L str span c) = L str span (subst ss c)
50instance Subst a => Subst [a] where
51 subst ss as = map (subst ss) as
54class FreeVars a where
55 freeVars :: a -> [X]
57instance FreeVars Type where
58 freeVars t =
59 case t of
60 VarT v -> [v]
61 LambdaT t1 t2 -> freeVars t1 ++ freeVars t2
62 ADT _ ts -> concatMap freeVars ts
63 RecordT fs t -> freeVars (concat $ Map.elems fs) ++ freeVars t
64 EmptyRecord -> []
65 Super _ -> []
67instance FreeVars Constraint where
68 freeVars (t1 :=: t2) = freeVars t1 ++ freeVars t2
69 freeVars (t1 :<: t2) = freeVars t1 ++ freeVars t2
70 freeVars (x :<<: Forall xs cs t) = filter (`notElem` xs) frees
71 where frees = concatMap freeVars cs ++ freeVars t
73instance FreeVars a => FreeVars (Located a) where
74 freeVars (L _ _ c) = freeVars c
76instance FreeVars a => FreeVars [a] where
77 freeVars = concatMap freeVars
79occurs x t = x `elem` freeVars t
81concretize :: Scheme -> GuidCounter (Type, [Located Constraint])
82concretize (Forall xs cs t) = do
83 ss <- zip xs `liftM` mapM (\_ -> liftM VarT guid) xs
84 return (subst ss t, subst ss cs)
86rescheme :: Scheme -> GuidCounter Scheme
87rescheme (Forall xs cs t) = do
88 xs' <- mapM (const guid) xs
89 let ss = zip xs (map VarT xs')
90 return $ Forall xs' (subst ss cs) (subst ss t)
92generalize :: [X] -> Scheme -> GuidCounter Scheme
93generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)
94 where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs
95 frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)
97newtype Superize a = S { runSuper :: State ([X], [X], [X]) a }
98 deriving (Monad)
100superize :: String -> Type -> GuidCounter Scheme
101superize name tipe =
102 do constraints <- liftM concat $
103 sequence [ mapM (<: nmbr) (nub ns)
104 , mapM (<: apnd) (nub as)
105 , mapM (<: comp) (nub cs) ]
106 return (Forall (concat [ns,as,cs]) constraints tipe')
107 where
108 (tipe', (ns,as,cs)) = runState (runSuper (go tipe)) ([],[],[])
109 t <: super = do x <- guid
110 return $ L (Just name) NoSpan (VarT t :<: super x)
112 nmbr t = number
113 apnd t = appendable t
114 comp t = comparable t
116 go :: Type -> Superize Type
117 go t =
118 case t of
119 EmptyRecord -> return t
120 Super _ -> return t
121 VarT _ -> return t
122 LambdaT t1 t2 -> liftM2 LambdaT (go t1) (go t2)
123 ADT "Number" [VarT t] -> addNumber t
124 ADT "Appendable" [VarT t] -> addAppendable t
125 ADT "Comparable" [VarT t] -> addComparable t
126 ADT name ts -> liftM (ADT name) (mapM go ts)
127 RecordT fs t -> liftM2 RecordT fs' (go t)
128 where pairs = Map.toList fs
129 fs' = do ps <- mapM (\(f,t) -> liftM ((,) f) (mapM go t)) pairs
130 return (Map.fromList ps)
132 add :: (X -> ([X],[X],[X]) -> ([X],[X],[X])) -> X -> Superize Type
133 add f v = S $ do (ns, as, cs) <- get
134 put $ f v (ns, as, cs)
135 return (VarT v)
137 addNumber = add (\n (ns,as,cs) -> (n:ns,as,cs))
138 addAppendable = add (\a (ns,as,cs) -> (ns,a:as,cs))
139 addComparable = add (\c (ns,as,cs) -> (ns,as,c:cs))