git.iko.soy/elk
on master help sign in
Remove the old type-checker code.
commit5cc99f5542eb2acfec03210b8e27da406ccb4281 authorEvan Czaplicki <evan@Evans-MacBook-Air.local> dateMon 8 Jul 2013, 16:58 (13 years ago) parent0ed7205
7 files changed−1007
compare with master
unifiedsplit
compiler/Types/Alias.hs−155 compiler/Types/Constrain.hs−344 compiler/Types/Hints.hs−32 compiler/Types/Solver.hs−215 compiler/Types/Substitutions.hs−138 compiler/Types/Types.hs−96 compiler/Types/Unify.hs−27
compiler/Types/Alias.hsdeleted−155
@@ -1,155 +0,0 @@
1−{-# LANGUAGE PatternGuards #-}
2−module Types.Alias (dealias, get, mistakes) where
3−
4−import SourceSyntax.Everything
5−import Control.Arrow (second)
6−import Data.List (group,sort)
7−import qualified Data.Map as Map
8−import qualified Data.Set as Set
9−import Transform.SortDefinitions
10−import Types.Substitutions (subst)
11−import Types.Types
12−import Data.Data
13−import Data.Generics.Uniplate.Data
14−
15−builtins :: [(String,([X],Type))]
16−builtins =
17− let touch = ("t0", time) : map (flip (,) int) ["x","y","x0","y0","id"]
18− state = [("string", string), ("selectionStart", int), ("selectionEnd", int)]
19− line = [("color", tipe "Color"), ("width", float),
20− ("cap", tipe "LineCap"), ("join", tipe "LineJoin"),
21− ("miterLimit", float), ("dashing", listOf int),
22− ("dashOffset", int)]
23− makeRecord fields =
24− RecordT (Map.fromList $ map (second (:[])) fields) EmptyRecord
25− in [ ("String", ([], listOf char)),
26− ("Time", ([], float)),
27− ("KeyCode", ([], int)),
28− ("Touch", ([], makeRecord touch)),
29− ("FieldState", ([], makeRecord state)),
30− ("LineStyle", ([], makeRecord line))
31− ]
32−
33−type AliasDict = Map.Map String ([X],Type)
34−
35−get :: [Declaration t v] -> AliasDict
36−get decl = Map.fromList (builtins ++ concatMap getAlias decl)
37− where
38− getAlias decl = case decl of
39− TypeAlias alias xs t -> [(alias, (xs,t))]
40− _ -> []
41−
42−dealias :: AliasDict -> Type -> Type
43−dealias aliases t =
44− let f = dealias aliases in
45− case t of
46− ADT name ts -> case Map.lookup name aliases of
47− Just (xs,t) -> f (subst (zip xs ts) t)
48− Nothing -> ADT name (map f ts)
49− LambdaT t u -> LambdaT (f t) (f u)
50− RecordT r t -> RecordT (Map.map (map f) r) (f t)
51− _ -> t
52−
53−mistakes :: (Data t, Data v) => [Declaration t v] -> [String]
54−mistakes decls = badKinds decls ++ dups decls ++ badOrder decls
55−
56−badKinds :: (Data t, Data v) => [Declaration t v] -> [String]
57−badKinds decls = map msg (concatMap bad decls)
58− where
59− msg x = "Type Error: Type alias '" ++ x ++
60− "' was given the wrong number of arguments."
61−
62− aliases :: AliasDict
63− aliases = get decls
64−
65− badType :: Type -> [String]
66− badType t =
67− case t of
68− ADT name ts ->
69− case Map.lookup name aliases of
70− Just (xs,t) | length xs == length ts -> []
71− | otherwise -> [name]
72− Nothing -> concatMap badType ts
73− LambdaT t u -> badType t ++ badType u
74− RecordT r t -> badType t ++ concatMap badType (concat (Map.elems r))
75− _ -> []
76−
77− --badDef :: AliasDict -> Def t v -> [String]
78− badDef def =
79− case def of
80− TypeAnnotation _ tipe -> badType tipe
81− Def _ expr ->
82− concatMap badDef $ concat [defList | Let defList _ <- universeBi expr]
83−
84− --bad :: Declaration t v -> [String]
85− bad s =
86− case s of
87− Datatype _ _ tcs -> concatMap badType (concatMap snd tcs)
88− ExportEvent _ _ tipe -> badType tipe
89− ImportEvent _ _ _ tipe -> badType tipe
90− TypeAlias _ _ tipe -> badType tipe
91− Definition d -> badDef d
92−
93−annotation :: Declaration t v -> [String]
94−annotation s =
95− case s of
96− Definition (TypeAnnotation name _) -> [name]
97− _ -> []
98−
99−definition :: Declaration t v -> [String]
100−definition s =
101− case s of
102− Definition d -> defName d
103− _ -> []
104−
105−defName :: Def t v -> [String]
106−defName d =
107− case d of
108− Def pattern _ -> Set.toList (boundVars pattern)
109− _ -> []
110−
111−dups :: [Declaration t v] -> [String]
112−dups decls = map defMsg (dup definition) ++ map annMsg (dup annotation)
113− where
114− --dup :: (Declaration t v -> [String]) -> [String]
115− dup f = map head . filter ((>1) . length) . group . sort $ concatMap f decls
116−
117− msg = "Syntax Error: There can only be one "
118− defMsg x = msg ++ "top-level definition of '" ++ x ++ "'."
119− annMsg x = msg ++ "type annotation for '" ++ x ++ "'."
120−
121−badOrder :: (Data t, Data v) => [Declaration t v] -> [String]
122−badOrder decls =
123− map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs decls)
124− where
125− msg x = "Syntax Error: The type annotation for '" ++ x ++
126− "' must be directly above its definition."
127− as = sort $ concatMap annotation decls
128− ds = sort $ concatMap definition decls
129−
130− expectedPairs :: [String] -> [String] -> [String]
131− expectedPairs as ds =
132− case (as,ds) of
133− (x:xs, y:ys) -> case compare x y of
134− LT -> expectedPairs xs (y:ys)
135− EQ -> x : expectedPairs xs ys
136− GT -> expectedPairs (x:xs) ys
137− ( _ , _ ) -> []
138−
139− --actualPairs :: [Def t v] -> [String]
140− actualPairs decls =
141− case decls of
142− Definition (TypeAnnotation n _) : Definition (Def (PVar m) _) : rest ->
143− (if n == m then [n] else []) ++ actualPairs rest
144− t:s:rest -> actualPairs (s:rest)
145− _ -> []
146−
147− missings :: [String] -> [String] -> [String]
148− missings expected actual =
149− case (expected, actual) of
150− (e:es, a:as) -> case compare e a of
151− LT -> e : missings es (a:as)
152− EQ -> missings es as
153− GT -> a : missings (e:es) as
154− ( [] , _ ) -> actual
155− ( _ , [] ) -> expected
compiler/Types/Constrain.hsdeleted−344
@@ -1,344 +0,0 @@
1−
2−module Types.Constrain (constrain) where
3−
4−import Control.Arrow (second)
5−import Control.Monad (liftM,mapM,zipWithM,foldM)
6−import Control.Monad.State (evalState)
7−import Data.Char (isDigit)
8−import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf)
9−import qualified Data.Map as Map
10−import qualified Data.Set as Set
11−
12−import SourceSyntax.Everything
13−import Unique
14−
15−import Types.Types
16−import qualified Types.Substitutions as Subs
17−
18−import System.IO.Unsafe
19−
20−beta = VarT `liftM` guid
21−unionA = Map.unionWith (++)
22−unionsA = Map.unionsWith (++)
23−
24−getAliases :: [(String,ImportMethod)] -> [(String,Scheme)] -> [(String,Scheme)]
25−getAliases imports hints = concatMap aliasesFrom imports
26− where
27− -- Get the names of values that are now in scope after a particular
28− -- import statement.
29− aliasesFrom :: (String,ImportMethod) -> [(String,Scheme)]
30− aliasesFrom (name,method) =
31− let values = concatMap (getValue name) hints
32− prefixed name = map (\(n,t) -> (name ++ "." ++ n, t)) values
33− in case method of
34− As alias -> prefixed alias
35− Hiding vs -> prefixed name ++ filter (\(n,t) -> n `notElem` vs) values
36− Importing vs -> prefixed name ++ filter (\(n,t) -> n `elem` vs) values
37−
38− -- Take a module name and a type annotation. Return the unprefxed
39− -- type annotation: getValue "List" ("List.map",t) == [("map",t)]
40− getValue :: String -> (String,Scheme) -> [(String,Scheme)]
41− getValue inModule (name,tipe) =
42− case inModule `isPrefixOf` name of
43− True -> [ (drop (length inModule + 1) name, tipe) ]
44− False -> []
45−
46−findAmbiguous hints assumptions continue =
47− let potentialDups = map head . filter (\g -> length g > 1) . group . sort $
48− filter (elem '.') hints
49− dups = filter (\k -> Map.member k assumptions) potentialDups
50− in case dups of
51− n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++
52− "' could refer to " ++
53− intercalate ", " (filter (isSuffixOf n) hints)
54− _ -> continue
55−
56−mergeSchemes :: [Map.Map String Scheme]
57− -> Unique (TVarMap, Constraints, Map.Map String Scheme)
58−mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs
59− return (Map.unions ass, concat css, Map.unions sss)
60− where
61− kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss)
62− split (k,vs) =
63− let ps = zipWith (\s v -> (s++k,v)) (map (flip replicate '_') [0..]) vs
64− eq t u = L (Just $ msg ++ k) NoSpan (VarT t :=: VarT u)
65− msg = "the definition of "
66− in do xs <- mapM (\_ -> guid) vs
67− return ( Map.fromList $ zip (map fst ps) (map (:[]) xs)
68− , case xs of
69− t:ts -> zipWith eq xs ts
70− [] -> []
71− , Map.fromList ps )
72−
73−--constrain :: Map.Map String Scheme
74−-- -> Module
75−-- -> Unique (Either String Constraints)
76−constrain typeHints (Module _ _ imports stmts) = do
77− (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts
78− aliasHints <- getAliases imports `liftM` typeHints
79− (as', cs', schemes) <- mergeSchemes schemess
80− let constraints = concat (cs':css)
81− as = unionsA (as':ass)
82− allHints = Map.union schemes (Map.fromList aliasHints)
83− insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
84− assumptions <- foldM insert as (Map.keys schemes)
85− findAmbiguous (map fst aliasHints) assumptions $ do
86− let f k s vs = map (\v -> L (Just k) NoSpan $ v :<<: s) vs
87− cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
88− escapees = Map.keys $ Map.difference assumptions allHints
89− msg = "Warning! Type-checker could not find variables:\n" ++ intercalate ", " escapees
90− return $ case escapees of
91− [] -> Right (schemess, constraints ++ cs)
92− _ -> unsafePerformIO (putStrLn msg) `seq` Right (schemess, constraints ++ cs)
93− --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)
94−
95−type TVarMap = Map.Map String [X]
96−type Constraints = [Located Constraint]
97−
98−loc e span = L (Just $ show e) span
99−
100−gen :: LExpr t v -> Unique (TVarMap, Constraints, Type)
101−gen (L _ span expr) =
102− let loc' = L (Just $ show expr) span in
103− case expr of
104− Var x ->
105− do b <- guid
106− return (Map.singleton x [b], [], VarT b)
107−
108− App e1 e2 ->
109− do (a1,c1,t1) <- gen e1
110− (a2,c2,t2) <- gen e2
111− b <- beta
112− return ( unionA a1 a2
113− , c1 ++ c2 ++ [loc' $ t1 :=: (LambdaT t2 b)]
114− , b )
115−
116− Lambda x e ->
117− do (a,c,t) <- gen e
118− b <- beta
119− v <- guid
120− return ( Map.delete x a
121− , (++) c . map (\x -> loc' $ VarT x :=: b) $
122− Map.findWithDefault [v] x a
123− , LambdaT b t )
124−
125− Let defs e ->
126− do (as,cs,t) <- gen e
127− (ass, schemes) <- liftM unzip (mapM defScheme defs)
128− let assumptions = unionsA (as:ass)
129− getName d = case d of FnDef f _ _ -> f
130− OpDef op _ _ _ -> op
131− TypeAnnotation n _ -> n
132− names = map getName defs
133− genCs name s = do
134− v <- guid
135− let vs = Map.findWithDefault [v] name assumptions
136− return $ map (\x -> loc name span $ x :<<: s) vs
137− cs' <- zipWithM genCs names schemes
138− return ( foldr Map.delete assumptions names
139− , concat cs' ++ cs
140− , t )
141−
142− Case e cases ->
143− do (as,cs,t) <- gen e
144− (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases
145− b <- beta
146− return ( unionsA $ as:ass
147− , let cases' = map snd cases
148− locs = zipWith merge cases' (tail cases')
149− cs' = zipWith (\t loc -> loc (b :=: t)) ts locs
150− in concat $ cs' : cs : css
151− , b)
152−
153− ExplicitList es ->
154− do (ass,css,ts) <- unzip3 `liftM` mapM gen es
155− t <- beta
156− let cs = zipWith (\t' (L a b _) -> L a b (t :=: t')) ts es
157− return ( unionsA ass, cs ++ concat css, listOf t )
158−
159− Data name es ->
160− gen $ foldl' (\f x -> merge f x $ App f x) (loc' $ Var name) es
161−
162− Binop op e1 e2 ->
163− gen $ loc' (App (loc' $ App (loc' $ Var op) e1) e2)
164−
165− Access e label ->
166− do (as,cs,rtype) <- gen e
167− t <- beta
168− rtype' <- beta
169− let fs = Map.singleton label [t]
170− c = (loc' (RecordT fs rtype' :=: rtype))
171− return (as, c:cs, t)
172−
173− Remove e x ->
174− do (as,cs,rtype) <- gen e
175− t <- beta
176− rtype' <- beta
177− let c = (loc' (RecordT (Map.singleton x [t]) rtype' :=: rtype))
178− return (as, c:cs, rtype')
179−
180− Insert e x v ->
181− do (eas,ecs,etype) <- gen e
182− (vas,vcs,vtype) <- gen v
183− return ( unionA eas vas
184− , ecs ++ vcs
185− , RecordT (Map.singleton x [vtype]) etype )
186−
187− Modify record fields ->
188− do (ras,rcs,rtype) <- gen record
189− (ass,css,newTs) <- unzip3 `liftM` mapM gen (map snd fields)
190− oldTs <- mapM (\_ -> beta) fields
191− rtype' <- beta
192− let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype'
193− c = [ loc' (rtype :=: rT oldTs) ]
194− return ( unionsA (ras:ass), concat (c : rcs : css), rT newTs )
195−
196− Record fields ->
197− let insert label tipe = Map.insertWith (++) label [tipe]
198− getScheme (f,args,e) = do
199− (as, _, (label, Forall _ cs tipe)) <- defGenHelp f args e
200− return (as, cs, insert label tipe)
201− in do (ass, css, fs) <- unzip3 `liftM` mapM getScheme fields
202− return ( unionsA ass
203− , concat css
204− , RecordT (foldr ($) Map.empty fs) EmptyRecord )
205−
206− Range e1@(L w1 s1 _) e2@(L w2 s2 _) ->
207− do (a1,c1,t1) <- gen e1
208− (a2,c2,t2) <- gen e2
209− return ( unionsA [a1,a2]
210− , c1 ++ c2 ++ [ L w1 s1 (t1 :=: int), L w1 s2 (t2 :=: int) ]
211− , listOf int )
212−
213− MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
214− let cs = map (loc' . (t :=:)) ts
215− return (unionsA ass, concat (cs:css), t)
216− where genPair (b@(L t s _),e) = do
217− (a1,c1,t1) <- gen b
218− (a2,c2,t2) <- gen e
219− return ( unionsA [a1,a2]
220− , c1 ++ c2 ++ [ L t s (t1 :=: bool) ]
221− , t2 )
222−
223− Markdown _ -> primitive element
224− Literal lit -> literalGen loc' lit
225−
226−literalGen :: (Constraint -> Located Constraint)
227− -> Literal
228− -> Unique (TVarMap, Constraints, Type)
229−literalGen loc lit =
230− case lit of
231− IntNum _ -> do t <- beta
232− return (Map.empty, [loc $ t :<: number], t)
233− FloatNum _ -> primitive float
234− Boolean _ -> primitive bool
235− Chr _ -> primitive char
236− Str _ -> primitive string
237−
238−
239−primitive :: Type -> Unique (TVarMap, Constraints, Type)
240−primitive t = return (Map.empty, [], t)
241−
242−caseGen :: Type
243− -> (Pattern, LExpr t v)
244− -> Unique (TVarMap, Constraints, Type)
245−caseGen tipe (p, ce@(L _ span e)) = do
246− (as ,cs ,t) <- gen ce
247− (as',cs',_) <- patternGen (loc p span) tipe as p
248− return ( as', cs ++ cs', t )
249−
250−patternGen :: (Constraint -> Located Constraint)
251− -> Type -- Type of e in `case e of ...`
252− -> TVarMap
253− -> Pattern
254− -> Unique (TVarMap, Constraints, Type)
255−patternGen loc tipe as pattern =
256− case pattern of
257− PAnything -> do b <- beta ; return ( as, [], b )
258−
259− PLiteral lit -> literalGen loc lit
260−
261− PVar v -> do
262− b <- beta
263− let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
264− return ( Map.delete v as, loc (b :=: tipe) : cs, b )
265−
266− PAlias v p -> do
267− b <- beta
268− let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
269− (as', cs', tipe') <- patternGen loc b as p
270− return (Map.delete v as',
271− cs' ++ [ loc (b :=: tipe), loc (b :=: tipe') ] ++ cs,
272− b)
273−
274− PData name ps -> do
275− constr <- guid
276− output <- beta
277− let step (as,cs,tipe) p = do b <- beta
278− (as',cs',t) <- patternGen loc b as p
279− return (as', cs ++ cs', t ==> tipe)
280− (as',cs, t) <- foldM step (as,[],tipe) (reverse ps)
281− return ( Map.insert name [constr] as'
282− , loc (VarT constr :=: t) : cs
283− , output )
284− PRecord fs ->
285− do pairs <- mapM (\f -> do b <- beta; return (f,b)) fs
286− b <- beta
287− let t = RecordT (Map.fromList $ map (second (:[])) pairs) b
288− mkCs (name,tipe) = map (loc . (tipe :=:) . VarT)
289− (Map.findWithDefault [] name as)
290− return ( foldr Map.delete as fs
291− , loc (t :=: tipe) : concatMap mkCs pairs
292− , t )
293−
294−
295−defScheme :: Def t v -> Unique (Map.Map String [X], Scheme)
296−defScheme def = do (as,cs,hint) <- defGen def
297− return ( as, snd hint )
298−
299−defGen def = case def of
300− FnDef f args e -> defGenHelp f args e
301− OpDef op a1 a2 e -> defGenHelp op [a1,a2] e
302− TypeAnnotation name tipe -> do
303− schm <- Subs.generalize [] =<< Subs.superize name tipe
304− return (Map.empty, [], (name, schm))
305−
306−defGenHelp name args e = do
307− argDict <- mapM (\a -> liftM ((,) a) guid) args
308− (as,cs,t) <- gen e
309− let as' = foldr Map.delete as args
310− tipe = foldr (==>) t $ map (VarT . snd) argDict
311− genCs (arg,x) = do
312− v <- guid
313− let as' = Map.findWithDefault [v] arg as
314− return $ map (\y -> loc arg NoSpan $ VarT x :=: VarT y) as'
315− cs' <- concat `liftM` mapM genCs argDict
316− scheme <- Subs.generalize (concat $ Map.elems as') $
317− Forall (map snd argDict) (cs' ++ cs) tipe
318− return ( as', [], (name, scheme) )
319−
320−
321−stmtGen :: Declaration t v
322− -> Unique (TVarMap, Constraints, Map.Map String Scheme)
323−stmtGen stmt =
324− case stmt of
325− Definition def -> do (as,cs,hint) <- defGen def
326− return ( as, cs, uncurry Map.singleton hint )
327−
328− Datatype name xs tcs ->
329− let toScheme ts = Forall xs [] (foldr (==>) (ADT name $ map VarT xs) ts)
330− in return (Map.empty, [], Map.fromList (map (second toScheme) tcs))
331−
332− ExportEvent js elm tipe ->
333− do x <- guid
334− return ( Map.singleton elm [x]
335− , [ loc elm NoSpan $ VarT x :=: tipe ]
336− , Map.empty )
337−
338− ImportEvent js e@(L txt span base) elm tipe ->
339− do (as,cs,t) <- gen e
340− return ( as
341− , L txt span (signalOf t :=: tipe) : cs
342− , Map.singleton elm (Forall [] [] tipe) )
343−
344− TypeAlias _ _ _ -> return (Map.empty, [], Map.empty)
compiler/Types/Hints.hsdeleted−32
@@ -1,32 +0,0 @@
1−module Types.Hints (hints) where
2−
3−import Control.Arrow (first)
4−import Control.Monad (liftM)
5−import Data.Maybe (catMaybes)
6−import qualified Data.Map as Map
7−import Unique
8−import qualified Metadata.Libraries as Libs
9−import Parse.Helpers (iParse)
10−import Parse.Type
11−import qualified Types.Substitutions as Subs
12−import Types.Types
13−
14−hints :: Unique [(String, Scheme)]
15−hints = liftM catMaybes (mapM toScheme values)
16− where
17− values :: [(String, String)]
18− values = addPrefixes (Map.toList (Map.map Map.toList Libs.libraries))
19−
20− addPrefixes :: [(String,[(String, String)])] -> [(String, String)]
21− addPrefixes = concatMap (\(m,vs) -> map (first (\n -> m ++ "." ++ n)) vs)
22−
23− toScheme :: (String, String) -> Unique (Maybe (String, Scheme))
24− toScheme (name, 't':'y':'p':'e':' ':_) = return Nothing
25− toScheme (name, 'd':'a':'t':'a':' ':_) = return Nothing
26− toScheme (name, tipeString) =
27− let err = "compiler error parsing type of " ++ name ++ ":\n" ++ tipeString
28− in case iParse (fmap toType typeExpr) err tipeString of
29− Left err -> error (show err)
30− Right tipe -> do
31− scheme <- Subs.generalize [] =<< Subs.superize name tipe
32− return (Just (name, scheme))
compiler/Types/Solver.hsdeleted−215
@@ -1,215 +0,0 @@
1−
2−module Types.Solver (solver) where
3−
4−import SourceSyntax.Everything
5−import Control.Arrow (second)
6−import Control.Monad (liftM)
7−import Data.Either (lefts,rights)
8−import Data.List (foldl')
9−import Data.Maybe (isJust)
10−import qualified Data.Set as Set
11−import qualified Data.Map as Map
12−import Unique
13−import Types.Types
14−import Types.Substitutions
15−import Types.Alias (dealias)
16−
17−import System.IO.Unsafe
18−
19−isSolved ss (L _ _ (t1 :=: t2)) = t1 == t2
20−isSolved ss (L _ _ (x :<<: _)) = isJust (lookup x ss)
21−isSolved ss c = False
22−
23−type Aliases = Map.Map String ([X],Type)
24−
25−crush :: Aliases -> Scheme -> Unique (Either String Scheme)
26−crush aliases forall@(Forall xs cs t) =
27− do subs <- solver aliases Map.empty cs
28− return $ do ss' <- subs
29− let ss = Map.toList ss'
30− cs' = filter (not . isSolved ss) (subst ss cs)
31− f x = x {-(unsafePerformIO $ do
32− print forall >> putStrLn "-------"
33− print x >> putStrLn "~~~~~~~") `seq` x-}
34− return . f $ Forall xs cs' (subst ss t)
35−
36−schemeSubHelp txt span x s t1 rltn t2 = do
37− (t1',cs1) <- sub t1
38− (t2',cs2) <- sub t2
39− return (L txt span (rltn t1' t2') : cs1 ++ cs2)
40− where sub t | not (occurs x t) = return (t, [])
41− | otherwise = do (st, cs) <- concretize s
42− return (subst [(x,st)] t, cs)
43−
44−schemeSub x s' c =
45− case s' of
46− Right s'' -> Right `liftM` schemeSub' x s'' c
47− Left err -> return $ Left err
48−
49−schemeSub' x s c@(L txt span constraint) =
50− case constraint of
51− (t1 :=: t2) -> schemeSubHelp txt span x s t1 (:=:) t2
52− (t1 :<: t2) -> schemeSubHelp txt span x s t1 (:<:) t2
53− (y :<<: Forall cxs ccs ctipe)
54− | not (occurs x c) -> return [c]
55− | otherwise ->
56− do Forall xs cs tipe <- rescheme s
57− let ss = [(x,tipe)]
58− constraints = subst ss (cs ++ ccs)
59− c' = y :<<: Forall (cxs ++ xs) constraints (subst ss ctipe)
60− return [ L txt span c' ]
61−
62−recordConstraints eq fs t fs' t' =
63− liftM concat . sequence $
64− [ constrain fs fs'
65− , liftM concat . mapM (\(k,ts) -> zipper [] k ts []) . Map.toList $
66− Map.difference fs fs'
67− , liftM concat . mapM (\(k,ts) -> zipper [] k [] ts) . Map.toList $
68− Map.difference fs' fs
69− ]
70− where constrain :: Map.Map String [Type] -> Map.Map String [Type]
71− -> Unique [Located Constraint]
72− constrain as bs = liftM concat . sequence . Map.elems $
73− Map.intersectionWithKey (zipper []) as bs
74− zipper :: [Located Constraint] -> String -> [Type] -> [Type]
75− -> Unique [Located Constraint]
76− zipper cs k xs ys =
77− case (xs,ys) of
78− (a:as, b:bs) -> zipper (eq a b : cs) k as bs
79− ([],[]) -> return cs
80− (as,[]) -> do x <- guid
81− let tipe = RecordT (Map.singleton k as) (VarT x)
82− return (cs ++ [eq t' tipe])
83− ([],bs) -> do x <- guid
84− let tipe = RecordT (Map.singleton k bs) (VarT x)
85− return (cs ++ [eq t tipe])
86−
87−solver :: Aliases
88− -> Map.Map X Type
89− -> [Located Constraint]
90− -> Unique (Either String (Map.Map X Type))
91−solver _ subs [] = return $ Right subs
92−solver aliases subs (L txt span c : cs) =
93− let loc = L txt span
94− eq t1 t2 = loc (t1 :=: t2)
95− solv = solver aliases subs
96− uniError' = uniError (\t1 t2 -> solv (eq t1 t2 : cs)) aliases txt span
97− in case c of
98− -- Destruct Type-constructors
99− t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2) ->
100− if n1 == n2 then solv (zipWith eq ts1 ts2 ++ cs)
101− else uniError' t1 t2
102−
103− LambdaT t1 t2 :=: LambdaT t1' t2' ->
104− solv ([ eq t1 t1', eq t2 t2' ] ++ cs)
105−
106− RecordT fs t :=: RecordT fs' t' ->
107− do cs' <- recordConstraints eq fs t fs' t'
108− solv (cs' ++ cs)
109−
110− -- Type-equality
111− VarT x :=: VarT y
112− | x == y -> solv cs
113− | otherwise ->
114− case (Map.lookup x subs, Map.lookup y subs) of
115− (Just (Super xts), Just (Super yts)) ->
116− let ts = Set.intersection xts yts
117− setXY t = Map.insert x t . Map.insert y t
118− in case Set.toList ts of
119− [] -> unionError txt span xts yts
120− [t] -> let cs1 = subst [(x,t),(y,t)] cs in
121− cs1 `seq` solver aliases (setXY t subs) cs1
122− _ -> solver aliases (setXY (Super ts) subs) cs
123− (Just (Super xts), _) ->
124− let cs2 = subst [(y,VarT x)] cs in
125− solver aliases (Map.insert y (VarT x) subs) cs2
126− (_, _) ->
127− let cs3 = subst [(x,VarT y)] cs in
128− solver aliases (Map.insert x (VarT y) subs) cs3
129−
130− VarT x :=: t -> do
131− if x `occurs` t then occursError txt span (VarT x) t else
132− (case Map.lookup x subs of
133− Nothing ->
134− let cs4 = subst [(x,t)] cs
135− subs' = Map.map (subst [(x,t)]) $ Map.insert x t subs
136− in solver aliases subs' cs4
137− Just (Super ts) ->
138− let ts' = Set.intersection ts (Set.singleton t) in
139− case Set.toList ts' of
140− [] -> solv (loc (t :<: Super ts) : cs)
141− [t'] -> let cs5 = subst [(x,t)] cs in
142− solver aliases (Map.insert x t' subs) cs5
143− _ -> solver aliases (Map.insert x (Super ts') subs) cs
144− Just t' -> solv (loc (t' :=: t) : cs)
145− )
146−
147− t :=: VarT x -> solv ((loc (VarT x :=: t)) : cs)
148−
149− t1 :=: t2 | t1 == t2 -> solv cs
150− | otherwise -> uniError' t1 t2
151−
152− -- subtypes
153− VarT x :<: Super ts ->
154− case Map.lookup x subs of
155− Nothing -> solver aliases (Map.insert x (Super ts) subs) cs
156− Just (Super ts') ->
157− case Set.toList $ Set.intersection ts ts' of
158− [] -> unionError txt span ts ts'
159− [t] -> solver aliases (Map.insert x t subs) (subst [(x,t)] cs)
160− ts'' -> solver aliases subs' cs
161− where subs' = Map.insert x (Super $ Set.fromList ts'') subs
162−
163− ADT "List" [t] :<: Super ts
164− | any f (Set.toList ts) -> solv cs
165− | otherwise -> subtypeError txt span (ADT "List" [t]) (Super ts)
166− where f (ADT "List" [VarT _]) = True
167− f (ADT "List" [t']) = dealias aliases t == t'
168− f _ = False
169−
170− t :<: Super ts
171− | Set.member t ts -> solv cs
172− | Set.member (dealias aliases t) ts -> solv cs
173− | otherwise -> subtypeError txt span t (Super ts)
174−
175− x :<<: s
176− | any (occurs x) cs ->
177− do s' <- crush aliases s
178− css <- mapM (schemeSub x s') cs
179− case lefts css of
180− err : _ -> return $ Left err
181− [] -> solv (concat (rights css))
182− | otherwise ->
183− do (t,cs7) <- concretize s
184− solv (cs ++ loc (VarT x :=: t) : cs7)
185−
186−showMsg msg = case msg of
187− Just str -> "\nIn context: " ++ str
188− Nothing -> ""
189−
190−occursError msg span t1 t2 =
191− return . Left $ concat
192− [ "Type error (" ++ show span ++ "):\n"
193− , "Occurs check: cannot construct the infinite type:\n"
194− , show t1, " = ", show t2, showMsg msg ]
195−
196−uniError solveWith aliases msg span t1 t2 =
197− let t1' = dealias aliases t1
198− t2' = dealias aliases t2
199− in if t1 /= t1' || t2 /= t2'
200− then solveWith t1' t2'
201− else return . Left $ concat
202− [ "Type error (" ++ show span ++ "):\n"
203− , show t1, " is not equal to ", show t2, showMsg msg ]
204−
205−unionError msg span ts ts' =
206− return . Left $ concat
207− [ "Type error (" ++ show span ++ "):\n"
208− , "There are no types in both "
209− , show (Super ts), " and ", show (Super ts'), showMsg msg ]
210−
211−subtypeError msg span t s =
212− return . Left $ concat
213− [ "Type error (" ++ show span ++ "):\n"
214− , show t, " is not a ", show s, showMsg msg ]
215−
compiler/Types/Substitutions.hsdeleted−138
@@ -1,138 +0,0 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−module Types.Substitutions (subst,
3− occurs,
4− freeVars,
5− concretize,
6− rescheme,
7− generalize,
8− superize) where
9−
10−import SourceSyntax.Everything
11−import Control.Monad (liftM, liftM2)
12−import Control.Monad.State (runState, State, get, put)
13−import Data.List (nub)
14−import qualified Data.Set as Set
15−import qualified Data.Map as Map
16−import Unique
17−import Types.Types
18−
19−class Subst a where
20− subst :: [(X,Type)] -> a -> a
21−
22−instance Subst Type where
23− subst ss t =
24− case t of
25− VarT x -> case lookup x ss of
26− Nothing -> VarT x
27− Just (Super _) -> VarT x
28− Just t -> t
29− LambdaT t1 t2 -> LambdaT (subst ss t1) (subst ss t2)
30− ADT name ts -> ADT name (subst ss ts)
31− RecordT fs t -> RecordT (Map.map (subst ss) fs) (subst ss t)
32− EmptyRecord -> EmptyRecord
33− Super ts -> Super ts
34−
35−instance Subst Scheme where
36− subst ss (Forall vs cs t) = Forall vs (subst ss cs) (subst ss t)
37−
38−instance Subst Constraint where
39− subst ss (t1 :=: t2) = subst ss t1 :=: subst ss t2
40− subst ss (t :<: super) = subst ss t :<: super
41− subst ss (x :<<: poly) = (case lookup x ss of
42− Just (VarT y) -> y
43− _ -> x
44− ) :<<: subst ss poly
45−
46−instance Subst a => Subst (Located a) where
47− subst ss (L str span c) = L str span (subst ss c)
48−
49−instance Subst a => Subst [a] where
50− subst ss as = map (subst ss) as
51−
52−
53−class FreeVars a where
54− freeVars :: a -> [X]
55−
56−instance FreeVars Type where
57− freeVars t =
58− case t of
59− VarT v -> [v]
60− LambdaT t1 t2 -> freeVars t1 ++ freeVars t2
61− ADT _ ts -> concatMap freeVars ts
62− RecordT fs t -> freeVars (concat $ Map.elems fs) ++ freeVars t
63− EmptyRecord -> []
64− Super _ -> []
65−
66−instance FreeVars Constraint where
67− freeVars (t1 :=: t2) = freeVars t1 ++ freeVars t2
68− freeVars (t1 :<: t2) = freeVars t1 ++ freeVars t2
69− freeVars (x :<<: Forall xs cs t) = filter (`notElem` xs) frees
70− where frees = concatMap freeVars cs ++ freeVars t
71−
72−instance FreeVars a => FreeVars (Located a) where
73− freeVars (L _ _ c) = freeVars c
74−
75−instance FreeVars a => FreeVars [a] where
76− freeVars = concatMap freeVars
77−
78−occurs x t = x `elem` freeVars t
79−
80−concretize :: Scheme -> Unique (Type, [Located Constraint])
81−concretize (Forall xs cs t) = do
82− ss <- zip xs `liftM` mapM (\_ -> liftM VarT guid) xs
83− return (subst ss t, subst ss cs)
84−
85−rescheme :: Scheme -> Unique Scheme
86−rescheme (Forall xs cs t) = do
87− xs' <- mapM (const guid) xs
88− let ss = zip xs (map VarT xs')
89− return $ Forall xs' (subst ss cs) (subst ss t)
90−
91−generalize :: [X] -> Scheme -> Unique Scheme
92−generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)
93− where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs
94− frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)
95−
96−newtype Superize a = S { runSuper :: State ([X], [X], [X]) a }
97− deriving (Monad)
98−
99−superize :: String -> Type -> Unique Scheme
100−superize name tipe =
101− do constraints <- liftM concat $
102− sequence [ mapM (<: nmbr) (nub ns)
103− , mapM (<: apnd) (nub as)
104− , mapM (<: comp) (nub cs) ]
105− return (Forall (concat [ns,as,cs]) constraints tipe')
106− where
107− (tipe', (ns,as,cs)) = runState (runSuper (go tipe)) ([],[],[])
108− t <: super = do x <- guid
109− return $ L (Just name) NoSpan (VarT t :<: super x)
110−
111− nmbr t = number
112− apnd t = appendable t
113− comp t = comparable t
114−
115− go :: Type -> Superize Type
116− go t =
117− case t of
118− EmptyRecord -> return t
119− Super _ -> return t
120− VarT _ -> return t
121− LambdaT t1 t2 -> liftM2 LambdaT (go t1) (go t2)
122− ADT "Number" [VarT t] -> addNumber t
123− ADT "Appendable" [VarT t] -> addAppendable t
124− ADT "Comparable" [VarT t] -> addComparable t
125− ADT name ts -> liftM (ADT name) (mapM go ts)
126− RecordT fs t -> liftM2 RecordT fs' (go t)
127− where pairs = Map.toList fs
128− fs' = do ps <- mapM (\(f,t) -> liftM ((,) f) (mapM go t)) pairs
129− return (Map.fromList ps)
130−
131− add :: (X -> ([X],[X],[X]) -> ([X],[X],[X])) -> X -> Superize Type
132− add f v = S $ do (ns, as, cs) <- get
133− put $ f v (ns, as, cs)
134− return (VarT v)
135−
136− addNumber = add (\n (ns,as,cs) -> (n:ns,as,cs))
137− addAppendable = add (\a (ns,as,cs) -> (ns,a:as,cs))
138− addComparable = add (\c (ns,as,cs) -> (ns,as,c:cs))
compiler/Types/Types.hsdeleted−96
@@ -1,96 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−module Types.Types where
3−
4−import SourceSyntax.Location
5−import Data.Char (isDigit)
6−import Data.List (intercalate,isPrefixOf)
7−import qualified Data.Set as Set
8−import qualified Data.Map as Map
9−import Data.Data
10−
11−type X = Int
12−
13−data Type = LambdaT Type Type
14− | VarT X
15− | ADT String [Type]
16− | EmptyRecord
17− | RecordT (Map.Map String [Type]) Type
18− | Super (Set.Set Type)
19− deriving (Eq, Ord, Data, Typeable)
20−
21−data Scheme = Forall [X] [Located Constraint] Type
22− deriving (Eq, Ord, Show, Data, Typeable)
23−
24−data Constraint = Type :=: Type
25− | Type :<: Type
26− | X :<<: Scheme
27− deriving (Eq, Ord, Show, Data, Typeable)
28−
29−recordT :: [(String,Type)] -> Map.Map String [Type]
30−recordT fields =
31− foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
32−
33−recordOf :: [(String,Type)] -> Type
34−recordOf fields = RecordT (recordT fields) EmptyRecord
35−
36−tipe t = ADT t []
37−
38−int = tipe "Int"
39−float = tipe "Float"
40−time = tipe "Time"
41−date = tipe "Date"
42−
43−char = tipe "Char"
44−bool = tipe "Bool"
45−text = tipe "Text"
46−order = tipe "Order"
47−string = tipe "String"
48−
49−number = Super $ Set.fromList [ int, float, time ]
50−appendable t = Super $ Set.fromList [ string, text, listOf (VarT t) ]
51−comparable t = Super $ Set.fromList [ int, float, char, string, time, date ]
52−
53−element = tipe "Element"
54−
55−listOf t = ADT "List" [t]
56−signalOf t = ADT "Signal" [t]
57−tupleOf ts = ADT ("Tuple" ++ show (length ts)) ts
58−maybeOf t = ADT "Maybe" [t]
59−eitherOf a b = ADT "Either" [a,b]
60−pairOf t = tupleOf [t,t]
61−point = pairOf int
62−
63−infixr ==>
64−t1 ==> t2 = LambdaT t1 t2
65−
66−infix 8 -:
67−name -: tipe = (,) name $ Forall [] [] tipe
68−
69−parens = ("("++) . (++")")
70−
71−instance Show Type where
72− show t =
73− let addParens (c:cs) =
74− if notElem ' ' cs || c == '(' || c == '{' then c:cs else parens (c:cs)
75− in case t of
76− LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2
77− LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
78− VarT x -> 't' : show x
79− ADT "List" [ADT "Char" []] -> "String"
80− ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
81− ADT name cs ->
82− if isTupleString name
83− then parens . intercalate "," $ map show cs
84− else name ++ concatMap ((' ':) . addParens . show) cs
85− Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"
86− EmptyRecord -> "{}"
87− RecordT fs t ->
88− start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"
89− where field n s = n ++ " : " ++ show s
90− fields (n,ss) = map (field n) ss
91− start = case t of
92− EmptyRecord -> "{ "
93− _ -> "{ " ++ show t ++ " | "
94−
95−
96−isTupleString str = "Tuple" `isPrefixOf` str && all isDigit (drop 5 str)
compiler/Types/Unify.hsdeleted−27
@@ -1,27 +0,0 @@
1−
2−module Types.Unify (unify) where
3−
4−import Control.Monad (liftM)
5−import qualified Data.Map as Map
6−
7−import SourceSyntax.Module
8−import Unique
9−import qualified Types.Constrain as Constrain
10−import qualified Types.Solver as Solver
11−import qualified Types.Alias as Alias
12−
13−import qualified Types.Substitutions as Subst
14−import System.IO.Unsafe
15−import Control.Arrow (second)
16−
17−unify hints modul@(Module _ _ _ stmts) = run $ do
18− result <- Constrain.constrain hints modul
19− case result of
20− Left err -> return (Left err)
21− Right (schemes, constraints) ->
22− do subs <- {- unsafePerformIO (mapM print constraints) `seq` -}
23− Solver.solver (Alias.get stmts) Map.empty constraints
24− let ss = either (const []) Map.toList subs
25− -- unsafePerformIO (mapM print . map (second (Subst.subst ss)) $ concatMap Map.toList schemes) `seq`
26− return subs
27−