b1f53d0 · elk · git.iko.soy

git.iko.soy/elk

Pipe source locations through the type checker

commitb1f53d04edb53b3cd9db21f68994824ca556d119 authorEvan Czaplicki <info@elm-lang.org> dateTue 30 Jul 2013, 16:01 (13 years ago) parentc6868f1

7 files changed+77−52

compare with master

unifiedsplit

compiler/Type/Constrain/Expression.hs+25−19 compiler/Type/Constrain/Literal.hs+15−9 compiler/Type/Constrain/Pattern.hs+6−1 compiler/Type/Fragment.hs+2−1 compiler/Type/Inference.hs+2−1 compiler/Type/Solve.hs+3−2 compiler/Type/Type.hs+24−19

compiler/Type/Constrain/Expression.hs+25−19

@@ -22,10 +22,16 @@ import qualified Transform.SortDefinitions as SD

2222

2323

2424constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint

25−constrain env (L _ expr) tipe =

26− let list t = Env.get env Env.types "_List" <| t in

25+constrain env (L span expr) tipe =

26+ let list t = Env.get env Env.types "_List" <| t

27+ and = L span . CAnd

28+ true = L span CTrue

29+ t1 === t2 = L span (CEqual t1 t2)

30+ x <? t = L span (CInstance x t)

31+ clet schemes c = L span (CLet schemes c)

32+ in

2733 case expr of

28− Literal lit -> Literal.constrain env lit tipe

34+ Literal lit -> Literal.constrain env span lit tipe

2935

3036 Var name -> return (name <? tipe)

3137

@@ -33,26 +39,26 @@ constrain env (L _ expr) tipe =

3339 exists $ \x -> do

3440 clo <- constrain env lo x

3541 chi <- constrain env hi x

36− return $ CAnd [clo, chi, list x === tipe]

42+ return $ and [clo, chi, list x === tipe]

3743

3844 ExplicitList exprs ->

3945 exists $ \x -> do

4046 cs <- mapM (\e -> constrain env e x) exprs

41− return $ CAnd (list x === tipe : cs)

47+ return . and $ list x === tipe : cs

4248

4349 Binop op e1 e2 ->

4450 exists $ \t1 ->

4551 exists $ \t2 -> do

4652 c1 <- constrain env e1 t1

4753 c2 <- constrain env e2 t2

48− return $ CAnd [ c1, c2, op <? (t1 ==> t2 ==> tipe) ]

54+ return $ and [ c1, c2, op <? (t1 ==> t2 ==> tipe) ]

4955

5056 Lambda p e ->

5157 exists $ \t1 ->

5258 exists $ \t2 -> do

5359 fragment <- Pattern.constrain env p t1

5460 c2 <- constrain env e t2

55− let c = ex (vars fragment) (CLet [monoscheme (typeEnv fragment)]

61+ let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]

5662 (typeConstraint fragment /\ c2 ))

5763 return $ c /\ tipe === (t1 ==> t2)

5864

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

6268 c2 <- constrain env e2 t

6369 return $ c1 /\ c2

6470

65− MultiIf branches -> CAnd <$> mapM constrain' branches

71+ MultiIf branches -> and <$> mapM constrain' branches

6672 where

6773 bool = Env.get env Env.types "Bool"

6874 constrain' (b,e) = do

@@ -75,12 +81,12 @@ constrain env (L _ expr) tipe =

7581 ce <- constrain env exp t

7682 let branch (p,e) = do

7783 fragment <- Pattern.constrain env p t

78− CLet [toScheme fragment] <$> constrain env e tipe

79− CAnd . (:) ce <$> mapM branch branches

84+ clet [toScheme fragment] <$> constrain env e tipe

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

8086

8187 Data name exprs ->

8288 do pairs <- mapM pair exprs

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

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

8490 return (cs /\ name <? ctipe)

8591 where

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

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

104110 cVal <- constrain env value tVal

105111 cRec <- constrain env e tRec

106112 let c = tipe === record (Map.singleton label [tVal]) tRec

107− return (CAnd [cVal, cRec, c])

113+ return (and [cVal, cRec, c])

108114

109115 Modify e fields ->

110116 exists $ \t -> do

@@ -118,28 +124,28 @@ constrain env (L _ expr) tipe =

118124

119125 cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)

120126

121− return $ cOld /\ ex newVars (CAnd (cNew : cs))

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

122128

123129 Record fields ->

124130 do vars <- forM fields $ \_ -> var Flexible

125131 cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)

126132 let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))

127133 recordType = record fields' (TermN EmptyRecord1)

128− return . ex vars $ CAnd (tipe === recordType : cs)

134+ return . ex vars . and $ tipe === recordType : cs

129135

130136 Markdown _ ->

131137 return $ tipe === Env.get env Env.types "Element"

132138

133139 Let defs body ->

134140 do c <- case body of

135− L _ (Var name) | name == saveEnvName -> return CSaveEnv

141+ L _ (Var name) | name == saveEnvName -> return (L span CSaveEnv)

136142 _ -> constrain env body tipe

137143 (schemes, rqs, fqs, header, c2, c1) <-

138144 Monad.foldM (constrainDef env)

139− ([], [], [], Map.empty, CTrue, CTrue)

145+ ([], [], [], Map.empty, true, true)

140146 (collapseDefs defs)

141− return $ CLet schemes

142− (CLet [Scheme rqs fqs (CLet [monoscheme header] c2) header ]

147+ return $ clet schemes

148+ (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

143149 (c1 /\ c))

144150

145151constrainDef env info (pattern, expr, maybeTipe) =

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

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

155161 let scheme = Scheme { rigidQuantifiers = [],

156162 flexibleQuantifiers = flexiVars ++ vars,

157− constraint = CTrue,

163+ constraint = Loc.none CTrue,

158164 header = Map.singleton name typ }

159165 c <- constrain env' expr typ

160166 return ( scheme : schemes

compiler/Type/Constrain/Literal.hs+15−9

@@ -4,16 +4,22 @@ import Data.Map ((!))

44import qualified Data.Map as Map

66import SourceSyntax.Literal

7+import SourceSyntax.Location

78import Type.Type

89import Type.Fragment

910import Type.Environment as Env

1011

11−constrain :: Environment -> Literal -> Type -> IO TypeConstraint

12−constrain 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) (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"))

19− Boolean _ -> return $ tipe === prim "Bool"

12+constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint

13+constrain env span literal tipe =

14+ do tipe' <- litType

15+ return . L span $ CEqual tipe tipe'

16+ where

17+ prim name = Env.get env Env.types name

18+

19+ litType =

20+ case literal of

21+ IntNum _ -> VarN `fmap` var (Is Number)

22+ FloatNum _ -> return (prim "Float")

23+ Chr _ -> return (prim "Char")

24+ Str _ -> return (TermN (App1 (prim "_List") (prim "Char")))

25+ Boolean _ -> return (prim "Bool")

compiler/Type/Constrain/Pattern.hs+6−1

@@ -9,6 +9,7 @@ import Data.Map ((!))

99import qualified Data.Map as Map

1010

1111import SourceSyntax.Pattern

12+import qualified SourceSyntax.Location as Loc

1213import Type.Type

1314import Type.Fragment

1415import Type.Environment as Env

@@ -17,11 +18,15 @@ import qualified Type.Constrain.Literal as Literal

1718

1819constrain :: Environment -> Pattern -> Type -> IO Fragment

1920constrain env pattern tipe =

21+ let span = Loc.NoSpan

22+ t1 === t2 = Loc.L span (CEqual t1 t2)

23+ x <? t = Loc.L span (CInstance x t)

24+ in

2025 case pattern of

2126 PAnything -> return emptyFragment

2227

2328 PLiteral lit -> do

24− c <- Literal.constrain env lit tipe

29+ c <- Literal.constrain env span lit tipe

2530 return $ emptyFragment { typeConstraint = c }

2631

2732 PVar name -> do

compiler/Type/Fragment.hs+2−1

@@ -5,6 +5,7 @@ import qualified Data.Map as Map

66import Type.Type

77import SourceSyntax.Pattern

8+import SourceSyntax.Location (none)

910data Fragment = Fragment {

1011 typeEnv :: Map.Map String Type,

@@ -12,7 +13,7 @@ data Fragment = Fragment {

1213 typeConstraint :: TypeConstraint

1314} deriving Show

1415

15−emptyFragment = Fragment Map.empty [] CTrue

16+emptyFragment = Fragment Map.empty [] (none CTrue)

1617

1718joinFragment f1 f2 = Fragment {

1819 typeEnv = Map.union (typeEnv f1) (typeEnv f2),

compiler/Type/Inference.hs+2−1

@@ -10,6 +10,7 @@ import qualified Type.Solve as Solve

1010

1111import SourceSyntax.Module as Module

1212import qualified SourceSyntax.Expression as Expr

13+import SourceSyntax.Location (none)

1314import SourceSyntax.PrettyPrint

1415import Text.PrettyPrint

1516import qualified Type.State as TS

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

3738 let allTypes = ctors ++ importedVars

3839 vars = concatMap (fst . snd) allTypes

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

40− environ = T.CLet [ T.Scheme vars [] T.CTrue header ]

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

4142

4243 fvar <- T.var T.Flexible

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

compiler/Type/Solve.hs+3−2

@@ -13,6 +13,7 @@ import Type.Unify

1313import qualified Type.Environment as Env

1414import qualified Type.State as TS

1515import qualified Text.PrettyPrint as P

16+import SourceSyntax.Location (Located(L))

1617

1718

1819-- | Every variable has rank less than or equal to the maxRank of the pool.

@@ -92,7 +93,7 @@ adjustRank youngMark visitedMark groupRank variable =

9293

9394

9495solve :: TypeConstraint -> StateT TS.SolverState IO ()

95−solve constraint =

96+solve (L span constraint) =

9697 case constraint of

9798 CTrue -> return ()

9899

@@ -105,7 +106,7 @@ solve constraint =

105106

106107 CAnd cs -> mapM_ solve cs

107108

108− CLet [Scheme [] fqs constraint' _] CTrue -> do

109+ CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do

109110 oldEnv <- TS.getEnv

110111 mapM TS.introduce fqs

111112 solve constraint'

compiler/Type/Type.hs+24−19

@@ -10,6 +10,7 @@ import System.IO.Unsafe

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

1111import Control.Monad.State

1212import Data.Traversable (traverse)

13+import SourceSyntax.Location

1314import SourceSyntax.Helpers (isTuple)

1415import qualified SourceSyntax.Type as Src

1516

@@ -35,7 +36,8 @@ type Variable = UF.Point Descriptor

3536type SchemeName = String

3637type TypeName = String

3738

38−data Constraint a b

39+type Constraint a b = Located (BasicConstraint a b)

40+data BasicConstraint a b

3941 = CTrue

4042 | CSaveEnv

4143 | CEqual a a

@@ -54,20 +56,16 @@ data Scheme a b = Scheme {

5456type TypeConstraint = Constraint Type Variable

5557type TypeScheme = Scheme Type Variable

5658

57−monoscheme headers = Scheme [] [] CTrue headers

59+monoscheme headers = Scheme [] [] (none CTrue) headers

5860

5961infixl 8 /\

6062

6163(/\) :: Constraint a b -> Constraint a b -> Constraint a b

62−a /\ CTrue = a

63−CTrue /\ b = b

64−a /\ b = CAnd [a,b]

65−

66−(===) :: Type -> Type -> TypeConstraint

67−(===) = CEqual

68−

69−(<?) :: SchemeName -> Type -> TypeConstraint

70−x <? t = CInstance x t

64+a@(L s1 c1) /\ b@(L s2 c2) =

65+ case (c1, c2) of

66+ (CTrue, _) -> b

67+ (_, CTrue) -> a

68+ _ -> merge a b (CAnd [a,b])

7169

7270infixr 9 ==>

7371(==>) :: Type -> Type -> Type

@@ -126,11 +124,11 @@ structuredVar structure = UF.fresh $ Descriptor {

126124

127125-- ex qs constraint == exists qs. constraint

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

129−ex fqs constraint = CLet [Scheme [] fqs constraint Map.empty] CTrue

127+ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s CTrue)

130128

131129-- fl qs constraint == forall qs. constraint

132130fl :: [Variable] -> TypeConstraint -> TypeConstraint

133−fl rqs constraint = CLet [Scheme rqs [] constraint Map.empty] CTrue

131+fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)

134132

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

136134exists f = do

@@ -146,6 +144,10 @@ instance PrettyType a => PrettyType (UF.Point a) where

146144 pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)

147145

148146

147+instance PrettyType a => PrettyType (Located a) where

148+ pretty when (L _ e) = pretty when e

149+

150+

149151instance PrettyType a => PrettyType (Term1 a) where

150152 pretty when term =

151153 let prty = pretty Never in

@@ -194,7 +196,7 @@ instance PrettyType Descriptor where

194196 _ -> P.text "?"

195197

196198

197−instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where

199+instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where

198200 pretty _ constraint =

199201 let prty = pretty Never in

200202 case constraint of

@@ -206,12 +208,12 @@ instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where

206208 CAnd cs ->

207209 P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)

208210

209− CLet [Scheme [] fqs constraint header] CTrue | Map.null header ->

211+ CLet [Scheme [] fqs constraint header] (L _ CTrue) | Map.null header ->

210212 P.sep [ binder, pretty Never c ]

211213 where

212− mergeExists vs c =

214+ mergeExists vs (L _ c) =

213215 case c of

214− CLet [Scheme [] fqs' c' _] CTrue -> mergeExists (vs ++ fqs') c'

216+ CLet [Scheme [] fqs' c' _] (L _ CTrue) -> mergeExists (vs ++ fqs') c'

215217 _ -> (vs, c)

216218

217219 (fqs', c) = mergeExists fqs constraint

@@ -227,7 +229,7 @@ instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where

227229 P.text name <+> P.text "<" <+> prty tipe

228230

229231instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where

230− pretty _ (Scheme rqs fqs constraint headers) =

232+ pretty _ (Scheme rqs fqs (L _ constraint) headers) =

231233 P.sep [ forall, cs, headers' ]

232234 where

233235 prty = pretty Never

@@ -287,7 +289,10 @@ class Crawl t where

287289 -> t

288290 -> StateT CrawlState IO t

289291

290−instance (Crawl t, Crawl v) => Crawl (Constraint t v) where

292+instance Crawl a => Crawl (Located a) where

293+ crawl nextState (L s e) = L s <$> crawl nextState e

294+

295+instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where

291296 crawl nextState constraint =

292297 let rnm = crawl nextState in

293298 case constraint of