@@ -11,12 +11,11 @@ import Ast
1111import Context
1212import Control.Monad (liftM, liftM2)
1313import Control.Monad.State (runState, State, get, put)
14−import Data.List (foldl')
15−import Data.Maybe (catMaybes)
14+import Data.List (nub)
1615import qualified Data.Set as Set
1716import qualified Data.Map as Map
1817import Guid
19−import Types.Types as Types
18+import Types.Types
2019
2120class Subst a where
2221 subst :: [(X,Type)] -> a -> a
@@ -92,21 +91,25 @@ generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)
9291 where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs
9392 frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)
9493
95−newtype Superize a = S { runSuper :: State (Int, Maybe X, Maybe X) a }
94+newtype Superize a = S { runSuper :: State ([X], [X], [X]) a }
9695 deriving (Monad)
9796
9897superize :: String -> Type -> GuidCounter Scheme
9998superize 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')
99+ do constraints <- liftM concat $
100+ sequence [ mapM (<: nmbr) (nub ns)
101+ , mapM (<: apnd) (nub as)
102+ , mapM (<: comp) (nub cs) ]
103+ return (Forall (concat [ns,as,cs]) constraints tipe')
109104 where
105+ (tipe', (ns,as,cs)) = runState (runSuper (go tipe)) ([],[],[])
106+ t <: super = do x <- guid
107+ return $ C (Just name) NoSpan (VarT t :<: super x)
108+
109+ nmbr t = number
110+ apnd t = appendable t
111+ comp t = comparable t
112+
110113 go :: Type -> Superize Type
111114 go t =
112115 case t of
@@ -114,24 +117,20 @@ superize name tipe =
114117 Super _ -> return t
115118 VarT _ -> return t
116119 LambdaT t1 t2 -> liftM2 LambdaT (go t1) (go t2)
117− ADT "Number" [] -> liftM VarT number
118− ADT "Appendable" [t] -> liftM VarT append
120+ ADT "Number" [VarT t] -> addNumber t
121+ ADT "Appendable" [VarT t] -> addAppendable t
122+ ADT "Comparable" [VarT t] -> addComparable t
119123 ADT name ts -> liftM (ADT name) (mapM go ts)
120124 RecordT fs t -> liftM2 RecordT fs' (go t)
121125 where pairs = Map.toList fs
122126 fs' = do ps <- mapM (\(f,t) -> liftM ((,) f) (mapM go t)) pairs
123127 return (Map.fromList ps)
124128
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
129+ add :: (X -> ([X],[X],[X]) -> ([X],[X],[X])) -> X -> Superize Type
130+ add f v = S $ do (ns, as, cs) <- get
131+ put $ f v (ns, as, cs)
132+ return (VarT v)
133+
134+ addNumber = add (\n (ns,as,cs) -> (n:ns,as,cs))
135+ addAppendable = add (\a (ns,as,cs) -> (ns,a:as,cs))
136+ addComparable = add (\c (ns,as,cs) -> (ns,as,c:cs))