e3e560b · elk · git.iko.soy

Elm.cabal+9−8

@@ -37,19 +37,19 @@ Library

3737 Elm.Internal.Utils,

3838 Elm.Internal.Version

3939 Hs-Source-Dirs: compiler

40− other-modules: SourceSyntax.Declaration,

40+ other-modules: SourceSyntax.Annotation,

41+ SourceSyntax.Declaration,

4142 SourceSyntax.Expression,

4243 SourceSyntax.Helpers,

4344 SourceSyntax.Literal,

44− SourceSyntax.Location,

4545 SourceSyntax.Module,

4646 SourceSyntax.Pattern,

4747 SourceSyntax.PrettyPrint,

4848 SourceSyntax.Type,

49+ SourceSyntax.Variable,

4950 Generate.JavaScript,

5051 Generate.JavaScript.Helpers,

5152 Generate.JavaScript.Ports,

52− Generate.Noscript,

5353 Generate.Markdown,

5454 Generate.Html,

5555 Generate.Cases,

@@ -119,19 +119,19 @@ Executable elm

119119 Main-is: Compiler.hs

120120 ghc-options: -threaded -O2

121121 Hs-Source-Dirs: compiler

122− other-modules: SourceSyntax.Declaration,

122+ other-modules: SourceSyntax.Annotation,

123+ SourceSyntax.Declaration,

123124 SourceSyntax.Expression,

124125 SourceSyntax.Helpers,

125126 SourceSyntax.Literal,

126− SourceSyntax.Location,

127127 SourceSyntax.Module,

128128 SourceSyntax.Pattern,

129129 SourceSyntax.PrettyPrint,

130130 SourceSyntax.Type,

131+ SourceSyntax.Variable,

131132 Generate.JavaScript,

132133 Generate.JavaScript.Helpers,

133134 Generate.JavaScript.Ports,

134− Generate.Noscript,

135135 Generate.Markdown,

136136 Generate.Html,

137137 Generate.Cases,

@@ -200,15 +200,16 @@ Executable elm

200200Executable elm-doc

201201 Main-is: Docs.hs

202202 Hs-Source-Dirs: compiler

203− other-modules: SourceSyntax.Declaration,

203+ other-modules: SourceSyntax.Annotation,

204+ SourceSyntax.Declaration,

204205 SourceSyntax.Expression,

205206 SourceSyntax.Helpers,

206207 SourceSyntax.Literal,

207− SourceSyntax.Location,

208208 SourceSyntax.Module,

209209 SourceSyntax.Pattern,

210210 SourceSyntax.PrettyPrint,

211211 SourceSyntax.Type,

212+ SourceSyntax.Variable,

212213 Parse.Binop,

213214 Parse.Declaration,

214215 Parse.Expression,

compiler/Build/Source.hs+1−2

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

22module Build.Source (build) where

33

44import qualified Data.Map as Map

5−import qualified Data.Set as Set

65import System.FilePath as FP

76import Text.PrettyPrint (Doc)

87

@@ -33,7 +32,7 @@ build noPrelude interfaces source =

3332

3433 let exports'

3534 | null exs =

36− let get = Set.toList . Pattern.boundVars in

35+ let get = Pattern.boundVarList in

3736 concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++

3837 concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++

3938 [ name | TypeAlias name _ (Type.Record _ _) <- decls ]

compiler/Generate/Cases.hs+32−31

@@ -6,14 +6,15 @@ import Control.Monad.State

66import Data.List (groupBy,sortBy)

77import Data.Maybe (fromMaybe)

88

9−import SourceSyntax.Location

10−import SourceSyntax.Literal

11−import SourceSyntax.Pattern

9+import SourceSyntax.Annotation

1210import SourceSyntax.Expression

11+import SourceSyntax.Literal

12+import qualified SourceSyntax.Pattern as P

13+import qualified SourceSyntax.Variable as V

1314import Transform.Substitute

1415

1516

16−toMatch :: [(Pattern, LExpr)] -> State Int (String, Match)

17+toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)

1718toMatch patterns = do

1819 v <- newVar

1920 (,) v <$> match [v] (map (first (:[])) patterns) Fail

@@ -27,7 +28,7 @@ data Match

2728 = Match String [Clause] Match

2829 | Break

2930 | Fail

30− | Other LExpr

31+ | Other Expr

3132 | Seq [Match]

3233 deriving Show

3334

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

3940matchSubst _ Break = Break

4041matchSubst _ Fail = Fail

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

42−matchSubst pairs (Other (L s e)) =

43− Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs

43+matchSubst pairs (Other (A a e)) =

44+ Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs

4445matchSubst pairs (Match n cs m) =

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

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

@@ -49,13 +50,13 @@ matchSubst pairs (Match n cs m) =

4950

5051isCon (p:_, _) =

5152 case p of

52− PData _ _ -> True

53− PLiteral _ -> True

54− _ -> False

53+ P.Data _ _ -> True

54+ P.Literal _ -> True

55+ _ -> False

5556

5657isVar p = not (isCon p)

5758

58−match :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match

59+match :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

5960match [] [] def = return def

6061match [] [([],e)] Fail = return $ Other e

6162match [] [([],e)] Break = return $ Other e

@@ -67,46 +68,46 @@ match vs@(v:_) cs def

6768 where

6869 cs' = map (dealias v) cs

6970

70−dealias v c@(p:ps, L s e) =

71+dealias v c@(p:ps, A a e) =

7172 case p of

72− PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e)

73+ P.Alias x pattern -> (pattern:ps, A a $ subst x (rawVar v) e)

7374 _ -> c

7475

75−matchVar :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match

76+matchVar :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

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

7778 where

78− subVar (p:ps, (L s e)) = (ps, L s $ subOnePattern p e)

79+ subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)

7980 where

8081 subOnePattern pattern e =

8182 case pattern of

82− PVar x -> subst x (Var v) e

83− PAnything -> e

84− PRecord fs ->

85− foldr (\x -> subst x (Access (L s (Var v)) x)) e fs

83+ P.Var x -> subst x (rawVar v) e

84+ P.Anything -> e

85+ P.Record fs ->

86+ foldr (\x -> subst x (Access (A a (rawVar v)) x)) e fs

8687

87−matchCon :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match

88+matchCon :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

8889matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css

8990 where

9091 css = groupBy eq (sortBy cmp cs)

9192

9293 cmp (p1:_,_) (p2:_,_) =

9394 case (p1,p2) of

94− (PData n1 _, PData n2 _) -> compare n1 n2

95+ (P.Data n1 _, P.Data n2 _) -> compare n1 n2

9596 _ -> compare p1 p2

9697

9798 eq (p1:_,_) (p2:_,_) =

9899 case (p1,p2) of

99− (PData n1 _, PData n2 _) -> n1 == n2

100+ (P.Data n1 _, P.Data n2 _) -> n1 == n2

100101 _ -> p1 == p2

101102

102103 toClause cs =

103104 case head cs of

104− (PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break

105− (PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break

105+ (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break

106+ (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break

106107

107108matchClause :: Either String Literal

108109 -> [String]

109− -> [([Pattern],LExpr)]

110+ -> [([P.Pattern],Expr)]

110111 -> Match

111112 -> State Int Clause

112113matchClause c (_:vs) cs def =

@@ -116,14 +117,14 @@ matchClause c (_:vs) cs def =

116117

117118 flatten (p:ps, e) =

118119 case p of

119− PData _ ps' -> (ps' ++ ps, e)

120− PLiteral _ -> (ps, e)

120+ P.Data _ ps' -> (ps' ++ ps, e)

121+ P.Literal _ -> (ps, e)

121122

122123 getVars =

123124 case head cs of

124− (PData _ ps : _, _) -> forM ps (const newVar)

125− (PLiteral _ : _, _) -> return []

125+ (P.Data _ ps : _, _) -> forM ps (const newVar)

126+ (P.Literal _ : _, _) -> return []

126127

127−matchMix :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match

128+matchMix :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

128129matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

129− where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

130+ where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

compiler/Generate/JavaScript.hs+52−47

@@ -1,25 +1,27 @@

11{-# OPTIONS_GHC -W #-}

22module Generate.JavaScript (generate) where

33

4−import Control.Arrow (first,(***))

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

5+import Control.Arrow (first,(***))

66import Control.Monad.State

77import qualified Data.List as List

88import qualified Data.Map as Map

99import qualified Data.Set as Set

10+import Language.ECMAScript3.PrettyPrint

11+import Language.ECMAScript3.Syntax

1012

1113import Generate.JavaScript.Helpers

1214import qualified Generate.Cases as Case

1315import qualified Generate.JavaScript.Ports as Port

1416import qualified Generate.Markdown as MD

17+import SourceSyntax.Annotation

18+import SourceSyntax.Expression

1519import qualified SourceSyntax.Helpers as Help

1620import SourceSyntax.Literal

17−import SourceSyntax.Pattern as Pattern

18−import SourceSyntax.Location

19−import SourceSyntax.Expression

2021import SourceSyntax.Module

21−import Language.ECMAScript3.Syntax

22−import Language.ECMAScript3.PrettyPrint

22+import qualified SourceSyntax.Pattern as P

23+import SourceSyntax.PrettyPrint (renderPretty)

24+import qualified SourceSyntax.Variable as V

2325import qualified Transform.SafeNames as MakeSafe

2426

2527varDecl :: String -> Expression () -> VarDecl ()

@@ -50,10 +52,10 @@ literal lit =

5052 FloatNum n -> NumLit () n

5153 Boolean b -> BoolLit () b

5254

53−expression :: LExpr -> State Int (Expression ())

54−expression (L span expr) =

55+expression :: Expr -> State Int (Expression ())

56+expression (A region expr) =

5557 case expr of

56− Var x -> return $ ref x

58+ Var (V.Raw x) -> return $ ref x

5759 Literal lit -> return $ literal lit

5860

5961 Range lo hi ->

@@ -93,9 +95,9 @@ expression (L span expr) =

9395 Map.toList . Map.filter (not . null) $ Map.map tail fs

9496 visible fs = map (first prop) . Map.toList $ Map.map head fs

9597

96− Binop op e1 e2 -> binop span op e1 e2

98+ Binop op e1 e2 -> binop region op e1 e2

9799

98− Lambda p e@(L s _) ->

100+ Lambda p e@(A ann _) ->

99101 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)

100102 body' <- expression body

101103 return $ case length args < 2 || length args > 9 of

@@ -104,13 +106,14 @@ expression (L span expr) =

104106 where

105107 depattern (args, body) pattern =

106108 case pattern of

107− PVar x -> return (args ++ [x], body)

109+ P.Var x -> return (args ++ [x], body)

108110 _ -> do arg <- Case.newVar

109− return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))

111+ return ( args ++ [arg]

112+ , A ann (Case (A ann (rawVar arg)) [(pattern, body)]))

110113

111114 (patterns, innerBody) = collect [p] e

112115

113− collect patterns lexpr@(L _ expr) =

116+ collect patterns lexpr@(A _ expr) =

114117 case expr of

115118 Lambda p e -> collect (p:patterns) e

116119 _ -> (patterns, lexpr)

@@ -127,7 +130,7 @@ expression (L span expr) =

127130 (func, args) = getArgs e1 [e2]

128131 getArgs func args =

129132 case func of

130− (L _ (App f arg)) -> getArgs f (arg : args)

133+ (A _ (App f arg)) -> getArgs f (arg : args)

131134 _ -> (func, args)

132135

133136 Let defs e ->

@@ -139,9 +142,9 @@ expression (L span expr) =

139142 MultiIf branches ->

140143 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

141144 return $ case last branches of

142− (L _ (Var "Basics.otherwise"), _) -> safeIfs branches'

143− (L _ (Literal (Boolean True)), _) -> safeIfs branches'

144− _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])

145+ (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'

146+ (A _ (Literal (Boolean True)), _) -> safeIfs branches'

147+ _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])

145148 where

146149 safeIfs branches = ifs (init branches) (snd (last branches))

147150 ifs branches finally = foldr iff finally branches

@@ -151,10 +154,12 @@ expression (L span expr) =

151154 do (tempVar,initialMatch) <- Case.toMatch cases

152155 (revisedMatch, stmt) <-

153156 case e of

154− L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])

155− _ -> do e' <- expression e

156− return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])

157− match' <- match span revisedMatch

157+ A _ (Var (V.Raw x)) ->

158+ return (Case.matchSubst [(tempVar,x)] initialMatch, [])

159+ _ ->

160+ do e' <- expression e

161+ return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])

162+ match' <- match region revisedMatch

158163 return (function [] (stmt ++ match') `call` [])

159164

160165 ExplicitList es ->

@@ -184,28 +189,28 @@ expression (L span expr) =

184189 [ string name, Port.outgoing tipe, value' ]

185190

186191definition :: Def -> State Int [Statement ()]

187−definition (Definition pattern expr@(L span _) _) = do

192+definition (Definition pattern expr@(A region _) _) = do

188193 expr' <- expression expr

189194 let assign x = varDecl x expr'

190195 case pattern of

191− PVar x

196+ P.Var x

192197 | Help.isOp x ->

193198 let op = LBracket () (ref "_op") (string x) in

194199 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

195200 | otherwise ->

196201 return [ VarDeclStmt () [ assign x ] ]

197202

198− PRecord fields ->

203+ P.Record fields ->

199204 let setField f = varDecl f (dotSep ["$",f]) in

200205 return [ VarDeclStmt () (assign "$" : map setField fields) ]

201206

202− PData name patterns | vars /= Nothing ->

207+ P.Data name patterns | vars /= Nothing ->

203208 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

204209 where

205210 vars = getVars patterns

206211 getVars patterns =

207212 case patterns of

208− PVar x : rest -> (x:) `fmap` getVars rest

213+ P.Var x : rest -> (x:) `fmap` getVars rest

209214 [] -> Just []

210215 _ -> Nothing

211216

@@ -216,23 +221,23 @@ definition (Definition pattern expr@(L span _) _) = do

216221

217222 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)

218223 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)

219− exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]

224+ exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]

220225

221226 _ ->

222227 do defs' <- concat <$> mapM toDef vars

223228 return (VarDeclStmt () [assign "$"] : defs')

224229 where

225− vars = Set.toList $ Pattern.boundVars pattern

226− mkVar = L span . Var

227− toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]

228− in definition $ Definition (PVar y) expr Nothing

230+ vars = P.boundVarList pattern

231+ mkVar = A region . rawVar

232+ toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]

233+ in definition $ Definition (P.Var y) expr Nothing

229234

230−match :: SrcSpan -> Case.Match -> State Int [Statement ()]

231−match span mtch =

235+match :: Region -> Case.Match -> State Int [Statement ()]

236+match region mtch =

232237 case mtch of

233238 Case.Match name clauses mtch' ->

234− do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses

235− mtch'' <- match span mtch'

239+ do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses

240+ mtch'' <- match region mtch'

236241 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')

237242 where

238243 isLiteral p = case p of

@@ -244,13 +249,13 @@ match span mtch =

244249 | otherwise = e

245250

246251 Case.Fail ->

247− return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]

252+ return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]

248253

249254 Case.Break -> return [BreakStmt () Nothing]

250255 Case.Other e ->

251256 do e' <- expression e

252257 return [ ret e' ]

253− Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)

258+ Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)

254259 where

255260 dropEnd acc [] = acc

256261 dropEnd acc (m:ms) =

@@ -258,9 +263,9 @@ match span mtch =

258263 Case.Other _ -> acc ++ [m]

259264 _ -> dropEnd (acc ++ [m]) ms

260265

261−clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())

262−clause span variable (Case.Clause value vars mtch) =

263− (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)

266+clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())

267+clause region variable (Case.Clause value vars mtch) =

268+ (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)

264269 where

265270 vars' = map (\n -> variable ++ "._" ++ show n) [0..]

266271 (isChar, pattern) =

@@ -273,8 +278,8 @@ clause span variable (Case.Clause value vars mtch) =

273278 [] -> name

274279 is -> drop (last is + 1) name

275280

276−flattenLets :: [Def] -> LExpr -> ([Def], LExpr)

277−flattenLets defs lexpr@(L _ expr) =

281+flattenLets :: [Def] -> Expr -> ([Def], Expr)

282+flattenLets defs lexpr@(A _ expr) =

278283 case expr of

279284 Let ds body -> flattenLets (defs ++ ds) body

280285 _ -> (defs, lexpr)

@@ -321,8 +326,8 @@ generate unsafeModule =

321326 Nothing -> tail . init $ List.inits path

322327 Just nmspc -> drop 2 . init . List.inits $ nmspc : path

323328

324−binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())

325−binop span op e1 e2 =

329+binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())

330+binop region op e1 e2 =

326331 case op of

327332 "Basics.." ->

328333 do es <- mapM expression (e1 : collect [] e2)

@@ -335,7 +340,7 @@ binop span op e1 e2 =

335340 do e1' <- expression e1

336341 e2' <- expression e2

337342 return $ obj "_L.append" `call` [e1', e2']

338− "::" -> expression (L span (Data "::" [e1,e2]))

343+ "::" -> expression (A region (Data "::" [e1,e2]))

339344 _ ->

340345 do e1' <- expression e1

341346 e2' <- expression e2

@@ -345,7 +350,7 @@ binop span op e1 e2 =

345350 where

346351 collect es e =

347352 case e of

348− L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2

353+ A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2

349354 _ -> es ++ [e]

350355

351356 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)

compiler/Generate/Noscript.hsdeleted−68

@@ -1,68 +0,0 @@

1−module Generate.Noscript (noscript) where

2−

3−import Data.List (isInfixOf)

4−import qualified SourceSyntax.Declaration as D

5−import SourceSyntax.Expression

6−import SourceSyntax.Literal

7−import SourceSyntax.Location

8−import SourceSyntax.Module

9−import qualified Generate.Markdown as MD

10−

11−noscript :: Extract def => Module def -> String

12−noscript modul = concat (extract modul)

13−

14−class Extract a where

15− extract :: a -> [String]

16−

17−instance Extract def => Extract (Module def) where

18− extract (Module _ _ _ stmts) =

19− map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)

20−

21−instance Extract def => Extract (D.Declaration' port def) where

22− extract (D.Definition d) = extract d

23− extract _ = []

24−

25−instance Extract Def where

26− extract (Definition _ e _) = extract e

27−

28−instance Extract e => Extract (Located e) where

29− extract (L _ e) = extract e

30−

31−instance Extract def => Extract (Expr' def) where

32− extract expr =

33− let f = extract in

34− case expr of

35− Literal (Str s) -> [s]

36− Binop op e1 e2 -> case (op, f e1, f e2) of

37− ("++", [s1], [s2]) -> [s1 ++ s2]

38− (_ , ss1 , ss2 ) -> ss1 ++ ss2

39− Lambda v e -> f e

40− App (L _ (App (L _ (App (L _ (Var func)) w)) h)) src

41− | "image" `isInfixOf` func -> extractImage src

42− App (L _ (App (L _ (Var func)) src)) txt

43− | "link" `isInfixOf` func -> extractLink src txt

44− App (L _ (Var func)) e

45− | "header" `isInfixOf` func -> tag "h1" e

46− | "bold" `isInfixOf` func -> tag "b" e

47− | "italic" `isInfixOf` func -> tag "i" e

48− | "monospace" `isInfixOf` func -> tag "code" e

49− App e1 e2 -> f e1 ++ f e2

50− Let defs e -> concatMap extract defs ++ f e

51− Var _ -> []

52− Case e cases -> concatMap (f . snd) cases

53− Data _ es -> concatMap f es

54− MultiIf es -> concatMap (f . snd) es

55− Markdown _ md _ -> [ MD.toHtml md ]

56− _ -> []

57−

58−extractLink src txt =

59− case (extract src, extract txt) of

60− ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]

61− ( ss1, ss2) -> ss1 ++ ss2

62−

63−extractImage src =

64− case extract src of

65− [s] -> ["<img src=\"" ++ s ++ "\">"]

66− ss -> ss

67−

68−tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract e)

compiler/Parse/Binop.hs+17−16

@@ -1,10 +1,11 @@

1+{-# OPTIONS_GHC -W #-}

12module Parse.Binop (binops, OpTable) where

23

34import Control.Applicative ((<$>))

4−import Data.List (intercalate)

5+import qualified Data.List as List

56import qualified Data.Map as Map

67

7−import SourceSyntax.Location (merge)

8+import SourceSyntax.Annotation (merge)

89import qualified SourceSyntax.Expression as E

910import SourceSyntax.Declaration (Assoc(..))

1011import Text.Parsec

@@ -16,13 +17,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table

1617opAssoc :: OpTable -> String -> Assoc

1718opAssoc table op = snd $ Map.findWithDefault (9,L) op table

1819

19−hasLevel :: OpTable -> Int -> (String, E.LParseExpr) -> Bool

20+hasLevel :: OpTable -> Int -> (String, E.ParseExpr) -> Bool

2021hasLevel table n (op,_) = opLevel table op == n

2122

22−binops :: IParser E.LParseExpr

23− -> IParser E.LParseExpr

23+binops :: IParser E.ParseExpr

24+ -> IParser E.ParseExpr

2425 -> IParser String

25− -> IParser E.LParseExpr

26+ -> IParser E.ParseExpr

2627binops term last anyOp =

2728 do e <- term

2829 table <- getState

@@ -38,9 +39,9 @@ binops term last anyOp =

3839

3940split :: OpTable

4041 -> Int

41− -> E.LParseExpr

42− -> [(String, E.LParseExpr)]

43− -> IParser E.LParseExpr

42+ -> E.ParseExpr

43+ -> [(String, E.ParseExpr)]

44+ -> IParser E.ParseExpr

4445split _ _ e [] = return e

4546split table n e eops = do

4647 assoc <- getAssoc table n eops

@@ -49,26 +50,26 @@ split table n e eops = do

4950 case assoc of R -> joinR es ops

5051 _ -> joinL es ops

5152

52−splitLevel :: OpTable -> Int -> E.LParseExpr -> [(String, E.LParseExpr)]

53− -> [IParser E.LParseExpr]

53+splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]

54+ -> [IParser E.ParseExpr]

5455splitLevel table n e eops =

5556 case break (hasLevel table n) eops of

56− (lops, (op,e'):rops) ->

57+ (lops, (_op,e'):rops) ->

5758 split table (n+1) e lops : splitLevel table n e' rops

5859 (lops, []) -> [ split table (n+1) e lops ]

5960

60−joinL :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr

61+joinL :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr

6162joinL [e] [] = return e

6263joinL (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops

6364joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."

6465

65−joinR :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr

66+joinR :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr

6667joinR [e] [] = return e

6768joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

6869 return (merge a e (E.Binop op a e))

6970joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."

7071

71−getAssoc :: OpTable -> Int -> [(String,E.LParseExpr)] -> IParser Assoc

72+getAssoc :: OpTable -> Int -> [(String,E.ParseExpr)] -> IParser Assoc

7273getAssoc table n eops

7374 | all (==L) assocs = return L

7475 | all (==R) assocs = return R

@@ -79,5 +80,5 @@ getAssoc table n eops

7980 assocs = map (opAssoc table . fst) levelOps

8081 msg problem =

8182 concat [ "Conflicting " ++ problem ++ " for binary operators ("

82− , intercalate ", " (map fst eops), "). "

83+ , List.intercalate ", " (map fst eops), "). "

8384 , "Consider adding parentheses to disambiguate." ]

compiler/Parse/Expression.hs+67−66

@@ -5,45 +5,45 @@ import Data.List (foldl')

55import Text.Parsec hiding (newline,spaces)

66import Text.Parsec.Indent

77

8+import Parse.Binop

89import Parse.Helpers

10+import Parse.Literal

911import qualified Parse.Pattern as Pattern

1012import qualified Parse.Type as Type

11−import Parse.Binop

12−import Parse.Literal

1313

14−import SourceSyntax.Location as Location

15−import SourceSyntax.Pattern hiding (tuple,list)

16−import qualified SourceSyntax.Literal as Literal

14+import SourceSyntax.Annotation as Annotation

15+import qualified SourceSyntax.Pattern as P

16+import qualified SourceSyntax.Literal as L

1717import SourceSyntax.Expression

1818

1919

2020-------- Basic Terms --------

2121

22−varTerm :: IParser ParseExpr

22+varTerm :: IParser ParseExpr'

2323varTerm = toVar <$> var <?> "variable"

2424

25−toVar :: String -> ParseExpr

26−toVar v = case v of "True" -> Literal (Literal.Boolean True)

27− "False" -> Literal (Literal.Boolean False)

28− _ -> Var v

25+toVar :: String -> ParseExpr'

26+toVar v = case v of "True" -> Literal (L.Boolean True)

27+ "False" -> Literal (L.Boolean False)

28+ _ -> rawVar v

2929

30−accessor :: IParser ParseExpr

30+accessor :: IParser ParseExpr'

3131accessor = do

3232 (start, lbl, end) <- located (try (string "." >> rLabel))

33− let loc e = Location.at start end e

34− return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))

33+ let loc e = Annotation.at start end e

34+ return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))

3535

36−negative :: IParser ParseExpr

36+negative :: IParser ParseExpr'

3737negative = do

3838 (start, nTerm, end) <-

3939 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

40− let loc e = Location.at start end e

41− return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)

40+ let loc e = Annotation.at start end e

41+ return (Binop "-" (loc $ Literal (L.IntNum 0)) nTerm)

4242

4343

4444-------- Complex Terms --------

4545

46−listTerm :: IParser ParseExpr

46+listTerm :: IParser ParseExpr'

4747listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)

4848 where

4949 range = do

@@ -66,86 +66,87 @@ listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)

6666 string "}}"

6767 return (span uid (length exprs), exprs ++ [e])

6868

69−parensTerm :: IParser LParseExpr

69+parensTerm :: IParser ParseExpr

7070parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

7171 where

7272 opFn = do

7373 (start, op, end) <- located anyOp

74− let loc = Location.at start end

75− return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $

76− Binop op (loc $ Var "x") (loc $ Var "y")

74+ let loc = Annotation.at start end

75+ return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $

76+ Binop op (loc $ rawVar "x") (loc $ rawVar "y")

7777

7878 tupleFn = do

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

8080 (start, commas, end) <- located (comma >> many (whitespace >> comma))

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

82− loc = Location.at start end

82+ loc = Annotation.at start end

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

84− (loc . tuple $ map (loc . Var) vars) (map PVar vars)

84+ (loc . tuple $ map (loc . rawVar) vars) (map P.Var vars)

8585

8686 parened = do

8787 (start, es, end) <- located (commaSep expr)

8888 return $ case es of

8989 [e] -> e

90− _ -> Location.at start end (tuple es)

90+ _ -> Annotation.at start end (tuple es)

9191

92−recordTerm :: IParser LParseExpr

92+recordTerm :: IParser ParseExpr

9393recordTerm = brackets $ choice [ misc, addLocation record ]

94− where field = do

95− label <- rLabel

96− patterns <- spacePrefix Pattern.term

97− padded equals

98− body <- expr

99− return (label, makeFunction patterns body)

94+ where

95+ field = do

96+ label <- rLabel

97+ patterns <- spacePrefix Pattern.term

98+ padded equals

99+ body <- expr

100+ return (label, makeFunction patterns body)

100101

101− record = Record <$> commaSep field

102+ record = Record <$> commaSep field

102103

103− change = do

104− lbl <- rLabel

105− padded (string "<-")

106− (,) lbl <$> expr

104+ change = do

105+ lbl <- rLabel

106+ padded (string "<-")

107+ (,) lbl <$> expr

107108

108− remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)

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

109110

110− insert r = addLocation $ do

111− string "|" >> whitespace

112− Insert r <$> rLabel <*> (padded equals >> expr)

111+ insert r = addLocation $ do

112+ string "|" >> whitespace

113+ Insert r <$> rLabel <*> (padded equals >> expr)

113114

114− modify r = addLocation

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

115+ modify r =

116+ addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)

116117

117− misc = try $ do

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

119− opt <- padded (optionMaybe (remove record))

120− case opt of

121− Just e -> try (insert e) <|> return e

122− Nothing -> try (insert record) <|> try (modify record)

118+ misc = try $ do

119+ record <- addLocation (rawVar <$> rLabel)

120+ opt <- padded (optionMaybe (remove record))

121+ case opt of

122+ Just e -> try (insert e) <|> return e

123+ Nothing -> try (insert record) <|> try (modify record)

123124

124125

125−term :: IParser LParseExpr

126+term :: IParser ParseExpr

126127term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])

127128 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

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

129130

130131-------- Applications --------

131132

132−appExpr :: IParser LParseExpr

133+appExpr :: IParser ParseExpr

133134appExpr = do

134135 t <- term

135136 ts <- constrainedSpacePrefix term $ \str ->

136137 if null str then notFollowedBy (char '-') else return ()

137138 return $ case ts of

138139 [] -> t

139− _ -> foldl' (\f x -> Location.merge f x $ App f x) t ts

140+ _ -> foldl' (\f x -> Annotation.merge f x $ App f x) t ts

140141

141142-------- Normal Expressions --------

142143

143−binaryExpr :: IParser LParseExpr

144+binaryExpr :: IParser ParseExpr

144145binaryExpr = binops appExpr lastExpr anyOp

145146 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

146147 <|> lambdaExpr

147148

148−ifExpr :: IParser ParseExpr

149+ifExpr :: IParser ParseExpr'

149150ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

150151 where

151152 normal = do

@@ -155,13 +156,13 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

155156 whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace

156157 elseBranch <- expr

157158 return $ MultiIf [(bool, thenBranch),

158− (Location.sameAs elseBranch (Literal . Literal.Boolean $ True), elseBranch)]

159+ (Annotation.sameAs elseBranch (Literal . L.Boolean $ True), elseBranch)]

159160 multiIf = MultiIf <$> spaceSep1 iff

160161 where iff = do string "|" ; whitespace

161162 b <- expr ; padded arrow

162163 (,) b <$> expr

163164

164−lambdaExpr :: IParser LParseExpr

165+lambdaExpr :: IParser ParseExpr

165166lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

166167 whitespace

167168 args <- spaceSep1 Pattern.term

@@ -172,14 +173,14 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

172173defSet :: IParser [ParseDef]

173174defSet = block (do d <- def ; whitespace ; return d)

174175

175−letExpr :: IParser ParseExpr

176+letExpr :: IParser ParseExpr'

176177letExpr = do

177178 reserved "let" ; whitespace

178179 defs <- defSet

179180 padded (reserved "in")

180181 Let defs <$> expr

181182

182−caseExpr :: IParser ParseExpr

183+caseExpr :: IParser ParseExpr'

183184caseExpr = do

184185 reserved "case"; e <- padded expr; reserved "of"; whitespace

185186 Case e <$> (with <|> without)

@@ -189,35 +190,35 @@ caseExpr = do

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

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

191192

192−expr :: IParser LParseExpr

193+expr :: IParser ParseExpr

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

194195 <|> lambdaExpr

195196 <|> binaryExpr

196197 <?> "an expression"

197198

198−defStart :: IParser [Pattern]

199+defStart :: IParser [P.Pattern]

199200defStart =

200201 choice [ do p1 <- try Pattern.term

201202 infics p1 <|> func p1

202− , func =<< (PVar <$> parens symOp)

203+ , func =<< (P.Var <$> parens symOp)

203204 , (:[]) <$> Pattern.expr

204205 ] <?> "the definition of a variable (x = ...)"

205206 where

206207 func pattern =

207208 case pattern of

208− PVar _ -> (pattern:) <$> spacePrefix Pattern.term

209+ P.Var _ -> (pattern:) <$> spacePrefix Pattern.term

209210 _ -> do try (lookAhead (whitespace >> string "="))

210211 return [pattern]

211212

212213 infics p1 = do

213214 o:p <- try (whitespace >> anyOp)

214215 p2 <- (whitespace >> Pattern.term)

215− return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]

216− else [ PVar (o:p), p1, p2 ]

216+ return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]

217+ else [ P.Var (o:p), p1, p2 ]

217218

218−makeFunction :: [Pattern] -> LParseExpr -> LParseExpr

219−makeFunction args body@(L s _) =

220− foldr (\arg body' -> L s $ Lambda arg body') body args

219+makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr

220+makeFunction args body@(A ann _) =

221+ foldr (\arg body' -> A ann $ Lambda arg body') body args

221222

222223definition :: IParser ParseDef

223224definition = withPos $ do

compiler/Parse/Helpers.hs+14−11

@@ -12,11 +12,12 @@ import Text.Parsec hiding (newline,spaces,State)

1212import Text.Parsec.Indent

1313import qualified Text.Parsec.Token as T

1414

15−import SourceSyntax.Helpers as Help

16−import SourceSyntax.Location as Location

15+import SourceSyntax.Annotation as Annotation

16+import SourceSyntax.Declaration (Assoc)

1717import SourceSyntax.Expression

18+import SourceSyntax.Helpers as Help

1819import SourceSyntax.PrettyPrint

19−import SourceSyntax.Declaration (Assoc)

20+import SourceSyntax.Variable as Variable

2021

2122reserveds = [ "if", "then", "else"

2223 , "case", "of"

@@ -181,10 +182,10 @@ parens = surround '(' ')' "paren"

181182brackets :: IParser a -> IParser a

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

183184

184−addLocation :: (Pretty a) => IParser a -> IParser (Location.Located a)

185+addLocation :: (Pretty a) => IParser a -> IParser (Annotation.Located a)

185186addLocation expr = do

186187 (start, e, end) <- located expr

187− return (Location.at start end e)

188+ return (Annotation.at start end e)

188189

189190located :: IParser a -> IParser (SourcePos, a, SourcePos)

190191located p = do

@@ -193,10 +194,10 @@ located p = do

193194 end <- getPosition

194195 return (start, e, end)

195196

196−accessible :: IParser LParseExpr -> IParser LParseExpr

197+accessible :: IParser ParseExpr -> IParser ParseExpr

197198accessible expr = do

198199 start <- getPosition

199− ce@(L _ e) <- expr

200+ ce@(A _ e) <- expr

200201 let rest f = do

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

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

@@ -205,10 +206,12 @@ accessible expr = do

205206 Just _ -> accessible $ do

206207 v <- var <?> "field access (e.g. List.map)"

207208 end <- getPosition

208− return (Location.at start end (f v))

209− case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))

210− | otherwise -> rest (Access ce)

211− _ -> rest (Access ce)

209+ return (Annotation.at start end (f v))

210+ case e of

211+ Var (Variable.Raw (c:cs))

212+ | isUpper c -> rest (\v -> rawVar (c:cs ++ '.':v))

213+ | otherwise -> rest (Access ce)

214+ _ -> rest (Access ce)

212215

213216

214217spaces :: IParser String

compiler/Parse/Pattern.hs+29−27

@@ -3,57 +3,59 @@ module Parse.Pattern (term, expr) where

33

44import Control.Applicative ((<$>))

55import Data.Char (isUpper)

6−import Data.List (intercalate)

6+import qualified Data.List as List

77import Text.Parsec hiding (newline,spaces,State)

88

99import Parse.Helpers

1010import Parse.Literal

1111import SourceSyntax.Literal

12−import SourceSyntax.Pattern hiding (tuple, list)

13−import qualified SourceSyntax.Pattern as Pattern

12+import qualified SourceSyntax.Pattern as P

1413

15−basic :: IParser Pattern

14+basic :: IParser P.Pattern

1615basic = choice

17− [ char '_' >> return PAnything

16+ [ char '_' >> return P.Anything

1817 , do v <- var

1918 return $ case v of

20− "True" -> PLiteral (Boolean True)

21− "False" -> PLiteral (Boolean False)

22− c:_ | isUpper c -> PData v []

23− _ -> PVar v

24− , PLiteral <$> literal

19+ "True" -> P.Literal (Boolean True)

20+ "False" -> P.Literal (Boolean False)

21+ c:_ | isUpper c -> P.Data v []

22+ _ -> P.Var v

23+ , P.Literal <$> literal

2524 ]

2625

27−asPattern :: Pattern -> IParser Pattern

26+asPattern :: P.Pattern -> IParser P.Pattern

2827asPattern pattern = do

2928 var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))

3029 return $ case var of

31− Just v -> PAlias v pattern

30+ Just v -> P.Alias v pattern

3231 Nothing -> pattern

3332

34−record :: IParser Pattern

35−record = PRecord <$> brackets (commaSep1 lowVar)

33+record :: IParser P.Pattern

34+record = P.Record <$> brackets (commaSep1 lowVar)

3635

37−tuple :: IParser Pattern

38−tuple = do ps <- parens (commaSep expr)

39− return $ case ps of { [p] -> p; _ -> Pattern.tuple ps }

36+tuple :: IParser P.Pattern

37+tuple = do

38+ ps <- parens (commaSep expr)

39+ return $ case ps of

40+ [p] -> p

41+ _ -> P.tuple ps

4042

41−list :: IParser Pattern

42−list = Pattern.list <$> braces (commaSep expr)

43+list :: IParser P.Pattern

44+list = P.list <$> braces (commaSep expr)

4345

44−term :: IParser Pattern

46+term :: IParser P.Pattern

4547term =

4648 (choice [ record, tuple, list, basic ]) <?> "pattern"

4749

48−patternConstructor :: IParser Pattern

50+patternConstructor :: IParser P.Pattern

4951patternConstructor = do

50− v <- intercalate "." <$> dotSep1 capVar

52+ v <- List.intercalate "." <$> dotSep1 capVar

5153 case v of

52− "True" -> return $ PLiteral (Boolean True)

53− "False" -> return $ PLiteral (Boolean False)

54− _ -> PData v <$> spacePrefix term

54+ "True" -> return $ P.Literal (Boolean True)

55+ "False" -> return $ P.Literal (Boolean False)

56+ _ -> P.Data v <$> spacePrefix term

5557

56−expr :: IParser Pattern

58+expr :: IParser P.Pattern

5759expr = do

5860 patterns <- consSep1 (patternConstructor <|> term)

59− asPattern (foldr1 Pattern.cons patterns) <?> "pattern"

61+ asPattern (foldr1 P.cons patterns) <?> "pattern"

compiler/SourceSyntax/Annotation.hsnew file+74

@@ -0,0 +1,74 @@

1+{-# OPTIONS_GHC -W #-}

2+module SourceSyntax.Annotation where

3+

4+import qualified Text.Parsec.Pos as Parsec

5+import qualified Text.PrettyPrint as P

6+import SourceSyntax.PrettyPrint

7+

8+data Annotated annotation expr = A annotation expr

9+ deriving (Show)

10+

11+data Region

12+ = Span Position Position P.Doc

13+ | None P.Doc

14+ deriving (Show)

15+

16+data Position = Position

17+ { line :: Int

18+ , column :: Int

19+ } deriving (Show)

20+

21+type Located expr = Annotated Region expr

22+

23+none e = A (None (pretty e)) e

24+noneNoDocs e = A (None P.empty) e

25+

26+at :: (Pretty expr) => Parsec.SourcePos -> Parsec.SourcePos -> expr

27+ -> Annotated Region expr

28+at start end e =

29+ A (Span (position start) (position end) (pretty e)) e

30+ where

31+ position loc = Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc)

32+

33+merge (A s1 _) (A s2 _) e =

34+ A (span (pretty e)) e

35+ where

36+ span = case (s1,s2) of

37+ (Span start _ _, Span _ end _) -> Span start end

38+ (Span start end _, _) -> Span start end

39+ (_, Span start end _) -> Span start end

40+ (_, _) -> None

41+

42+mergeOldDocs (A s1 _) (A s2 _) e =

43+ A span e

44+ where

45+ span = case (s1,s2) of

46+ (Span start _ d1, Span _ end d2) ->

47+ Span start end (P.vcat [d1, P.text "\n", d2])

48+

49+ (Span _ _ _, _) -> s1

50+ (_, Span _ _ _) -> s2

51+ (_, _) -> None P.empty

52+

53+sameAs :: Annotated a expr -> expr' -> Annotated a expr'

54+sameAs (A annotation _) expr = A annotation expr

55+

56+getRegionDocs region =

57+ case region of

58+ Span _ _ doc -> doc

59+ None doc -> doc

60+

61+instance Pretty Region where

62+ pretty span =

63+ case span of

64+ None _ -> P.empty

65+ Span start end _ ->

66+ P.text $

67+ case line start == line end of

68+ False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)

69+ True -> "on line " ++ show (line end) ++ ", column " ++

70+ show (column start) ++ " to " ++ show (column end)

71+

72+instance Pretty e => Pretty (Annotated a e) where

73+ pretty (A _ e) = pretty e

74+

compiler/SourceSyntax/Declaration.hs+2−2

@@ -20,11 +20,11 @@ data Assoc = L | N | R

2020

2121data ParsePort

2222 = PPAnnotation String T.Type

23− | PPDef String Expr.LParseExpr

23+ | PPDef String Expr.ParseExpr

2424 deriving (Show)

2525

2626data Port

27− = Out String Expr.LExpr T.Type

27+ = Out String Expr.Expr T.Type

2828 | In String T.Type

2929 deriving (Show)

3030

compiler/SourceSyntax/Expression.hs+88−62

@@ -11,49 +11,54 @@ module SourceSyntax.Expression where

1111import SourceSyntax.PrettyPrint

1212import Text.PrettyPrint as P

1313import qualified SourceSyntax.Helpers as Help

14−import qualified SourceSyntax.Location as Location

14+import qualified SourceSyntax.Annotation as Annotation

1515import qualified SourceSyntax.Pattern as Pattern

1616import qualified SourceSyntax.Type as SrcType

1717import qualified SourceSyntax.Literal as Literal

18+import qualified SourceSyntax.Variable as Variable

1819

1920---- GENERAL AST ----

2021

21−{-| This is a located expression, meaning it is tagged with info about where it

22−came from in the source code. Expr' is defined in terms of LExpr' so that the

23−location information does not need to be an extra field on every constructor.

24−-}

25−type LExpr' def = Location.Located (Expr' def)

26−

2722{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has

2823"type holes" that allow us to enrich the AST with additional information as we

29−move through the compilation process. The type holes let us show these

30−structural changes in the types. The only type hole right now is:

24+move through the compilation process. The type holes are used to represent:

25+

26+ ann: Annotations for arbitrary expressions. Allows you to add information

27+ to the AST like position in source code or inferred types.

28+

29+ def: Definition style. The source syntax separates type annotations and

30+ definitions, but after parsing we check that they are well formed and

31+ collapse them.

3132

32− def: Parsing allows two kinds of definitions (type annotations or definitions),

33− but later checks will see that they are well formed and combine them.

33+ var: Representation of variables. Starts as strings, but is later enriched

34+ with information about what module a variable came from.

3435

3536-}

36−data Expr' def

37+type GeneralExpr annotation definition variable =

38+ Annotation.Annotated annotation (GeneralExpr' annotation definition variable)

39+

40+data GeneralExpr' ann def var

3741 = Literal Literal.Literal

38− | Var String

39− | Range (LExpr' def) (LExpr' def)

40− | ExplicitList [LExpr' def]

41− | Binop String (LExpr' def) (LExpr' def)

42− | Lambda Pattern.Pattern (LExpr' def)

43− | App (LExpr' def) (LExpr' def)

44− | MultiIf [(LExpr' def,LExpr' def)]

45− | Let [def] (LExpr' def)

46− | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]

47− | Data String [LExpr' def]

48− | Access (LExpr' def) String

49− | Remove (LExpr' def) String

50− | Insert (LExpr' def) String (LExpr' def)

51− | Modify (LExpr' def) [(String, LExpr' def)]

52− | Record [(String, LExpr' def)]

53− | Markdown String String [LExpr' def]

42+ | Var var

43+ | Range (GeneralExpr ann def var) (GeneralExpr ann def var)

44+ | ExplicitList [GeneralExpr ann def var]

45+ | Binop String (GeneralExpr ann def var) (GeneralExpr ann def var)

46+ | Lambda Pattern.Pattern (GeneralExpr ann def var)

47+ | App (GeneralExpr ann def var) (GeneralExpr ann def var)

48+ | MultiIf [(GeneralExpr ann def var,GeneralExpr ann def var)]

49+ | Let [def] (GeneralExpr ann def var)

50+ | Case (GeneralExpr ann def var) [(Pattern.Pattern, GeneralExpr ann def var)]

51+ | Data String [GeneralExpr ann def var]

52+ | Access (GeneralExpr ann def var) String

53+ | Remove (GeneralExpr ann def var) String

54+ | Insert (GeneralExpr ann def var) String (GeneralExpr ann def var)

55+ | Modify (GeneralExpr ann def var) [(String, GeneralExpr ann def var)]

56+ | Record [(String, GeneralExpr ann def var)]

57+ | Markdown String String [GeneralExpr ann def var]

5458 -- for type checking and code gen only

5559 | PortIn String SrcType.Type

56− | PortOut String SrcType.Type (LExpr' def)

60+ | PortOut String SrcType.Type (GeneralExpr ann def var)

61+ deriving (Show)

5762

5863

5964---- SPECIALIZED ASTs ----

@@ -62,81 +67,100 @@ data Expr' def

6267annotations and definitions, which is how they appear in source code and how

6368they are parsed.

6469-}

65−type ParseExpr = Expr' ParseDef

66−type LParseExpr = LExpr' ParseDef

70+type ParseExpr = GeneralExpr Annotation.Region ParseDef Variable.Raw

71+type ParseExpr' = GeneralExpr' Annotation.Region ParseDef Variable.Raw

6772

6873data ParseDef

69− = Def Pattern.Pattern LParseExpr

74+ = Def Pattern.Pattern ParseExpr

7075 | TypeAnnotation String SrcType.Type

71− deriving (Show)

76+ deriving (Show)

7277

7378{-| "Normal" expressions. When the compiler checks that type annotations and

7479ports are all paired with definitions in the appropriate order, it collapses

7580them into a Def that is easier to work with in later phases of compilation.

7681-}

77−type LExpr = LExpr' Def

78−type Expr = Expr' Def

82+type Expr = GeneralExpr Annotation.Region Def Variable.Raw

83+type Expr' = GeneralExpr' Annotation.Region Def Variable.Raw

7984

80−data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)

85+data Def = Definition Pattern.Pattern Expr (Maybe SrcType.Type)

8186 deriving (Show)

8287

8388

89+

8490---- UTILITIES ----

8591

86−tuple :: [LExpr' def] -> Expr' def

92+rawVar :: String -> GeneralExpr' ann def Variable.Raw

93+rawVar x = Var (Variable.Raw x)

94+

95+tuple :: [GeneralExpr ann def var] -> GeneralExpr' ann def var

8796tuple es = Data ("_Tuple" ++ show (length es)) es

8897

89−delist :: LExpr' def -> [LExpr' def]

90−delist (Location.L _ (Data "::" [h,t])) = h : delist t

98+delist :: GeneralExpr ann def var -> [GeneralExpr ann def var]

99+delist (Annotation.A _ (Data "::" [h,t])) = h : delist t

91100delist _ = []

92101

93102saveEnvName :: String

94103saveEnvName = "_save_the_environment!!!"

95104

96−dummyLet :: Pretty def => [def] -> LExpr' def

105+dummyLet :: (Pretty def) => [def] -> GeneralExpr Annotation.Region def Variable.Raw

97106dummyLet defs =

98− Location.none $ Let defs (Location.none $ Var saveEnvName)

107+ Annotation.none $ Let defs (Annotation.none $ rawVar saveEnvName)

99108

100−instance Pretty def => Show (Expr' def) where

101− show = render . pretty

102−

103−instance Pretty def => Pretty (Expr' def) where

109+instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where

104110 pretty expr =

105111 case expr of

106112 Literal lit -> pretty lit

107− Var x -> variable x

113+

114+ Var x -> pretty x

115+

108116 Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)

117+

109118 ExplicitList es -> P.brackets (commaCat (map pretty es))

110− Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->

119+

120+ Binop "-" (Annotation.A _ (Literal (Literal.IntNum 0))) e ->

111121 P.text "-" <> prettyParens e

122+

112123 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]

113− where op' = if Help.isOp op then op else "`" ++ op ++ "`"

124+ where

125+ op' = if Help.isOp op then op else "`" ++ op ++ "`"

126+

114127 Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body

115128 where

116− (ps,body) = collectLambdas (Location.none $ Lambda p e)

129+ (ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)

117130 args = P.sep (map Pattern.prettyParens ps)

131+

118132 App _ _ -> P.hang func 2 (P.sep args)

119− where func:args = map prettyParens (collectApps (Location.none expr))

120− MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)

133+ where

134+ func:args = map prettyParens (collectApps (Annotation.A undefined expr))

135+

136+ MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)

121137 where

122138 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)

139+

123140 Let defs e ->

124141 P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))

125142 , P.text "in" <+> pretty e ]

143+

126144 Case e pats ->

127145 P.hang pexpr 2 (P.vcat (map pretty' pats))

128146 where

129147 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]

130148 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b

149+

131150 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl

132151 Data "[]" [] -> P.text "[]"

133152 Data name es

134153 | Help.isTuple name -> P.parens (commaCat (map pretty es))

135154 | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))

155+

136156 Access e x -> prettyParens e <> P.text "." <> variable x

157+

137158 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)

138− Insert (Location.L _ (Remove e y)) x v ->

139− P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)

159+

160+ Insert (Annotation.A _ (Remove e y)) x v ->

161+ P.braces $ P.hsep [ pretty e, P.text "-", variable y, P.text "|"

162+ , variable x, P.equals, pretty v ]

163+

140164 Insert e x v ->

141165 P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)

142166

@@ -175,21 +199,23 @@ instance Pretty Def where

175199 Nothing -> P.empty

176200 Just tipe -> pretty pattern <+> P.colon <+> pretty tipe

177201

178−collectApps :: LExpr' def -> [LExpr' def]

179−collectApps lexpr@(Location.L _ expr) =

202+collectApps :: GeneralExpr ann def var -> [GeneralExpr ann def var]

203+collectApps annExpr@(Annotation.A _ expr) =

180204 case expr of

181205 App a b -> collectApps a ++ [b]

182− _ -> [lexpr]

206+ _ -> [annExpr]

183207

184−collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)

185−collectLambdas lexpr@(Location.L _ expr) =

208+collectLambdas :: GeneralExpr ann def var -> ([Pattern.Pattern], GeneralExpr ann def var)

209+collectLambdas lexpr@(Annotation.A _ expr) =

186210 case expr of

187− Lambda pattern body -> (pattern : ps, body')

188− where (ps, body') = collectLambdas body

211+ Lambda pattern body ->

212+ let (ps, body') = collectLambdas body

213+ in (pattern : ps, body')

214+

189215 _ -> ([], lexpr)

190216

191−prettyParens :: (Pretty def) => LExpr' def -> Doc

192−prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

217+prettyParens :: (Pretty def, Pretty var) => GeneralExpr ann def var -> Doc

218+prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)

193219 where

194220 needed =

195221 case expr of

compiler/SourceSyntax/Location.hsdeleted−58

@@ -1,58 +0,0 @@

1−module SourceSyntax.Location where

2−

3−import Text.PrettyPrint

4−import SourceSyntax.PrettyPrint

5−import qualified Text.Parsec.Pos as Parsec

6−

7−data SrcPos = Pos { line :: Int, column :: Int }

8− deriving (Eq, Ord)

9−

10−data SrcSpan = Span SrcPos SrcPos String | NoSpan String

11− deriving (Eq, Ord)

12−

13−data Located e = L SrcSpan e

14− deriving (Eq, Ord)

15−

16−none e = L (NoSpan (render $ pretty e)) e

17−noneNoDocs = L (NoSpan "")

18−

19−at start end e = L (Span (Pos (Parsec.sourceLine start) (Parsec.sourceColumn start))

20− (Pos (Parsec.sourceLine end ) (Parsec.sourceColumn end ))

21− (render $ pretty e)) e

22−

23−merge (L s1 _) (L s2 _) e = L (span (render $ pretty e)) e

24− where span = case (s1,s2) of

25− (Span start _ _, Span _ end _) -> Span start end

26− (Span start end _, _) -> Span start end

27− (_, Span start end _) -> Span start end

28− (_, _) -> NoSpan

29−

30−mergeOldDocs (L s1 _) (L s2 _) e = L span e

31− where span = case (s1,s2) of

32− (Span start _ d1, Span _ end d2) -> Span start end (d1 ++ "\n\n" ++ d2)

33− (Span _ _ _, _) -> s1

34− (_, Span _ _ _) -> s2

35− (_, _) -> NoSpan ""

36−

37−sameAs (L s _) = L s

38−

39−

40−instance Show SrcPos where

41− show (Pos r c) = show r ++ "," ++ show c

42−

43−instance Show SrcSpan where

44− show span =

45− case span of

46− NoSpan _ -> ""

47− Span start end _ ->

48− case line start == line end of

49− False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)

50− True -> "on line " ++ show (line end) ++ ", column " ++

51− show (column start) ++ " to " ++ show (column end)

52−

53−instance Show e => Show (Located e) where

54− show (L _ e) = show e

55−

56−instance Pretty a => Pretty (Located a) where

57− pretty (L _ e) = pretty e

58−

compiler/SourceSyntax/Module.hs+6−6

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

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

88import Text.PrettyPrint as P

99

10−import SourceSyntax.Expression (LExpr)

10+import SourceSyntax.Expression (Expr)

1111import SourceSyntax.Declaration

1212import SourceSyntax.PrettyPrint

1313import SourceSyntax.Type

@@ -30,12 +30,12 @@ instance (Pretty def) => Pretty (Module def) where

3030 where

3131 prettyDecls = P.sep $ map pretty decls

3232

33− modul = P.text "module" <+> moduleName <+> where'

33+ modul = P.text "module" <+> moduleName <+> prettyExports <+> P.text "where"

3434 moduleName = P.text $ List.intercalate "." modNames

35− where' =

35+ prettyExports =

3636 case exports of

37− [] -> P.text "where"

38− _ -> P.parens (commaCat $ map P.text exports) <+> P.text "where"

37+ [] -> P.empty

38+ _ -> P.parens . commaCat $ map P.text exports

3939

4040 prettyImports = P.vcat $ map prettyImport imports

4141

@@ -72,7 +72,7 @@ data MetadataModule =

7272 , path :: FilePath

7373 , exports :: [String]

7474 , imports :: [(String, ImportMethod)]

75− , program :: LExpr

75+ , program :: Expr

7676 , types :: Map.Map String Type

7777 , fixities :: [(Assoc, Int, String)]

7878 , aliases :: [Alias]

compiler/SourceSyntax/Pattern.hs+30−26

@@ -7,50 +7,54 @@ import Text.PrettyPrint as PP

77import qualified Data.Set as Set

88import SourceSyntax.Literal as Literal

99

10−data Pattern = PData String [Pattern]

11− | PRecord [String]

12− | PAlias String Pattern

13− | PVar String

14− | PAnything

15− | PLiteral Literal.Literal

16− deriving (Eq, Ord, Show)

10+data Pattern

11+ = Data String [Pattern]

12+ | Record [String]

13+ | Alias String Pattern

14+ | Var String

15+ | Anything

16+ | Literal Literal.Literal

17+ deriving (Eq, Ord, Show)

1718

1819cons :: Pattern -> Pattern -> Pattern

19−cons h t = PData "::" [h,t]

20+cons h t = Data "::" [h,t]

2021

2122nil :: Pattern

22−nil = PData "[]" []

23+nil = Data "[]" []

2324

2425list :: [Pattern] -> Pattern

2526list = foldr cons nil

2627

2728tuple :: [Pattern] -> Pattern

28−tuple es = PData ("_Tuple" ++ show (length es)) es

29+tuple es = Data ("_Tuple" ++ show (length es)) es

30+

31+boundVarList :: Pattern -> [String]

32+boundVarList = Set.toList . boundVars

2933

3034boundVars :: Pattern -> Set.Set String

3135boundVars pattern =

3236 case pattern of

33− PVar x -> Set.singleton x

34− PAlias x p -> Set.insert x (boundVars p)

35− PData _ ps -> Set.unions (map boundVars ps)

36− PRecord fields -> Set.fromList fields

37− PAnything -> Set.empty

38− PLiteral _ -> Set.empty

37+ Var x -> Set.singleton x

38+ Alias x p -> Set.insert x (boundVars p)

39+ Data _ ps -> Set.unions (map boundVars ps)

40+ Record fields -> Set.fromList fields

41+ Anything -> Set.empty

42+ Literal _ -> Set.empty

3943

4044

4145instance Pretty Pattern where

4246 pretty pattern =

4347 case pattern of

44− PVar x -> variable x

45− PLiteral lit -> pretty lit

46− PRecord fs -> PP.braces (commaCat $ map variable fs)

47− PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x

48− PAnything -> PP.text "_"

49− PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl

48+ Var x -> variable x

49+ Literal lit -> pretty lit

50+ Record fs -> PP.braces (commaCat $ map variable fs)

51+ Alias x p -> prettyParens p <+> PP.text "as" <+> variable x

52+ Anything -> PP.text "_"

53+ Data "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl

5054 where isCons = case hd of

51− PData "::" _ -> True

55+ Data "::" _ -> True

5256 _ -> False

53− PData name ps ->

57+ Data name ps ->

5458 if Help.isTuple name then

5559 PP.parens . commaCat $ map pretty ps

5660 else hsep (PP.text name : map prettyParens ps)

@@ -60,6 +64,6 @@ prettyParens pattern = parensIf needsThem (pretty pattern)

6064 where

6165 needsThem =

6266 case pattern of

63− PData name (_:_) | not (Help.isTuple name) -> True

64− PAlias _ _ -> True

67+ Data name (_:_) | not (Help.isTuple name) -> True

68+ Alias _ _ -> True

6569 _ -> False

compiler/SourceSyntax/PrettyPrint.hs+5

@@ -10,11 +10,16 @@ class Pretty a where

1010instance Pretty () where

1111 pretty () = empty

1212

13+renderPretty :: (Pretty a) => a -> String

14+renderPretty e = render (pretty e)

15+

1316commaCat docs = cat (punctuate comma docs)

1417commaSep docs = sep (punctuate comma docs)

1518

19+parensIf :: Bool -> Doc -> Doc

1620parensIf bool doc = if bool then parens doc else doc

1721

22+variable :: String -> Doc

1823variable x =

1924 if Help.isOp x then parens (text x)

2025 else text (reprime x)

compiler/SourceSyntax/Type.hs+3−6

@@ -1,18 +1,18 @@

11{-# OPTIONS_GHC -W #-}

22module SourceSyntax.Type where

33

4+import Control.Applicative ((<$>), (<*>))

45import Data.Binary

56import qualified Data.Map as Map

6−import qualified SourceSyntax.Helpers as Help

7−import Control.Applicative ((<$>), (<*>))

87import SourceSyntax.PrettyPrint

8+import qualified SourceSyntax.Helpers as Help

99import Text.PrettyPrint as P

1010

1111data Type = Lambda Type Type

1212 | Var String

1313 | Data String [Type]

1414 | Record [(String,Type)] (Maybe String)

15− deriving (Eq)

15+ deriving (Eq,Show)

1616

1717fieldMap :: [(String,a)] -> Map.Map String [a]

1818fieldMap fields =

@@ -27,9 +27,6 @@ listOf t = Data "_List" [t]

2727tupleOf :: [Type] -> Type

2828tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts

2929

30−instance Show Type where

31− show = render . pretty

32−

3330instance Pretty Type where

3431 pretty tipe =

3532 case tipe of

compiler/SourceSyntax/Variable.hsnew file+11

@@ -0,0 +1,11 @@

1+

2+module SourceSyntax.Variable where

3+

4+import qualified Text.PrettyPrint as P

5+import SourceSyntax.PrettyPrint

6+

7+newtype Raw = Raw String

8+ deriving (Eq,Ord,Show)

9+

10+instance Pretty Raw where

11+ pretty (Raw var) = variable var

compiler/Transform/Canonicalize.hs+23−21

@@ -1,19 +1,20 @@

1−{-# OPTIONS_GHC -W #-}

1+{-# OPTIONS_GHC -Wall #-}

22module Transform.Canonicalize (interface, metadataModule) where

33

44import Control.Arrow ((***))

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

66import Control.Monad.Identity

7−import qualified Data.Traversable as T

7+import qualified Data.Either as Either

8+import qualified Data.List as List

89import qualified Data.Map as Map

910import qualified Data.Set as Set

10−import qualified Data.List as List

11−import qualified Data.Either as Either

12−import SourceSyntax.Module

11+import qualified Data.Traversable as T

12+import SourceSyntax.Annotation as A

1313import SourceSyntax.Expression

14−import SourceSyntax.Location as Loc

14+import SourceSyntax.Module

1515import qualified SourceSyntax.Pattern as P

1616import qualified SourceSyntax.Type as Type

17+import qualified SourceSyntax.Variable as Var

1718import Text.PrettyPrint as P

1819

1920interface :: String -> ModuleInterface -> ModuleInterface

@@ -96,8 +97,7 @@ type Env = Map.Map String String

9697

9798extend :: Env -> P.Pattern -> Env

9899extend env pattern = Map.union (Map.fromList (zip xs xs)) env

99− where xs = Set.toList (P.boundVars pattern)

100−

100+ where xs = P.boundVarList pattern

101101

102102replace :: String -> Env -> String -> Either String String

103103replace variable env v =

@@ -110,14 +110,15 @@ replace variable env v =

110110 msg = if null matches then "" else

111111 "\nClose matches include: " ++ List.intercalate ", " matches

112112

113−rename :: Env -> LExpr -> Either [Doc] LExpr

114−rename env (L s expr) =

113+-- TODO: Var.Raw -> Var.Canonical

114+rename :: Env -> Expr -> Either [Doc] Expr

115+rename env (A ann expr) =

115116 let rnm = rename env

116− throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]

117+ throw err = Left [ P.text $ "Error " ++ show ann ++ "\n" ++ err ]

117118 format = Either.either throw return

118− renameType' env = renameType (format . replace "variable" env)

119+ renameType' environ = renameType (format . replace "variable" environ)

119120 in

120− L s <$>

121+ A ann <$>

121122 case expr of

122123 Literal _ -> return expr

123124

@@ -155,7 +156,8 @@ rename env (L s expr) =

155156 <*> rename env' body

156157 <*> T.traverse (renameType' env') mtipe

157158

158− Var x -> Var <$> format (replace "variable" env x)

159+ -- TODO: Raw -> Canonical

160+ Var (Var.Raw x) -> rawVar <$> format (replace "variable" env x)

159161

160162 Data name es -> Data name <$> mapM rnm es

161163

@@ -176,10 +178,10 @@ rename env (L s expr) =

176178renamePattern :: Env -> P.Pattern -> Either String P.Pattern

177179renamePattern env pattern =

178180 case pattern of

179− P.PVar _ -> return pattern

180− P.PLiteral _ -> return pattern

181− P.PRecord _ -> return pattern

182− P.PAnything -> return pattern

183− P.PAlias x p -> P.PAlias x <$> renamePattern env p

184− P.PData name ps -> P.PData <$> replace "pattern" env name

185− <*> mapM (renamePattern env) ps

181+ P.Var _ -> return pattern

182+ P.Literal _ -> return pattern

183+ P.Record _ -> return pattern

184+ P.Anything -> return pattern

185+ P.Alias x p -> P.Alias x <$> renamePattern env p

186+ P.Data name ps -> P.Data <$> replace "pattern" env name

187+ <*> mapM (renamePattern env) ps

compiler/Transform/Check.hs+4−5

@@ -32,7 +32,7 @@ dupErr err x =

3232

3333duplicates :: [D.Declaration] -> [String]

3434duplicates decls =

35− map msg (dups (portNames ++ concatMap getNames defPatterns)) ++

35+ map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++

3636 case mapM exprDups (portExprs ++ defExprs) of

3737 Left name -> [msg name]

3838 Right _ -> []

@@ -50,14 +50,13 @@ duplicates decls =

5050 D.Out name expr _ -> (name, [expr])

5151 D.In name _ -> (name, [])

5252

53− getNames = Set.toList . Pattern.boundVars

54−

55− exprDups :: E.LExpr -> Either String E.LExpr

53+ exprDups :: E.Expr -> Either String E.Expr

5654 exprDups expr = Expr.crawlLet defsDups expr

5755

5856 defsDups :: [E.Def] -> Either String [E.Def]

5957 defsDups defs =

60− case dups $ concatMap (\(E.Definition name _ _) -> getNames name) defs of

58+ let varsIn (E.Definition pattern _ _) = Pattern.boundVarList pattern in

59+ case dups $ concatMap varsIn defs of

6160 [] -> Right defs

6261 name:_ -> Left name

6362

compiler/Transform/Declaration.hs+1−1

@@ -42,7 +42,7 @@ combineAnnotations = go

4242

4343 TypeAnnotation name tipe ->

4444 case defRest of

45− D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' ->

45+ D.Definition (Def pat@(P.Var name') expr) : rest | name == name' ->

4646 do expr' <- exprCombineAnnotations expr

4747 let def' = E.Definition pat expr' (Just tipe)

4848 (:) (D.Definition def') <$> go rest

compiler/Transform/Definition.hs+1−1

@@ -16,7 +16,7 @@ combineAnnotations = go

1616

1717 go defs =

1818 case defs of

19− TypeAnnotation name tipe : Def pat@(P.PVar name') expr : rest | name == name' ->

19+ TypeAnnotation name tipe : Def pat@(P.Var name') expr : rest | name == name' ->

2020 do expr' <- exprCombineAnnotations expr

2121 let def = Definition pat expr' (Just tipe)

2222 (:) def <$> go rest

compiler/Transform/Expression.hs+15−13

@@ -2,17 +2,19 @@

22module Transform.Expression (crawlLet, checkPorts) where

33

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

5+import SourceSyntax.Annotation ( Annotated(A) )

56import SourceSyntax.Expression

6−import SourceSyntax.Location

7−import qualified SourceSyntax.Type as ST

7+import SourceSyntax.Type (Type)

88

9−crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')

9+crawlLet :: ([def] -> Either a [def'])

10+ -> GeneralExpr ann def var

11+ -> Either a (GeneralExpr ann def' var)

1012crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())

1113

12−checkPorts :: (String -> ST.Type -> Either a ())

13− -> (String -> ST.Type -> Either a ())

14− -> LExpr

15− -> Either a LExpr

14+checkPorts :: (String -> Type -> Either a ())

15+ -> (String -> Type -> Either a ())

16+ -> Expr

17+ -> Either a Expr

1618checkPorts inCheck outCheck expr =

1719 crawl inCheck outCheck (mapM checkDef) expr

1820 where

@@ -20,15 +22,15 @@ checkPorts inCheck outCheck expr =

2022 do _ <- checkPorts inCheck outCheck body

2123 return def

2224

23−crawl :: (String -> ST.Type -> Either a ())

24− -> (String -> ST.Type -> Either a ())

25+crawl :: (String -> Type -> Either a ())

26+ -> (String -> Type -> Either a ())

2527 -> ([def] -> Either a [def'])

26− -> LExpr' def

27− -> Either a (LExpr' def')

28+ -> GeneralExpr ann def var

29+ -> Either a (GeneralExpr ann def' var)

2830crawl portInCheck portOutCheck defsTransform = go

2931 where

30− go (L srcSpan expr) =

31− L srcSpan <$>

32+ go (A srcSpan expr) =

33+ A srcSpan <$>

3234 case expr of

3335 Var x -> return (Var x)

3436 Lambda p e -> Lambda p <$> go e

compiler/Transform/SafeNames.hs+19−18

@@ -1,43 +1,44 @@

11{-# OPTIONS_GHC -Wall #-}

22module Transform.SafeNames (metadataModule) where

33

4−import Control.Arrow (first, (***))

5−import Data.List (intercalate)

6−

4+import Control.Arrow (first, (***))

5+import qualified Data.List as List

76import qualified Data.Set as Set

87

9−import qualified Parse.Helpers as PHelp

8+import qualified Parse.Helpers as PHelp

9+import SourceSyntax.Annotation

1010import SourceSyntax.Expression

1111import qualified SourceSyntax.Helpers as SHelp

12−import SourceSyntax.Location

1312import SourceSyntax.Module

14−import SourceSyntax.Pattern

13+import qualified SourceSyntax.Pattern as P

14+import qualified SourceSyntax.Variable as Variable

1515

1616var :: String -> String

17−var = intercalate "." . map (dereserve . deprime) . SHelp.splitDots

17+var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots

1818 where

1919 deprime = map (\c -> if c == '\'' then '$' else c)

2020 dereserve x = case Set.member x PHelp.jsReserveds of

2121 False -> x

2222 True -> "$" ++ x

2323

24−pattern :: Pattern -> Pattern

24+pattern :: P.Pattern -> P.Pattern

2525pattern pat =

2626 case pat of

27− PVar x -> PVar (var x)

28− PLiteral _ -> pat

29− PRecord fs -> PRecord (map var fs)

30− PAnything -> pat

31− PAlias x p -> PAlias (var x) (pattern p)

32− PData name ps -> PData name (map pattern ps)

27+ P.Var x -> P.Var (var x)

28+ P.Literal _ -> pat

29+ P.Record fs -> P.Record (map var fs)

30+ P.Anything -> pat

31+ P.Alias x p -> P.Alias (var x) (pattern p)

32+ P.Data name ps -> P.Data name (map pattern ps)

3333

34−expression :: LExpr -> LExpr

35−expression (L loc expr) =

34+-- TODO: should be "normal expression" -> "expression for JS generation"

35+expression :: Expr -> Expr

36+expression (A ann expr) =

3637 let f = expression in

37− L loc $

38+ A ann $

3839 case expr of

3940 Literal _ -> expr

40− Var x -> Var (var x)

41+ Var (Variable.Raw x) -> rawVar (var x)

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

4243 ExplicitList es -> ExplicitList (map f es)

4344 Binop op e1 e2 -> Binop op (f e1) (f e2)

compiler/Transform/SortDefinitions.hs+18−17

@@ -3,23 +3,24 @@ module Transform.SortDefinitions (sortDefs) where

33

44import Control.Monad.State

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

6+import qualified Data.Graph as Graph

67import qualified Data.Map as Map

8+import qualified Data.Maybe as Maybe

9+import qualified Data.Set as Set

10+import SourceSyntax.Annotation

711import SourceSyntax.Expression

8−import SourceSyntax.Location

912import qualified SourceSyntax.Pattern as P

10−import qualified Data.Graph as Graph

11−import qualified Data.Set as Set

12−import qualified Data.Maybe as Maybe

13+import qualified SourceSyntax.Variable as V

1314

1415ctors :: P.Pattern -> [String]

1516ctors pattern =

1617 case pattern of

17− P.PVar _ -> []

18− P.PAlias _ p -> ctors p

19− P.PData ctor ps -> ctor : concatMap ctors ps

20− P.PRecord _ -> []

21− P.PAnything -> []

22− P.PLiteral _ -> []

18+ P.Var _ -> []

19+ P.Alias _ p -> ctors p

20+ P.Data ctor ps -> ctor : concatMap ctors ps

21+ P.Record _ -> []

22+ P.Anything -> []

23+ P.Literal _ -> []

2324

2425free :: String -> State (Set.Set String) ()

2526free x = modify (Set.insert x)

@@ -27,15 +28,15 @@ free x = modify (Set.insert x)

2728bound :: Set.Set String -> State (Set.Set String) ()

2829bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

2930

30−sortDefs :: LExpr -> LExpr

31+sortDefs :: Expr -> Expr

3132sortDefs expr = evalState (reorder expr) Set.empty

3233

33−reorder :: LExpr -> State (Set.Set String) LExpr

34−reorder (L s expr) =

35− L s <$>

34+reorder :: Expr -> State (Set.Set String) Expr

35+reorder (A ann expr) =

36+ A ann <$>

3637 case expr of

3738 -- Be careful adding and restricting freeVars

38− Var x -> free x >> return expr

39+ Var (V.Raw x) -> free x >> return expr

3940

4041 Lambda p e ->

4142 uncurry Lambda <$> bindingReorder (p,e)

@@ -103,11 +104,11 @@ reorder (L s expr) =

103104 bound (P.boundVars pattern)

104105 mapM free (ctors pattern)

105106

106− let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss

107+ let A _ let' = foldr (\ds bod -> A ann (Let ds bod)) body' defss

107108

108109 return let'

109110

110−bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)

111+bindingReorder :: (P.Pattern, Expr) -> State (Set.Set String) (P.Pattern, Expr)

111112bindingReorder (pattern,expr) =

112113 do expr' <- reorder expr

113114 bound (P.boundVars pattern)

compiler/Transform/Substitute.hs+8−6

@@ -2,14 +2,16 @@

22module Transform.Substitute (subst) where

33

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

5+import qualified Data.Set as Set

6+

7+import SourceSyntax.Annotation

58import SourceSyntax.Expression

6−import SourceSyntax.Location

79import qualified SourceSyntax.Pattern as Pattern

8−import qualified Data.Set as Set

10+import qualified SourceSyntax.Variable as V

911

10−subst :: String -> Expr -> Expr -> Expr

12+subst :: String -> Expr' -> Expr' -> Expr'

1113subst old new expr =

12− let f (L s e) = L s (subst old new e) in

14+ let f (A a e) = A a (subst old new e) in

1315 case expr of

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

1517 ExplicitList es -> ExplicitList (map f es)

@@ -28,7 +30,7 @@ subst old new expr =

2830 anyShadow =

2931 any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]

3032

31− Var x -> if x == old then new else expr

33+ Var (V.Raw x) -> if x == old then new else expr

3234 Case e cases -> Case (f e) $ map (second f) cases

3335 Data name es -> Data name (map f es)

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

@@ -39,4 +41,4 @@ subst old new expr =

3941 Literal _ -> expr

4042 Markdown uid md es -> Markdown uid md (map f es)

4143 PortIn name st -> PortIn name st

42− PortOut name st signal -> PortOut name st (f signal)

44+ PortOut name st signal -> PortOut name st (f signal)

compiler/Type/Constrain/Declaration.hs+23−23

@@ -1,62 +1,62 @@

11{-# OPTIONS_GHC -Wall #-}

22module Type.Constrain.Declaration where

33

4−import SourceSyntax.Declaration

4+import qualified SourceSyntax.Annotation as A

5+import qualified SourceSyntax.Declaration as D

56import qualified SourceSyntax.Expression as E

6−import qualified SourceSyntax.Location as L

77import qualified SourceSyntax.Pattern as P

88import qualified SourceSyntax.Type as T

99

10−toExpr :: [Declaration] -> [E.Def]

10+toExpr :: [D.Declaration] -> [E.Def]

1111toExpr = concatMap toDefs

1212

13−toDefs :: Declaration -> [E.Def]

13+toDefs :: D.Declaration -> [E.Def]

1414toDefs decl =

1515 case decl of

16− Definition def -> [def]

16+ D.Definition def -> [def]

1717

18− Datatype name tvars constructors -> concatMap toDefs' constructors

18+ D.Datatype name tvars constructors -> concatMap toDefs' constructors

1919 where

2020 toDefs' (ctor, tipes) =

2121 let vars = take (length tipes) arguments

2222 tbody = T.Data name $ map T.Var tvars

23− body = L.none . E.Data ctor $ map (L.none . E.Var) vars

23+ body = A.none . E.Data ctor $ map (A.none . E.rawVar) vars

2424 in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]

2525

26− TypeAlias name _ tipe@(T.Record fields ext) ->

26+ D.TypeAlias name _ tipe@(T.Record fields ext) ->

2727 [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]

2828 where

2929 args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext

3030

31− var = L.none . E.Var

31+ var = A.none . E.rawVar

3232 vars = take (length args) arguments

3333

3434 efields = zip (map fst fields) (map var vars)

3535 record = case ext of

36− Nothing -> L.none $ E.Record efields

37− Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields

36+ Nothing -> A.none $ E.Record efields

37+ Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields

3838

3939 -- Type aliases must be added to an extended equality dictionary,

4040 -- but they do not require any basic constraints.

41− TypeAlias _ _ _ -> []

41+ D.TypeAlias _ _ _ -> []

4242

43− Port port ->

43+ D.Port port ->

4444 case port of

45− Out name expr@(L.L s _) tipe ->

46− [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]

47− In name tipe ->

48− [ definition name (L.none $ E.PortIn name tipe) tipe ]

45+ D.Out name expr@(A.A s _) tipe ->

46+ [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]

47+ D.In name tipe ->

48+ [ definition name (A.none $ E.PortIn name tipe) tipe ]

4949

5050 -- no constraints are needed for fixity declarations

51− Fixity _ _ _ -> []

51+ D.Fixity _ _ _ -> []

5252

5353

5454arguments :: [String]

5555arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

5656

57−buildFunction :: E.LExpr -> [String] -> E.LExpr

58−buildFunction body@(L.L s _) vars =

59− foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)

57+buildFunction :: E.Expr -> [String] -> E.Expr

58+buildFunction body@(A.A s _) vars =

59+ foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)

6060

61−definition :: String -> E.LExpr -> T.Type -> E.Def

62−definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)

61+definition :: String -> E.Expr -> T.Type -> E.Def

62+definition name expr tipe = E.Definition (P.Var name) expr (Just tipe)

compiler/Type/Constrain/Expression.hs+34−33

@@ -1,38 +1,39 @@

11{-# OPTIONS_GHC -W #-}

22module Type.Constrain.Expression where

33

4−import qualified Data.List as List

5−import qualified Data.Map as Map

6−import qualified Data.Set as Set

74import Control.Applicative ((<$>))

85import qualified Control.Monad as Monad

96import Control.Monad.Error

7+import qualified Data.List as List

8+import qualified Data.Map as Map

109import qualified Text.PrettyPrint as PP

1110

12−import SourceSyntax.Location as Loc

13−import SourceSyntax.Pattern (Pattern(PVar), boundVars)

11+import SourceSyntax.Annotation as Ann

1412import SourceSyntax.Expression

15−import qualified SourceSyntax.Type as SrcT

13+import qualified SourceSyntax.Pattern as P

14+import qualified SourceSyntax.Type as ST

15+import qualified SourceSyntax.Variable as V

1616import Type.Type hiding (Descriptor(..))

1717import Type.Fragment

1818import qualified Type.Environment as Env

1919import qualified Type.Constrain.Literal as Literal

2020import qualified Type.Constrain.Pattern as Pattern

2121

22−constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint

23−constrain env (L span expr) tipe =

22+constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint

23+constrain env (A region expr) tipe =

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

25− and = L span . CAnd

26− true = L span CTrue

27− t1 === t2 = L span (CEqual t1 t2)

28− x <? t = L span (CInstance x t)

29− clet schemes c = L span (CLet schemes c)

25+ and = A region . CAnd

26+ true = A region CTrue

27+ t1 === t2 = A region (CEqual t1 t2)

28+ x <? t = A region (CInstance x t)

29+ clet schemes c = A region (CLet schemes c)

3030 in

3131 case expr of

32− Literal lit -> liftIO $ Literal.constrain env span lit tipe

32+ Literal lit -> liftIO $ Literal.constrain env region lit tipe

3333

34− Var name | name == saveEnvName -> return (L span CSaveEnv)

35− | otherwise -> return (name <? tipe)

34+ Var (V.Raw name)

35+ | name == saveEnvName -> return (A region CSaveEnv)

36+ | otherwise -> return (name <? tipe)

3637

3738 Range lo hi ->

3839 exists $ \x -> do

@@ -55,7 +56,7 @@ constrain env (L span expr) tipe =

5556 Lambda p e ->

5657 exists $ \t1 ->

5758 exists $ \t2 -> do

58− fragment <- try span $ Pattern.constrain env p t1

59+ fragment <- try region $ Pattern.constrain env p t1

5960 c2 <- constrain env e t2

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

6162 (typeConstraint fragment /\ c2 ))

@@ -79,7 +80,7 @@ constrain env (L span expr) tipe =

7980 exists $ \t -> do

8081 ce <- constrain env exp t

8182 let branch (p,e) = do

82− fragment <- try span $ Pattern.constrain env p t

83+ fragment <- try region $ Pattern.constrain env p t

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

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

8586

@@ -112,11 +113,11 @@ constrain env (L span expr) tipe =

112113 Modify e fields ->

113114 exists $ \t -> do

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

115− let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))

116+ let oldFields = ST.fieldMap (zip (map fst fields) (map VarN oldVars))

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

117118

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

119− let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))

120+ let newFields = ST.fieldMap (zip (map fst fields) (map VarN newVars))

120121 let cNew = tipe === record newFields t

121122

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

@@ -126,7 +127,7 @@ constrain env (L span expr) tipe =

126127 Record fields ->

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

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

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

130+ let fields' = ST.fieldMap (zip (map fst fields) (map VarN vars))

130131 recordType = record fields' (TermN EmptyRecord1)

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

132133

@@ -158,14 +159,14 @@ constrainDef env info (Definition pattern expr maybeTipe) =

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

159160 -- Currently, qs is always [].

160161 case (pattern, maybeTipe) of

161− (PVar name, Just tipe) -> do

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

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

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

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

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

166167 let scheme = Scheme { rigidQuantifiers = [],

167168 flexibleQuantifiers = flexiVars ++ vars,

168− constraint = Loc.noneNoDocs CTrue,

169+ constraint = Ann.noneNoDocs CTrue,

169170 header = Map.singleton name typ }

170171 c <- constrain env' expr typ

171172 return ( scheme : schemes

@@ -175,7 +176,7 @@ constrainDef env info (Definition pattern expr maybeTipe) =

175176 , c2

176177 , fl rigidVars c /\ c1 )

177178

178− (PVar name, Nothing) -> do

179+ (P.Var name, Nothing) -> do

179180 v <- liftIO $ var Flexible

180181 let tipe = VarN v

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

@@ -191,19 +192,19 @@ constrainDef env info (Definition pattern expr maybeTipe) =

191192 _ -> error (show pattern)

192193

193194expandPattern :: Def -> [Def]

194−expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =

195+expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =

195196 case pattern of

196− PVar _ -> [def]

197− _ -> Definition (PVar x) lexpr maybeType : map toDef vars

197+ P.Var _ -> [def]

198+ _ -> Definition (P.Var x) lexpr maybeType : map toDef vars

198199 where

199− vars = Set.toList $ boundVars pattern

200+ vars = P.boundVarList pattern

200201 x = "$" ++ concat vars

201− mkVar = L s . Var

202− toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

202+ mkVar = A r . rawVar

203+ toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

203204

204−try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

205−try span computation = do

205+try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

206+try region computation = do

206207 result <- liftIO $ runErrorT computation

207208 case result of

208− Left err -> throwError [err span]

209+ Left err -> throwError [err region]

209210 Right value -> return value

compiler/Type/Constrain/Literal.hs+5−4

@@ -1,14 +1,15 @@

1+{-# OPTIONS_GHC -W #-}

12module Type.Constrain.Literal where

23

4+import SourceSyntax.Annotation

35import SourceSyntax.Literal

4−import SourceSyntax.Location

56import Type.Type

67import Type.Environment as Env

78

8−constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint

9−constrain env span literal tipe =

9+constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint

10+constrain env region literal tipe =

1011 do tipe' <- litType

11− return . L span $ CEqual tipe tipe'

12+ return . A region $ CEqual tipe tipe'

1213 where

1314 prim name = return (Env.get env Env.types name)

1415

compiler/Type/Constrain/Pattern.hs+17−18

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -W #-}

12{-# LANGUAGE FlexibleInstances #-}

23module Type.Constrain.Pattern where

34

@@ -8,31 +9,29 @@ import Control.Monad.Error

89import qualified Data.Map as Map

910import qualified Text.PrettyPrint as PP

1011

11−import SourceSyntax.Pattern

12−import SourceSyntax.Location

13−import SourceSyntax.PrettyPrint

14−import Text.PrettyPrint (render)

15−import qualified SourceSyntax.Location as Loc

12+import qualified SourceSyntax.Annotation as A

13+import qualified SourceSyntax.Pattern as P

14+import SourceSyntax.PrettyPrint (pretty)

1615import Type.Type

1716import Type.Fragment

1817import Type.Environment as Env

1918import qualified Type.Constrain.Literal as Literal

2019

2120

22−constrain :: Environment -> Pattern -> Type -> ErrorT (SrcSpan -> PP.Doc) IO Fragment

21+constrain :: Environment -> P.Pattern -> Type -> ErrorT (A.Region -> PP.Doc) IO Fragment

2322constrain env pattern tipe =

24− let span = Loc.NoSpan (render $ pretty pattern)

25− t1 === t2 = Loc.L span (CEqual t1 t2)

26− x <? t = Loc.L span (CInstance x t)

23+ let region = A.None (pretty pattern)

24+ t1 === t2 = A.A region (CEqual t1 t2)

25+ x <? t = A.A region (CInstance x t)

2726 in

2827 case pattern of

29− PAnything -> return emptyFragment

28+ P.Anything -> return emptyFragment

3029

31− PLiteral lit -> do

32− c <- liftIO $ Literal.constrain env span lit tipe

30+ P.Literal lit -> do

31+ c <- liftIO $ Literal.constrain env region lit tipe

3332 return $ emptyFragment { typeConstraint = c }

3433

35− PVar name -> do

34+ P.Var name -> do

3635 v <- liftIO $ var Flexible

3736 return $ Fragment {

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

@@ -40,14 +39,14 @@ constrain env pattern tipe =

4039 typeConstraint = VarN v === tipe

4140 }

4241

43− PAlias name p -> do

42+ P.Alias name p -> do

4443 fragment <- constrain env p tipe

4544 return $ fragment {

4645 typeEnv = Map.insert name tipe (typeEnv fragment),

4746 typeConstraint = name <? tipe /\ typeConstraint fragment

4847 }

4948

50− PData name patterns -> do

49+ P.Data name patterns -> do

5150 (kind, cvars, args, result) <- liftIO $ freshDataScheme env name

5251 let msg = concat [ "Constructor '", name, "' expects ", show kind

5352 , " argument", if kind == 1 then "" else "s"

@@ -63,7 +62,7 @@ constrain env pattern tipe =

6362 vars = cvars ++ vars fragment

6463 }

6564

66− PRecord fields -> do

65+ P.Record fields -> do

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

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

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

@@ -73,8 +72,8 @@ constrain env pattern tipe =

7372 typeConstraint = c

7473 }

7574

76−instance Error (SrcSpan -> PP.Doc) where

75+instance Error (A.Region -> PP.Doc) where

7776 noMsg _ = PP.empty

7877 strMsg str span =

7978 PP.vcat [ PP.text $ "Type error " ++ show span

80− , PP.text str ]

79+ , PP.text str ]

compiler/Type/ExtraChecks.hs+39−36

@@ -1,32 +1,35 @@

11{-# OPTIONS_GHC -W #-}

2+

3+{-| This module contains checks to be run *after* type inference has completed

4+successfully. At that point we still need to do occurs checks and ensure that

5+`main` has an acceptable type.

6+-}

27module Type.ExtraChecks (mainType, occurs, portTypes) where

3−-- This module contains checks to be run *after* type inference has

4−-- completed successfully. At that point we still need to do occurs

5−-- checks and ensure that `main` has an acceptable type.

68

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

810import Control.Monad.State

911import qualified Data.List as List

1012import qualified Data.Map as Map

13+import qualified Data.Traversable as Traverse

1114import qualified Data.UnionFind.IO as UF

12−import Type.Type ( Variable, structure, Term1(..), toSrcType )

13−import qualified Type.State as TS

14−import qualified Type.Alias as Alias

1515import Text.PrettyPrint as P

16−import SourceSyntax.PrettyPrint (pretty)

17−import qualified SourceSyntax.Helpers as Help

18−import qualified SourceSyntax.Type as T

16+

17+import qualified SourceSyntax.Annotation as A

1918import qualified SourceSyntax.Expression as E

20−import qualified SourceSyntax.Location as L

19+import qualified SourceSyntax.Helpers as Help

20+import qualified SourceSyntax.PrettyPrint as SPP

21+import qualified SourceSyntax.Type as ST

2122import qualified Transform.Expression as Expr

22−import qualified Data.Traversable as Traverse

23+import qualified Type.Type as TT

24+import qualified Type.State as TS

25+import qualified Type.Alias as Alias

2326

2427throw err = Left [ P.vcat err ]

2528

26−mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))

27−mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env

29+mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))

30+mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env

2831 where

29− mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)

32+ mainCheck :: Alias.Rules -> Map.Map String ST.Type -> Either [P.Doc] (Map.Map String ST.Type)

3033 mainCheck rules env =

3134 case Map.lookup "main" env of

3235 Nothing -> Right env

@@ -37,40 +40,40 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env

3740 acceptable = [ "Graphics.Element.Element"

3841 , "Signal.Signal Graphics.Element.Element" ]

3942

40− tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType

43+ tipe = SPP.renderPretty $ Alias.canonicalRealias (fst rules) mainType

4144 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

4245 , P.text "Instead 'main' has type:\n"

43− , P.nest 4 . pretty $ Alias.realias rules mainType

46+ , P.nest 4 . SPP.pretty $ Alias.realias rules mainType

4447 , P.text " " ]

4548

4649data Direction = In | Out

4750

48−portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()

51+portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()

4952portTypes rules expr =

5053 const () <$> Expr.checkPorts (check In) (check Out) expr

5154 where

5255 check = isValid True False False

5356 isValid isTopLevel seenFunc seenSignal direction name tipe =

5457 case tipe of

55− T.Data ctor ts

58+ ST.Data ctor ts

5659 | isJs ctor || isElm ctor -> mapM_ valid ts

5760 | ctor == "Signal.Signal" -> handleSignal ts

5861 | otherwise -> err' True "an unsupported type"

5962

60− T.Var _ -> err "free type variables"

63+ ST.Var _ -> err "free type variables"

6164

62− T.Lambda _ _ ->

65+ ST.Lambda _ _ ->

6366 case direction of

6467 In -> err "functions"

6568 Out | seenFunc -> err "higher-order functions"

6669 | seenSignal -> err "signals that contain functions"

6770 | otherwise ->

68− forM_ (T.collectLambdas tipe)

71+ forM_ (ST.collectLambdas tipe)

6972 (isValid' True seenSignal direction name)

7073

71− T.Record _ (Just _) -> err "extended records with free type variables"

74+ ST.Record _ (Just _) -> err "extended records with free type variables"

7275

73− T.Record fields Nothing ->

76+ ST.Record fields Nothing ->

7477 mapM_ (\(k,v) -> (,) k <$> valid v) fields

7578

7679 where

@@ -100,7 +103,7 @@ portTypes rules expr =

100103 [ txt [ "Type Error: the value ", dir "coming in" "sent out"

101104 , " through port '", name, "' is invalid." ]

102105 , txt [ "It contains ", kind, ":\n" ]

103− , (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"

106+ , (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n"

104107 , txt [ "Acceptable values for ", dir "incoming" "outgoing"

105108 , " ports include JavaScript values and" ]

106109 , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]

@@ -112,37 +115,37 @@ portTypes rules expr =

112115 , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]

113116 ]

114117

115−occurs :: (String, Variable) -> StateT TS.SolverState IO ()

118+occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()

116119occurs (name, variable) =

117120 do vars <- liftIO $ infiniteVars [] variable

118121 case vars of

119122 [] -> return ()

120123 var:_ -> do

121124 desc <- liftIO $ UF.descriptor var

122− case structure desc of

125+ case TT.structure desc of

123126 Nothing ->

124127 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

125128 Just _ ->

126− do liftIO $ UF.setDescriptor var (desc { structure = Nothing })

129+ do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })

127130 var' <- liftIO $ UF.fresh desc

128− TS.addError (L.NoSpan name) (Just msg) var var'

131+ TS.addError (A.None (P.text name)) (Just msg) var var'

129132 where

130133 msg = "Infinite types are not allowed"

131134 fallback _ = return $ P.text msg

132135

133− infiniteVars :: [Variable] -> Variable -> IO [Variable]

134− infiniteVars seen var =

136+ infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]

137+ infiniteVars seen var =

135138 let go = infiniteVars (var:seen) in

136139 if var `elem` seen

137140 then return [var]

138141 else do

139142 desc <- UF.descriptor var

140− case structure desc of

143+ case TT.structure desc of

141144 Nothing -> return []

142145 Just struct ->

143146 case struct of

144− App1 a b -> (++) <$> go a <*> go b

145− Fun1 a b -> (++) <$> go a <*> go b

146− Var1 a -> go a

147− EmptyRecord1 -> return []

148− Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))

147+ TT.App1 a b -> (++) <$> go a <*> go b

148+ TT.Fun1 a b -> (++) <$> go a <*> go b

149+ TT.Var1 a -> go a

150+ TT.EmptyRecord1 -> return []

151+ TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))

compiler/Type/Fragment.hs+12−13

@@ -5,24 +5,23 @@ import qualified Data.Map as Map

55

66import Type.Type

77import SourceSyntax.Pattern

8−import SourceSyntax.Location (noneNoDocs)

8+import SourceSyntax.Annotation (noneNoDocs)

99

10−data Fragment = Fragment {

11− typeEnv :: Map.Map String Type,

12− vars :: [Variable],

13− typeConstraint :: TypeConstraint

14−} deriving Show

10+data Fragment = Fragment

11+ { typeEnv :: Map.Map String Type

12+ , vars :: [Variable]

13+ , typeConstraint :: TypeConstraint

14+ } deriving Show

1515

1616emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)

1717

18−joinFragment f1 f2 = Fragment {

19− typeEnv = Map.union (typeEnv f1) (typeEnv f2),

20− vars = vars f1 ++ vars f2,

21− typeConstraint = typeConstraint f1 /\ typeConstraint f2

22−}

18+joinFragment f1 f2 = Fragment

19+ { typeEnv = Map.union (typeEnv f1) (typeEnv f2)

20+ , vars = vars f1 ++ vars f2

21+ , typeConstraint = typeConstraint f1 /\ typeConstraint f2

22+ }

2323

2424joinFragments = List.foldl' (flip joinFragment) emptyFragment

2525

26−

2726toScheme fragment =

28− Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)

27+ Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)

compiler/Type/Inference.hs+1−1

@@ -9,7 +9,7 @@ import qualified Type.Constrain.Expression as TcExpr

99import qualified Type.Solve as Solve

1010

1111import SourceSyntax.Module as Module

12−import SourceSyntax.Location (noneNoDocs)

12+import SourceSyntax.Annotation (noneNoDocs)

1313import SourceSyntax.Type (Type)

1414import Text.PrettyPrint

1515import qualified Type.State as TS

compiler/Type/Solve.hs+19−19

@@ -3,15 +3,15 @@ module Type.Solve (solve) where

33

44import Control.Monad

55import Control.Monad.State

6−import qualified Data.UnionFind.IO as UF

6+import qualified Data.List as List

77import qualified Data.Map as Map

88import qualified Data.Traversable as Traversable

9−import qualified Data.List as List

9+import qualified Data.UnionFind.IO as UF

1010import Type.Type

1111import Type.Unify

1212import qualified Type.ExtraChecks as Check

1313import qualified Type.State as TS

14−import SourceSyntax.Location (Located(L), SrcSpan)

14+import qualified SourceSyntax.Annotation as A

1515

1616

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

@@ -96,7 +96,7 @@ adjustRank youngMark visitedMark groupRank variable =

9696

9797

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

99−solve (L span constraint) =

99+solve (A.A region constraint) =

100100 case constraint of

101101 CTrue -> return ()

102102

@@ -105,11 +105,11 @@ solve (L span constraint) =

105105 CEqual term1 term2 -> do

106106 t1 <- TS.flatten term1

107107 t2 <- TS.flatten term2

108− unify span t1 t2

108+ unify region t1 t2

109109

110110 CAnd cs -> mapM_ solve cs

111111

112− CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do

112+ CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) -> do

113113 oldEnv <- TS.getEnv

114114 mapM TS.introduce fqs

115115 solve constraint'

@@ -117,7 +117,7 @@ solve (L span constraint) =

117117

118118 CLet schemes constraint' -> do

119119 oldEnv <- TS.getEnv

120− headers <- Map.unions `fmap` mapM (solveScheme span) schemes

120+ headers <- Map.unions `fmap` mapM (solveScheme region) schemes

121121 TS.modifyEnv $ \env -> Map.union headers env

122122 solve constraint'

123123 mapM Check.occurs $ Map.toList headers

@@ -134,10 +134,10 @@ solve (L span constraint) =

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

135135

136136 t <- TS.flatten term

137− unify span freshCopy t

137+ unify region freshCopy t

138138

139−solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)

140−solveScheme span scheme =

139+solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)

140+solveScheme region scheme =

141141 case scheme of

142142 Scheme [] [] constraint header -> do

143143 solve constraint

@@ -154,39 +154,39 @@ solveScheme span scheme =

154154 header' <- Traversable.traverse TS.flatten header

155155 solve constraint

156156

157− allDistinct span rigidQuantifiers

157+ allDistinct region rigidQuantifiers

158158 youngPool <- TS.getPool

159159 TS.switchToPool oldPool

160160 generalize youngPool

161− mapM (isGeneric span) rigidQuantifiers

161+ mapM (isGeneric region) rigidQuantifiers

162162 return header'

163163

164164

165165-- Checks that all of the given variables belong to distinct equivalence classes.

166166-- Also checks that their structure is Nothing, so they represent a variable, not

167167-- a more complex term.

168−allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()

169−allDistinct span vars = do

168+allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()

169+allDistinct region vars = do

170170 seen <- TS.uniqueMark

171171 let check var = do

172172 desc <- liftIO $ UF.descriptor var

173173 case structure desc of

174− Just _ -> TS.addError span (Just msg) var var

174+ Just _ -> TS.addError region (Just msg) var var

175175 where msg = "Cannot generalize something that is not a type variable."

176176

177177 Nothing -> do

178178 if mark desc == seen

179179 then let msg = "Duplicate variable during generalization."

180− in TS.addError span (Just msg) var var

180+ in TS.addError region (Just msg) var var

181181 else return ()

182182 liftIO $ UF.setDescriptor var (desc { mark = seen })

183183 mapM_ check vars

184184

185185-- Check that a variable has rank == noRank, meaning that it can be generalized.

186−isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()

187−isGeneric span var = do

186+isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()

187+isGeneric region var = do

188188 desc <- liftIO $ UF.descriptor var

189189 if rank desc == noRank

190190 then return ()

191191 else let msg = "Unable to generalize a type variable. It is not unranked."

192− in TS.addError span (Just msg) var var

192+ in TS.addError region (Just msg) var var

compiler/Type/State.hs+12−20

@@ -1,16 +1,17 @@

11{-# OPTIONS_GHC -W #-}

22module Type.State where

33

4−import Type.Type

5−import qualified Data.Map as Map

6−import qualified Data.UnionFind.IO as UF

7−import Control.Monad.State

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

5+import Control.Monad.State

6+import qualified Data.Map as Map

97import qualified Data.Traversable as Traversable

10−import Text.PrettyPrint as P

8+import qualified Data.UnionFind.IO as UF

9+

10+import qualified SourceSyntax.Annotation as A

1111import SourceSyntax.PrettyPrint

12−import SourceSyntax.Location

12+import Text.PrettyPrint as P

1313import qualified Type.Alias as Alias

14+import Type.Type

1415

1516-- Pool

1617-- Holds a bunch of variables

@@ -46,7 +47,7 @@ initialState = SS {

4647modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }

4748modifyPool f = modify $ \state -> state { sPool = f (sPool state) }

4849

49−addError span hint t1 t2 =

50+addError region hint t1 t2 =

5051 modify $ \state -> state { sErrors = makeError : sErrors state }

5152 where

5253 makeError rules = do

@@ -54,24 +55,15 @@ addError span hint t1 t2 =

5455 t1' <- prettiest <$> toSrcType t1

5556 t2' <- prettiest <$> toSrcType t2

5657 return . P.vcat $

57− [ P.text $ "Type error" ++ location ++ ":"

58+ [ P.text "Type error" <+> pretty region <> P.colon

5859 , maybe P.empty P.text hint

59− , display $ case span of { NoSpan msg -> msg ; Span _ _ msg -> msg }

60+ , P.text ""

61+ , P.nest 8 $ A.getRegionDocs region

62+ , P.text ""

6063 , P.text " Expected Type:" <+> t1'

6164 , P.text " Actual Type:" <+> t2'

6265 ]

6366

64− location = case span of

65− NoSpan _ -> ""

66− Span p1 p2 _ ->

67− if line p1 == line p2 then " on line " ++ show (line p1)

68− else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)

69−

70− display msg =

71− P.vcat [ P.text $ concatMap ("\n "++) (lines msg)

72− , P.text " " ]

73−

74−

7567switchToPool pool = modifyPool (\_ -> pool)

7668

7769getPool :: StateT SolverState IO Pool

compiler/Type/Type.hs+14−12

@@ -11,7 +11,7 @@ import Control.Applicative ((<$>),(<*>))

1111import Control.Monad.State

1212import Control.Monad.Error

1313import Data.Traversable (traverse)

14−import SourceSyntax.Location

14+import SourceSyntax.Annotation

1515import SourceSyntax.Helpers (isTuple)

1616import qualified SourceSyntax.Type as Src

1717

@@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

6262infixl 8 /\

6363

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

65−a@(L _ c1) /\ b@(L _ c2) =

65+a@(A _ c1) /\ b@(A _ c2) =

6666 case (c1, c2) of

6767 (CTrue, _) -> b

6868 (_, CTrue) -> a

@@ -128,11 +128,13 @@ structuredVar structure = UF.fresh $ Descriptor {

128128

129129-- ex qs constraint == exists qs. constraint

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

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

131+ex fqs constraint@(A ann _) =

132+ A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)

132133

133134-- fl qs constraint == forall qs. constraint

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

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

136+fl rqs constraint@(A ann _) =

137+ A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)

136138

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

138140exists f = do

@@ -148,8 +150,8 @@ instance PrettyType a => PrettyType (UF.Point a) where

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

149151

150152

151−instance PrettyType a => PrettyType (Located a) where

152− pretty when (L _ e) = pretty when e

153+instance PrettyType t => PrettyType (Annotated a t) where

154+ pretty when (A _ e) = pretty when e

153155

154156

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

@@ -212,12 +214,12 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where

212214 CAnd cs ->

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

214216

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

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

216218 P.sep [ binder, pretty Never c ]

217219 where

218− mergeExists vs (L _ c) =

220+ mergeExists vs (A _ c) =

219221 case c of

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

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

221223 _ -> (vs, c)

222224

223225 (fqs', c) = mergeExists fqs constraint

@@ -233,7 +235,7 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where

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

234236

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

236− pretty _ (Scheme rqs fqs (L _ constraint) headers) =

238+ pretty _ (Scheme rqs fqs (A _ constraint) headers) =

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

238240 where

239241 prty = pretty Never

@@ -297,8 +299,8 @@ class Crawl t where

297299 -> t

298300 -> StateT CrawlState IO t

299301

300−instance Crawl a => Crawl (Located a) where

301− crawl nextState (L s e) = L s <$> crawl nextState e

302+instance Crawl e => Crawl (Annotated a e) where

303+ crawl nextState (A ann e) = A ann <$> crawl nextState e

302304

303305instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where

304306 crawl nextState constraint =

compiler/Type/Unify.hs+15−15

@@ -1,27 +1,27 @@

11{-# OPTIONS_GHC -W #-}

22module Type.Unify (unify) where

33

4−import Type.Type

5−import qualified Data.UnionFind.IO as UF

4+import Control.Monad.State

65import qualified Data.Map as Map

76import qualified Data.Maybe as Maybe

7+import qualified Data.UnionFind.IO as UF

8+import qualified SourceSyntax.Annotation as A

89import qualified Type.State as TS

9−import Control.Monad.State

10−import SourceSyntax.Location

10+import Type.Type

1111import Type.PrettyPrint

1212import Text.PrettyPrint (render)

1313

14−unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()

15−unify span variable1 variable2 = do

14+unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()

15+unify region variable1 variable2 = do

1616 equivalent <- liftIO $ UF.equivalent variable1 variable2

1717 if equivalent then return ()

18− else actuallyUnify span variable1 variable2

18+ else actuallyUnify region variable1 variable2

1919

20−actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()

21−actuallyUnify span variable1 variable2 = do

20+actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()

21+actuallyUnify region variable1 variable2 = do

2222 desc1 <- liftIO $ UF.descriptor variable1

2323 desc2 <- liftIO $ UF.descriptor variable2

24− let unify' = unify span

24+ let unify' = unify region

2525

2626 name' :: Maybe String

2727 name' = case (name desc1, name desc2) of

@@ -79,11 +79,11 @@ actuallyUnify span variable1 variable2 = do

7979

8080 unifyNumber svar name

8181 | name `elem` ["Int","Float","number"] = flexAndUnify svar

82− | otherwise = TS.addError span (Just hint) variable1 variable2

82+ | otherwise = TS.addError region (Just hint) variable1 variable2

8383 where hint = "A number must be an Int or Float."

8484

8585 comparableError maybe =

86− TS.addError span (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

86+ TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

8787 where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."

8888

8989 unifyComparable var name

@@ -110,7 +110,7 @@ actuallyUnify span variable1 variable2 = do

110110 List _ -> flexAndUnify varSuper

111111 _ -> comparableError Nothing

112112

113− rigidError variable = TS.addError span (Just hint) variable1 variable2

113+ rigidError variable = TS.addError region (Just hint) variable1 variable2

114114 where

115115 var = "'" ++ render (pretty Never variable) ++ "'"

116116 hint = "Cannot unify rigid type variable " ++ var ++

@@ -141,7 +141,7 @@ actuallyUnify span variable1 variable2 = do

141141

142142 (Rigid, _, _, _) -> rigidError variable1

143143 (_, Rigid, _, _) -> rigidError variable2

144− _ -> TS.addError span Nothing variable1 variable2

144+ _ -> TS.addError region Nothing variable1 variable2

145145

146146 case (structure desc1, structure desc2) of

147147 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge

@@ -196,5 +196,5 @@ actuallyUnify span variable1 variable2 = do

196196 eat (_:xs) (_:ys) = eat xs ys

197197 eat xs _ = xs

198198

199− _ -> TS.addError span Nothing variable1 variable2

199+ _ -> TS.addError region Nothing variable1 variable2

200200

tests/Tests/Property.hs+17−16

@@ -10,7 +10,7 @@ import Text.Parsec.Combinator (eof)

1010import Text.PrettyPrint as P

1111

1212import SourceSyntax.Literal as Lit

13−import SourceSyntax.Pattern as Pat

13+import qualified SourceSyntax.Pattern as P

1414import SourceSyntax.PrettyPrint (Pretty, pretty)

1515import Parse.Helpers (IParser, iParse)

1616import Parse.Literal (literal)

@@ -31,24 +31,25 @@ propertyTests =

3131 where

3232 -- This test was autogenerated from the Pattern test and should be

3333 -- left in all its ugly glory.

34− longPat = Pat.PData "I" [ Pat.PLiteral (Lit.Chr '+')

35− , Pat.PRecord [

36− "q7yclkcm7k_ikstrczv_"

37− , "wQRv6gKsvvkjw4b5F"

38− ,"c9'eFfhk9FTvsMnwF_D"

39− ,"yqxhEkHvRFwZ"

40− ,"o"

41− ,"nbUlCn3y3NnkVoxhW"

42− ,"iJ0MNy3KZ_lrs"

43− ,"ug"

44− ,"sHHsX"

45− ,"mRKs9d"

46− ,"o2KiCX5'ZRzHJfRi8" ]

47− , Pat.PVar "su'BrrbPUK6I33Eq" ]

34+ longPat = P.Data "I" [ P.Literal (Lit.Chr '+')

35+ , P.Record

36+ [ "q7yclkcm7k_ikstrczv_"

37+ , "wQRv6gKsvvkjw4b5F"

38+ ,"c9'eFfhk9FTvsMnwF_D"

39+ ,"yqxhEkHvRFwZ"

40+ ,"o"

41+ ,"nbUlCn3y3NnkVoxhW"

42+ ,"iJ0MNy3KZ_lrs"

43+ ,"ug"

44+ ,"sHHsX"

45+ ,"mRKs9d"

46+ ,"o2KiCX5'ZRzHJfRi8" ]

47+ , P.Var "su'BrrbPUK6I33Eq"

48+ ]

4849

4950prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool

5051prop_parse_print p x =

5152 either (const False) (== x) . parse_print p $ x

5253

5354parse_print :: (Pretty a) => IParser a -> a -> Either String a

54−parse_print p = either (Left . show) (Right) . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty

55+parse_print p = either (Left . show) Right . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty

tests/Tests/Property/Arbitrary.hs+91−76

@@ -8,98 +8,112 @@ import Test.QuickCheck.Gen

88import qualified Data.Set as Set

99import qualified Parse.Helpers (reserveds)

1010

11−import SourceSyntax.Literal

12−import SourceSyntax.Pattern

13−import SourceSyntax.Type hiding (listOf)

14−

15−instance Arbitrary Literal where

16− arbitrary = oneof [ IntNum <$> arbitrary

17− , FloatNum <$> (arbitrary `suchThat` noE)

18− , Chr <$> arbitrary

19− -- This is too permissive

20− , Str <$> arbitrary

21− -- Booleans aren't actually source syntax

22− -- , Boolean <$> arbitrary

23− ]

24− shrink l = case l of

25− IntNum n -> IntNum <$> shrink n

26− FloatNum f -> FloatNum <$> (filter noE . shrink $ f)

27− Chr c -> Chr <$> shrink c

28− Str s -> Str <$> shrink s

29− Boolean b -> Boolean <$> shrink b

11+import qualified SourceSyntax.Literal as L

12+import qualified SourceSyntax.Pattern as P

13+import qualified SourceSyntax.Type as T

14+

15+instance Arbitrary L.Literal where

16+ arbitrary =

17+ oneof

18+ [ L.IntNum <$> arbitrary

19+ , L.FloatNum <$> (arbitrary `suchThat` noE)

20+ , L.Chr <$> arbitrary

21+ -- This is too permissive

22+ , L.Str <$> arbitrary

23+ -- Booleans aren't actually source syntax

24+ -- , Boolean <$> arbitrary

25+ ]

26+

27+ shrink lit =

28+ case lit of

29+ L.IntNum n -> L.IntNum <$> shrink n

30+ L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f)

31+ L.Chr c -> L.Chr <$> shrink c

32+ L.Str s -> L.Str <$> shrink s

33+ L.Boolean b -> L.Boolean <$> shrink b

3034

3135noE :: Double -> Bool

3236noE = notElem 'e' . show

3337

38+genVector :: Int -> (Int -> Gen a) -> Gen [a]

39+genVector n generator = do

40+ len <- choose (0,n)

41+ let m = n `div` (len + 1)

42+ vectorOf len $ generator m

3443

35−instance Arbitrary Pattern where

44+instance Arbitrary P.Pattern where

3645 arbitrary = sized pat

37− where pat :: Int -> Gen Pattern

38− pat n = oneof [ pure PAnything

39− , PVar <$> lowVar

40− , PRecord <$> (listOf1 lowVar)

41− , PLiteral <$> arbitrary

42− , PAlias <$> lowVar <*> pat (n-1)

43− , PData <$> capVar <*> sizedPats

44− ]

45− where sizedPats = do

46− len <- choose (0,n)

47− let m = n `div` (len + 1)

48− vectorOf len $ pat m

49−

50− shrink pat = case pat of

51− PAnything -> []

52− PVar v -> PVar <$> shrinkWHead v

53− PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)

54− PLiteral l -> PLiteral <$> shrink l

55− PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)

56− PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)

46+ where

47+ pat :: Int -> Gen P.Pattern

48+ pat n =

49+ oneof

50+ [ pure P.Anything

51+ , P.Var <$> lowVar

52+ , P.Record <$> (listOf1 lowVar)

53+ , P.Literal <$> arbitrary

54+ , P.Alias <$> lowVar <*> pat (n-1)

55+ , P.Data <$> capVar <*> genVector n pat

56+ ]

57+

58+ shrink pat =

59+ case pat of

60+ P.Anything -> []

61+ P.Var v -> P.Var <$> shrinkWHead v

62+ P.Literal l -> P.Literal <$> shrink l

63+ P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)

64+ P.Data s ps -> ps ++ (P.Data <$> shrinkWHead s <*> shrink ps)

65+ P.Record fs ->

66+ P.Record <$> filter (all notNull) (filter notNull (shrink fs))

67+ where

68+ notNull = not . null

5769

5870shrinkWHead :: Arbitrary a => [a] -> [[a]]

5971shrinkWHead [] = error "Should be nonempty"

6072shrinkWHead (x:xs) = (x:) <$> shrink xs

6173

62−instance Arbitrary Type where

74+instance Arbitrary T.Type where

6375 arbitrary = sized tipe

64− where tipe :: Int -> Gen Type

65− tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe

66− , Var <$> lowVar

67− , Data <$> capVar <*> depthTipes

68− , Record <$> fields <*> pure Nothing

69− , Record <$> fields1 <*> (Just <$> lowVar)

70− ]

71− where depthTipe = choose (0,n) >>= tipe

72− depthTipes = do

73− len <- choose (0,n)

74− let m = n `div` (len + 1)

75− vectorOf len $ tipe m

76−

77− field = (,) <$> lowVar <*> depthTipe

78− fields = do

79− len <- choose (0,n)

80− let m = n `div` (len + 1)

81− vectorOf len $ (,) <$> lowVar <*> tipe m

82− fields1 = (:) <$> field <*> fields

83−

84− shrink tipe = case tipe of

85− Lambda s t -> s : t : (Lambda <$> shrink s <*> shrink t)

86− Var _ -> []

87− Data n ts -> ts ++ (Data <$> shrinkWHead n <*> shrink ts)

88− Record fs t -> map snd fs ++ case t of

89− Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing

90− Just _ ->

91− do

92− fields <- filter (not . null) $ shrinkList shrinkField fs

93− return $ Record fields t

94− where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t

76+ where

77+ tipe :: Int -> Gen T.Type

78+ tipe n =

79+ let depthTipe = tipe =<< choose (0,n)

80+ field = (,) <$> lowVar <*> depthTipe

81+ fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)

82+ fields1 = (:) <$> field <*> fields

83+ in

84+ oneof

85+ [ T.Lambda <$> depthTipe <*> depthTipe

86+ , T.Var <$> lowVar

87+ , T.Data <$> capVar <*> genVector n tipe

88+ , T.Record <$> fields <*> pure Nothing

89+ , T.Record <$> fields1 <*> (Just <$> lowVar)

90+ ]

91+

92+ shrink tipe =

93+ case tipe of

94+ T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)

95+ T.Var _ -> []

96+ T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)

97+ T.Record fs t -> map snd fs ++ record

98+ where

99+ record =

100+ case t of

101+ Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing

102+ Just _ ->

103+ do fields <- filter (not . null) $ shrinkList shrinkField fs

104+ return $ T.Record fields t

105+

106+ shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t

95107

96108lowVar :: Gen String

97109lowVar = notReserved $ (:) <$> lower <*> listOf varLetter

98− where lower = elements ['a'..'z']

110+ where

111+ lower = elements ['a'..'z']

99112

100113capVar :: Gen String

101114capVar = notReserved $ (:) <$> upper <*> listOf varLetter

102− where upper = elements ['A'..'Z']

115+ where

116+ upper = elements ['A'..'Z']

103117

104118varLetter :: Gen Char

105119varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']

@@ -109,5 +123,6 @@ notReserved = flip exceptFor Parse.Helpers.reserveds

109123

110124exceptFor :: (Ord a) => Gen a -> [a] -> Gen a

111125exceptFor g xs = g `suchThat` notAnX

112− where notAnX = flip Set.notMember xset

113− xset = Set.fromList xs

126+ where

127+ notAnX = flip Set.notMember xset

128+ xset = Set.fromList xs