964d296 · elk · git.iko.soy

12import Data.List (isPrefixOf)

13import qualified Text.PrettyPrint as PP

14

15−import qualified AST.Type as Src

16−import AST.Module (ADT, Alias)

15+import AST.Module (ADTs)

16+import qualified AST.Type as T

17+import qualified AST.Variable as V

17import Type.Type

18import Type.Type

18

19

19type TypeDict = Map.Map String Type

20type TypeDict = Map.Map String Type

21

22

22data Environment = Environment {

23data Environment = Environment {

23 constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),

24 constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),

24− aliases :: Map.Map String ([String], Src.Type),

25 types :: TypeDict,

26 value :: TypeDict

27}

28

29−initialEnvironment :: [ADT] -> [Alias] -> IO Environment

29+initialEnvironment :: ADTs -> IO Environment

30−initialEnvironment datatypes aliases = do

30+initialEnvironment datatypes = do

31 types <- makeTypes datatypes

32− let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases

33− env = Environment {

32+ let env = Environment

34− constructor = Map.empty,

33+ { constructor = Map.empty

35− value = Map.empty,

34+ , value = Map.empty

36− types = types,

35+ , types = types

37− aliases = aliases' }

36+ }

38−

39 return $ env { constructor = makeConstructors env datatypes }

37 return $ env { constructor = makeConstructors env datatypes }

40

38

41−makeTypes :: [ADT] -> IO TypeDict

39+makeTypes :: ADTs -> IO TypeDict

42−makeTypes datatypes =

40+makeTypes datatypes =

43− Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)

41+ do adts <- Traverse.sequence (Map.mapWithKey make datatypes)

42+ bs <- Map.fromList . zip (map fst builtins) <$> mapM (uncurry make) builtins

43+ return (Map.union adts bs)

44 where

45− nameAndKind (name, tvars, _) = (name, length tvars)

46−

47− makeCtor (name, _) = do

48− ctor <- VarN <$> namedVar Constant name

45+ make name _ = VarN <$> namedVar Constant name

49− return (name, ctor)

50

46

51 tuple n = ("_Tuple" ++ show n, n)

47 tuple n = ("_Tuple" ++ show n, n)

52

48

60

56

61

57

62makeConstructors :: Environment

58makeConstructors :: Environment

63− -> [ADT]

59+ -> ADTs

64 -> Map.Map String (IO (Int, [Variable], [Type], Type))

60 -> Map.Map String (IO (Int, [Variable], [Type], Type))

65makeConstructors env datatypes = Map.fromList builtins

61makeConstructors env datatypes = Map.fromList builtins

66 where

62 where

80 builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))

76 builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t))

81 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))

77 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))

82 ] ++ map tupleCtor [0..9]

78 ] ++ map tupleCtor [0..9]

83− ++ concatMap (ctorToType env) datatypes

79+ ++ concatMap (ctorToType env) (Map.toList datatypes)

84

80

85

81

86−ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

82+--ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

87−ctorToType env (name, tvars, ctors) =

83+ctorToType env (name, (tvars, ctors)) =

88 zip (map fst ctors) (map inst ctors)

84 zip (map fst ctors) (map inst ctors)

89 where

85 where

90− inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)

86+ inst :: (String, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)

91 inst ctor = do

87 inst ctor = do

92− ((args, tipe), (dict,_)) <- State.runStateT (go ctor) (Map.empty, Map.empty)

88+ ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty

93 return (length args, Map.elems dict, args, tipe)

89 return (length args, Map.elems dict, args, tipe)

94

90

95

91

96− go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)

92+ go :: (String, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)

97 go (_, args) = do

93 go (_, args) = do

98 types <- mapM (instantiator env) args

94 types <- mapM (instantiator env) args

99− returnType <- instantiator env (Src.Data name (map Src.Var tvars))

95+ returnType <- instantiator env (T.Data (error "name") (map T.Var tvars))

100 return (types, returnType)

96 return (types, returnType)

101

97

102

98

112instance ErrorList PP.Doc where

108instance ErrorList PP.Doc where

113 listMsg str = [PP.text str]

109 listMsg str = [PP.text str]

114

110

115−instantiateType :: Environment -> Src.Type -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)

111+instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)

116instantiateType env sourceType dict =

112instantiateType env sourceType dict =

117− do result <- liftIO $ try (State.runStateT (instantiator env sourceType) (dict, Map.empty))

113+ do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)

118− case result :: Either SomeException (Type, (VarDict, TypeDict)) of

114+ case result :: Either SomeException (Type, VarDict) of

119 Left someError -> throwError [ PP.text $ show someError ]

115 Left someError -> throwError [ PP.text $ show someError ]

120− Right (tipe, (dict',_)) -> return (Map.elems dict', tipe)

116+ Right (tipe, dict') -> return (Map.elems dict', tipe)

121

117

122−instantiator :: Environment -> Src.Type

123− -> State.StateT (VarDict, TypeDict) IO Type

118+instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type

124instantiator env sourceType = go sourceType

119instantiator env sourceType = go sourceType

125 where

120 where

126− go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type

121+ go :: T.CanonicalType -> State.StateT VarDict IO Type

127 go sourceType =

122 go sourceType =

128 case sourceType of

123 case sourceType of

129− Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2

124+ T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2

130−

125+

131− Src.Var x -> do

126+ T.Var x -> do

132− (dict, aliases) <- State.get

127+ dict <- State.get

133− case (Map.lookup x dict, Map.lookup x aliases) of

128+ case Map.lookup x dict of

134− (_, Just t) -> return t

135− (Just v, _) -> return (VarN v)

129+ Just v -> return (VarN v)

136− _ ->

130+ Nothing ->

137 do var <- State.liftIO $ namedVar flex x

131 do var <- State.liftIO $ namedVar flex x

138− State.put (Map.insert x var dict, aliases)

132+ State.put (Map.insert x var dict)

139 return (VarN var)

133 return (VarN var)

140 where

134 where

141 flex | "number" `isPrefixOf` x = Is Number

135 flex | "number" `isPrefixOf` x = Is Number

143 | "appendable" `isPrefixOf` x = Is Appendable

137 | "appendable" `isPrefixOf` x = Is Appendable

144 | otherwise = Flexible

138 | otherwise = Flexible

145

139

146− Src.Data name ts -> do

140+ T.Data name ts -> do

147 ts' <- mapM go ts

141 ts' <- mapM go ts

148− case (Map.lookup name (types env), Map.lookup name (aliases env)) of

142+ case Map.lookup (V.toString name) (types env) of

149− (Just t, _) -> return $ foldl (<|) t ts'

143+ Just t -> return $ foldl (<|) t ts'

150− (_, Just (tvars, t)) ->

151− let tvarLen = length tvars

152− msg = "\nType alias '" ++ name ++ "' expects " ++ show tvarLen ++

153− " type argument" ++ (if tvarLen == 1 then "" else "s") ++

154− " but was given " ++ show (length ts')

155− in if length ts' /= length tvars then error msg else

156− do (dict, aliases) <- State.get

157− let aliases' = Map.union (Map.fromList $ zip tvars ts') aliases

158− State.put (dict, aliases')

159− t' <- go t

160− State.put (dict, aliases)

161− return t'

162− _ -> error $ "\nCould not find type constructor '" ++

144+ Nothing -> error $ "\nCould not find type constructor '" ++

163− name ++ "' while checking types."

145+ V.toString name ++ "' while checking types."

164−

146+

165− Src.Record fields ext -> do

147+ T.Record fields ext -> do

166− fields' <- Traverse.traverse (mapM go) (Src.fieldMap fields)

148+ fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)

167 ext' <- case ext of

149 ext' <- case ext of

168 Nothing -> return $ TermN EmptyRecord1

150 Nothing -> return $ TermN EmptyRecord1

169− Just x -> go (Src.Var x)

151+ Just x -> go x

170 return $ TermN (Record1 fields' ext')

152 return $ TermN (Record1 fields' ext')