6b28fea · elk · git.iko.soy

git.iko.soy/elk

Switch name of Context to Located. Whoo static types :)

commit6b28feaa2bbaaea630beb4fdbb3f282063da51b3 authorevancz <info@elm-lang.org> dateWed 29 May 2013, 16:20 (13 years ago) parent5e7a34f

18 files changed+187−188

compare with master

unifiedsplit

Elm.cabal+3−3 compiler/Gen/Cases.hs+7−7 compiler/Gen/CompileToJS.hs+9−9 compiler/Gen/ExtractNoscript.hs+9−10 compiler/Model/Ast.hs+10−10 compiler/Model/Context.hs → compiler/Model/Located.hs+9−9 compiler/Parse/Binops.hs+1−1 compiler/Parse/Expr.hs+18−18 compiler/Parse/Library.hs+4−4 compiler/Parse/Patterns.hs+15−15 compiler/Parse/Types.hs+4−4 compiler/Transform/Optimize.hs+27−27 compiler/Transform/Rename.hs+3−3 compiler/Transform/Substitute.hs+2−2 compiler/Types/Constrain.hs+40−40 compiler/Types/Solver.hs+17−17 compiler/Types/Substitutions.hs+7−7 compiler/Types/Types.hs+2−2

Elm.cabal+3−3

@@ -34,7 +34,7 @@ Library

3434 Language.Elm.Quasi

3535 Hs-Source-Dirs: compiler, compiler/Gen, compiler/Model, compiler/Transform

3636 other-modules: Ast,

37− Context,

37+ Located,

3838 CompileToJS,

3939 Cases,

4040 Substitute,

@@ -88,7 +88,7 @@ Executable elm

8888 extensions: CPP

8989 cpp-options: -DELM_COMPILEDATADIR="dist/data"

9090 other-modules: Ast,

91− Context,

91+ Located,

9292 CompileToJS,

9393 Cases,

9494 Substitute,

@@ -138,7 +138,7 @@ Executable elm-doc

138138 Main-is: Docs.hs

139139 Hs-Source-Dirs: compiler, compiler/Model, compiler/Transform

140140 other-modules: Ast,

141− Context,

141+ Located,

142142 Parse.Library,

143143 Parse.Modules,

144144 Rename

compiler/Gen/Cases.hs+7−7

@@ -7,7 +7,7 @@ import Data.List (groupBy,sortBy,lookup)

77import Data.Maybe (fromMaybe)

99import Ast

10−import Context

10+import Located

1111import Guid

1212import Substitute

1313

@@ -32,8 +32,8 @@ matchSubst :: [(String,String)] -> Match -> Match

3232matchSubst _ Break = Break

3333matchSubst _ Fail = Fail

3434matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)

35−matchSubst pairs (Other (C t s e)) =

36− Other . C t s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs

35+matchSubst pairs (Other (L t s e)) =

36+ Other . L t s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs

3737matchSubst pairs (Match n cs m) =

3838 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

3939 where varSubst v = fromMaybe v (lookup v pairs)

@@ -58,13 +58,13 @@ match vs cs def

5858matchVar :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

5959matchVar (v:vs) cs def = match vs (map subVar cs) def

6060 where

61− subVar (p:ps, ce@(C t s e)) =

62− let ctx = C t s in

61+ subVar (p:ps, ce@(L t s e)) =

62+ let loc = L t s in

6363 (ps, case p of

64− PVar x -> C t s $ subst x (Var v) e

64+ PVar x -> L t s $ subst x (Var v) e

6565 PAnything -> ce

6666 PRecord fs ->

67− ctx $ foldr (\x -> subst x (Access (ctx (Var v)) x)) e fs

67+ loc $ foldr (\x -> subst x (Access (loc (Var v)) x)) e fs

6868 )

6969

7070matchCon :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

compiler/Gen/CompileToJS.hs+9−9

@@ -9,7 +9,7 @@ import Data.Either (partitionEithers)

99import qualified Text.Pandoc as Pan

1010

1111import Ast

12−import Context

12+import Located

1313import Rename (derename)

1414import Cases

1515import Guid

@@ -156,8 +156,8 @@ instance ToJS Statement where

156156 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs

157157 where toDef (name,args) =

158158 let vars = map (('a':) . show) [1..length args] in

159− Definition . FnDef name vars . noContext $

160− Data (derename name) (map (noContext . Var) vars)

159+ Definition . FnDef name vars . notLocated $

160+ Data (derename name) (map (notLocated . Var) vars)

161161 ImportEvent js base elm _ ->

162162 do v <- toJS' base

163163 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"

@@ -174,7 +174,7 @@ instance ToJS Statement where

174174 TypeAlias n _ t -> return ""

175175

176176toJS' :: CExpr -> GuidCounter String

177−toJS' (C txt span expr) =

177+toJS' (L txt span expr) =

178178 case expr of

179179 MultiIf ps -> multiIfToJS span ps

180180 Case e cases -> caseToJS span e cases

@@ -189,8 +189,8 @@ makeRecord kvs = record `liftM` collect kvs

189189 where

190190 combine r (k,v) = Map.insertWith (++) k v r

191191 collect = liftM (foldl' combine Map.empty) . mapM prep

192− prep (k, as, e@(C t s _)) =

193− do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)

192+ prep (k, as, e@(L t s _)) =

193+ do v <- toJS' (foldr (\x e -> L t s $ Lambda x e) e as)

194194 return (k,[v])

195195 fields fs =

196196 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))

@@ -246,7 +246,7 @@ jsApp e1 e2 =

246246 (func, args) = go [e2] e1

247247 go args e =

248248 case e of

249− (C _ _ (App e1 e2)) -> go (e2 : args) e1

249+ (L _ _ (App e1 e2)) -> go (e2 : args) e1

250250 _ -> (e, args)

251251

252252formatMarkdown = concatMap f

@@ -257,7 +257,7 @@ formatMarkdown = concatMap f

257257

258258multiIfToJS span ps =

259259 case last ps of

260− (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)

260+ (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)

261261 _ -> format ("_E.If" ++ parens (quoted (show span))) ps

262262 where

263263 format base ps =

@@ -280,7 +280,7 @@ caseToJS span e ps = do

280280 match <- caseToMatch ps

281281 e' <- toJS' e

282282 let (match',stmt) = case (match,e) of

283− (Match name _ _, C _ _ (Var x)) -> (matchSubst [(name,x)] match, "")

283+ (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")

284284 (Match name _ _, _) -> (match, assign name e')

285285 _ -> (match, "")

286286 matches <- matchToJS span match'

compiler/Gen/ExtractNoscript.hs+9−10

@@ -1,8 +1,7 @@

1−

21module ExtractNoscript (extractNoscript) where

43import Ast

5−import Context

4+import Located

65import qualified Text.Pandoc as Pan

87extractNoscript :: Module -> String

@@ -23,8 +22,8 @@ instance Extract Def where

2322 extract (FnDef _ _ e) = extract e

2423 extract (OpDef _ _ _ e) = extract e

2524

26−instance Extract e => Extract (Context e) where

27− extract (C _ _ e) = extract e

25+instance Extract e => Extract (Located e) where

26+ extract (L _ _ e) = extract e

2827

2928instance Extract Expr where

3029 extract expr =

@@ -35,12 +34,12 @@ instance Extract Expr where

3534 ("++", [s1], [s2]) -> [s1 ++ s2]

3635 (_ , ss1 , ss2 ) -> ss1 ++ ss2

3736 Lambda v e -> f e

38− App (C _ _ (App (C _ _ (Var "link")) src)) txt -> linkExtract src txt

39− App (C _ _ (App (C _ _ (Var "Text.link")) src)) txt -> linkExtract src txt

40− App (C _ _ (Var "header")) e -> tag "h1" e

41− App (C _ _ (Var "bold")) e -> tag "b" e

42− App (C _ _ (Var "italic")) e -> tag "i" e

43− App (C _ _ (Var "monospace")) e -> tag "code" e

37+ App (L _ _ (App (L _ _ (Var "link")) src)) txt -> linkExtract src txt

38+ App (L _ _ (App (L _ _ (Var "Text.link")) src)) txt -> linkExtract src txt

39+ App (L _ _ (Var "header")) e -> tag "h1" e

40+ App (L _ _ (Var "bold")) e -> tag "b" e

41+ App (L _ _ (Var "italic")) e -> tag "i" e

42+ App (L _ _ (Var "monospace")) e -> tag "code" e

4443 App e1 e2 -> f e1 ++ f e2

4544 If eb et ef -> f et ++ f ef

4645 Let defs e -> concatMap extract defs ++ f e

compiler/Model/Ast.hs+10−10

@@ -1,7 +1,7 @@

22module Ast where

4−import Context

4+import Located

55import Data.Char (isDigit, isSymbol)

66import Data.List (intercalate)

77import Types.Types

@@ -22,7 +22,7 @@ data Pattern = PData String [Pattern]

2222 | PAnything

2323 deriving (Eq)

2424

25−type CExpr = Context Expr

25+type CExpr = Located Expr

2626data Expr = IntNum Int

2727 | FloatNum Float

2828 | Chr Char

@@ -59,11 +59,11 @@ data Statement = Definition Def

5959 deriving (Eq,Show)

6060

6161cons h t = epos h t (Data "Cons" [h,t])

62−nil = C (Just "[]") NoSpan (Data "Nil" [])

62+nil = L (Just "[]") NoSpan (Data "Nil" [])

6363list = foldr cons nil

6464tuple es = Data ("Tuple" ++ show (length es)) es

6565

66−delist (C _ _ (Data "Cons" [h,t])) = h : delist t

66+delist (L _ _ (Data "Cons" [h,t])) = h : delist t

6767delist _ = []

6868

6969

@@ -93,7 +93,7 @@ instance Show Pattern where

9393

9494instance Show Expr where

9595 show e =

96− let show' (C _ _ e) = parensIf (needsParens e) (show e) in

96+ let show' (L _ _ e) = parensIf (needsParens e) (show e) in

9797 case e of

9898 IntNum n -> show n

9999 FloatNum n -> show n

@@ -103,7 +103,7 @@ instance Show Expr where

103103 Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"

104104 Access e x -> show' e ++ "." ++ x

105105 Remove e x -> brkt (show e ++ " - " ++ x)

106− Insert (C _ _ (Remove e y)) x v ->

106+ Insert (L _ _ (Remove e y)) x v ->

107107 brkt (show e ++ " - " ++ y ++ " | " ++ x ++ " = " ++ show v)

108108 Insert e x v -> brkt (show e ++ " | " ++ x ++ " = " ++ show v)

109109 Modify e fs -> brkt (show e ++" | "++ intercalate ", " (map field fs))

@@ -111,7 +111,7 @@ instance Show Expr where

111111 Record r -> brkt (intercalate ", " (map fields r))

112112 where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e

113113 Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2

114− Lambda x e -> let (xs,e') = getLambdas (noContext $ Lambda x e) in

114+ Lambda x e -> let (xs,e') = getLambdas (notLocated $ Lambda x e) in

115115 concat [ "\\", intercalate " " xs, " -> ", show e' ]

116116 App e1 e2 -> show' e1 ++ " " ++ show' e2

117117 If e1 e2 e3 -> concat [ "if ", show e1, " then ", show e2, " else ", show e3 ]

@@ -124,7 +124,7 @@ instance Show Expr where

124124 where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats

125125 Data name es

126126 | name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $

127− delist (noContext $ Data "Cons" es)

127+ delist (notLocated $ Data "Cons" es)

128128 | name == "Nil" -> "[]"

129129 | otherwise -> name ++ " " ++ intercalate " " (map show' es)

130130 Markdown _ -> "[markdown| ... |]"

@@ -134,10 +134,10 @@ instance Show Def where

134134 show e =

135135 case e of

136136 FnDef v [] e -> v ++ " = " ++ show e

137− FnDef f args e -> f ++ " " ++ intercalate " " args ++ " = " ++ show e

137+ FnDef f args e -> f ++ concatMap (' ':) args ++ " = " ++ show e

138138 OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e

139139

140−getLambdas (C _ _ (Lambda x e)) = (x:xs,e')

140+getLambdas (L _ _ (Lambda x e)) = (x:xs,e')

141141 where (xs,e') = getLambdas e

142142getLambdas e = ([],e)

143143

compiler/Model/Context.hs → compiler/Model/Located.hsrenamed+9−9

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

2−module Context where

2+module Located where

44import Text.Parsec.Pos

@@ -10,7 +10,7 @@ data SrcPos = Pos Int Int

1010data SrcSpan = Span SrcPos SrcPos | NoSpan

1111 deriving (Eq,Ord)

1212

13−data Context e = C (Maybe String) SrcSpan e deriving (Eq,Ord)

13+data Located e = L (Maybe String) SrcSpan e deriving (Eq,Ord)

1414

1515

1616instance Show SrcPos where

@@ -22,22 +22,22 @@ instance Show SrcSpan where

2222 Span start end -> show start

2323 NoSpan -> ""

2424

25−instance Show e => Show (Context e) where

26− show (C _ _ e) = show e

25+instance Show e => Show (Located e) where

26+ show (L _ _ e) = show e

2727

2828

2929

30−noContext = C Nothing NoSpan

30+notLocated = L Nothing NoSpan

3131

32−pos start end = C Nothing

32+pos start end = L Nothing

3333 (Span (Pos (sourceLine start) (sourceColumn start))

3434 (Pos (sourceLine end ) (sourceColumn end )))

3535

36−epos (C _ s1 _) (C _ s2 _) = C Nothing span

36+epos (L _ s1 _) (L _ s2 _) = L Nothing span

3737 where span = case (s1,s2) of

3838 (Span start _, Span _ end) -> Span start end

3939 (_, NoSpan) -> s1

4040 (NoSpan, _) -> s2

4141

42−addCtx x (C Nothing span e) = C (Just (show x)) span e

43−addCtx x (C txt span e) = C txt span e

42+addLoc x (L Nothing span e) = L (Just (show x)) span e

43+addLoc x (L txt span e) = L txt span e

compiler/Parse/Binops.hs+1−1

@@ -1,7 +1,6 @@

11module Parse.Binops (binops) where

33import Ast

4−import Context

54import Control.Monad (liftM,guard)

65import Control.Monad.Error

76import Data.List (foldl',splitAt,elemIndices

@@ -9,6 +8,7 @@ import Data.List (foldl',splitAt,elemIndices

98import qualified Data.Map as Map

109import Data.Maybe (mapMaybe)

1110

11+import Located (epos)

1212import Text.Parsec

1313import Parse.Library

1414

compiler/Parse/Expr.hs+18−18

@@ -1,7 +1,7 @@

11module Parse.Expr (def,term) where

33import Ast

4−import Context

4+import Located

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

66import Control.Monad

77import Data.Char (isSymbol, isDigit)

@@ -51,8 +51,8 @@ accessor = do

5151 start <- getPosition

5252 lbl <- try (string "." >> rLabel)

5353 end <- getPosition

54− let ctx e = addCtx ("." ++ lbl) (pos start end e)

55− return (Lambda "_" (ctx $ Access (ctx $ Var "_") lbl))

54+ let loc e = addLoc ("." ++ lbl) (pos start end e)

55+ return (Lambda "_" (loc $ Access (loc $ Var "_") lbl))

5656

5757

5858-------- Complex Terms --------

@@ -65,7 +65,7 @@ listTerm =

6565 <|> (braces $ choice

6666 [ try $ do { lo <- expr; whitespace; string ".." ; whitespace

6767 ; Range lo <$> expr }

68− , do (C _ _ e) <- list <$> commaSep expr

68+ , do (L _ _ e) <- list <$> commaSep expr

6969 return e

7070 ])

7171

@@ -74,17 +74,17 @@ parensTerm = parens $ choice

7474 [ do start <- getPosition

7575 op <- try anyOp

7676 end <- getPosition

77− let ctxt = pos start end

78− return . ctxt . Lambda "x" . ctxt . Lambda "y" . ctxt $

79− Binop op (ctxt $ Var "x") (ctxt $ Var "y")

77+ let loc = pos start end

78+ return . loc . Lambda "x" . loc . Lambda "y" . loc $

79+ Binop op (loc $ Var "x") (loc $ Var "y")

8080 , do start <- getPosition

8181 let comma = char ',' <?> "comma ','"

8282 commas <- comma >> many (whitespace >> comma)

8383 end <- getPosition

8484 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]

85− ctxt = pos start end

86− return $ foldr (\x e -> ctxt $ Lambda x e)

87− (ctxt . tuple $ map (ctxt . Var) vars) vars

85+ loc = pos start end

86+ return $ foldr (\x e -> loc $ Lambda x e)

87+ (loc . tuple $ map (loc . Var) vars) vars

8888 , do start <- getPosition

8989 es <- commaSep expr

9090 end <- getPosition

@@ -93,7 +93,7 @@ parensTerm = parens $ choice

9393 ]

9494

9595recordTerm :: IParser CExpr

96−recordTerm = brackets $ choice [ misc, addContext record ]

96+recordTerm = brackets $ choice [ misc, addLocation record ]

9797 where field = do

9898 fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix patternTerm

9999 whitespace

@@ -107,15 +107,15 @@ recordTerm = brackets $ choice [ misc, addContext record ]

107107 lbl <- rLabel

108108 whitespace >> string "<-" >> whitespace

109109 (,) lbl <$> expr

110− remove r = addContext (string "-" >> whitespace >> Remove r <$> rLabel)

111− insert r = addContext $ do

110+ remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)

111+ insert r = addLocation $ do

112112 string "|" >> whitespace

113113 Insert r <$> rLabel <*>

114114 (whitespace >> string "=" >> whitespace >> expr)

115− modify r = addContext

115+ modify r = addLocation

116116 (string "|" >> whitespace >> Modify r <$> commaSep1 change)

117117 misc = try $ do

118− record <- addContext (Var <$> rLabel)

118+ record <- addLocation (Var <$> rLabel)

119119 whitespace

120120 opt <- optionMaybe (remove record)

121121 whitespace

@@ -125,8 +125,8 @@ recordTerm = brackets $ choice [ misc, addContext record ]

125125

126126

127127term :: IParser CExpr

128−term = addContext (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])

129− <|> accessible (addContext varTerm <|> parensTerm <|> recordTerm)

128+term = addLocation (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])

129+ <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

130130 <?> "basic term (4, x, 'c', etc.)"

131131

132132-------- Applications --------

@@ -182,7 +182,7 @@ caseExpr = do

182182 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

183183 without = block (do c <- case_ ; whitespace ; return c)

184184

185−expr = addContext (choice [ ifExpr, letExpr, caseExpr ])

185+expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

186186 <|> lambdaExpr

187187 <|> binaryExpr

188188 <?> "an expression"

compiler/Parse/Library.hs+4−4

@@ -2,7 +2,7 @@

22module Parse.Library where

44import Ast

5−import Context

5+import Located

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

77import Control.Monad

88import Control.Monad.State

@@ -124,8 +124,8 @@ parens = surround '(' ')' "paren"

124124brackets :: IParser a -> IParser a

125125brackets = surround '{' '}' "bracket"

126126

127−addContext :: IParser Expr -> IParser CExpr

128−addContext expr = do

127+addLocation :: IParser Expr -> IParser CExpr

128+addLocation expr = do

129129 start <- getPosition

130130 e <- expr

131131 end <- getPosition

@@ -134,7 +134,7 @@ addContext expr = do

134134accessible :: IParser CExpr -> IParser CExpr

135135accessible expr = do

136136 start <- getPosition

137− ce@(C s t e) <- expr

137+ ce@(L s t e) <- expr

138138 let rest f = do

139139 let dot = char '.' >> notFollowedBy (char '.')

140140 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")

compiler/Parse/Patterns.hs+15−15

@@ -2,7 +2,7 @@

22module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where

44import Ast

5−import Context

5+import Located

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

77import Control.Monad

88import Control.Monad.State

@@ -42,13 +42,13 @@ patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?>

4242makeLambda :: [Pattern] -> CExpr -> GuidCounter CExpr

4343makeLambda pats body = go (reverse pats) body

4444 where go [] body = return body

45− go (p:ps) body@(C t s _) = do

45+ go (p:ps) body@(L t s _) = do

4646 (x,e) <- extract p body

47− go ps (C t s $ Lambda x e)

47+ go ps (L t s $ Lambda x e)

4848

4949extract :: Pattern -> CExpr -> GuidCounter (String, CExpr)

50−extract pattern body@(C t s _) =

51− let ctx = C t s in

50+extract pattern body@(L t s _) =

51+ let loc = L t s in

5252 let fn x e = (x,e) in

5353 case pattern of

5454 PAnything -> return $ fn "_" body

@@ -56,12 +56,12 @@ extract pattern body@(C t s _) =

5656 PData name ps -> do

5757 x <- guid

5858 let a = '_' : show x

59− return . fn a . ctx $ Case (ctx (Var a)) [(pattern, body)]

59+ return . fn a . loc $ Case (loc (Var a)) [(pattern, body)]

6060 PRecord fs -> do

6161 x <- guid

6262 let a = '_' : show x

63− toDef f = FnDef f [] (ctx $ Access (ctx $ Var a) f)

64− return . fn a . ctx $ Let (map toDef fs) body

63+ toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)

64+ return . fn a . loc $ Let (map toDef fs) body

6565

6666extracts :: [Pattern] -> CExpr -> GuidCounter ([String], CExpr)

6767extracts ps body = go [] (reverse ps) body

@@ -70,8 +70,8 @@ extracts ps body = go [] (reverse ps) body

7070 go (x:args) ps e

7171

7272flattenPatterns :: [Pattern] -> CExpr -> GuidCounter (IParser [Def])

73−flattenPatterns patterns exp@(C t s _) =

74− let ctx = C t s in

73+flattenPatterns patterns exp@(L t s _) =

74+ let loc = L t s in

7575 case patterns of

7676 PVar f : args -> do

7777 (as,e) <- extracts args exp

@@ -85,21 +85,21 @@ flattenPatterns patterns exp@(C t s _) =

8585 ") cannot be used on the left-hand side of an assign statement."

8686

8787matchSingle :: Pattern -> CExpr -> Pattern -> GuidCounter [Def]

88−matchSingle pat exp@(C t s _) p =

89− let ctx = C t s in

88+matchSingle pat exp@(L t s _) p =

89+ let loc = L t s in

9090 case p of

9191 PData _ ps -> do

9292 x <- guid

9393 let v = '_' : show x

94− dss <- mapM (matchSingle pat . ctx $ Var v) ps

94+ dss <- mapM (matchSingle pat . loc $ Var v) ps

9595 return (FnDef v [] exp : concat dss)

9696

9797 PVar x ->

98− return [ FnDef x [] (ctx $ Case exp [(pat, ctx $ Var x)]) ]

98+ return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]

9999

100100 PRecord fs -> do

101101 a <- (\x -> '_' : show x) `liftM` guid

102− let toDef f = FnDef f [] (ctx $ Access (ctx $ Var a) f)

102+ let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)

103103 return (FnDef a [] exp : map toDef fs)

104104

105105 PAnything -> return []

compiler/Parse/Types.hs+4−4

@@ -9,7 +9,7 @@ import Data.List (lookup,intercalate)

99import Text.Parsec

1010import Text.Parsec.Indent

1111

12−import Context

12+import Located

1313import Parse.Library

1414import Types.Types hiding (parens,string)

1515import Guid

@@ -88,11 +88,11 @@ typeAlias = do

8888 _ -> []

8989

9090toConstructor start end alias kvs =

91− Definition (FnDef alias args (ctxt (Record rec)))

91+ Definition (FnDef alias args (loc (Record rec)))

9292 where

93− ctxt = pos start end

93+ loc = pos start end

9494 args = map fst kvs

95− rec = map (\a -> (a, [], ctxt (Var a))) args

95+ rec = map (\a -> (a, [], loc (Var a))) args

9696

9797

9898typeAnnotation :: IParser Statement

compiler/Transform/Optimize.hs+27−27

@@ -1,7 +1,7 @@

11module Optimize (optimize) where

33import Ast

4−import Context

4+import Located

55import Control.Arrow (second)

66import Data.Char (isAlpha)

77import Substitute

@@ -24,8 +24,8 @@ instance Simplify Def where

2424 simp (FnDef func args e) = FnDef func args (simp e)

2525 simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)

2626

27−instance Simplify e => Simplify (Context e) where

28− simp (C t s e) = C t s (simp e)

27+instance Simplify e => Simplify (Located e) where

28+ simp (L t s e) = L t s (simp e)

2929

3030instance Simplify Expr where

3131 simp expr =

@@ -35,10 +35,10 @@ instance Simplify Expr where

3535 Binop op e1 e2 -> simp_binop op (f e1) (f e2)

3636 Lambda x e -> Lambda x (f e)

3737 Record fs -> Record (map (\(f,as,e) -> (f, as, simp e)) fs)

38− App (C t s (Lambda x e1)) e2 ->

39− if isValue e2' then subst x e2' e1' else App (C t s (Lambda x ce1')) ce2'

40− where ce1'@(C _ _ e1') = f e1

41− ce2'@(C _ _ e2') = f e2

38+ App (L t s (Lambda x e1)) e2 ->

39+ if isValue e2' then subst x e2' e1' else App (L t s (Lambda x ce1')) ce2'

40+ where ce1'@(L _ _ e1') = f e1

41+ ce2'@(L _ _ e2') = f e2

4242 App e1 e2 -> App (f e1) (f e2)

4343 If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)

4444 Let defs e -> Let (map simp defs) (f e)

@@ -46,7 +46,7 @@ instance Simplify Expr where

4646 Case e cases -> Case (f e) (map (second f) cases)

4747 _ -> expr

4848

49−simp_if (C _ _ (Boolean b)) (C _ _ e2) (C _ _ e3) = if b then e2 else e3

49+simp_if (L _ _ (Boolean b)) (L _ _ e2) (L _ _ e3) = if b then e2 else e3

5050simp_if a b c = If a b c

5151

5252isValue e =

@@ -61,9 +61,9 @@ isValue e =

6161

6262simp_binop = binop

6363

64−binop op ce1@(C t1 s1 e1) ce2@(C t2 s2 e2) =

65− let c1 = C t1 s1 in

66− let c2 = C t2 s2 in

64+binop op ce1@(L t1 s1 e1) ce2@(L t2 s2 e2) =

65+ let c1 = L t1 s1 in

66+ let c2 = L t2 s2 in

6767 case (op, e1, e2) of

6868 (_, IntNum n, IntNum m) -> case op of

6969 { "+" -> IntNum $ (+) n m

@@ -85,19 +85,19 @@ binop op ce1@(C t1 s1 e1) ce2@(C t2 s2 e2) =

8585 ("*", _, IntNum n) -> binop "*" ce2 ce1

8686

8787 ("+", IntNum 0, _) -> e2

88− ("+", IntNum n, Binop "+" (C _ _ (IntNum m)) ce) ->

88+ ("+", IntNum n, Binop "+" (L _ _ (IntNum m)) ce) ->

8989 binop "+" (c1 $ IntNum (n+m)) ce

90− ("+", Binop "+" (C _ _ (IntNum n)) ce1'

91− , Binop "+" (C _ _ (IntNum m)) ce2') ->

92− binop "+" (noContext $ IntNum (n+m)) (noContext $ Binop "+" ce1' ce2')

90+ ("+", Binop "+" (L _ _ (IntNum n)) ce1'

91+ , Binop "+" (L _ _ (IntNum m)) ce2') ->

92+ binop "+" (notLocated $ IntNum (n+m)) (notLocated $ Binop "+" ce1' ce2')

9393

9494 ("*", IntNum 0, _) -> e1

9595 ("*", IntNum 1, _) -> e2

96− ("*", IntNum n, Binop "*" (C _ _ (IntNum m)) ce) ->

97− binop "*" (noContext $ IntNum (n*m)) ce

98− ("*", Binop "*" (C _ _ (IntNum n)) ce1'

99− , Binop "*" (C _ _ (IntNum m)) ce2') ->

100− binop "*" (noContext $ IntNum (n*m)) (noContext $ Binop "*" ce1' ce2')

96+ ("*", IntNum n, Binop "*" (L _ _ (IntNum m)) ce) ->

97+ binop "*" (notLocated $ IntNum (n*m)) ce

98+ ("*", Binop "*" (L _ _ (IntNum n)) ce1'

99+ , Binop "*" (L _ _ (IntNum m)) ce2') ->

100+ binop "*" (notLocated $ IntNum (n*m)) (notLocated $ Binop "*" ce1' ce2')

101101

102102 ("-", _, IntNum 0) -> e1

103103 ("/", _, IntNum 1) -> e1

@@ -112,24 +112,24 @@ binop op ce1@(C t1 s1 e1) ce2@(C t2 s2 e2) =

112112 ("||", Boolean True, _) -> Boolean True

113113 ("||", Boolean False, _) -> e2

114114

115− ("::", _, _) -> let (C _ _ e) = cons ce1 ce2 in e

115+ ("::", _, _) -> let (L _ _ e) = cons ce1 ce2 in e

116116

117117 ("++", Str s1, Str s2) -> Str $ s1 ++ s2

118− ("++", Str s1, Binop "++" (C _ _ (Str s2)) ce) ->

118+ ("++", Str s1, Binop "++" (L _ _ (Str s2)) ce) ->

119119 Binop "++" (c1 $ Str $ s1 ++ s2) ce

120− ("++", Binop "++" e (C _ _ (Str s1)), Str s2) ->

120+ ("++", Binop "++" e (L _ _ (Str s1)), Str s2) ->

121121 Binop "++" e (c1 $ Str $ s1 ++ s2)

122122

123123 ("++", Data "Nil" [], _) -> e2

124124 ("++", _, Data "Nil" []) -> e1

125− ("++", Data "Cons" [h,t], _) -> Data "Cons" [h, noContext $ binop "++" t ce2]

125+ ("++", Data "Cons" [h,t], _) -> Data "Cons" [h, notLocated $ binop "++" t ce2]

126126

127127 ("|>", _, _) -> App ce2 ce1

128128 ("<|", _, _) -> App ce1 ce2

129129 (".", _, _) ->

130− Lambda "x" (noContext $

131− App ce1 (noContext $ App ce2 (noContext $ Var "x")))

130+ Lambda "x" (notLocated $

131+ App ce1 (notLocated $ App ce2 (notLocated $ Var "x")))

132132

133133 _ | isAlpha (head op) || '_' == head op ->

134− App (noContext $ App (noContext $ Var op) ce1) ce2

134+ App (notLocated $ App (notLocated $ Var op) ce1) ce2

135135 | otherwise -> Binop op ce1 ce2

compiler/Transform/Rename.hs+3−3

@@ -2,7 +2,7 @@

22module Rename (renameModule, derename, deprime) where

44import Ast

5−import Context

5+import Located

66import Control.Arrow (first)

77import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)

88import Control.Monad.State (evalState, State, get, put)

@@ -53,8 +53,8 @@ renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts

5353 ImportEvent _ _ n _ -> [n]

5454 _ -> []

5555

56−instance Rename a => Rename (Context a) where

57− rename env (C t s e) = C t s `liftM` rename env e

56+instance Rename a => Rename (Located a) where

57+ rename env (L t s e) = L t s `liftM` rename env e

5858

5959instance Rename Expr where

6060 rename env expr =

compiler/Transform/Substitute.hs+2−2

@@ -1,12 +1,12 @@

11module Substitute (subst) where

33import Ast

4−import Context

4+import Located

55import Control.Arrow (second, (***))

77subst :: String -> Expr -> Expr -> Expr

88subst old new expr =

9− let f (C t s e) = C t s (subst old new e) in

9+ let f (L t s e) = L t s (subst old new e) in

1010 case expr of

1111 Range e1 e2 -> Range (f e1) (f e2)

1212 Access e x -> Access (f e) x

compiler/Types/Constrain.hs+40−40

@@ -10,7 +10,7 @@ import qualified Data.Map as Map

1010import qualified Data.Set as Set

1111

1212import Ast

13−import Context

13+import Located

1414import Guid

1515

1616import Types.Types

@@ -62,7 +62,7 @@ mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs

6262 kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss)

6363 split (k,vs) =

6464 let ps = zipWith (\s v -> (s++k,v)) (map (flip replicate '_') [0..]) vs

65− eq t u = C (Just $ msg ++ k) NoSpan (VarT t :=: VarT u)

65+ eq t u = L (Just $ msg ++ k) NoSpan (VarT t :=: VarT u)

6666 msg = "the definition of "

6767 in do xs <- mapM (\_ -> guid) vs

6868 return ( Map.fromList $ zip (map fst ps) (map (:[]) xs)

@@ -81,7 +81,7 @@ constrain typeHints (Module _ _ imports stmts) = do

8181 insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as

8282 assumptions <- foldM insert as (Map.keys schemes)

8383 findAmbiguous (map fst aliasHints) assumptions $ do

84− let f k s vs = map (\v -> C (Just k) NoSpan $ v :<<: s) vs

84+ let f k s vs = map (\v -> L (Just k) NoSpan $ v :<<: s) vs

8585 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions

8686 escapees = Map.keys $ Map.difference assumptions allHints

8787 msg = "Warning! Type-checker could not find variables:\n" ++ intercalate ", " escapees

@@ -91,13 +91,13 @@ constrain typeHints (Module _ _ imports stmts) = do

9191 --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)

9292

9393type TVarMap = Map.Map String [X]

94−type ConstraintSet = Set.Set (Context Constraint)

94+type ConstraintSet = Set.Set (Located Constraint)

9595

96−ctx e span = C (Just $ show e) span

96+loc e span = L (Just $ show e) span

9797

9898gen :: CExpr -> GuidCounter (TVarMap, ConstraintSet, Type)

99−gen (C _ span expr) =

100− let ctx' = C (Just $ show expr) span in

99+gen (L _ span expr) =

100+ let loc' = L (Just $ show expr) span in

101101 case expr of

102102 Var x ->

103103 do b <- guid

@@ -109,7 +109,7 @@ gen (C _ span expr) =

109109 b <- beta

110110 return ( unionA a1 a2

111111 , Set.unions [c1,c2

112− ,Set.singleton . ctx' $ t1 :=: (LambdaT t2 b)]

112+ ,Set.singleton . loc' $ t1 :=: (LambdaT t2 b)]

113113 , b )

114114

115115 Lambda x e ->

@@ -118,7 +118,7 @@ gen (C _ span expr) =

118118 v <- guid

119119 return ( Map.delete x a

120120 , Set.union c . Set.fromList .

121− map (\x -> ctx' $ VarT x :=: b) $

121+ map (\x -> loc' $ VarT x :=: b) $

122122 Map.findWithDefault [v] x a

123123 , LambdaT b t )

124124

@@ -132,7 +132,7 @@ gen (C _ span expr) =

132132 genCs name s = do

133133 v <- guid

134134 let vs = Map.findWithDefault [v] name assumptions

135− return $ map (\x -> ctx name span $ x :<<: s) vs

135+ return $ map (\x -> loc name span $ x :<<: s) vs

136136 cs' <- zipWithM genCs names schemes

137137 return ( foldr Map.delete assumptions names

138138 , Set.union (Set.fromList . concat $ cs') cs

@@ -143,9 +143,9 @@ gen (C _ span expr) =

143143 (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases

144144 return ( unionsA $ as:ass

145145 , let cases' = map snd cases

146− ctxs = zipWith epos cases' (tail cases')

146+ locs = zipWith epos cases' (tail cases')

147147 csts = zipWith (:=:) ts (tail ts)

148− cs' = Set.fromList (zipWith ($) ctxs csts)

148+ cs' = Set.fromList (zipWith ($) locs csts)

149149 in Set.unions $ cs' : cs : css

150150 , head ts)

151151

@@ -154,30 +154,30 @@ gen (C _ span expr) =

154154 (a2,c2,t2) <- gen e2

155155 (a3,c3,t3) <- gen e3

156156 return ( unionsA [a1,a2,a3]

157− , let c4 = Set.fromList [ ctx e1 span (t1 :=: bool)

158− , ctx' (t2 :=: t3) ]

157+ , let c4 = Set.fromList [ loc e1 span (t1 :=: bool)

158+ , loc' (t2 :=: t3) ]

159159 in Set.unions [c1,c2,c3,c4]

160160 , t2 )

161161

162162 Data name es ->

163− gen $ foldl' (\f x -> epos f x $ App f x) (ctx' $ Var name) es

163+ gen $ foldl' (\f x -> epos f x $ App f x) (loc' $ Var name) es

164164

165165 Binop op e1 e2 ->

166− gen $ ctx' (App (ctx' $ App (ctx' $ Var op) e1) e2)

166+ gen $ loc' (App (loc' $ App (loc' $ Var op) e1) e2)

167167

168168 Access e label ->

169169 do (as,cs,rtype) <- gen e

170170 t <- beta

171171 rtype' <- beta

172172 let fs = Map.singleton label [t]

173− c = (ctx' (RecordT fs rtype' :=: rtype))

173+ c = (loc' (RecordT fs rtype' :=: rtype))

174174 return (as, Set.insert c cs, t)

175175

176176 Remove e x ->

177177 do (as,cs,rtype) <- gen e

178178 t <- beta

179179 rtype' <- beta

180− let c = (ctx' (RecordT (Map.singleton x [t]) rtype' :=: rtype))

180+ let c = (loc' (RecordT (Map.singleton x [t]) rtype' :=: rtype))

181181 return (as, Set.insert c cs, rtype')

182182

183183 Insert e x v ->

@@ -193,7 +193,7 @@ gen (C _ span expr) =

193193 oldTs <- mapM (\_ -> beta) fields

194194 rtype' <- beta

195195 let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype'

196− c = Set.singleton (ctx' (rtype :=: rT oldTs))

196+ c = Set.singleton (loc' (rtype :=: rT oldTs))

197197 return ( unionsA (ras:ass), Set.unions (c : rcs : css), rT newTs )

198198

199199 Record fields ->

@@ -206,27 +206,27 @@ gen (C _ span expr) =

206206 , Set.fromList (concat css)

207207 , RecordT (foldr ($) Map.empty fs) EmptyRecord )

208208

209− Range e1@(C w1 s1 _) e2@(C w2 s2 _) ->

209+ Range e1@(L w1 s1 _) e2@(L w2 s2 _) ->

210210 do (a1,c1,t1) <- gen e1

211211 (a2,c2,t2) <- gen e2

212212 return ( unionsA [a1,a2]

213− , Set.unions [ c1, c2, Set.fromList [ C w1 s1 (t1 :=: int)

214− , C w1 s2 (t2 :=: int) ] ]

213+ , Set.unions [ c1, c2, Set.fromList [ L w1 s1 (t1 :=: int)

214+ , L w1 s2 (t2 :=: int) ] ]

215215 , listOf int )

216216

217217 MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps

218− let cs = Set.fromList (map (ctx' . (t :=:)) ts)

218+ let cs = Set.fromList (map (loc' . (t :=:)) ts)

219219 return (unionsA ass, Set.unions (cs:css), t)

220− where genPair (b@(C t s _),e) = do

220+ where genPair (b@(L t s _),e) = do

221221 (a1,c1,t1) <- gen b

222222 (a2,c2,t2) <- gen e

223223 return ( unionsA [a1,a2]

224224 , Set.unions [ c1, c2

225− , Set.singleton (C t s (t1 :=: bool)) ]

225+ , Set.singleton (L t s (t1 :=: bool)) ]

226226 , t2 )

227227

228228 IntNum _ -> do t <- beta

229− return (Map.empty, Set.singleton (ctx' $ t :<: number), t)

229+ return (Map.empty, Set.singleton (loc' $ t :<: number), t)

230230

231231 FloatNum _ -> primitive float

232232 Chr _ -> primitive char

@@ -241,41 +241,41 @@ primitive t = return (Map.empty, Set.empty, t)

241241caseGen :: Type

242242 -> (Pattern, CExpr)

243243 -> GuidCounter (TVarMap, ConstraintSet, Type)

244−caseGen tipe (p, ce@(C _ span e)) = do

244+caseGen tipe (p, ce@(L _ span e)) = do

245245 (as ,cs ,t) <- gen ce

246− (as',cs',_) <- patternGen (ctx p span) tipe as p

246+ (as',cs',_) <- patternGen (loc p span) tipe as p

247247 return ( as', Set.union cs cs', t )

248248

249−patternGen :: (Constraint -> Context Constraint)

249+patternGen :: (Constraint -> Located Constraint)

250250 -> Type -- Type of e in `case e of ...`

251251 -> TVarMap

252252 -> Pattern

253253 -> GuidCounter (TVarMap, ConstraintSet, Type)

254−patternGen ctxt tipe as pattern =

254+patternGen loc tipe as pattern =

255255 case pattern of

256256 PAnything -> do b <- beta ; return ( as, Set.empty, b )

257257 PVar v -> do

258258 b <- beta

259− let cs = map (ctxt . (b :=:) . VarT) (Map.findWithDefault [] v as)

260− return ( Map.delete v as, Set.fromList (ctxt (b :=: tipe) : cs), b )

259+ let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)

260+ return ( Map.delete v as, Set.fromList (loc (b :=: tipe) : cs), b )

261261 PData name ps -> do

262262 constr <- guid

263263 output <- beta

264264 let step (as,cs,tipe) p = do b <- beta

265− (as',cs',t) <- patternGen ctxt b as p

265+ (as',cs',t) <- patternGen loc b as p

266266 return (as', Set.union cs cs', t ==> tipe)

267267 (as',cs, t) <- foldM step (as,Set.empty,tipe) (reverse ps)

268268 return ( Map.insert name [constr] as'

269− , Set.insert (ctxt (VarT constr :=: t)) cs

269+ , Set.insert (loc (VarT constr :=: t)) cs

270270 , output )

271271 PRecord fs ->

272272 do pairs <- mapM (\f -> do b <- beta; return (f,b)) fs

273273 b <- beta

274274 let t = RecordT (Map.fromList $ map (second (:[])) pairs) b

275− mkCs (name,tipe) = map (ctxt . (tipe :=:) . VarT)

275+ mkCs (name,tipe) = map (loc . (tipe :=:) . VarT)

276276 (Map.findWithDefault [] name as)

277277 return ( foldr Map.delete as fs

278− , Set.fromList (ctxt (t :=: tipe) : concatMap mkCs pairs)

278+ , Set.fromList (loc (t :=: tipe) : concatMap mkCs pairs)

279279 , t )

280280

281281

@@ -295,7 +295,7 @@ defGenHelp name args e = do

295295 genCs (arg,x) = do

296296 v <- guid

297297 let as' = Map.findWithDefault [v] arg as

298− return $ map (\y -> ctx arg NoSpan $ VarT x :=: VarT y) as'

298+ return $ map (\y -> loc arg NoSpan $ VarT x :=: VarT y) as'

299299 cs' <- concat `liftM` mapM genCs argDict

300300 scheme <- Subs.generalize (concat $ Map.elems as') $

301301 Forall (map snd argDict) (cs' ++ Set.toList cs) tipe

@@ -316,13 +316,13 @@ stmtGen stmt =

316316 ExportEvent js elm tipe ->

317317 do x <- guid

318318 return ( Map.singleton elm [x]

319− , Set.singleton . ctx elm NoSpan $ VarT x :=: tipe

319+ , Set.singleton . loc elm NoSpan $ VarT x :=: tipe

320320 , Map.empty )

321321

322− ImportEvent js e@(C txt span base) elm tipe ->

322+ ImportEvent js e@(L txt span base) elm tipe ->

323323 do (as,cs,t) <- gen e

324324 return ( as

325− , Set.insert (C txt span (signalOf t :=: tipe)) cs

325+ , Set.insert (L txt span (signalOf t :=: tipe)) cs

326326 , Map.singleton elm (Forall [] [] tipe) )

327327

328328 TypeAnnotation name tipe ->

compiler/Types/Solver.hs+17−17

@@ -1,7 +1,7 @@

22module Types.Solver (solver) where

4−import Context

4+import Located

55import Control.Arrow (second)

66import Control.Monad (liftM)

77import Data.Either (lefts,rights)

@@ -14,8 +14,8 @@ import Types.Types

1414import Types.Substitutions

1515import Types.Alias (dealias)

1616

17−isSolved ss (C _ _ (t1 :=: t2)) = t1 == t2

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

17+isSolved ss (L _ _ (t1 :=: t2)) = t1 == t2

18+isSolved ss (L _ _ (x :<<: _)) = isJust (lookup x ss)

1919isSolved ss c = False

2020

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

@@ -31,7 +31,7 @@ crush aliases (Forall xs cs t) =

3131schemeSubHelp txt span x s t1 rltn t2 = do

3232 (t1',cs1) <- sub t1

3333 (t2',cs2) <- sub t2

34− return (C txt span (rltn t1' t2') : cs1 ++ cs2)

34+ return (L txt span (rltn t1' t2') : cs1 ++ cs2)

3535 where sub t | not (occurs x t) = return (t, [])

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

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

@@ -42,7 +42,7 @@ schemeSub aliases x s c =

4242 Right s'' -> Right `liftM` schemeSub' x s'' c

4343 Left err -> return $ Left err

4444

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

45+schemeSub' x s c@(L txt span constraint) =

4646 case constraint of

4747 (t1 :=: t2) -> schemeSubHelp txt span x s t1 (:=:) t2

4848 (t1 :<: t2) -> schemeSubHelp txt span x s t1 (:<:) t2

@@ -53,7 +53,7 @@ schemeSub' x s c@(C txt span constraint) =

5353 let ss = [(x,tipe)]

5454 constraints = subst ss (cs ++ ccs)

5555 c' = y :<<: Forall (cxs ++ xs) constraints (subst ss ctipe)

56− return [ C txt span c' ]

56+ return [ L txt span c' ]

5757

5858recordConstraints eq fs t fs' t' =

5959 liftM concat . sequence $

@@ -64,11 +64,11 @@ recordConstraints eq fs t fs' t' =

6464 Map.difference fs' fs

6565 ]

6666 where constrain :: Map.Map String [Type] -> Map.Map String [Type]

67− -> GuidCounter [Context Constraint]

67+ -> GuidCounter [Located Constraint]

6868 constrain as bs = liftM concat . sequence . Map.elems $

6969 Map.intersectionWithKey (zipper []) as bs

70− zipper :: [Context Constraint] -> String -> [Type] -> [Type]

71− -> GuidCounter [Context Constraint]

70+ zipper :: [Located Constraint] -> String -> [Type] -> [Type]

71+ -> GuidCounter [Located Constraint]

7272 zipper cs k xs ys =

7373 case (xs,ys) of

7474 (a:as, b:bs) -> zipper (eq a b : cs) k as bs

@@ -82,12 +82,12 @@ recordConstraints eq fs t fs' t' =

8282

8383solver :: Aliases

8484 -> Map.Map X Type

85− -> [Context Constraint]

85+ -> [Located Constraint]

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

8787solver _ subs [] = return $ Right subs

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

89− let ctx = C txt span

90− eq t1 t2 = ctx (t1 :=: t2)

88+solver aliases subs (L txt span c : cs) =

89+ let loc = L txt span

90+ eq t1 t2 = loc (t1 :=: t2)

9191 solv = solver aliases subs

9292 uniError' = uniError (\t1 t2 -> solv (eq t1 t2 : cs)) aliases txt span

9393 in case c of

@@ -133,14 +133,14 @@ solver aliases subs (C txt span c : cs) =

133133 Just (Super ts) ->

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

135135 case Set.toList ts' of

136− [] -> solv (ctx (t :<: Super ts) : cs)

136+ [] -> solv (loc (t :<: Super ts) : cs)

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

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

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

140− Just t' -> solv (ctx (t' :=: t) : cs)

140+ Just t' -> solv (loc (t' :=: t) : cs)

141141 )

142142

143− t :=: VarT x -> solv ((ctx (VarT x :=: t)) : cs)

143+ t :=: VarT x -> solv ((loc (VarT x :=: t)) : cs)

144144

145145 t1 :=: t2 | t1 == t2 -> solv cs

146146 | otherwise -> uniError' t1 t2

@@ -176,7 +176,7 @@ solver aliases subs (C txt span c : cs) =

176176 [] -> solv (concat (rights css))

177177 | otherwise ->

178178 do (t,cs7) <- concretize s

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

179+ solv (cs ++ loc (VarT x :=: t) : cs7)

180180

181181showMsg msg = case msg of

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

compiler/Types/Substitutions.hs+7−7

@@ -8,7 +8,7 @@ module Types.Substitutions (subst,

88 superize) where

1010import Ast

11−import Context

11+import Located

1212import Control.Monad (liftM, liftM2)

1313import Control.Monad.State (runState, State, get, put)

1414import Data.List (nub)

@@ -41,8 +41,8 @@ instance Subst Constraint where

4141 subst ss (t :<: super) = subst ss t :<: super

4242 subst ss (x :<<: poly) = x :<<: subst ss poly

4343

44−instance Subst a => Subst (Context a) where

45− subst ss (C str span c) = C str span (subst ss c)

44+instance Subst a => Subst (Located a) where

45+ subst ss (L str span c) = L str span (subst ss c)

4646

4747instance Subst a => Subst [a] where

4848 subst ss as = map (subst ss) as

@@ -67,15 +67,15 @@ instance FreeVars Constraint where

6767 freeVars (x :<<: Forall xs cs t) = filter (`notElem` xs) frees

6868 where frees = concatMap freeVars cs ++ freeVars t

6969

70−instance FreeVars a => FreeVars (Context a) where

71− freeVars (C _ _ c) = freeVars c

70+instance FreeVars a => FreeVars (Located a) where

71+ freeVars (L _ _ c) = freeVars c

7272

7373instance FreeVars a => FreeVars [a] where

7474 freeVars = concatMap freeVars

7575

7676occurs x t = x `elem` freeVars t

7777

78−concretize :: Scheme -> GuidCounter (Type, [Context Constraint])

78+concretize :: Scheme -> GuidCounter (Type, [Located Constraint])

7979concretize (Forall xs cs t) = do

8080 ss <- zip xs `liftM` mapM (\_ -> liftM VarT guid) xs

8181 return (subst ss t, subst ss cs)

@@ -104,7 +104,7 @@ superize name tipe =

104104 where

105105 (tipe', (ns,as,cs)) = runState (runSuper (go tipe)) ([],[],[])

106106 t <: super = do x <- guid

107− return $ C (Just name) NoSpan (VarT t :<: super x)

107+ return $ L (Just name) NoSpan (VarT t :<: super x)

108108

109109 nmbr t = number

110110 apnd t = appendable t

compiler/Types/Types.hs+2−2

@@ -1,7 +1,7 @@

22module Types.Types where

4−import Context

4+import Located

55import Data.Char (isDigit)

66import Data.List (intercalate,isPrefixOf)

77import qualified Data.Set as Set

@@ -17,7 +17,7 @@ data Type = LambdaT Type Type

1717 | Super (Set.Set Type)

1818 deriving (Eq, Ord)

1919

20−data Scheme = Forall [X] [Context Constraint] Type deriving (Eq, Ord, Show)

20+data Scheme = Forall [X] [Located Constraint] Type deriving (Eq, Ord, Show)

2121

2222data Constraint = Type :=: Type

2323 | Type :<: Type