git.iko.soy/elk
on master help sign in
Use canonical names during type inference
eae58a7Evan Czaplicki
compiler/Type/Environment.hs+46−30
compare with master
unifiedsplit
@@ -12,21 +12,21 @@ import qualified Data.Map as Map
12import Data.List (isPrefixOf)
12import Data.List (isPrefixOf)
13import qualified Text.PrettyPrint as PP
13import qualified Text.PrettyPrint as PP
14
14
15−import AST.Module (ADTs)
16import qualified AST.Type as T
15import qualified AST.Type as T
17import qualified AST.Variable as V
16import qualified AST.Variable as V
17+import AST.Module (CanonicalAdt, AdtInfo)
18import Type.Type
18import Type.Type
19
19
20type TypeDict = Map.Map String Type
20type TypeDict = Map.Map String Type
21type VarDict = Map.Map String Variable
21type VarDict = Map.Map String Variable
22
22
23−data Environment = Environment {
23+data Environment = Environment
24− constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),
24+ { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))
25− types :: TypeDict,
25+ , types :: TypeDict
26− value :: TypeDict
26+ , value :: TypeDict
27−}
27+ }
28
28
29−initialEnvironment :: ADTs -> IO Environment
29+initialEnvironment :: [CanonicalAdt] -> IO Environment
30initialEnvironment datatypes = do
30initialEnvironment datatypes = do
31 types <- makeTypes datatypes
31 types <- makeTypes datatypes
32 let env = Environment
32 let env = Environment
@@ -36,27 +36,35 @@ initialEnvironment datatypes = do
36 }
36 }
37 return $ env { constructor = makeConstructors env datatypes }
37 return $ env { constructor = makeConstructors env datatypes }
38
38
39−makeTypes :: ADTs -> IO TypeDict
39+makeTypes :: [CanonicalAdt] -> IO TypeDict
40makeTypes datatypes =
40makeTypes datatypes =
41− do adts <- Traverse.sequence (Map.mapWithKey make datatypes)
41+ do adts <- mapM makeImported datatypes
42− bs <- Map.fromList . zip (map fst builtins) <$> mapM (uncurry make) builtins
42+ bs <- mapM makeBuiltin builtins
43− return (Map.union adts bs)
43+ return (Map.fromList (adts ++ bs))
44 where
44 where
45+ makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
46+ makeImported (var, _) = do
45− make name _ = VarN <$> namedVar Constant name
47+ tvar <- namedVar Constant var
48+ return (V.toString var, VarN tvar)
46
49
47− tuple n = ("_Tuple" ++ show n, n)
50+ makeBuiltin :: (String, Int) -> IO (String, Type)
51+ makeBuiltin (name, _) = do
52+ name' <- namedVar Constant (V.builtin name)
53+ return (name, VarN name')
48
54
49− kind n names = map (\name -> (name, n)) names
50−
51− builtins :: [(String,Int)]
55+ builtins :: [(String, Int)]
52 builtins = concat [ map tuple [0..9]
56 builtins = concat [ map tuple [0..9]
53 , kind 1 ["_List"]
57 , kind 1 ["_List"]
54 , kind 0 ["Int","Float","Char","String","Bool"]
58 , kind 0 ["Int","Float","Char","String","Bool"]
55 ]
59 ]
60+ where
61+ tuple n = ("_Tuple" ++ show n, n)
62+ kind n names = map (\name -> (name, n)) names
63+
56
64
57
65
58makeConstructors :: Environment
66makeConstructors :: Environment
59− -> ADTs
67+ -> [CanonicalAdt]
60 -> Map.Map String (IO (Int, [Variable], [Type], Type))
68 -> Map.Map String (IO (Int, [Variable], [Type], Type))
61makeConstructors env datatypes = Map.fromList builtins
69makeConstructors env datatypes = Map.fromList builtins
62 where
70 where
@@ -76,30 +84,32 @@ makeConstructors env datatypes = Map.fromList builtins
76 builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
84 builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))
77 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
85 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))
78 ] ++ map tupleCtor [0..9]
86 ] ++ map tupleCtor [0..9]
79− ++ concatMap (ctorToType env) (Map.toList datatypes)
87+ ++ concatMap (ctorToType env) datatypes
80
88
81
89
90+ctorToType :: Environment
91+ -> (V.Canonical, AdtInfo V.Canonical)
82−--ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
92+ -> [(String, IO (Int, [Variable], [Type], Type))]
83ctorToType env (name, (tvars, ctors)) =
93ctorToType env (name, (tvars, ctors)) =
84− zip (map fst ctors) (map inst ctors)
94+ zip (map (V.toString . fst) ctors) (map inst ctors)
85 where
95 where
86− inst :: (String, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
96+ inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)
87 inst ctor = do
97 inst ctor = do
88 ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
98 ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty
89 return (length args, Map.elems dict, args, tipe)
99 return (length args, Map.elems dict, args, tipe)
90
100
91
101
92− go :: (String, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
102+ go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)
93 go (_, args) = do
103 go (_, args) = do
94 types <- mapM (instantiator env) args
104 types <- mapM (instantiator env) args
95− returnType <- instantiator env (T.Data (error "name") (map T.Var tvars))
105+ returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
96 return (types, returnType)
106 return (types, returnType)
97
107
98
108
99get :: Environment -> (Environment -> Map.Map String a) -> String -> a
109get :: Environment -> (Environment -> Map.Map String a) -> String -> a
100get env subDict key = Map.findWithDefault err key (subDict env)
110get env subDict key = Map.findWithDefault err key (subDict env)
101 where
111 where
102− err = error $ "\nCould not find type constructor '" ++ key ++ "' while checking types."
112+ err = error $ "Could not find type constructor '" ++ key ++ "' while checking types."
103
113
104
114
105freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
115freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)
@@ -128,7 +138,7 @@ instantiator env sourceType = go sourceType
128 case Map.lookup x dict of
138 case Map.lookup x dict of
129 Just v -> return (VarN v)
139 Just v -> return (VarN v)
130 Nothing ->
140 Nothing ->
131− do var <- State.liftIO $ namedVar flex x
141+ do var <- State.liftIO $ namedVar flex (V.local x)
132 State.put (Map.insert x var dict)
142 State.put (Map.insert x var dict)
133 return (VarN var)
143 return (VarN var)
134 where
144 where
@@ -137,12 +147,18 @@ instantiator env sourceType = go sourceType
137 | "appendable" `isPrefixOf` x = Is Appendable
147 | "appendable" `isPrefixOf` x = Is Appendable
138 | otherwise = Flexible
148 | otherwise = Flexible
139
149
140− T.Data name ts -> do
150+ T.Aliased _ t -> go t
151+
152+ T.Type var ->
153+ case Map.lookup (V.toString var) (types env) of
154+ Just t -> return t
155+ Nothing -> error $ "Could not find type constructor '" ++
156+ V.toString var ++ "' while checking types."
157+
158+ T.App t ts -> do
159+ t' <- go t
141 ts' <- mapM go ts
160 ts' <- mapM go ts
142− case Map.lookup (V.toString name) (types env) of
143− Just t -> return $ foldl (<|) t ts'
161+ return $ foldl (<|) t' ts'
144− Nothing -> error $ "\nCould not find type constructor '" ++
145− V.toString name ++ "' while checking types."
146
162
147 T.Record fields ext -> do
163 T.Record fields ext -> do
148 fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
164 fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
compiler/Type/Type.hs+33−23
@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -W #-}
1module Type.Type where
2module Type.Type where
2
3
3import qualified Data.Char as Char
4import qualified Data.Char as Char
@@ -12,7 +13,6 @@ import Control.Monad.State
12import Control.Monad.Error
13import Control.Monad.Error
13import Data.Traversable (traverse)
14import Data.Traversable (traverse)
14import AST.Annotation
15import AST.Annotation
15−import AST.Helpers (isTuple)
16import qualified AST.Type as T
16import qualified AST.Type as T
17import qualified AST.Variable as Var
17import qualified AST.Variable as Var
18
18
@@ -36,7 +36,7 @@ type Type = TermN Variable
36type Variable = UF.Point Descriptor
36type Variable = UF.Point Descriptor
37
37
38type SchemeName = String
38type SchemeName = String
39−type TypeName = String
39+type TypeName = Var.Canonical
40
40
41type Constraint a b = Located (BasicConstraint a b)
41type Constraint a b = Located (BasicConstraint a b)
42data BasicConstraint a b
42data BasicConstraint a b
@@ -96,7 +96,7 @@ data Flex = Rigid | Flexible | Constant | Is SuperType
96data SuperType = Number | Comparable | Appendable
96data SuperType = Number | Comparable | Appendable
97 deriving (Show, Eq)
97 deriving (Show, Eq)
98
98
99−namedVar :: Flex -> String -> IO Variable
99+namedVar :: Flex -> Var.Canonical -> IO Variable
100namedVar flex name = UF.fresh $ Descriptor {
100namedVar flex name = UF.fresh $ Descriptor {
101 structure = Nothing,
101 structure = Nothing,
102 rank = noRank,
102 rank = noRank,
@@ -203,8 +203,12 @@ instance PrettyType Descriptor where
203 pretty when desc =
203 pretty when desc =
204 case (structure desc, name desc) of
204 case (structure desc, name desc) of
205 (Just term, _) -> pretty when term
205 (Just term, _) -> pretty when term
206− (_, Just name) -> if not (isTuple name) then P.text name else
206+ (_, Just name)
207+ | Var.isTuple name ->
207− P.parens . P.text $ replicate (read (drop 6 name) - 1) ','
208+ P.parens . P.text $ replicate (read (drop 6 (Var.toString name)) - 1) ','
209+ | otherwise ->
210+ P.text (Var.toString name)
211+
208 _ -> P.text "?"
212 _ -> P.text "?"
209
213
210
214
@@ -278,23 +282,20 @@ addNames value = do
278 getNames desc state@(vars, a, b, c) =
282 getNames desc state@(vars, a, b, c) =
279 let name' = name desc in
283 let name' = name desc in
280 case name' of
284 case name' of
281− Just var -> (name', (var:vars, a, b, c))
285+ Just (Var.Canonical _ var) -> (name', (var:vars, a, b, c))
282− Nothing -> (name', state)
286+ _ -> (name', state)
283
287
284 rename desc state@(vars, a, b, c) =
288 rename desc state@(vars, a, b, c) =
285 case name desc of
289 case name desc of
286 Just var -> (Just var, state)
290 Just var -> (Just var, state)
287 Nothing ->
291 Nothing ->
288 case flex desc of
292 case flex desc of
289− Is Number -> (Just $ "number" ++ replicate a '\'', (vars, a+1, b, c))
293+ Is Number -> (local $ "number" ++ replicate a '\'', (vars, a+1, b, c))
290− Is Comparable -> (Just $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))
294+ Is Comparable -> (local $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))
291− Is Appendable -> (Just $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))
295+ Is Appendable -> (local $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))
292− other -> (Just $ head vars, (tail vars, a, b, c))
296+ _ -> (local $ head vars, (tail vars, a, b, c))
293− where mark = case other of
297+ where
294− Flexible -> ""
298+ local v = Just (Var.local v)
295− Rigid -> "!"
296− Constant -> "#"
297−
298
299
299type CrawlState = ([String], Int, Int, Int)
300type CrawlState = ([String], Int, Int, Int)
300
301
@@ -367,24 +368,33 @@ toSrcType variable = do
367 Just term ->
368 Just term ->
368 case term of
369 case term of
369 App1 a b -> do
370 App1 a b -> do
370− T.Data name ts <- toSrcType a
371+ a' <- toSrcType a
371 b' <- toSrcType b
372 b' <- toSrcType b
372− return (T.Data name (ts ++ [b']))
373+ case a' of
374+ T.App f args -> return $ T.App f (args ++ [b'])
375+ _ -> return $ T.App a' [b']
376+
373 Fun1 a b -> T.Lambda <$> toSrcType a <*> toSrcType b
377 Fun1 a b -> T.Lambda <$> toSrcType a <*> toSrcType b
378+
374 Var1 a -> toSrcType a
379 Var1 a -> toSrcType a
380+
375 EmptyRecord1 -> return $ T.Record [] Nothing
381 EmptyRecord1 -> return $ T.Record [] Nothing
382+
376 Record1 tfields extension -> do
383 Record1 tfields extension -> do
377 fields' <- traverse (mapM toSrcType) tfields
384 fields' <- traverse (mapM toSrcType) tfields
378 let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]
385 let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]
379 ext' <- toSrcType extension
386 ext' <- toSrcType extension
380 return $ case ext' of
387 return $ case ext' of
381 T.Record fs ext -> T.Record (fs ++ fields) ext
388 T.Record fs ext -> T.Record (fs ++ fields) ext
382− T.Var x -> T.Record fields (Just ext')
389+ T.Var _ -> T.Record fields (Just ext')
383 _ -> error "Used toSrcType on a type that is not well-formed"
390 _ -> error "Used toSrcType on a type that is not well-formed"
391+
384 Nothing ->
392 Nothing ->
385 case name desc of
393 case name desc of
394+ Just var@(Var.Canonical _ x@(c:_))
386− Just x@(c:_) | Char.isLower c -> return (T.Var x)
395+ | Char.isLower c -> return (T.Var x)
387− | otherwise -> return (T.Data (Var.Canonical (error "did not finish converting toSrcType") x) [])
396+ | otherwise -> return $ T.Type var
397+
388 _ -> error $ concat
398 _ -> error $ concat
389 [ "Problem converting the following type "
399 [ "Problem converting the following type "
390 , "from a type-checker type to a source-syntax type:"
400 , "from a type-checker type to a source-syntax type:"
@@ -399,10 +409,10 @@ collectApps variable = go [] variable
399 desc <- UF.descriptor variable
409 desc <- UF.descriptor variable
400 case (structure desc, vars) of
410 case (structure desc, vars) of
401 (Nothing, [v]) -> case name desc of
411 (Nothing, [v]) -> case name desc of
402− Just "_List" -> return (List v)
412+ Just n | Var.isList n -> return (List v)
403 _ -> return Other
413 _ -> return Other
404 (Nothing, vs) -> case name desc of
414 (Nothing, vs) -> case name desc of
405− Just ctor | isTuple ctor -> return (Tuple vs)
415+ Just n | Var.isTuple n -> return (Tuple vs)
406 _ -> return Other
416 _ -> return Other
407 (Just term, _) -> case term of
417 (Just term, _) -> case term of
408 App1 a b -> go (vars ++ [b]) a
418 App1 a b -> go (vars ++ [b]) a
compiler/Type/Unify.hs+18−12
@@ -2,10 +2,12 @@
2module Type.Unify (unify) where
2module Type.Unify (unify) where
3
3
4import Control.Monad.State
4import Control.Monad.State
5+import qualified Data.List as List
5import qualified Data.Map as Map
6import qualified Data.Map as Map
6import qualified Data.Maybe as Maybe
7import qualified Data.Maybe as Maybe
7import qualified Data.UnionFind.IO as UF
8import qualified Data.UnionFind.IO as UF
8import qualified AST.Annotation as A
9import qualified AST.Annotation as A
10+import qualified AST.Variable as Var
9import qualified Type.State as TS
11import qualified Type.State as TS
10import Type.Type
12import Type.Type
11import Type.PrettyPrint
13import Type.PrettyPrint
@@ -23,7 +25,7 @@ actuallyUnify region variable1 variable2 = do
23 desc2 <- liftIO $ UF.descriptor variable2
25 desc2 <- liftIO $ UF.descriptor variable2
24 let unify' = unify region
26 let unify' = unify region
25
27
26− name' :: Maybe String
28+ name' :: Maybe Var.Canonical
27 name' = case (name desc1, name desc2) of
29 name' = case (name desc1, name desc2) of
28 (Just name1, Just name2) ->
30 (Just name1, Just name2) ->
29 case (flex desc1, flex desc2) of
31 case (flex desc1, flex desc2) of
@@ -77,10 +79,12 @@ actuallyUnify region variable1 variable2 = do
77 liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }
79 liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }
78 unify' variable1 variable2
80 unify' variable1 variable2
79
81
80− unifyNumber svar name
82+ unifyNumber svar (Var.Canonical home name) =
83+ case home of
81− | name `elem` ["Int","Float","number"] = flexAndUnify svar
84+ Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar
85+ Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar
86+ _ -> let hint = "A number must be an Int or Float."
82− | otherwise = TS.addError region (Just hint) variable1 variable2
87+ in TS.addError region (Just hint) variable1 variable2
83− where hint = "A number must be an Int or Float."
84
88
85 comparableError maybe =
89 comparableError maybe =
86 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
90 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
@@ -90,9 +94,11 @@ actuallyUnify region variable1 variable2 = do
90 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
94 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
91 where msg = "An appendable must be of type String, List, or Text."
95 where msg = "An appendable must be of type String, List, or Text."
92
96
93− unifyComparable var name
97+ unifyComparable var (Var.Canonical home name) =
98+ case home of
94− | name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var
99+ Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify var
100+ Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify var
95− | otherwise = comparableError Nothing
101+ _ -> comparableError Nothing
96
102
97 unifyComparableStructure varSuper varFlex =
103 unifyComparableStructure varSuper varFlex =
98 do struct <- liftIO $ collectApps varFlex
104 do struct <- liftIO $ collectApps varFlex
@@ -136,10 +142,10 @@ actuallyUnify region variable1 variable2 = do
136 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
142 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2
137 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
143 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1
138
144
139− (Is Appendable, _, _, Just ctor)
145+ (Is Appendable, _, _, Just name)
140− | ctor `elem` ["Text.Text","String"] -> flexAndUnify variable1
146+ | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1
141− (_, Is Appendable, Just ctor, _)
147+ (_, Is Appendable, Just name, _)
142− | ctor `elem` ["Text.Text","String"] -> flexAndUnify variable2
148+ | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2
143 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
149 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2
144 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
150 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1
145
151