87fa86c · elk · git.iko.soy

git.iko.soy/elk

Get type dealiasing working.

commit87fa86c7e8232072264a0d1b7ff395459e96dd81 authorevancz <info@elm-lang.org> dateFri 5 Apr 2013, 09:55 (14 years ago) parent5faf79c

6 files changed+76−104

compare with master

unifiedsplit

compiler/Initialize.hs+4−7 compiler/Parse/Types.hs+2−5 compiler/Types/Alias.hs+16−28 compiler/Types/Solver.hs+47−38 compiler/Types/Types.hs+3−24 compiler/Types/Unify.hs+4−2

compiler/Initialize.hs+4−7

@@ -14,7 +14,7 @@ import Libraries (libraries)

1414import Types.Types ((-:))

1515import Types.Hints (hints)

1616import Types.Unify

17−import Types.Alias

17+import Types.Alias (dealias, mistakes)

1818import Optimize

1919import CompileToJS (jsModule)

2020

@@ -25,12 +25,9 @@ checkMistakes modul@(Module name ex im stmts) =

2525 [] -> return modul

2626

2727checkTypes :: Module -> Either String Module

28−checkTypes (Module name ex im stmts) =

29− let stmts' = dealias stmts

30− modul = Module name ex im stmts'

31− in do subs <- unify hints modul

32− let modul' = optimize . renameModule $ Module name ex im stmts'

33− subs `seq` return modul'

28+checkTypes modul =

29+ do subs <- unify hints modul

30+ subs `seq` return (optimize (renameModule modul))

3431

3532check :: Module -> Either String Module

3633check = checkMistakes >=> checkTypes

compiler/Parse/Types.hs+2−5

@@ -11,7 +11,7 @@ import Text.Parsec.Indent

1111

1212import Context

1313import Parse.Library

14−import Types.Types hiding (string,parens)

14+import Types.Types hiding (parens,string)

1515import Guid

1616

1717data ParseType = VarPT String

@@ -47,10 +47,7 @@ typeUnambiguous :: IParser ParseType

4747typeUnambiguous = typeList <|> typeTuple <|> typeRecord

4848

4949typeSimple :: IParser ParseType

50−typeSimple = dealias <$> var

51− where dealias "String" = listPT (VarPT "Char")

52− dealias "Time" = VarPT "Float"

53− dealias v = VarPT v

50+typeSimple = VarPT <$> var

5451

5552typeApp :: IParser ParseType

5653typeApp = do name <- capVar <?> "type constructor"

compiler/Types/Alias.hs+16−28

@@ -1,5 +1,5 @@

2−module Types.Alias (dealias, mistakes) where

2+module Types.Alias (dealias, get, mistakes) where

44import Ast

55import Control.Arrow (second)

@@ -10,37 +10,25 @@ import Types.Substitutions (subst)

1010import Types.Types

1111

1212builtins :: [(String,([X],Type))]

13−builtins = [ ("String", ([], string)) ]

13+builtins = [ ("String", ([], listOf char))

14+ , ("Time", ([], float)) ]

1415

15−getAliases :: [Statement] -> Map.Map String ([X],Type)

16−getAliases stmts = Map.fromList (builtins ++ concatMap getAlias stmts)

16+get :: [Statement] -> Map.Map String ([X],Type)

17+get stmts = Map.fromList (builtins ++ concatMap getAlias stmts)

1718 where getAlias stmt = case stmt of

1819 TypeAlias alias xs t -> [(alias, (xs,t))]

1920 _ -> []

2021

21−

22−dealias :: [Statement] -> [Statement]

23−dealias stmts = map dealiasS stmts

24− where

25− dealiasT :: Type -> Type

26− dealiasT t =

27− case t of

28− ADT name ts -> case Map.lookup name (getAliases stmts) of

29− Just (xs,t) -> dealiasT (subst (zip xs ts) t)

30− Nothing -> ADT name (map dealiasT ts)

31− LambdaT t u -> LambdaT (dealiasT t) (dealiasT u)

32− RecordT r t -> RecordT (Map.map (map dealiasT) r) (dealiasT t)

33− _ -> t

34−

35− dealiasS :: Statement -> Statement

36− dealiasS s =

37− case s of

38− Datatype n xs tcs -> Datatype n xs (map (second (map dealiasT)) tcs)

39− ExportEvent js elm tipe -> ExportEvent js elm (dealiasT tipe)

40− ImportEvent js e elm tipe -> ImportEvent js e elm (dealiasT tipe)

41− TypeAnnotation name tipe -> TypeAnnotation name (dealiasT tipe)

42− TypeAlias alias xs tipe -> TypeAlias alias xs (dealiasT tipe)

43− Definition _ -> s

22+dealias :: Map.Map String ([X],Type) -> Type -> Type

23+dealias aliases t =

24+ let f = dealias aliases in

25+ case t of

26+ ADT name ts -> case Map.lookup name aliases of

27+ Just (xs,t) -> f (subst (zip xs ts) t)

28+ Nothing -> ADT name (map f ts)

29+ LambdaT t u -> LambdaT (f t) (f u)

30+ RecordT r t -> RecordT (Map.map (map f) r) (f t)

31+ _ -> t

4432

4533mistakes :: [Statement] -> [String]

4634mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts

@@ -55,7 +43,7 @@ badKinds stmts = map msg (concatMap badS stmts)

5543 badT t =

5644 case t of

5745 ADT name ts ->

58− case Map.lookup name (getAliases stmts) of

46+ case Map.lookup name (get stmts) of

5947 Just (xs,t) | length xs == length ts -> []

6048 | otherwise -> [name]

6149 Nothing -> concatMap badT ts

compiler/Types/Solver.hs+47−38

@@ -13,14 +13,17 @@ import Guid

1313import Types.Types

1414import Types.Constrain

1515import Types.Substitutions

16+import Types.Alias (dealias)

1617

1718isSolved ss (C _ _ (t1 :=: t2)) = t1 == t2

1819isSolved ss (C _ _ (x :<<: _)) = isJust (lookup x ss)

1920isSolved ss c = False

2021

21−crush :: Scheme -> GuidCounter (Either String Scheme)

22−crush (Forall xs cs t) =

23− do subs <- solver cs Map.empty

22+type Aliases = Map.Map String ([X],Type)

23+

24+crush :: Aliases -> Scheme -> GuidCounter (Either String Scheme)

25+crush aliases (Forall xs cs t) =

26+ do subs <- solver aliases Map.empty cs

2427 return $ do ss' <- subs

2528 let ss = Map.toList ss'

2629 cs' = filter (not . isSolved ss) (subst ss cs)

@@ -34,10 +37,11 @@ schemeSubHelp txt span x s t1 rltn t2 = do

3437 | otherwise = do (st, cs) <- concretize s

3538 return (subst [(x,st)] t, cs)

3639

37−schemeSub x s c = do s' <- crush s

38− case s' of

39− Right s'' -> Right `liftM` schemeSub' x s'' c

40− Left err -> return $ Left err

40+schemeSub aliases x s c =

41+ do s' <- crush aliases s

42+ case s' of

43+ Right s'' -> Right `liftM` schemeSub' x s'' c

44+ Left err -> return $ Left err

4145

4246schemeSub' x s c@(C txt span constraint) =

4347 case constraint of

@@ -77,29 +81,34 @@ recordConstraints eq fs t fs' t' =

7781 let tipe = RecordT (Map.singleton k bs) (VarT x)

7882 return (cs ++ [eq t tipe])

7983

80−solver :: [Context Constraint]

84+solver :: Aliases

8185 -> Map.Map X Type

86+ -> [Context Constraint]

8287 -> GuidCounter (Either String (Map.Map X Type))

83−solver [] subs = return $ Right subs

84−solver (C txt span c : cs) subs =

88+solver _ subs [] = return $ Right subs

89+solver aliases subs (C txt span c : cs) =

8590 let ctx = C txt span

8691 eq t1 t2 = ctx (t1 :=: t2)

92+ solv = solver aliases subs

8793 in case c of

8894 -- Destruct Type-constructors

8995 t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2) ->

90− if n1 /= n2 then uniError txt span t1 t2 else

91− solver (zipWith eq ts1 ts2 ++ cs) subs

96+ if n1 == n2 then solv (zipWith eq ts1 ts2 ++ cs)

97+ else let t1' = dealias aliases t1

98+ t2' = dealias aliases t2

99+ in if t1 == t1' && t2 == t2' then uniError txt span t1 t2

100+ else solv (ctx (t1' :=: t2') : cs)

92101

93102 LambdaT t1 t2 :=: LambdaT t1' t2' ->

94− solver ([ eq t1 t1', eq t2 t2' ] ++ cs) subs

103+ solv ([ eq t1 t1', eq t2 t2' ] ++ cs)

95104

96105 RecordT fs t :=: RecordT fs' t' ->

97106 do cs' <- recordConstraints eq fs t fs' t'

98− solver (cs' ++ cs) subs

107+ solv (cs' ++ cs)

99108

100109 -- Type-equality

101110 VarT x :=: VarT y

102− | x == y -> solver cs subs

111+ | x == y -> solv cs

103112 | otherwise ->

104113 case (Map.lookup x subs, Map.lookup y subs) of

105114 (Just (Super xts), Just (Super yts)) ->

@@ -108,68 +117,68 @@ solver (C txt span c : cs) subs =

108117 in case Set.toList ts of

109118 [] -> unionError txt span xts yts

110119 [t] -> let cs1 = subst [(x,t),(y,t)] cs in

111− cs1 `seq` solver cs1 (setXY t subs)

112− _ -> solver cs $ setXY (Super ts) subs

120+ cs1 `seq` solver aliases (setXY t subs) cs1

121+ _ -> solver aliases (setXY (Super ts) subs) cs

113122 (Just (Super xts), _) ->

114123 let cs2 = subst [(y,VarT x)] cs in

115− solver cs2 $ Map.insert y (VarT x) subs

124+ solver aliases (Map.insert y (VarT x) subs) cs2

116125 (_, _) ->

117126 let cs3 = subst [(x,VarT y)] cs in

118− solver cs3 $ Map.insert x (VarT y) subs

127+ solver aliases (Map.insert x (VarT y) subs) cs3

119128

120129 VarT x :=: t -> do

121130 if x `occurs` t then occursError txt span (VarT x) t else

122131 (case Map.lookup x subs of

123− Nothing -> let cs4 = subst [(x,t)] cs in

124− solver cs4 . Map.map (subst [(x,t)]) $

125− Map.insert x t subs

132+ Nothing ->

133+ let cs4 = subst [(x,t)] cs

134+ subs' = Map.map (subst [(x,t)]) $ Map.insert x t subs

135+ in solver aliases subs' cs4

126136 Just (Super ts) ->

127137 let ts' = Set.intersection ts (Set.singleton t) in

128138 case Set.toList ts' of

129− [] -> solver (ctx (t :<: Super ts) : cs) subs

139+ [] -> solv (ctx (t :<: Super ts) : cs)

130140 [t'] -> let cs5 = subst [(x,t)] cs in

131− solver cs5 $ Map.insert x t' subs

132− _ -> solver cs $ Map.insert x (Super ts') subs

133− Just t' -> solver (ctx (t' :=: t) : cs) subs

141+ solver aliases (Map.insert x t' subs) cs5

142+ _ -> solver aliases (Map.insert x (Super ts') subs) cs

143+ Just t' -> solv (ctx (t' :=: t) : cs)

134144 )

135145

136− t :=: VarT x -> solver ((ctx (VarT x :=: t)) : cs) subs

146+ t :=: VarT x -> solv ((ctx (VarT x :=: t)) : cs)

137147

138− t1 :=: t2 | t1 == t2 -> solver cs subs

148+ t1 :=: t2 | t1 == t2 -> solv cs

139149 | otherwise -> uniError txt span t1 t2

140150

141151 -- subtypes

142152 VarT x :<: Super ts ->

143153 case Map.lookup x subs of

144− Nothing -> solver cs $ Map.insert x (Super ts) subs

154+ Nothing -> solver aliases (Map.insert x (Super ts) subs) cs

145155 Just (Super ts') ->

146156 case Set.toList $ Set.intersection ts ts' of

147157 [] -> unionError txt span ts ts'

148− [t] -> solver (subst [(x,t)] cs) $ Map.insert x t subs

149− ts'' -> solver cs $

150− Map.insert x (Super $ Set.fromList ts'') subs

158+ [t] -> solver aliases (Map.insert x t subs) (subst [(x,t)] cs)

159+ ts'' -> solver aliases subs' cs

160+ where subs' = Map.insert x (Super $ Set.fromList ts'') subs

151161

152162 ADT "List" [t] :<: Super ts

153− | any f (Set.toList ts) -> solver cs subs

163+ | any f (Set.toList ts) -> solv cs

154164 | otherwise -> subtypeError txt span (ADT "List" [t]) (Super ts)

155165 where f (ADT "List" [VarT _]) = True

156166 f (ADT "List" [t']) = t == t'

157167 f _ = False

158168

159169 t :<: Super ts

160− | Set.member t ts -> solver cs subs

170+ | Set.member t ts -> solv cs

161171 | otherwise -> subtypeError txt span t (Super ts)

162172

163173 x :<<: s

164174 | any (occurs x) cs ->

165− do css <- mapM (schemeSub x s) cs

175+ do css <- mapM (schemeSub aliases x s) cs

166176 case lefts css of

167177 err : _ -> return $ Left err

168− [] -> solver (concat (rights css)) subs

178+ [] -> solv (concat (rights css))

169179 | otherwise ->

170180 do (t,cs7) <- concretize s

171− let cs'' = (cs ++ ctx (VarT x :=: t) : cs7)

172− solver cs'' subs

181+ solv (cs ++ ctx (VarT x :=: t) : cs7)

173182

174183showMsg msg = case msg of

175184 Just str -> "\nIn context: " ++ str

compiler/Types/Types.hs+3−24

@@ -40,22 +40,10 @@ number = Super (Set.fromList [ int, float ])

4040char = tipe "Char"

4141bool = tipe "Bool"

4242

43−string = listOf char -- tipe "String"

43+string = tipe "String"

4444text = tipe "Text"

4545

46−time = float --tipe "Time"

47−date = tipe "Date"

48−month = tipe "Month"

49−day = tipe "Day"

50−

5146element = tipe "Element"

52−direction = tipe "Direction"

53−form = tipe "Form"

54−line = tipe "Line"

55−shape = tipe "Shape"

56−color = tipe "Color"

57−position = tipe "Position"

58−location = tipe "Location"

5947

6048listOf t = ADT "List" [t]

6149signalOf t = ADT "Signal" [t]

@@ -65,16 +53,7 @@ eitherOf a b = ADT "Either" [a,b]

6553pairOf t = tupleOf [t,t]

6654point = pairOf int

6755appendable t = Super (Set.fromList [ string, text, listOf t ])

68−comparable = Super (Set.fromList [ int, float, char, string, time, date ])

69−

70−jsBool = tipe "JSBool"

71−jsNumber = tipe "JSNumber"

72−jsString = tipe "JSString"

73−jsElement = tipe "JSElement"

74−jsArray t = ADT "JSArray" [t]

75−jsTuple ts = ADT ("JSTuple" ++ show (length ts)) ts

76−jsonValue = tipe "JsonValue"

77−jsonObject = tipe "JsonObject"

56+--comparable = Super (Set.fromList [ int, float, char, string, time, date ])

7857

7958infixr ==>

8059t1 ==> t2 = LambdaT t1 t2

@@ -91,7 +70,7 @@ instance Show Type where

9170 LambdaT t1@(LambdaT _ _) t2 -> show' t1 ++ " -> " ++ show t2

9271 LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2

9372 VarT x -> 't' : show x

94− ADT "List" [ADT "Char" []] -> "String"

73+ --ADT "List" [ADT "Char" []] -> "String"

9574 ADT "List" [tipe] -> "[" ++ show tipe ++ "]"

9675 ADT name cs ->

9776 if isTupleString name

compiler/Types/Unify.hs+4−2

@@ -4,11 +4,13 @@ module Types.Unify (unify) where

44import Control.Monad (liftM)

55import qualified Data.Map as Map

7+import Ast

78import Guid

89import Types.Constrain

910import Types.Solver

11+import Types.Alias as Alias

1012

11−unify hints modul = run $ do

13+unify hints modul@(Module _ _ _ stmts) = run $ do

1214 constraints <- constrain hints modul

13− either (return . Left) (\cs -> solver cs Map.empty) constraints

15+ either (return . Left) (solver (Alias.get stmts) Map.empty) constraints

1416