9fe6c9a · elk · git.iko.soy

compiler/Type/Constrain/Expression.hs+12−12

compare with master

unifiedsplit

@@ -33,10 +33,10 @@ test str =

33 Left err -> error $ "Parse error at " ++ show err

34 Right expression -> do

35 env <- Env.initialEnvironment []

36− var <- flexibleVar

36+ v <- var Flexible

37 let expr = SD.sortDefs expression

38 print (pretty expr)

39− constraint <- constrain env expr (VarN var)

39+ constraint <- constrain env expr (VarN v)

40 print =<< extraPretty constraint

41 state <- execStateT (solve constraint) TS.initialState

42 let errors = TS.sErrors state

@@ -110,7 +110,7 @@ constrain env (L _ _ expr) tipe =

110 (ctipe, cs) <- Monad.foldM step (tipe,CTrue) (reverse pairs)

111 return (cs /\ name <? ctipe)

112 where

113− pair e = do v <- flexibleVar -- needs an ex

113+ pair e = do v <- var Flexible -- needs an ex

114 return (e, VarN v)

115

116 step (t,c) (e,x) = do

@@ -142,11 +142,11 @@ constrain env (L _ _ expr) tipe =

142 return (CAnd (cOld : cNew : constraints))

143 where

144 dummyField (label, _) = do

145− v <- flexibleVar -- needs an ex

145+ v <- var Flexible -- needs an ex

146 return (label, [VarN v])

147

148 field (label, value) = do

149− v <- flexibleVar -- needs an ex

149+ v <- var Flexible -- needs an ex

150 c <- ex [v] <$> constrain env value (VarN v)

151 return ((label, [VarN v]), c)

152

@@ -157,7 +157,7 @@ constrain env (L _ _ expr) tipe =

157 return $ ex (map snd pairs) (CAnd (tipe === recordType : cs))

158 where

159 field (name, body) = do

160− v <- flexibleVar -- needs an ex

160+ v <- var Flexible -- needs an ex

161 c <- constrain env body (VarN v)

162 return ((name, v), c)

163

@@ -182,7 +182,7 @@ constrainDef env info (pattern, expr, maybeTipe) =

182 in

183 case (pattern, maybeTipe) of

184 (PVar name, Just tipe) ->

185− do flexiVars <- mapM (\_ -> flexibleVar) qs

185+ do flexiVars <- mapM (\_ -> var Flexible) qs

186 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars

187 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

188 (vars, typ) <- Env.instantiateTypeWithContext env tipe Map.empty

@@ -199,16 +199,16 @@ constrainDef env info (pattern, expr, maybeTipe) =

199 , fl rigidQuantifiers c /\ c1 )

200

201 (PVar name, Nothing) ->

202− do var <- flexibleVar

202+ do v <- var Flexible

203− rigidVars <- mapM (\_ -> rigidVar) qs -- Some mistake may be happening here.

203+ rigidVars <- mapM (\_ -> var Rigid) qs -- Some mistake may be happening here.

204− -- Currently, qs is always the empty list.

204+ -- Currently, qs is always the empty list.

205− let tipe = VarN var

205+ let tipe = VarN v

206 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars

207 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

208 c <- constrain env' expr tipe

209 return ( schemes

210 , rigidVars ++ rigidQuantifiers

211− , var : flexibleQuantifiers

211+ , v : flexibleQuantifiers

212 , Map.insert name tipe headers

213 , c /\ c2

214 , c1 )

compiler/Type/Constrain/Literal.hs+1−1

@@ -12,7 +12,7 @@ constrain :: Environment -> Literal -> Type -> IO TypeConstraint

12constrain env literal tipe =

13 let prim name = Env.get env Env.types name in

14 case literal of

15− IntNum _ -> fmap (\n -> tipe === VarN n) number

15+ IntNum _ -> fmap (\n -> tipe === VarN n) (var (Is Number))

16 FloatNum _ -> return $ tipe === prim "Float"

17 Chr _ -> return $ tipe === prim "Char"

18 Str _ -> return $ tipe === TermN (App1 (prim "_List") (prim "Char"))

compiler/Type/Constrain/Pattern.hs+2−2

@@ -25,7 +25,7 @@ constrain env pattern tipe =

25 return $ emptyFragment { typeConstraint = c }

26

27 PVar name -> do

28− v <- flexibleVar

28+ v <- var Flexible

29 return $ Fragment {

30 typeEnv = Map.singleton name (VarN v),

31 vars = [v],

@@ -52,7 +52,7 @@ constrain env pattern tipe =

52 }

53

54 PRecord fields -> do

55− pairs <- mapM (\name -> (,) name <$> flexibleVar) fields

55+ pairs <- mapM (\name -> (,) name <$> var Flexible) fields

56 let tenv = Map.fromList (map (second VarN) pairs)

57 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

58 return $ Fragment {

compiler/Type/Environment.hs+7−7

@@ -66,10 +66,10 @@ makeConstructors types = Map.fromList builtins

66 let (args, result) = tipe (map VarN vars)

67 return (length args, vars, args, result)

68

69− inst = instance' flexibleVar

69+ inst = instance' (var Flexible)

70− nmbr = instance' number 1

70+ nmbr = instance' (var (Is Number)) 1

71− cmpr = instance' comparable 1

71+ cmpr = instance' (var (Is Comparable)) 1

72− apnd = instance' appendable 1

72+ apnd = instance' (var (Is Appendable)) 1

73

74 tupleCtor n =

75 let name = "_Tuple" ++ show n

@@ -132,9 +132,9 @@ instantiateTypeWithContext env sourceType dict =

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

133 return (VarN var)

134 where

135− flex | "number" `isPrefixOf` x = IsIn Number

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

136− | "comparable" `isPrefixOf` x = IsIn Comparable

136+ | "comparable" `isPrefixOf` x = Is Comparable

137− | "appendable" `isPrefixOf` x = IsIn Appendable

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

138 | otherwise = Flexible

139

140 Src.Data name ts -> do

compiler/Type/Inference.hs+2−2

@@ -29,7 +29,6 @@ infer interfaces' modul = unsafePerformIO $ do

29-- mapM print (concatMap iAdts (Map.elems interfaces))

30

31 env <- Env.initialEnvironment (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

32− var <- T.flexibleVar

33 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->

32 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->

34 do (_, vars, args, result) <- Env.freshDataScheme env name

33 do (_, vars, args, result) <- Env.freshDataScheme env name

35 return (name, (vars, foldr (T.==>) result args))

34 return (name, (vars, foldr (T.==>) result args))

@@ -55,7 +54,8 @@ infer interfaces' modul = unsafePerformIO $ do

55 header = Map.map snd (Map.fromList allTypes)

54 header = Map.map snd (Map.fromList allTypes)

56 environ = T.CLet [ T.Scheme vars [] T.CTrue header ]

55 environ = T.CLet [ T.Scheme vars [] T.CTrue header ]

57

56

57+ fvar <- T.var T.Flexible

58− constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN var)

58+ constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)

59 --print =<< T.extraPretty constraint

60

61 state <- execStateT (Solve.solve constraint) TS.initialState

compiler/Type/Solve.hs+1−1

@@ -123,7 +123,7 @@ solve constraint =

123 case Map.lookup name env of

124 Just tipe -> TS.makeInstance tipe

125 Nothing

126− | List.isPrefixOf "Native." name -> liftIO flexibleVar

126+ | List.isPrefixOf "Native." name -> liftIO (var Flexible)

127 | otherwise ->

128 error ("Could not find '" ++ name ++ "' when solving type constraints.")

129

compiler/Type/State.hs+1−1

@@ -138,7 +138,7 @@ makeCopy alreadyCopied variable = do

138 rank = maxRank pool,

139 mark = noMark,

140 flex = case flex desc of

141− IsIn s -> IsIn s

141+ Is s -> Is s

142 _ -> Flexible,

143 copy = Nothing,

144 name = case flex desc of

compiler/Type/Type.hs+25−29

@@ -88,16 +88,12 @@ outermostRank = 0 :: Int

88noMark = 0

89initialMark = 1

90

91−data Flex = Rigid | Flexible | Constant | IsIn SuperType

91+data Flex = Rigid | Flexible | Constant | Is SuperType

92 deriving (Show, Eq)

93

94data SuperType = Number | Comparable | Appendable

95 deriving (Show, Eq)

96

97−number = namedVar (IsIn Number) "number"

98−comparable = namedVar (IsIn Comparable) "comparable"

99−appendable = namedVar (IsIn Appendable) "appendable"

100−

101namedVar flex name = UF.fresh $ Descriptor {

97namedVar flex name = UF.fresh $ Descriptor {

102 structure = Nothing,

98 structure = Nothing,

103 rank = noRank,

99 rank = noRank,

@@ -107,23 +103,15 @@ namedVar flex name = UF.fresh $ Descriptor {

107 mark = noMark

103 mark = noMark

108 }

104 }

109

105

110−flexibleVar = UF.fresh $ Descriptor {

106+var flex = UF.fresh $ Descriptor {

111 structure = Nothing,

107 structure = Nothing,

112 rank = noRank,

108 rank = noRank,

113− flex = Flexible,

109+ flex = flex,

114 name = Nothing,

110 name = Nothing,

115 copy = Nothing,

111 copy = Nothing,

116 mark = noMark

112 mark = noMark

117 }

113 }

118

114

119−rigidVar = UF.fresh $ Descriptor {

120− structure = Nothing,

121− rank = noRank,

122− flex = Rigid,

123− name = Nothing,

124− copy = Nothing,

125− mark = noMark

126− }

127

115

128-- ex qs constraint == exists qs. constraint

116-- ex qs constraint == exists qs. constraint

129ex :: [Variable] -> TypeConstraint -> TypeConstraint

117ex :: [Variable] -> TypeConstraint -> TypeConstraint

@@ -135,7 +123,7 @@ fl rqs constraint = CLet [Scheme rqs [] constraint Map.empty] CTrue

135

123

136exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint

124exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint

137exists f = do

125exists f = do

138− v <- flexibleVar

126+ v <- var Flexible

139 ex [v] <$> f (VarN v)

127 ex [v] <$> f (VarN v)

140

128

141

129

@@ -252,31 +240,39 @@ extraPretty t = pretty Never <$> addNames t

252

240

253addNames :: (Crawl t) => t -> IO t

241addNames :: (Crawl t) => t -> IO t

254addNames value = do

242addNames value = do

255− (_, rawVars) <- runStateT (crawl getNames value) []

243+ (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)

256 let vars = map head . List.group $ List.sort rawVars

244 let vars = map head . List.group $ List.sort rawVars

257 suffix s = map (++s) (map (:[]) ['a'..'z'])

245 suffix s = map (++s) (map (:[]) ['a'..'z'])

258 allVars = concatMap suffix $ ["","'","_"] ++ map show [0..]

246 allVars = concatMap suffix $ ["","'","_"] ++ map show [0..]

259 okayVars = filter (`notElem` vars) allVars

247 okayVars = filter (`notElem` vars) allVars

260− runStateT (crawl rename value) okayVars

248+ runStateT (crawl rename value) (okayVars, 0, 0, 0)

261 return value

249 return value

262 where

250 where

263− getNames name vars =

251+ getNames desc state@(vars, a, b, c) =

252+ let name' = name desc in

253+ case name' of

254+ Just var -> (name', (var:vars, a, b, c))

255+ Nothing -> (name', state)

256+

257+ rename desc state@(vars, a, b, c) =

264− case name of

258+ case name desc of

265− Just var -> (name, var:vars)

259+ Just var -> (Just var, state)

266− Nothing -> (name, vars)

260+ Nothing ->

261+ case flex desc of

262+ Is Number -> (Just $ "number" ++ replicate a '\'', (vars, a+1, b, c))

263+ Is Comparable -> (Just $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))

264+ Is Appendable -> (Just $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))

265+ _ -> (Just $ head vars, (tail vars, a, b, c))

267

266

268− rename name vars =

269− case name of

270− Just var -> (name, vars)

271− Nothing -> (Just (head vars), tail vars)

272

267

268+type CrawlState = ([String], Int, Int, Int)

273

269

274-- Code for traversing all the type data-structures and giving

270-- Code for traversing all the type data-structures and giving

275-- names to the variables embedded deep in there.

271-- names to the variables embedded deep in there.

276class Crawl t where

272class Crawl t where

277− crawl :: (Maybe TypeName -> [String] -> (Maybe TypeName, [String]))

273+ crawl :: (Descriptor -> CrawlState -> (Maybe TypeName, CrawlState))

278 -> t

274 -> t

279− -> StateT [String] IO t

275+ -> StateT CrawlState IO t

280

276

281instance (Crawl t, Crawl v) => Crawl (Constraint t v) where

277instance (Crawl t, Crawl v) => Crawl (Constraint t v) where

282 crawl nextState constraint =

278 crawl nextState constraint =

@@ -324,7 +320,7 @@ instance Crawl a => Crawl (UF.Point a) where

324instance Crawl Descriptor where

320instance Crawl Descriptor where

325 crawl nextState desc = do

321 crawl nextState desc = do

326 state <- get

322 state <- get

327− let (name', state') = nextState (name desc) state

323+ let (name', state') = nextState desc state

328 structure' <- traverse (crawl nextState) (structure desc)

324 structure' <- traverse (crawl nextState) (structure desc)

329 put state'

325 put state'

330 return $ desc { name = name', structure = structure' }

326 return $ desc { name = name', structure = structure' }

compiler/Type/Unify.hs+13−13

@@ -23,9 +23,9 @@ actuallyUnify variable1 variable2 = do

23 case (flex desc1, flex desc2) of

24 (_, Flexible) -> Just name1

25 (Flexible, _) -> Just name2

26− (IsIn Number, IsIn _) -> Just name1

26+ (Is Number, Is _) -> Just name1

27− (IsIn _, IsIn Number) -> Just name2

27+ (Is _, Is Number) -> Just name2

28− (IsIn _, IsIn _) -> Just name1

28+ (Is _, Is _) -> Just name1

29 (_, _) -> Nothing

30 (Just name1, _) -> Just name1

31 (_, Just name2) -> Just name2

@@ -35,9 +35,9 @@ actuallyUnify variable1 variable2 = do

35 flex' = case (flex desc1, flex desc2) of

36 (f, Flexible) -> f

37 (Flexible, f) -> f

38− (IsIn Number, IsIn _) -> IsIn Number

38+ (Is Number, Is _) -> Is Number

39− (IsIn _, IsIn Number) -> IsIn Number

39+ (Is _, Is Number) -> Is Number

40− (IsIn super, IsIn _) -> IsIn super

40+ (Is super, Is _) -> Is super

41 (_, _) -> Flexible

42

43 rank' :: Int

@@ -73,24 +73,24 @@ actuallyUnify variable1 variable2 = do

73

74 superUnify =

75 case (flex desc1, flex desc2, name desc1, name desc2) of

76− (IsIn super1, IsIn super2, _, _)

76+ (Is super1, Is super2, _, _)

77 | super1 == super2 -> merge

78− (IsIn Number, IsIn Comparable, _, _) -> merge1

78+ (Is Number, Is Comparable, _, _) -> merge1

79− (IsIn Comparable, IsIn Number, _, _) -> merge2

79+ (Is Comparable, Is Number, _, _) -> merge2

80

81− (IsIn Number, _, _, Just name)

81+ (Is Number, _, _, Just name)

82 | name `elem` ["Int","Float"] -> flexAndUnify variable1

83 | otherwise -> TS.addError "Expecting a number (Int or Float)" variable1 variable2

84

85− (_, IsIn Number, Just name, _)

85+ (_, Is Number, Just name, _)

86 | name `elem` ["Int","Float"] -> flexAndUnify variable2

87 | otherwise -> TS.addError "Expecting a number (Int or Float)" variable1 variable2

88

89− (IsIn Comparable, _, _, Just name)

89+ (Is Comparable, _, _, Just name)

90 | name `elem` ["Int","Float","Char"] -> flexAndUnify variable1

91 | otherwise -> TS.addError "Expecting something comparable (Int, Float, Char, [comparable])." variable1 variable2

92

93− (_, IsIn Comparable, Just name, _)

93+ (_, Is Comparable, Just name, _)

94 | name `elem` ["Int","Float","Char"] -> flexAndUnify variable2

95 | otherwise -> TS.addError "Expecting something comparable (Int, Float, Char, [comparable])." variable1 variable2

96