@@ -1,20 +1,22 @@
1−
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
22module Types.Substitutions (subst,
33 occurs,
44 freeVars,
55 concretize,
66 rescheme,
7− generalize) where
7+ generalize,
8+ superize) where
89
910import Ast
1011import Context
11−import Control.DeepSeq (NFData (..), deepseq)
12−import Control.Monad (liftM)
12+import Control.Monad (liftM, liftM2)
13+import Control.Monad.State (runState, State, get, put)
1314import Data.List (foldl')
15+import Data.Maybe (catMaybes)
1416import qualified Data.Set as Set
1517import qualified Data.Map as Map
1618import Guid
17−import Types.Types
19+import Types.Types as Types
1820
1921class Subst a where
2022 subst :: [(X,Type)] -> a -> a
@@ -51,13 +53,14 @@ class FreeVars a where
5153 freeVars :: a -> [X]
5254
5355instance FreeVars Type where
54− freeVars (VarT v) = [v]
55− freeVars (LambdaT t1 t2) = freeVars t1 ++ freeVars t2
56− freeVars (ADT _ ts) = concatMap freeVars ts
57− freeVars (RecordT fs t) =
58− freeVars (concat $ Map.elems fs) ++ freeVars t
59− freeVars EmptyRecord = []
60− freeVars (Super _ ) = []
56+ freeVars t =
57+ case t of
58+ VarT v -> [v]
59+ LambdaT t1 t2 -> freeVars t1 ++ freeVars t2
60+ ADT _ ts -> concatMap freeVars ts
61+ RecordT fs t -> freeVars (concat $ Map.elems fs) ++ freeVars t
62+ EmptyRecord -> []
63+ Super _ -> []
6164
6265instance FreeVars Constraint where
6366 freeVars (t1 :=: t2) = freeVars t1 ++ freeVars t2
@@ -88,3 +91,47 @@ generalize :: [X] -> Scheme -> GuidCounter Scheme
8891generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)
8992 where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs
9093 frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)
94+
95+newtype Superize a = S { runSuper :: State (Int, Maybe X, Maybe X) a }
96+ deriving (Monad)
97+
98+superize :: String -> Type -> GuidCounter Scheme
99+superize name tipe =
100+ do x <- guid
101+ let (tipe', (m, number, append)) =
102+ runState (runSuper (go tipe)) (x+1, Nothing, Nothing)
103+ mkC super = liftM (\x -> C (Just name) NoSpan (VarT x :<: super))
104+ set m
105+ return (Forall (catMaybes [number,append])
106+ (catMaybes [ mkC Types.number number
107+ , mkC (Types.appendable x) append])
108+ tipe')
109+ where
110+ go :: Type -> Superize Type
111+ go t =
112+ case t of
113+ EmptyRecord -> return t
114+ Super _ -> return t
115+ VarT _ -> return t
116+ LambdaT t1 t2 -> liftM2 LambdaT (go t1) (go t2)
117+ ADT "Number" [] -> liftM VarT number
118+ ADT "Appendable" [] -> liftM VarT append
119+ ADT name ts -> liftM (ADT name) (mapM go ts)
120+ RecordT fs t -> liftM2 RecordT fs' (go t)
121+ where pairs = Map.toList fs
122+ fs' = do ps <- mapM (\(f,t) -> liftM ((,) f) (mapM go t)) pairs
123+ return (Map.fromList ps)
124+
125+ number :: Superize X
126+ number = S $ do (n, num, append) <- get
127+ case num of
128+ Just x -> return x
129+ Nothing -> do put (n + 1, Just n, append)
130+ return n
131+
132+ append :: Superize X
133+ append = S $ do (n, number, app) <- get
134+ case app of
135+ Just x -> return x
136+ Nothing -> do put (n + 1, number, Just n)
137+ return n