a12554f · elk · git.iko.soy

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

@@ -106,7 +106,7 @@ constrain env (A region expr) tipe =

106106 and . (:) ce <$> mapM branch branches

107107

108108 Data name exprs ->

109− do vars <- forM exprs $ \_ -> liftIO (var Flexible)

109+ do vars <- forM exprs $ \_ -> liftIO (variable Flexible)

110110 let pairs = zip exprs (map varN vars)

111111 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

112112 return $ ex vars (cs /\ name <? ctipe)

@@ -133,11 +133,11 @@ constrain env (A region expr) tipe =

133133

134134 Modify e fields ->

135135 exists $ \t -> do

136− oldVars <- forM fields $ \_ -> liftIO (var Flexible)

136+ oldVars <- forM fields $ \_ -> liftIO (variable Flexible)

137137 let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))

138138 cOld <- ex oldVars <$> constrain env e (record oldFields t)

139139

140− newVars <- forM fields $ \_ -> liftIO (var Flexible)

140+ newVars <- forM fields $ \_ -> liftIO (variable Flexible)

141141 let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))

142142 let cNew = tipe === record newFields t

143143

@@ -146,14 +146,14 @@ constrain env (A region expr) tipe =

146146 return $ cOld /\ ex newVars (and (cNew : cs))

147147

148148 Record fields ->

149− do vars <- forM fields $ \_ -> liftIO (var Flexible)

149+ do vars <- forM fields $ \_ -> liftIO (variable Flexible)

150150 cs <- zipWithM (constrain env) (map snd fields) (map varN vars)

151151 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

152152 recordType = record fields' (termN EmptyRecord1)

153153 return . ex vars . and $ tipe === recordType : cs

154154

155155 Markdown _ _ es ->

156− do vars <- forM es $ \_ -> liftIO (var Flexible)

156+ do vars <- forM es $ \_ -> liftIO (variable Flexible)

157157 let tvars = map varN vars

158158 cs <- zipWithM (constrain env) es tvars

159159 return . ex vars $ and ("Text.markdown" <? tipe : cs)

@@ -177,11 +177,11 @@ constrainDef env info (Canonical.Definition pattern expr maybeTipe) =

177177 let qs = [] -- should come from the def, but I'm not sure what would live there...

178178 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

179179 in

180− do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.

180+ do rigidVars <- forM qs (\_ -> liftIO $ variable Rigid) -- Some mistake may be happening here.

181181 -- Currently, qs is always [].

182182 case (pattern, maybeTipe) of

183183 (P.Var name, Just tipe) -> do

184− flexiVars <- forM qs (\_ -> liftIO $ var Flexible)

184+ flexiVars <- forM qs (\_ -> liftIO $ variable Flexible)

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

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

187187 (vars, typ) <- Env.instantiateType env tipe Map.empty

@@ -198,7 +198,7 @@ constrainDef env info (Canonical.Definition pattern expr maybeTipe) =

198198 , fl rigidVars c /\ c1 )

199199

200200 (P.Var name, Nothing) -> do

201− v <- liftIO $ var Flexible

201+ v <- liftIO $ variable Flexible

202202 let tipe = varN v

203203 inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars

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

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

@@ -15,7 +15,7 @@ constrain env region literal tipe =

1515

1616 litType =

1717 case literal of

18− IntNum _ -> varN `fmap` var (Is Number)

18+ IntNum _ -> varN `fmap` variable (Is Number)

1919 FloatNum _ -> prim "Float"

2020 Chr _ -> prim "Char"

2121 Str _ -> prim "String"

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

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

3434 return $ emptyFragment { typeConstraint = c }

3535

3636 P.Var name -> do

37− v <- liftIO $ var Flexible

37+ v <- liftIO $ variable Flexible

3838 return $ Fragment {

3939 typeEnv = Map.singleton name (varN v),

4040 vars = [v],

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

6565 }

6666

6767 P.Record fields -> do

68− pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields

68+ pairs <- liftIO $ mapM (\name -> (,) name <$> variable Flexible) fields

6969 let tenv = Map.fromList (map (second varN) pairs)

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

7171 return $ Fragment {

compiler/Type/Environment.hs+1−1

@@ -71,7 +71,7 @@ makeConstructors env datatypes = Map.fromList builtins

7171

7272 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

7373 inst numTVars tipe = do

74− vars <- forM [1..numTVars] $ \_ -> var Flexible

74+ vars <- forM [1..numTVars] $ \_ -> variable Flexible

7575 let (args, result) = tipe (map (varN) vars)

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

7777

compiler/Type/Inference.hs+1−1

@@ -40,7 +40,7 @@ infer interfaces modul = unsafePerformIO $ do

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

4141 environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]

4242

43− fvar <- liftIO $ T.var T.Flexible

43+ fvar <- liftIO $ T.variable T.Flexible

4444 c <- TcExpr.constrain env (program moduleBody) (T.varN fvar)

4545 return (header, environ c)

4646

compiler/Type/Solve.hs+13−13

@@ -21,9 +21,9 @@ generalize youngPool = do

2121 youngMark <- TS.uniqueMark

2222 let youngRank = TS.maxRank youngPool

2323 insert dict var = do

24− desc <- liftIO $ UF.descriptor var

24+ descriptor <- liftIO $ UF.descriptor var

2525 liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })

26− return $ Map.insertWith (++) (rank desc) [var] dict

26+ return $ Map.insertWith (++) (rank descriptor) [var] dict

2727

2828 -- Sort the youngPool variables by rank.

2929 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)

@@ -64,24 +64,24 @@ generalize youngPool = do

6464-- adjust the ranks of variables such that ranks never increase as you

6565-- move deeper into a variable.

6666adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int

67−adjustRank youngMark visitedMark groupRank variable =

68− do desc <- liftIO $ UF.descriptor variable

67+adjustRank youngMark visitedMark groupRank var =

68+ do descriptor <- liftIO $ UF.descriptor var

6969 case () of

70− () | mark desc == youngMark ->

70+ () | mark descriptor == youngMark ->

7171 do -- Set the variable as marked first because it may be cyclic.

72− liftIO $ UF.modifyDescriptor variable $ \desc ->

72+ liftIO $ UF.modifyDescriptor var $ \desc ->

7373 desc { mark = visitedMark }

74− rank' <- maybe (return groupRank) adjustTerm (structure desc)

75− liftIO $ UF.modifyDescriptor variable $ \desc ->

74+ rank' <- maybe (return groupRank) adjustTerm (structure descriptor)

75+ liftIO $ UF.modifyDescriptor var $ \desc ->

7676 desc { rank = rank' }

7777 return rank'

7878

79− | mark desc /= visitedMark ->

80− do let rank' = min groupRank (rank desc)

81− liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })

79+ | mark descriptor /= visitedMark ->

80+ do let rank' = min groupRank (rank descriptor)

81+ liftIO $ UF.setDescriptor var (descriptor { mark = visitedMark, rank = rank' })

8282 return rank'

8383

84− | otherwise -> return (rank desc)

84+ | otherwise -> return (rank descriptor)

8585

8686 where

8787 adjust = adjustRank youngMark visitedMark groupRank

@@ -132,7 +132,7 @@ solve (A.A region constraint) =

132132 case Map.lookup name env of

133133 Just tipe -> TS.makeInstance tipe

134134 Nothing

135− | List.isPrefixOf "Native." name -> liftIO (var Flexible)

135+ | List.isPrefixOf "Native." name -> liftIO (variable Flexible)

136136 | otherwise ->

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

138138

compiler/Type/Type.hs+24−16

@@ -9,8 +9,8 @@ import Type.PrettyPrint

99import Text.PrettyPrint as P

1010import System.IO.Unsafe

1111import Control.Applicative ((<$>),(<*>))

12−import Control.Monad.State

13−import Control.Monad.Error

12+import Control.Monad.State (StateT, get, put, execStateT, runStateT)

13+import Control.Monad.Error (ErrorT, Error, liftIO)

1414import Data.Traversable (traverse)

1515import AST.Annotation

1616import qualified AST.PrettyPrint as PP

@@ -65,6 +65,7 @@ data Scheme a b = Scheme {

6565type TypeConstraint = Constraint Type Variable

6666type TypeScheme = Scheme Type Variable

6767

68+monoscheme :: Map.Map String a -> Scheme a b

6869monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

6970

7071infixl 8 /\

@@ -80,6 +81,7 @@ infixr 9 ==>

8081(==>) :: Type -> Type -> Type

8182a ==> b = termN (Fun1 a b)

8283

84+(<|) :: TermN a -> TermN a -> TermN a

8385f <| a = termN (App1 f a)

8486

8587data Descriptor = Descriptor

@@ -92,10 +94,16 @@ data Descriptor = Descriptor

9294 , alias :: Maybe Var.Canonical

9395 } deriving Show

9496

97+noRank :: Int

9598noRank = -1

96−outermostRank = 0 :: Int

9799

100+outermostRank :: Int

101+outermostRank = 0

102+

103+noMark :: Int

98104noMark = 0

105+

106+initialMark :: Int

99107initialMark = 1

100108

101109data Flex = Rigid | Flexible | Constant | Is SuperType

@@ -115,8 +123,8 @@ namedVar flex name = UF.fresh $ Descriptor

115123 , alias = Nothing

116124 }

117125

118−var :: Flex -> IO Variable

119−var flex = UF.fresh $ Descriptor

126+variable :: Flex -> IO Variable

127+variable flex = UF.fresh $ Descriptor

120128 { structure = Nothing

121129 , rank = noRank

122130 , flex = flex

@@ -139,12 +147,12 @@ fl rqs constraint@(A ann _) =

139147

140148exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

141149exists f = do

142− v <- liftIO $ var Flexible

150+ v <- liftIO $ variable Flexible

143151 ex [v] <$> f (varN v)

144152

145153existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

146154existsNumber f = do

147− v <- liftIO $ var (Is Number)

155+ v <- liftIO $ variable (Is Number)

148156 ex [v] <$> f (varN v)

149157

150158

@@ -278,7 +286,7 @@ addNames value = do

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

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

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

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

289+ allVars = concatMap suffix $ ["","'","_"] ++ map show [ (0 :: Int) .. ]

282290 okayVars = filter (`notElem` vars) allVars

283291 runStateT (crawl rename value) (okayVars, 0, 0, 0)

284292 return value

@@ -366,21 +374,21 @@ instance Crawl Descriptor where

366374

367375

368376toSrcType :: Variable -> IO T.CanonicalType

369−toSrcType variable =

370− do desc <- UF.descriptor =<< addNames variable

377+toSrcType var =

378+ do desc <- UF.descriptor =<< addNames var

371379 srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)

372380 return $ maybe srcType (\name -> T.Aliased name srcType) (alias desc)

373381 where

374382 backupSrcType desc =

375383 case name desc of

376− Just var@(Var.Canonical _ x@(c:_))

384+ Just v@(Var.Canonical _ x@(c:_))

377385 | Char.isLower c -> return (T.Var x)

378− | otherwise -> return $ T.Type var

386+ | otherwise -> return $ T.Type v

379387

380388 _ -> error $ concat

381389 [ "Problem converting the following type "

382390 , "from a type-checker type to a source-syntax type:"

383− , P.render (pretty Never variable) ]

391+ , P.render (pretty Never var) ]

384392

385393 termToSrcType term =

386394 case term of

@@ -410,10 +418,10 @@ toSrcType variable =

410418data AppStructure = List Variable | Tuple [Variable] | Other

411419

412420collectApps :: Variable -> IO AppStructure

413−collectApps variable = go [] variable

421+collectApps var = go [] var

414422 where

415− go vars variable = do

416− desc <- UF.descriptor variable

423+ go vars var = do

424+ desc <- UF.descriptor var

417425 case (structure desc, vars) of

418426 (Nothing, [v]) -> case name desc of

419427 Just n | Var.isList n -> return (List v)

compiler/Type/Unify.hs+5−5

@@ -122,13 +122,13 @@ actuallyUnify region variable1 variable2 = do

122122 case struct of

123123 Other -> comparableError Nothing

124124 List v -> do flexAndUnify varSuper

125− unify' v =<< liftIO (var $ Is Comparable)

125+ unify' v =<< liftIO (variable $ Is Comparable)

126126 Tuple vs

127127 | length vs > 6 ->

128128 comparableError $ Just "Cannot compare a tuple with more than 6 elements."

129129 | otherwise ->

130130 do flexAndUnify varSuper

131− cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)

131+ cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)

132132 zipWithM_ unify' vs cmpVars

133133

134134 unifyAppendable varSuper varFlex =

@@ -137,10 +137,10 @@ actuallyUnify region variable1 variable2 = do

137137 List _ -> flexAndUnify varSuper

138138 _ -> appendableError Nothing

139139

140− rigidError variable = TS.addError region (Just hint) variable1 variable2

140+ rigidError var = TS.addError region (Just hint) variable1 variable2

141141 where

142− v = "'" ++ render (pretty Never variable) ++ "'"

143− hint = "Cannot unify rigid type variable " ++ v ++

142+ var' = "'" ++ render (pretty Never var) ++ "'"

143+ hint = "Cannot unify rigid type variable " ++ var' ++

144144 ".\nThe problem probably relates to a type annotation. Note that rigid type\n\

145145 \variables are not shared between a top-level and let-bound type annotations."

146146