a12554f · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

cosmetic: try to make -Wall happier

a12554fEvan Czaplicki12 years ago

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

compare with master

unifiedsplit

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

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

107

108 Data name exprs ->

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

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

110 let pairs = zip exprs (map varN vars)

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

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

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

133

134 Modify e fields ->

135 exists $ \t -> do

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

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

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

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

139

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

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

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

142 let cNew = tipe === record newFields t

143

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

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

147

148 Record fields ->

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

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

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

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

152 recordType = record fields' (termN EmptyRecord1)

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

154

155 Markdown _ _ es ->

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

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

157 let tvars = map varN vars

158 cs <- zipWithM (constrain env) es tvars

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

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

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

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

179 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.

181 -- Currently, qs is always [].

182 case (pattern, maybeTipe) of

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

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

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

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

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

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

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

198 , fl rigidVars c /\ c1 )

199

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

201− v <- liftIO $ var Flexible

201+ v <- liftIO $ variable Flexible

202 let tipe = varN v

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

204 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 =

16 litType =

17 case literal of

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

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

19 FloatNum _ -> prim "Float"

20 Chr _ -> prim "Char"

21 Str _ -> prim "String"

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

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

34 return $ emptyFragment { typeConstraint = c }

36 P.Var name -> do

37− v <- liftIO $ var Flexible

37+ v <- liftIO $ variable Flexible

38 return $ Fragment {

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

40 vars = [v],

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

65 }

67 P.Record fields -> do

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

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

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

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

71 return $ Fragment {

compiler/Type/Environment.hs+1−1

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

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

73 inst numTVars tipe = do

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

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

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

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

compiler/Type/Inference.hs+1−1

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

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

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

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

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

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

45 return (header, environ c)

compiler/Type/Solve.hs+13−13

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

21 youngMark <- TS.uniqueMark

22 let youngRank = TS.maxRank youngPool

23 insert dict var = do

24− desc <- liftIO $ UF.descriptor var

24+ descriptor <- liftIO $ UF.descriptor var

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

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

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

28 -- Sort the youngPool variables by rank.

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

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

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

65-- move deeper into a variable.

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

67−adjustRank youngMark visitedMark groupRank variable =

67+adjustRank youngMark visitedMark groupRank var =

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

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

69 case () of

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

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

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

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

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

73 desc { mark = visitedMark }

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

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

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

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

76 desc { rank = rank' }

77 return rank'

79− | mark desc /= visitedMark ->

79+ | mark descriptor /= visitedMark ->

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

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

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

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

82 return rank'

84− | otherwise -> return (rank desc)

84+ | otherwise -> return (rank descriptor)

86 where

87 adjust = adjustRank youngMark visitedMark groupRank

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

132 case Map.lookup name env of

133 Just tipe -> TS.makeInstance tipe

134 Nothing

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

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

136 | otherwise ->

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

138

compiler/Type/Type.hs+24−16

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

9import Text.PrettyPrint as P

10import System.IO.Unsafe

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

12−import Control.Monad.State

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

13−import Control.Monad.Error

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

14import Data.Traversable (traverse)

15import AST.Annotation

16import qualified AST.PrettyPrint as PP

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

65type TypeConstraint = Constraint Type Variable

66type TypeScheme = Scheme Type Variable

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

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

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

70infixl 8 /\

71infixl 8 /\

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

80(==>) :: Type -> Type -> Type

81(==>) :: Type -> Type -> Type

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

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

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

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

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

85data Descriptor = Descriptor

87data Descriptor = Descriptor

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

92 , alias :: Maybe Var.Canonical

94 , alias :: Maybe Var.Canonical

93 } deriving Show

95 } deriving Show

97+noRank :: Int

95noRank = -1

98noRank = -1

96−outermostRank = 0 :: Int

100+outermostRank :: Int

101+outermostRank = 0

102+

103+noMark :: Int

98noMark = 0

104noMark = 0

105+

106+initialMark :: Int

99initialMark = 1

107initialMark = 1

100

108

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

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

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

115 , alias = Nothing

123 , alias = Nothing

116 }

124 }

117

125

118−var :: Flex -> IO Variable

126+variable :: Flex -> IO Variable

119−var flex = UF.fresh $ Descriptor

127+variable flex = UF.fresh $ Descriptor

120 { structure = Nothing

128 { structure = Nothing

121 , rank = noRank

129 , rank = noRank

122 , flex = flex

130 , flex = flex

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

139

147

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

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

141exists f = do

149exists f = do

142− v <- liftIO $ var Flexible

150+ v <- liftIO $ variable Flexible

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

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

144

152

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

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

146existsNumber f = do

154existsNumber f = do

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

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

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

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

149

157

150

158

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

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

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

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

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

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

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

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

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

282 okayVars = filter (`notElem` vars) allVars

290 okayVars = filter (`notElem` vars) allVars

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

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

284 return value

292 return value

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

366

374

367

375

368toSrcType :: Variable -> IO T.CanonicalType

376toSrcType :: Variable -> IO T.CanonicalType

369−toSrcType variable =

377+toSrcType var =

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

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

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

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

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

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

373 where

381 where

374 backupSrcType desc =

382 backupSrcType desc =

375 case name desc of

383 case name desc of

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

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

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

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

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

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

379

387

380 _ -> error $ concat

388 _ -> error $ concat

381 [ "Problem converting the following type "

389 [ "Problem converting the following type "

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

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

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

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

384

392

385 termToSrcType term =

393 termToSrcType term =

386 case term of

394 case term of

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

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

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

411

419

412collectApps :: Variable -> IO AppStructure

420collectApps :: Variable -> IO AppStructure

413−collectApps variable = go [] variable

421+collectApps var = go [] var

414 where

422 where

415− go vars variable = do

423+ go vars var = do

416− desc <- UF.descriptor variable

424+ desc <- UF.descriptor var

417 case (structure desc, vars) of

425 case (structure desc, vars) of

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

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

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

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

compiler/Type/Unify.hs+5−5

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

122 case struct of

123 Other -> comparableError Nothing

124 List v -> do flexAndUnify varSuper

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

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

126 Tuple vs

127 | length vs > 6 ->

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

129 | otherwise ->

130 do flexAndUnify varSuper

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

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

132 zipWithM_ unify' vs cmpVars

133

134 unifyAppendable varSuper varFlex =

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

137 List _ -> flexAndUnify varSuper

138 _ -> appendableError Nothing

139

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

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

141 where

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

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

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

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

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

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

146