e3e560b · elk · git.iko.soy

Elm.cabal+9−8

compare with master

unifiedsplit

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

37 Elm.Internal.Utils,

38 Elm.Internal.Version

39 Hs-Source-Dirs: compiler

40− other-modules: SourceSyntax.Declaration,

40+ other-modules: SourceSyntax.Annotation,

41+ SourceSyntax.Declaration,

41 SourceSyntax.Expression,

42 SourceSyntax.Expression,

42 SourceSyntax.Helpers,

43 SourceSyntax.Helpers,

43 SourceSyntax.Literal,

44 SourceSyntax.Literal,

44− SourceSyntax.Location,

45 SourceSyntax.Module,

46 SourceSyntax.Pattern,

47 SourceSyntax.PrettyPrint,

48 SourceSyntax.Type,

49+ SourceSyntax.Variable,

49 Generate.JavaScript,

50 Generate.JavaScript,

50 Generate.JavaScript.Helpers,

51 Generate.JavaScript.Helpers,

51 Generate.JavaScript.Ports,

52 Generate.JavaScript.Ports,

52− Generate.Noscript,

53 Generate.Markdown,

54 Generate.Html,

55 Generate.Cases,

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

119 Main-is: Compiler.hs

120 ghc-options: -threaded -O2

121 Hs-Source-Dirs: compiler

122− other-modules: SourceSyntax.Declaration,

122+ other-modules: SourceSyntax.Annotation,

123+ SourceSyntax.Declaration,

123 SourceSyntax.Expression,

124 SourceSyntax.Expression,

124 SourceSyntax.Helpers,

125 SourceSyntax.Helpers,

125 SourceSyntax.Literal,

126 SourceSyntax.Literal,

126− SourceSyntax.Location,

127 SourceSyntax.Module,

128 SourceSyntax.Pattern,

129 SourceSyntax.PrettyPrint,

130 SourceSyntax.Type,

131+ SourceSyntax.Variable,

131 Generate.JavaScript,

132 Generate.JavaScript,

132 Generate.JavaScript.Helpers,

133 Generate.JavaScript.Helpers,

133 Generate.JavaScript.Ports,

134 Generate.JavaScript.Ports,

134− Generate.Noscript,

135 Generate.Markdown,

136 Generate.Html,

137 Generate.Cases,

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

200Executable elm-doc

201 Main-is: Docs.hs

202 Hs-Source-Dirs: compiler

203− other-modules: SourceSyntax.Declaration,

203+ other-modules: SourceSyntax.Annotation,

204+ SourceSyntax.Declaration,

204 SourceSyntax.Expression,

205 SourceSyntax.Expression,

205 SourceSyntax.Helpers,

206 SourceSyntax.Helpers,

206 SourceSyntax.Literal,

207 SourceSyntax.Literal,

207− SourceSyntax.Location,

208 SourceSyntax.Module,

209 SourceSyntax.Pattern,

210 SourceSyntax.PrettyPrint,

211 SourceSyntax.Type,

212+ SourceSyntax.Variable,

212 Parse.Binop,

213 Parse.Binop,

213 Parse.Declaration,

214 Parse.Declaration,

214 Parse.Expression,

215 Parse.Expression,

compiler/Build/Source.hs+1−2

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

2module Build.Source (build) where

3

4import qualified Data.Map as Map

5−import qualified Data.Set as Set

6import System.FilePath as FP

5import System.FilePath as FP

7import Text.PrettyPrint (Doc)

6import Text.PrettyPrint (Doc)

8

7

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

33

32

34 let exports'

33 let exports'

35 | null exs =

34 | null exs =

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

35+ let get = Pattern.boundVarList in

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

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

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

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

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

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

compiler/Generate/Cases.hs+32−31

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

6import Data.List (groupBy,sortBy)

7import Data.Maybe (fromMaybe)

8

9−import SourceSyntax.Location

9+import SourceSyntax.Annotation

10−import SourceSyntax.Literal

11−import SourceSyntax.Pattern

12import SourceSyntax.Expression

10import SourceSyntax.Expression

11+import SourceSyntax.Literal

12+import qualified SourceSyntax.Pattern as P

13+import qualified SourceSyntax.Variable as V

13import Transform.Substitute

14import Transform.Substitute

14

15

16

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

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

17toMatch patterns = do

18toMatch patterns = do

18 v <- newVar

19 v <- newVar

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

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

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

27 = Match String [Clause] Match

28 = Match String [Clause] Match

28 | Break

29 | Break

29 | Fail

30 | Fail

30− | Other LExpr

31+ | Other Expr

31 | Seq [Match]

32 | Seq [Match]

32 deriving Show

33 deriving Show

33

34

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

39matchSubst _ Break = Break

40matchSubst _ Break = Break

40matchSubst _ Fail = Fail

41matchSubst _ Fail = Fail

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

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

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

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

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

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

44matchSubst pairs (Match n cs m) =

45matchSubst pairs (Match n cs m) =

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

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

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

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

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

49

50

50isCon (p:_, _) =

51isCon (p:_, _) =

51 case p of

52 case p of

52− PData _ _ -> True

53+ P.Data _ _ -> True

53− PLiteral _ -> True

54+ P.Literal _ -> True

54− _ -> False

55+ _ -> False

55

56

56isVar p = not (isCon p)

57isVar p = not (isCon p)

57

58

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

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

59match [] [] def = return def

60match [] [] def = return def

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

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

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

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

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

67 where

68 where

68 cs' = map (dealias v) cs

69 cs' = map (dealias v) cs

69

70

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

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

71 case p of

72 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)

73 _ -> c

74 _ -> c

74

75

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

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

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

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

77 where

78 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)

79 where

80 where

80 subOnePattern pattern e =

81 subOnePattern pattern e =

81 case pattern of

82 case pattern of

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

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

83− PAnything -> e

84+ P.Anything -> e

84− PRecord fs ->

85+ P.Record fs ->

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

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

86

87

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

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

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

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

89 where

90 where

90 css = groupBy eq (sortBy cmp cs)

91 css = groupBy eq (sortBy cmp cs)

91

92

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

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

93 case (p1,p2) of

94 case (p1,p2) of

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

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

95 _ -> compare p1 p2

96 _ -> compare p1 p2

96

97

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

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

98 case (p1,p2) of

99 case (p1,p2) of

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

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

100 _ -> p1 == p2

101 _ -> p1 == p2

101

102

102 toClause cs =

103 toClause cs =

103 case head cs of

104 case head cs of

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

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

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

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

106

107

107matchClause :: Either String Literal

108matchClause :: Either String Literal

108 -> [String]

109 -> [String]

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

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

110 -> Match

111 -> Match

111 -> State Int Clause

112 -> State Int Clause

112matchClause c (_:vs) cs def =

113matchClause c (_:vs) cs def =

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

116

117

117 flatten (p:ps, e) =

118 flatten (p:ps, e) =

118 case p of

119 case p of

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

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

120− PLiteral _ -> (ps, e)

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

121

122

122 getVars =

123 getVars =

123 case head cs of

124 case head cs of

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

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

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

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

126

127

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

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

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

129matchMix 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 @@

1{-# OPTIONS_GHC -W #-}

2module Generate.JavaScript (generate) where

3

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

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

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

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

6import Control.Monad.State

7import qualified Data.List as List

8import qualified Data.Map as Map

9import qualified Data.Set as Set

10+import Language.ECMAScript3.PrettyPrint

11+import Language.ECMAScript3.Syntax

10

12

11import Generate.JavaScript.Helpers

13import Generate.JavaScript.Helpers

12import qualified Generate.Cases as Case

14import qualified Generate.Cases as Case

13import qualified Generate.JavaScript.Ports as Port

15import qualified Generate.JavaScript.Ports as Port

14import qualified Generate.Markdown as MD

16import qualified Generate.Markdown as MD

17+import SourceSyntax.Annotation

18+import SourceSyntax.Expression

15import qualified SourceSyntax.Helpers as Help

19import qualified SourceSyntax.Helpers as Help

16import SourceSyntax.Literal

20import SourceSyntax.Literal

17−import SourceSyntax.Pattern as Pattern

18−import SourceSyntax.Location

19−import SourceSyntax.Expression

20import SourceSyntax.Module

21import SourceSyntax.Module

21−import Language.ECMAScript3.Syntax

22+import qualified SourceSyntax.Pattern as P

22−import Language.ECMAScript3.PrettyPrint

23+import SourceSyntax.PrettyPrint (renderPretty)

24+import qualified SourceSyntax.Variable as V

23import qualified Transform.SafeNames as MakeSafe

25import qualified Transform.SafeNames as MakeSafe

24

26

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

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

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

50 FloatNum n -> NumLit () n

52 FloatNum n -> NumLit () n

51 Boolean b -> BoolLit () b

53 Boolean b -> BoolLit () b

52

54

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

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

54−expression (L span expr) =

56+expression (A region expr) =

55 case expr of

57 case expr of

56− Var x -> return $ ref x

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

57 Literal lit -> return $ literal lit

59 Literal lit -> return $ literal lit

58

60

59 Range lo hi ->

61 Range lo hi ->

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

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

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

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

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

95

97

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

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

97

99

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

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

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

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

100 body' <- expression body

102 body' <- expression body

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

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

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

104 where

106 where

105 depattern (args, body) pattern =

107 depattern (args, body) pattern =

106 case pattern of

108 case pattern of

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

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

108 _ -> do arg <- Case.newVar

110 _ -> do arg <- Case.newVar

111+ return ( args ++ [arg]

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

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

110

113

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

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

112

115

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

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

114 case expr of

117 case expr of

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

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

116 _ -> (patterns, lexpr)

119 _ -> (patterns, lexpr)

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

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

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

128 getArgs func args =

131 getArgs func args =

129 case func of

132 case func of

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

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

131 _ -> (func, args)

134 _ -> (func, args)

132

135

133 Let defs e ->

136 Let defs e ->

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

139 MultiIf branches ->

142 MultiIf branches ->

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

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

141 return $ case last branches of

144 return $ case last branches of

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

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

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

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

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

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

145 where

148 where

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

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

147 ifs branches finally = foldr iff finally branches

150 ifs branches finally = foldr iff finally branches

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

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

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

152 (revisedMatch, stmt) <-

155 (revisedMatch, stmt) <-

153 case e of

156 case e of

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

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

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

159+ _ ->

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

160+ do e' <- expression e

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

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

157− match' <- match span revisedMatch

162+ match' <- match region revisedMatch

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

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

159

164

160 ExplicitList es ->

165 ExplicitList es ->

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

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

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

185

190

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

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

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

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

188 expr' <- expression expr

193 expr' <- expression expr

189 let assign x = varDecl x expr'

194 let assign x = varDecl x expr'

190 case pattern of

195 case pattern of

191− PVar x

196+ P.Var x

192 | Help.isOp x ->

197 | Help.isOp x ->

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

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

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

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

195 | otherwise ->

200 | otherwise ->

196 return [ VarDeclStmt () [ assign x ] ]

201 return [ VarDeclStmt () [ assign x ] ]

197

202

198− PRecord fields ->

203+ P.Record fields ->

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

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

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

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

201

206

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

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

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

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

204 where

209 where

205 vars = getVars patterns

210 vars = getVars patterns

206 getVars patterns =

211 getVars patterns =

207 case patterns of

212 case patterns of

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

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

209 [] -> Just []

214 [] -> Just []

210 _ -> Nothing

215 _ -> Nothing

211

216

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

216

221

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

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

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

223 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)]

220

225

221 _ ->

226 _ ->

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

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

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

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

224 where

229 where

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

230+ vars = P.boundVarList pattern

226− mkVar = L span . Var

231+ mkVar = A region . rawVar

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

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

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

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

229

234

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

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

231−match span mtch =

236+match region mtch =

232 case mtch of

237 case mtch of

233 Case.Match name clauses mtch' ->

238 Case.Match name clauses mtch' ->

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

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

235− mtch'' <- match span mtch'

240+ mtch'' <- match region mtch'

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

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

237 where

242 where

238 isLiteral p = case p of

243 isLiteral p = case p of

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

244 | otherwise = e

249 | otherwise = e

245

250

246 Case.Fail ->

251 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)]) ]

248

253

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

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

250 Case.Other e ->

255 Case.Other e ->

251 do e' <- expression e

256 do e' <- expression e

252 return [ ret e' ]

257 return [ ret e' ]

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

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

254 where

259 where

255 dropEnd acc [] = acc

260 dropEnd acc [] = acc

256 dropEnd acc (m:ms) =

261 dropEnd acc (m:ms) =

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

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

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

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

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

260

265

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

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

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

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

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

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

264 where

269 where

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

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

266 (isChar, pattern) =

271 (isChar, pattern) =

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

273 [] -> name

278 [] -> name

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

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

275

280

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

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

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

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

278 case expr of

283 case expr of

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

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

280 _ -> (defs, lexpr)

285 _ -> (defs, lexpr)

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

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

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

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

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

323

328

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

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

325−binop span op e1 e2 =

330+binop region op e1 e2 =

326 case op of

331 case op of

327 "Basics.." ->

332 "Basics.." ->

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

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

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

335 do e1' <- expression e1

340 do e1' <- expression e1

336 e2' <- expression e2

341 e2' <- expression e2

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

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

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

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

339 _ ->

344 _ ->

340 do e1' <- expression e1

345 do e1' <- expression e1

341 e2' <- expression e2

346 e2' <- expression e2

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

345 where

350 where

346 collect es e =

351 collect es e =

347 case e of

352 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

349 _ -> es ++ [e]

354 _ -> es ++ [e]

350

355

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

356 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 #-}

1module Parse.Binop (binops, OpTable) where

2module Parse.Binop (binops, OpTable) where

2

3

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

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

4−import Data.List (intercalate)

5+import qualified Data.List as List

5import qualified Data.Map as Map

6import qualified Data.Map as Map

6

7

7−import SourceSyntax.Location (merge)

8+import SourceSyntax.Annotation (merge)

8import qualified SourceSyntax.Expression as E

9import qualified SourceSyntax.Expression as E

9import SourceSyntax.Declaration (Assoc(..))

10import SourceSyntax.Declaration (Assoc(..))

10import Text.Parsec

11import Text.Parsec

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

16opAssoc :: OpTable -> String -> Assoc

17opAssoc :: OpTable -> String -> Assoc

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

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

18

19

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

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

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

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

21

22

22−binops :: IParser E.LParseExpr

23+binops :: IParser E.ParseExpr

23− -> IParser E.LParseExpr

24+ -> IParser E.ParseExpr

24 -> IParser String

25 -> IParser String

25− -> IParser E.LParseExpr

26+ -> IParser E.ParseExpr

26binops term last anyOp =

27binops term last anyOp =

27 do e <- term

28 do e <- term

28 table <- getState

29 table <- getState

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

38

39

39split :: OpTable

40split :: OpTable

40 -> Int

41 -> Int

41− -> E.LParseExpr

42+ -> E.ParseExpr

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

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

43− -> IParser E.LParseExpr

44+ -> IParser E.ParseExpr

44split _ _ e [] = return e

45split _ _ e [] = return e

45split table n e eops = do

46split table n e eops = do

46 assoc <- getAssoc table n eops

47 assoc <- getAssoc table n eops

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

49 case assoc of R -> joinR es ops

50 case assoc of R -> joinR es ops

50 _ -> joinL es ops

51 _ -> joinL es ops

51

52

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

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

53− -> [IParser E.LParseExpr]

54+ -> [IParser E.ParseExpr]

54splitLevel table n e eops =

55splitLevel table n e eops =

55 case break (hasLevel table n) eops of

56 case break (hasLevel table n) eops of

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

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

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

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

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

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

59

60

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

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

61joinL [e] [] = return e

62joinL [e] [] = return e

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

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

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

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

64

65

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

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

66joinR [e] [] = return e

67joinR [e] [] = return e

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

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

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

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

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

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

70

71

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

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

72getAssoc table n eops

73getAssoc table n eops

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

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

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

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

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

79 assocs = map (opAssoc table . fst) levelOps

80 assocs = map (opAssoc table . fst) levelOps

80 msg problem =

81 msg problem =

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

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

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

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

83 , "Consider adding parentheses to disambiguate." ]

84 , "Consider adding parentheses to disambiguate." ]

compiler/Parse/Expression.hs+67−66

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

5import Text.Parsec hiding (newline,spaces)

6import Text.Parsec.Indent

7

8+import Parse.Binop

8import Parse.Helpers

9import Parse.Helpers

10+import Parse.Literal

9import qualified Parse.Pattern as Pattern

11import qualified Parse.Pattern as Pattern

10import qualified Parse.Type as Type

12import qualified Parse.Type as Type

11−import Parse.Binop

12−import Parse.Literal

13

14−import SourceSyntax.Location as Location

14+import SourceSyntax.Annotation as Annotation

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

15+import qualified SourceSyntax.Pattern as P

16−import qualified SourceSyntax.Literal as Literal

16+import qualified SourceSyntax.Literal as L

17import SourceSyntax.Expression

18

19

20-------- Basic Terms --------

21

22−varTerm :: IParser ParseExpr

22+varTerm :: IParser ParseExpr'

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

24

25−toVar :: String -> ParseExpr

25+toVar :: String -> ParseExpr'

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

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

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

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

28− _ -> Var v

28+ _ -> rawVar v

29

30−accessor :: IParser ParseExpr

30+accessor :: IParser ParseExpr'

31accessor = do

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

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

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

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

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

35

36−negative :: IParser ParseExpr

36+negative :: IParser ParseExpr'

37negative = do

38 (start, nTerm, end) <-

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

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

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

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

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

42

43

44-------- Complex Terms --------

45

46−listTerm :: IParser ParseExpr

46+listTerm :: IParser ParseExpr'

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

48 where

49 range = do

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

66 string "}}"

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

68

69−parensTerm :: IParser LParseExpr

69+parensTerm :: IParser ParseExpr

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

71 where

72 opFn = do

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

74− let loc = Location.at start end

74+ let loc = Annotation.at start end

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

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

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

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

77

78 tupleFn = do

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

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

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

82− loc = Location.at start end

82+ loc = Annotation.at start end

83 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)

85

86 parened = do

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

88 return $ case es of

89 [e] -> e

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

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

91

92−recordTerm :: IParser LParseExpr

92+recordTerm :: IParser ParseExpr

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

94+ where

94− where field = do

95+ field = do

95− label <- rLabel

96+ label <- rLabel

96− patterns <- spacePrefix Pattern.term

97+ patterns <- spacePrefix Pattern.term

97− padded equals

98+ padded equals

98− body <- expr

99+ body <- expr

99− return (label, makeFunction patterns body)

100+ return (label, makeFunction patterns body)

100

101

101− record = Record <$> commaSep field

102+ record = Record <$> commaSep field

102

103

103− change = do

104+ change = do

104− lbl <- rLabel

105+ lbl <- rLabel

105− padded (string "<-")

106+ padded (string "<-")

106− (,) lbl <$> expr

107+ (,) lbl <$> expr

107

108

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

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

109

110

110− insert r = addLocation $ do

111+ insert r = addLocation $ do

111− string "|" >> whitespace

112+ string "|" >> whitespace

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

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

113

114

114− modify r = addLocation

115+ modify r =

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

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

116

117

117− misc = try $ do

118+ misc = try $ do

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

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

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

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

120− case opt of

121+ case opt of

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

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

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

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

123

124

125

125−term :: IParser LParseExpr

126+term :: IParser ParseExpr

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

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

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

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

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

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

129

130

130-------- Applications --------

131-------- Applications --------

131

132

132−appExpr :: IParser LParseExpr

133+appExpr :: IParser ParseExpr

133appExpr = do

134appExpr = do

134 t <- term

135 t <- term

135 ts <- constrainedSpacePrefix term $ \str ->

136 ts <- constrainedSpacePrefix term $ \str ->

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

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

137 return $ case ts of

138 return $ case ts of

138 [] -> t

139 [] -> 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

140

141

141-------- Normal Expressions --------

142-------- Normal Expressions --------

142

143

143−binaryExpr :: IParser LParseExpr

144+binaryExpr :: IParser ParseExpr

144binaryExpr = binops appExpr lastExpr anyOp

145binaryExpr = binops appExpr lastExpr anyOp

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

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

146 <|> lambdaExpr

147 <|> lambdaExpr

147

148

148−ifExpr :: IParser ParseExpr

149+ifExpr :: IParser ParseExpr'

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

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

150 where

151 where

151 normal = do

152 normal = do

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

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

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

156 elseBranch <- expr

157 elseBranch <- expr

157 return $ MultiIf [(bool, thenBranch),

158 return $ MultiIf [(bool, thenBranch),

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

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

159 multiIf = MultiIf <$> spaceSep1 iff

160 multiIf = MultiIf <$> spaceSep1 iff

160 where iff = do string "|" ; whitespace

161 where iff = do string "|" ; whitespace

161 b <- expr ; padded arrow

162 b <- expr ; padded arrow

162 (,) b <$> expr

163 (,) b <$> expr

163

164

164−lambdaExpr :: IParser LParseExpr

165+lambdaExpr :: IParser ParseExpr

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

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

166 whitespace

167 whitespace

167 args <- spaceSep1 Pattern.term

168 args <- spaceSep1 Pattern.term

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

172defSet :: IParser [ParseDef]

173defSet :: IParser [ParseDef]

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

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

174

175

175−letExpr :: IParser ParseExpr

176+letExpr :: IParser ParseExpr'

176letExpr = do

177letExpr = do

177 reserved "let" ; whitespace

178 reserved "let" ; whitespace

178 defs <- defSet

179 defs <- defSet

179 padded (reserved "in")

180 padded (reserved "in")

180 Let defs <$> expr

181 Let defs <$> expr

181

182

182−caseExpr :: IParser ParseExpr

183+caseExpr :: IParser ParseExpr'

183caseExpr = do

184caseExpr = do

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

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

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

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

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

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

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

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

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

191

192

192−expr :: IParser LParseExpr

193+expr :: IParser ParseExpr

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

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

194 <|> lambdaExpr

195 <|> lambdaExpr

195 <|> binaryExpr

196 <|> binaryExpr

196 <?> "an expression"

197 <?> "an expression"

197

198

198−defStart :: IParser [Pattern]

199+defStart :: IParser [P.Pattern]

199defStart =

200defStart =

200 choice [ do p1 <- try Pattern.term

201 choice [ do p1 <- try Pattern.term

201 infics p1 <|> func p1

202 infics p1 <|> func p1

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

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

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

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

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

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

205 where

206 where

206 func pattern =

207 func pattern =

207 case pattern of

208 case pattern of

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

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

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

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

210 return [pattern]

211 return [pattern]

211

212

212 infics p1 = do

213 infics p1 = do

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

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

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

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

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

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

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

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

217

218

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

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

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

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

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

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

221

222

222definition :: IParser ParseDef

223definition :: IParser ParseDef

223definition = withPos $ do

224definition = withPos $ do

compiler/Parse/Helpers.hs+14−11

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

12import Text.Parsec.Indent

13import qualified Text.Parsec.Token as T

14

15−import SourceSyntax.Helpers as Help

15+import SourceSyntax.Annotation as Annotation

16−import SourceSyntax.Location as Location

16+import SourceSyntax.Declaration (Assoc)

17import SourceSyntax.Expression

18+import SourceSyntax.Helpers as Help

18import SourceSyntax.PrettyPrint

19import SourceSyntax.PrettyPrint

19−import SourceSyntax.Declaration (Assoc)

20+import SourceSyntax.Variable as Variable

20

21

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

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

22 , "case", "of"

23 , "case", "of"

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

181brackets :: IParser a -> IParser a

182brackets :: IParser a -> IParser a

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

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

183

184

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

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

185addLocation expr = do

186addLocation expr = do

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

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

187− return (Location.at start end e)

188+ return (Annotation.at start end e)

188

189

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

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

190located p = do

191located p = do

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

193 end <- getPosition

194 end <- getPosition

194 return (start, e, end)

195 return (start, e, end)

195

196

196−accessible :: IParser LParseExpr -> IParser LParseExpr

197+accessible :: IParser ParseExpr -> IParser ParseExpr

197accessible expr = do

198accessible expr = do

198 start <- getPosition

199 start <- getPosition

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

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

200 let rest f = do

201 let rest f = do

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

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

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

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

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

205 Just _ -> accessible $ do

206 Just _ -> accessible $ do

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

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

207 end <- getPosition

208 end <- getPosition

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

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

210+ case e of

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

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

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

210− | otherwise -> rest (Access ce)

213+ | otherwise -> rest (Access ce)

211− _ -> rest (Access ce)

214+ _ -> rest (Access ce)

212

215

213

216

214spaces :: IParser String

217spaces :: IParser String

compiler/Parse/Pattern.hs+29−27

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

3

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

5import Data.Char (isUpper)

6−import Data.List (intercalate)

6+import qualified Data.List as List

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

8

9import Parse.Helpers

10import Parse.Literal

11import SourceSyntax.Literal

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

13−import qualified SourceSyntax.Pattern as Pattern

12+import qualified SourceSyntax.Pattern as P

14

13

15−basic :: IParser Pattern

14+basic :: IParser P.Pattern

16basic = choice

15basic = choice

17− [ char '_' >> return PAnything

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

18 , do v <- var

17 , do v <- var

19 return $ case v of

18 return $ case v of

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

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

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

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

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

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

23− _ -> PVar v

22+ _ -> P.Var v

24− , PLiteral <$> literal

23+ , P.Literal <$> literal

25 ]

24 ]

26

25

27−asPattern :: Pattern -> IParser Pattern

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

28asPattern pattern = do

27asPattern pattern = do

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

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

30 return $ case var of

29 return $ case var of

31− Just v -> PAlias v pattern

30+ Just v -> P.Alias v pattern

32 Nothing -> pattern

31 Nothing -> pattern

33

32

34−record :: IParser Pattern

33+record :: IParser P.Pattern

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

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

36

35

37−tuple :: IParser Pattern

36+tuple :: IParser P.Pattern

37+tuple = do

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

38+ ps <- parens (commaSep expr)

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

39+ return $ case ps of

40+ [p] -> p

41+ _ -> P.tuple ps

40

42

41−list :: IParser Pattern

43+list :: IParser P.Pattern

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

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

43

45

44−term :: IParser Pattern

46+term :: IParser P.Pattern

45term =

47term =

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

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

47

49

48−patternConstructor :: IParser Pattern

50+patternConstructor :: IParser P.Pattern

49patternConstructor = do

51patternConstructor = do

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

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

51 case v of

53 case v of

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

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

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

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

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

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

55

57

56−expr :: IParser Pattern

58+expr :: IParser P.Pattern

57expr = do

59expr = do

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

60 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

20

21data ParsePort

22 = PPAnnotation String T.Type

23− | PPDef String Expr.LParseExpr

23+ | PPDef String Expr.ParseExpr

24 deriving (Show)

25

26data Port

27− = Out String Expr.LExpr T.Type

27+ = Out String Expr.Expr T.Type

28 | In String T.Type

29 deriving (Show)

30

compiler/SourceSyntax/Expression.hs+88−62

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

11import SourceSyntax.PrettyPrint

12import Text.PrettyPrint as P

13import qualified SourceSyntax.Helpers as Help

14−import qualified SourceSyntax.Location as Location

14+import qualified SourceSyntax.Annotation as Annotation

15import qualified SourceSyntax.Pattern as Pattern

16import qualified SourceSyntax.Type as SrcType

17import qualified SourceSyntax.Literal as Literal

18+import qualified SourceSyntax.Variable as Variable

18

19

19---- GENERAL AST ----

20---- GENERAL AST ----

20

21

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−

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

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

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

23"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

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

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

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.

31

32

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

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

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

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

34

35

35-}

36-}

37+type GeneralExpr annotation definition variable =

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

39+

36−data Expr' def

40+data GeneralExpr' ann def var

37 = Literal Literal.Literal

41 = Literal Literal.Literal

38− | Var String

42+ | Var var

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

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

40− | ExplicitList [LExpr' def]

44+ | ExplicitList [GeneralExpr ann def var]

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

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

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

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

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

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

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

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

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

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

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

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

47− | Data String [LExpr' def]

51+ | Data String [GeneralExpr ann def var]

48− | Access (LExpr' def) String

52+ | Access (GeneralExpr ann def var) String

49− | Remove (LExpr' def) String

53+ | Remove (GeneralExpr ann def var) String

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

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

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

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

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

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

53− | Markdown String String [LExpr' def]

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

54 -- for type checking and code gen only

58 -- for type checking and code gen only

55 | PortIn String SrcType.Type

59 | PortIn String SrcType.Type

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

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

61+ deriving (Show)

57

62

58

63

59---- SPECIALIZED ASTs ----

64---- SPECIALIZED ASTs ----

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

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

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

63they are parsed.

68they are parsed.

64-}

69-}

65−type ParseExpr = Expr' ParseDef

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

66−type LParseExpr = LExpr' ParseDef

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

67

72

68data ParseDef

73data ParseDef

69− = Def Pattern.Pattern LParseExpr

74+ = Def Pattern.Pattern ParseExpr

70 | TypeAnnotation String SrcType.Type

75 | TypeAnnotation String SrcType.Type

71− deriving (Show)

76+ deriving (Show)

72

77

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

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

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

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

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

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

76-}

81-}

77−type LExpr = LExpr' Def

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

78−type Expr = Expr' Def

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

79

84

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

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

81 deriving (Show)

86 deriving (Show)

82

87

83

88

89+

84---- UTILITIES ----

90---- UTILITIES ----

85

91

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

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

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

88

97

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

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

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

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

91delist _ = []

100delist _ = []

92

101

93saveEnvName :: String

102saveEnvName :: String

94saveEnvName = "_save_the_environment!!!"

103saveEnvName = "_save_the_environment!!!"

95

104

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

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

97dummyLet defs =

106dummyLet defs =

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

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

99

108

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

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

101− show = render . pretty

102−

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

104 pretty expr =

110 pretty expr =

105 case expr of

111 case expr of

106 Literal lit -> pretty lit

112 Literal lit -> pretty lit

113+

107− Var x -> variable x

114+ Var x -> pretty x

115+

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

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

117+

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

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

119+

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

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

111 P.text "-" <> prettyParens e

121 P.text "-" <> prettyParens e

122+

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

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

124+ where

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

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

126+

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

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

115 where

128 where

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

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

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

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

131+

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

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

133+ where

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

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

135+

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

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

121 where

137 where

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

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

139+

123 Let defs e ->

140 Let defs e ->

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

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

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

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

143+

126 Case e pats ->

144 Case e pats ->

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

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

128 where

146 where

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

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

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

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

149+

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

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

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

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

133 Data name es

152 Data name es

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

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

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

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

155+

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

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

157+

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

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

159+

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

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

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

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

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

163+

140 Insert e x v ->

164 Insert e x v ->

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

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

142

166

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

175 Nothing -> P.empty

199 Nothing -> P.empty

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

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

177

201

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

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

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

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

180 case expr of

204 case expr of

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

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

182− _ -> [lexpr]

206+ _ -> [annExpr]

183

207

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

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

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

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

186 case expr of

210 case expr of

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

211+ Lambda pattern body ->

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

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

213+ in (pattern : ps, body')

214+

189 _ -> ([], lexpr)

215 _ -> ([], lexpr)

190

216

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

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

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

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

193 where

219 where

194 needed =

220 needed =

195 case expr of

221 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

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

8import Text.PrettyPrint as P

9

10−import SourceSyntax.Expression (LExpr)

10+import SourceSyntax.Expression (Expr)

11import SourceSyntax.Declaration

12import SourceSyntax.PrettyPrint

13import SourceSyntax.Type

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

30 where

31 prettyDecls = P.sep $ map pretty decls

32

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

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

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

35− where' =

35+ prettyExports =

36 case exports of

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

37+ [] -> P.empty

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

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

39

40 prettyImports = P.vcat $ map prettyImport imports

41

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

72 , path :: FilePath

73 , exports :: [String]

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

75− , program :: LExpr

75+ , program :: Expr

76 , types :: Map.Map String Type

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

78 , aliases :: [Alias]

compiler/SourceSyntax/Pattern.hs+30−26

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

7import qualified Data.Set as Set

8import SourceSyntax.Literal as Literal

9

10+data Pattern

10−data Pattern = PData String [Pattern]

11+ = Data String [Pattern]

11− | PRecord [String]

12+ | Record [String]

12− | PAlias String Pattern

13+ | Alias String Pattern

13− | PVar String

14+ | Var String

14− | PAnything

15+ | Anything

15− | PLiteral Literal.Literal

16+ | Literal Literal.Literal

16− deriving (Eq, Ord, Show)

17+ deriving (Eq, Ord, Show)

17

18

18cons :: Pattern -> Pattern -> Pattern

19cons :: Pattern -> Pattern -> Pattern

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

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

20

21

21nil :: Pattern

22nil :: Pattern

22−nil = PData "[]" []

23+nil = Data "[]" []

23

24

24list :: [Pattern] -> Pattern

25list :: [Pattern] -> Pattern

25list = foldr cons nil

26list = foldr cons nil

26

27

27tuple :: [Pattern] -> Pattern

28tuple :: [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

29

33

30boundVars :: Pattern -> Set.Set String

34boundVars :: Pattern -> Set.Set String

31boundVars pattern =

35boundVars pattern =

32 case pattern of

36 case pattern of

33− PVar x -> Set.singleton x

37+ Var x -> Set.singleton x

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

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

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

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

36− PRecord fields -> Set.fromList fields

40+ Record fields -> Set.fromList fields

37− PAnything -> Set.empty

41+ Anything -> Set.empty

38− PLiteral _ -> Set.empty

42+ Literal _ -> Set.empty

39

43

40

44

41instance Pretty Pattern where

45instance Pretty Pattern where

42 pretty pattern =

46 pretty pattern =

43 case pattern of

47 case pattern of

44− PVar x -> variable x

48+ Var x -> variable x

45− PLiteral lit -> pretty lit

49+ Literal lit -> pretty lit

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

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

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

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

48− PAnything -> PP.text "_"

52+ Anything -> PP.text "_"

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

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

50 where isCons = case hd of

54 where isCons = case hd of

51− PData "::" _ -> True

55+ Data "::" _ -> True

52 _ -> False

56 _ -> False

53− PData name ps ->

57+ Data name ps ->

54 if Help.isTuple name then

58 if Help.isTuple name then

55 PP.parens . commaCat $ map pretty ps

59 PP.parens . commaCat $ map pretty ps

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

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

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

60 where

64 where

61 needsThem =

65 needsThem =

62 case pattern of

66 case pattern of

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

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

64− PAlias _ _ -> True

68+ Alias _ _ -> True

65 _ -> False

69 _ -> False

compiler/SourceSyntax/PrettyPrint.hs+5

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

10instance Pretty () where

11 pretty () = empty

12

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

14+renderPretty e = render (pretty e)

15+

13commaCat docs = cat (punctuate comma docs)

16commaCat docs = cat (punctuate comma docs)

14commaSep docs = sep (punctuate comma docs)

17commaSep docs = sep (punctuate comma docs)

15

18

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

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

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

17

21

22+variable :: String -> Doc

18variable x =

23variable x =

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

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

20 else text (reprime x)

25 else text (reprime x)

compiler/SourceSyntax/Type.hs+3−6

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

1{-# OPTIONS_GHC -W #-}

2module SourceSyntax.Type where

3

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

4import Data.Binary

5import Data.Binary

5import qualified Data.Map as Map

6import qualified Data.Map as Map

6−import qualified SourceSyntax.Helpers as Help

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

8import SourceSyntax.PrettyPrint

7import SourceSyntax.PrettyPrint

8+import qualified SourceSyntax.Helpers as Help

9import Text.PrettyPrint as P

10

11data Type = Lambda Type Type

12 | Var String

13 | Data String [Type]

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

15− deriving (Eq)

15+ deriving (Eq,Show)

16

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

18fieldMap fields =

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

27tupleOf :: [Type] -> Type

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

29

30−instance Show Type where

31− show = render . pretty

32−

33instance Pretty Type where

30instance Pretty Type where

34 pretty tipe =

31 pretty tipe =

35 case tipe of

32 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 #-}

2module Transform.Canonicalize (interface, metadataModule) where

3

4import Control.Arrow ((***))

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

6import Control.Monad.Identity

7−import qualified Data.Traversable as T

7+import qualified Data.Either as Either

8+import qualified Data.List as List

8import qualified Data.Map as Map

9import qualified Data.Map as Map

9import qualified Data.Set as Set

10import qualified Data.Set as Set

10−import qualified Data.List as List

11+import qualified Data.Traversable as T

11−import qualified Data.Either as Either

12−import SourceSyntax.Module

12+import SourceSyntax.Annotation as A

13import SourceSyntax.Expression

14−import SourceSyntax.Location as Loc

14+import SourceSyntax.Module

15import qualified SourceSyntax.Pattern as P

16import qualified SourceSyntax.Type as Type

17+import qualified SourceSyntax.Variable as Var

17import Text.PrettyPrint as P

18import Text.PrettyPrint as P

18

19

19interface :: String -> ModuleInterface -> ModuleInterface

20interface :: String -> ModuleInterface -> ModuleInterface

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

96

97

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

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

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

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

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

100+ where xs = P.boundVarList pattern

100−

101

102replace :: String -> Env -> String -> Either String String

103replace variable env v =

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

110 msg = if null matches then "" else

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

112

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

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

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

114−rename env (L s expr) =

115+rename env (A ann expr) =

115 let rnm = rename env

116 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 ]

117 format = Either.either throw return

118 format = Either.either throw return

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

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

119 in

120 in

120− L s <$>

121+ A ann <$>

121 case expr of

122 case expr of

122 Literal _ -> return expr

123 Literal _ -> return expr

123

124

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

155 <*> rename env' body

156 <*> rename env' body

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

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

157

158

159+ -- TODO: Raw -> Canonical

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

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

159

161

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

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

161

163

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

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

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

177renamePattern env pattern =

179renamePattern env pattern =

178 case pattern of

180 case pattern of

179− P.PVar _ -> return pattern

181+ P.Var _ -> return pattern

180− P.PLiteral _ -> return pattern

182+ P.Literal _ -> return pattern

181− P.PRecord _ -> return pattern

183+ P.Record _ -> return pattern

182− P.PAnything -> return pattern

184+ P.Anything -> return pattern

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

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

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

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

185− <*> mapM (renamePattern env) ps

187+ <*> mapM (renamePattern env) ps

compiler/Transform/Check.hs+4−5

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

32

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

34duplicates decls =

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

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

36 case mapM exprDups (portExprs ++ defExprs) of

37 Left name -> [msg name]

38 Right _ -> []

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

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

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

52

53− getNames = Set.toList . Pattern.boundVars

54−

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

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

56 exprDups expr = Expr.crawlLet defsDups expr

54 exprDups expr = Expr.crawlLet defsDups expr

57

55

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

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

59 defsDups defs =

57 defsDups defs =

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

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

59+ case dups $ concatMap varsIn defs of

61 [] -> Right defs

60 [] -> Right defs

62 name:_ -> Left name

61 name:_ -> Left name

63

62

compiler/Transform/Declaration.hs+1−1

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

42

43 TypeAnnotation name tipe ->

44 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' ->

46 do expr' <- exprCombineAnnotations expr

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

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

compiler/Transform/Definition.hs+1−1

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

16

17 go defs =

18 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' ->

20 do expr' <- exprCombineAnnotations expr

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

22 (:) def <$> go rest

compiler/Transform/Expression.hs+15−13

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

2module Transform.Expression (crawlLet, checkPorts) where

3

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

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

5import SourceSyntax.Expression

6import SourceSyntax.Expression

6−import SourceSyntax.Location

7+import SourceSyntax.Type (Type)

7−import qualified SourceSyntax.Type as ST

8

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)

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

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

11

13

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

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

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

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

14− -> LExpr

16+ -> Expr

15− -> Either a LExpr

17+ -> Either a Expr

16checkPorts inCheck outCheck expr =

18checkPorts inCheck outCheck expr =

17 crawl inCheck outCheck (mapM checkDef) expr

19 crawl inCheck outCheck (mapM checkDef) expr

18 where

20 where

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

20 do _ <- checkPorts inCheck outCheck body

22 do _ <- checkPorts inCheck outCheck body

21 return def

23 return def

22

24

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

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

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

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

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

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

26− -> LExpr' def

28+ -> GeneralExpr ann def var

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

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

28crawl portInCheck portOutCheck defsTransform = go

30crawl portInCheck portOutCheck defsTransform = go

29 where

31 where

30− go (L srcSpan expr) =

32+ go (A srcSpan expr) =

31− L srcSpan <$>

33+ A srcSpan <$>

32 case expr of

34 case expr of

33 Var x -> return (Var x)

35 Var x -> return (Var x)

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

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

compiler/Transform/SafeNames.hs+19−18

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

1{-# OPTIONS_GHC -Wall #-}

2module Transform.SafeNames (metadataModule) where

3

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

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

5−import Data.List (intercalate)

5+import qualified Data.List as List

6−

7import qualified Data.Set as Set

6import qualified Data.Set as Set

8

7

9−import qualified Parse.Helpers as PHelp

8+import qualified Parse.Helpers as PHelp

9+import SourceSyntax.Annotation

10import SourceSyntax.Expression

11import qualified SourceSyntax.Helpers as SHelp

12−import SourceSyntax.Location

13import SourceSyntax.Module

12import SourceSyntax.Module

14−import SourceSyntax.Pattern

13+import qualified SourceSyntax.Pattern as P

14+import qualified SourceSyntax.Variable as Variable

15

16var :: String -> String

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

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

18 where

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

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

21 False -> x

22 True -> "$" ++ x

23

24−pattern :: Pattern -> Pattern

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

25pattern pat =

26 case pat of

27− PVar x -> PVar (var x)

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

28− PLiteral _ -> pat

28+ P.Literal _ -> pat

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

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

30− PAnything -> pat

30+ P.Anything -> pat

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

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

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

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

33

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

34−expression :: LExpr -> LExpr

35+expression :: Expr -> Expr

35−expression (L loc expr) =

36+expression (A ann expr) =

36 let f = expression in

37 let f = expression in

37− L loc $

38+ A ann $

38 case expr of

39 case expr of

39 Literal _ -> expr

40 Literal _ -> expr

40− Var x -> Var (var x)

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

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

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

42 ExplicitList es -> ExplicitList (map f es)

43 ExplicitList es -> ExplicitList (map f es)

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

44 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

3

4import Control.Monad.State

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

6+import qualified Data.Graph as Graph

6import qualified Data.Map as Map

7import qualified Data.Map as Map

8+import qualified Data.Maybe as Maybe

9+import qualified Data.Set as Set

10+import SourceSyntax.Annotation

7import SourceSyntax.Expression

11import SourceSyntax.Expression

8−import SourceSyntax.Location

9import qualified SourceSyntax.Pattern as P

12import qualified SourceSyntax.Pattern as P

10−import qualified Data.Graph as Graph

13+import qualified SourceSyntax.Variable as V

11−import qualified Data.Set as Set

12−import qualified Data.Maybe as Maybe

13

14

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

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

15ctors pattern =

16ctors pattern =

16 case pattern of

17 case pattern of

17− P.PVar _ -> []

18+ P.Var _ -> []

18− P.PAlias _ p -> ctors p

19+ P.Alias _ p -> ctors p

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

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

20− P.PRecord _ -> []

21+ P.Record _ -> []

21− P.PAnything -> []

22+ P.Anything -> []

22− P.PLiteral _ -> []

23+ P.Literal _ -> []

23

24

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

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

25free x = modify (Set.insert x)

26free x = modify (Set.insert x)

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

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

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

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

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

29

30

30−sortDefs :: LExpr -> LExpr

31+sortDefs :: Expr -> Expr

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

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

32

33

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

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

34−reorder (L s expr) =

35+reorder (A ann expr) =

35− L s <$>

36+ A ann <$>

36 case expr of

37 case expr of

37 -- Be careful adding and restricting freeVars

38 -- Be careful adding and restricting freeVars

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

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

39

40

40 Lambda p e ->

41 Lambda p e ->

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

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

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

103 bound (P.boundVars pattern)

104 bound (P.boundVars pattern)

104 mapM free (ctors pattern)

105 mapM free (ctors pattern)

105

106

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

107

108

108 return let'

109 return let'

109

110

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

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

111bindingReorder (pattern,expr) =

112bindingReorder (pattern,expr) =

112 do expr' <- reorder expr

113 do expr' <- reorder expr

113 bound (P.boundVars pattern)

114 bound (P.boundVars pattern)

compiler/Transform/Substitute.hs+8−6

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

2module Transform.Substitute (subst) where

3

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

5+import qualified Data.Set as Set

6+

7+import SourceSyntax.Annotation

5import SourceSyntax.Expression

8import SourceSyntax.Expression

6−import SourceSyntax.Location

7import qualified SourceSyntax.Pattern as Pattern

9import qualified SourceSyntax.Pattern as Pattern

8−import qualified Data.Set as Set

10+import qualified SourceSyntax.Variable as V

9

11

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

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

11subst old new expr =

13subst 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

13 case expr of

15 case expr of

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

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

15 ExplicitList es -> ExplicitList (map f es)

17 ExplicitList es -> ExplicitList (map f es)

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

28 anyShadow =

30 anyShadow =

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

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

30

32

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

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

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

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

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

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

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

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

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

39 Literal _ -> expr

41 Literal _ -> expr

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

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

41 PortIn name st -> PortIn name st

43 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 @@

1{-# OPTIONS_GHC -Wall #-}

2module Type.Constrain.Declaration where

3

4+import qualified SourceSyntax.Annotation as A

4−import SourceSyntax.Declaration

5+import qualified SourceSyntax.Declaration as D

5import qualified SourceSyntax.Expression as E

6import qualified SourceSyntax.Expression as E

6−import qualified SourceSyntax.Location as L

7import qualified SourceSyntax.Pattern as P

8import qualified SourceSyntax.Type as T

9

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

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

11toExpr = concatMap toDefs

12

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

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

14toDefs decl =

15 case decl of

16− Definition def -> [def]

16+ D.Definition def -> [def]

17

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

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

19 where

20 toDefs' (ctor, tipes) =

21 let vars = take (length tipes) arguments

22 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

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

25

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

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

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

28 where

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

30

31− var = L.none . E.Var

31+ var = A.none . E.rawVar

32 vars = take (length args) arguments

33

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

35 record = case ext of

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

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

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

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

38

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

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

41− TypeAlias _ _ _ -> []

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

42

43− Port port ->

43+ D.Port port ->

44 case port of

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

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

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

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

47− In name tipe ->

47+ D.In name tipe ->

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

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

49

50 -- no constraints are needed for fixity declarations

51− Fixity _ _ _ -> []

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

52

53

54arguments :: [String]

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

56

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

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

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

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

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

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

60

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

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

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

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

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

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

1{-# OPTIONS_GHC -W #-}

2module Type.Constrain.Expression where

3

4−import qualified Data.List as List

5−import qualified Data.Map as Map

6−import qualified Data.Set as Set

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

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

8import qualified Control.Monad as Monad

5import qualified Control.Monad as Monad

9import Control.Monad.Error

6import Control.Monad.Error

7+import qualified Data.List as List

8+import qualified Data.Map as Map

10import qualified Text.PrettyPrint as PP

9import qualified Text.PrettyPrint as PP

11

10

12−import SourceSyntax.Location as Loc

11+import SourceSyntax.Annotation as Ann

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

14import SourceSyntax.Expression

12import 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

16import Type.Type hiding (Descriptor(..))

17import Type.Fragment

18import qualified Type.Environment as Env

19import qualified Type.Constrain.Literal as Literal

20import qualified Type.Constrain.Pattern as Pattern

21

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

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

23−constrain env (L span expr) tipe =

23+constrain env (A region expr) tipe =

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

25− and = L span . CAnd

25+ and = A region . CAnd

26− true = L span CTrue

26+ true = A region CTrue

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

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

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

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

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

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

30 in

31 case expr of

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

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

33

34+ Var (V.Raw name)

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

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

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

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

36

37

37 Range lo hi ->

38 Range lo hi ->

38 exists $ \x -> do

39 exists $ \x -> do

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

55 Lambda p e ->

56 Lambda p e ->

56 exists $ \t1 ->

57 exists $ \t1 ->

57 exists $ \t2 -> do

58 exists $ \t2 -> do

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

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

59 c2 <- constrain env e t2

60 c2 <- constrain env e t2

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

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

61 (typeConstraint fragment /\ c2 ))

62 (typeConstraint fragment /\ c2 ))

@@ -79,7 +80,7 @@ constrain env (L span expr) tipe =

79 exists $ \t -> do

80 exists $ \t -> do

80 ce <- constrain env exp t

81 ce <- constrain env exp t

81 let branch (p,e) = do

82 let branch (p,e) = do

82− fragment <- try span $ Pattern.constrain env p t

83+ fragment <- try region $ Pattern.constrain env p t

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

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

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

85 and . (:) ce <$> mapM branch branches

85

86

@@ -112,11 +113,11 @@ constrain env (L span expr) tipe =

112 Modify e fields ->

113 Modify e fields ->

113 exists $ \t -> do

114 exists $ \t -> do

114 oldVars <- forM fields $ \_ -> liftIO (var Flexible)

115 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))

116 cOld <- ex oldVars <$> constrain env e (record oldFields t)

117 cOld <- ex oldVars <$> constrain env e (record oldFields t)

117

118

118 newVars <- forM fields $ \_ -> liftIO (var Flexible)

119 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))

120 let cNew = tipe === record newFields t

121 let cNew = tipe === record newFields t

121

122

122 cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)

123 cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)

@@ -126,7 +127,7 @@ constrain env (L span expr) tipe =

126 Record fields ->

127 Record fields ->

127 do vars <- forM fields $ \_ -> liftIO (var Flexible)

128 do vars <- forM fields $ \_ -> liftIO (var Flexible)

128 cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)

129 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))

130 recordType = record fields' (TermN EmptyRecord1)

131 recordType = record fields' (TermN EmptyRecord1)

131 return . ex vars . and $ tipe === recordType : cs

132 return . ex vars . and $ tipe === recordType : cs

132

133

@@ -158,14 +159,14 @@ constrainDef env info (Definition pattern expr maybeTipe) =

158 do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.

159 do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.

159 -- Currently, qs is always [].

160 -- Currently, qs is always [].

160 case (pattern, maybeTipe) of

161 case (pattern, maybeTipe) of

161− (PVar name, Just tipe) -> do

162+ (P.Var name, Just tipe) -> do

162 flexiVars <- forM qs (\_ -> liftIO $ var Flexible)

163 flexiVars <- forM qs (\_ -> liftIO $ var Flexible)

163 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars

164 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars

164 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

165 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

165 (vars, typ) <- Env.instantiateType env tipe Map.empty

166 (vars, typ) <- Env.instantiateType env tipe Map.empty

166 let scheme = Scheme { rigidQuantifiers = [],

167 let scheme = Scheme { rigidQuantifiers = [],

167 flexibleQuantifiers = flexiVars ++ vars,

168 flexibleQuantifiers = flexiVars ++ vars,

168− constraint = Loc.noneNoDocs CTrue,

169+ constraint = Ann.noneNoDocs CTrue,

169 header = Map.singleton name typ }

170 header = Map.singleton name typ }

170 c <- constrain env' expr typ

171 c <- constrain env' expr typ

171 return ( scheme : schemes

172 return ( scheme : schemes

@@ -175,7 +176,7 @@ constrainDef env info (Definition pattern expr maybeTipe) =

175 , c2

176 , c2

176 , fl rigidVars c /\ c1 )

177 , fl rigidVars c /\ c1 )

177

178

178− (PVar name, Nothing) -> do

179+ (P.Var name, Nothing) -> do

179 v <- liftIO $ var Flexible

180 v <- liftIO $ var Flexible

180 let tipe = VarN v

181 let tipe = VarN v

181 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars

182 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars

@@ -191,19 +192,19 @@ constrainDef env info (Definition pattern expr maybeTipe) =

191 _ -> error (show pattern)

192 _ -> error (show pattern)

192

193

193expandPattern :: Def -> [Def]

194expandPattern :: Def -> [Def]

194−expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =

195+expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =

195 case pattern of

196 case pattern of

196− PVar _ -> [def]

197+ P.Var _ -> [def]

197− _ -> Definition (PVar x) lexpr maybeType : map toDef vars

198+ _ -> Definition (P.Var x) lexpr maybeType : map toDef vars

198 where

199 where

199− vars = Set.toList $ boundVars pattern

200+ vars = P.boundVarList pattern

200 x = "$" ++ concat vars

201 x = "$" ++ concat vars

201− mkVar = L s . Var

202+ mkVar = A r . rawVar

202− toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

203+ toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

203

204

204−try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

205+try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

205−try span computation = do

206+try region computation = do

206 result <- liftIO $ runErrorT computation

207 result <- liftIO $ runErrorT computation

207 case result of

208 case result of

208− Left err -> throwError [err span]

209+ Left err -> throwError [err region]

209 Right value -> return value

210 Right value -> return value

compiler/Type/Constrain/Literal.hs+5−4

@@ -1,14 +1,15 @@

1+{-# OPTIONS_GHC -W #-}

1module Type.Constrain.Literal where

2module Type.Constrain.Literal where

2

3

4+import SourceSyntax.Annotation

3import SourceSyntax.Literal

5import SourceSyntax.Literal

4−import SourceSyntax.Location

5import Type.Type

6import Type.Type

6import Type.Environment as Env

7import Type.Environment as Env

7

8

8−constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint

9+constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint

9−constrain env span literal tipe =

10+constrain env region literal tipe =

10 do tipe' <- litType

11 do tipe' <- litType

11− return . L span $ CEqual tipe tipe'

12+ return . A region $ CEqual tipe tipe'

12 where

13 where

13 prim name = return (Env.get env Env.types name)

14 prim name = return (Env.get env Env.types name)

14

15

compiler/Type/Constrain/Pattern.hs+17−18

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -W #-}

1{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE FlexibleInstances #-}

2module Type.Constrain.Pattern where

3module Type.Constrain.Pattern where

3

4

@@ -8,31 +9,29 @@ import Control.Monad.Error

8import qualified Data.Map as Map

9import qualified Data.Map as Map

9import qualified Text.PrettyPrint as PP

10import qualified Text.PrettyPrint as PP

10

11

12+import qualified SourceSyntax.Annotation as A

11−import SourceSyntax.Pattern

13+import qualified SourceSyntax.Pattern as P

12−import SourceSyntax.Location

13−import SourceSyntax.PrettyPrint

14+import SourceSyntax.PrettyPrint (pretty)

14−import Text.PrettyPrint (render)

15−import qualified SourceSyntax.Location as Loc

16import Type.Type

15import Type.Type

17import Type.Fragment

16import Type.Fragment

18import Type.Environment as Env

17import Type.Environment as Env

19import qualified Type.Constrain.Literal as Literal

18import qualified Type.Constrain.Literal as Literal

20

19

21

20

22−constrain :: Environment -> Pattern -> Type -> ErrorT (SrcSpan -> PP.Doc) IO Fragment

21+constrain :: Environment -> P.Pattern -> Type -> ErrorT (A.Region -> PP.Doc) IO Fragment

23constrain env pattern tipe =

22constrain env pattern tipe =

24− let span = Loc.NoSpan (render $ pretty pattern)

23+ let region = A.None (pretty pattern)

25− t1 === t2 = Loc.L span (CEqual t1 t2)

24+ t1 === t2 = A.A region (CEqual t1 t2)

26− x <? t = Loc.L span (CInstance x t)

25+ x <? t = A.A region (CInstance x t)

27 in

26 in

28 case pattern of

27 case pattern of

29− PAnything -> return emptyFragment

28+ P.Anything -> return emptyFragment

30

29

31− PLiteral lit -> do

30+ P.Literal lit -> do

32− c <- liftIO $ Literal.constrain env span lit tipe

31+ c <- liftIO $ Literal.constrain env region lit tipe

33 return $ emptyFragment { typeConstraint = c }

32 return $ emptyFragment { typeConstraint = c }

34

33

35− PVar name -> do

34+ P.Var name -> do

36 v <- liftIO $ var Flexible

35 v <- liftIO $ var Flexible

37 return $ Fragment {

36 return $ Fragment {

38 typeEnv = Map.singleton name (VarN v),

37 typeEnv = Map.singleton name (VarN v),

@@ -40,14 +39,14 @@ constrain env pattern tipe =

40 typeConstraint = VarN v === tipe

39 typeConstraint = VarN v === tipe

41 }

40 }

42

41

43− PAlias name p -> do

42+ P.Alias name p -> do

44 fragment <- constrain env p tipe

43 fragment <- constrain env p tipe

45 return $ fragment {

44 return $ fragment {

46 typeEnv = Map.insert name tipe (typeEnv fragment),

45 typeEnv = Map.insert name tipe (typeEnv fragment),

47 typeConstraint = name <? tipe /\ typeConstraint fragment

46 typeConstraint = name <? tipe /\ typeConstraint fragment

48 }

47 }

49

48

50− PData name patterns -> do

49+ P.Data name patterns -> do

51 (kind, cvars, args, result) <- liftIO $ freshDataScheme env name

50 (kind, cvars, args, result) <- liftIO $ freshDataScheme env name

52 let msg = concat [ "Constructor '", name, "' expects ", show kind

51 let msg = concat [ "Constructor '", name, "' expects ", show kind

53 , " argument", if kind == 1 then "" else "s"

52 , " argument", if kind == 1 then "" else "s"

@@ -63,7 +62,7 @@ constrain env pattern tipe =

63 vars = cvars ++ vars fragment

62 vars = cvars ++ vars fragment

64 }

63 }

65

64

66− PRecord fields -> do

65+ P.Record fields -> do

67 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields

66 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields

68 let tenv = Map.fromList (map (second VarN) pairs)

67 let tenv = Map.fromList (map (second VarN) pairs)

69 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

68 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

@@ -73,8 +72,8 @@ constrain env pattern tipe =

73 typeConstraint = c

72 typeConstraint = c

74 }

73 }

75

74

76−instance Error (SrcSpan -> PP.Doc) where

75+instance Error (A.Region -> PP.Doc) where

77 noMsg _ = PP.empty

76 noMsg _ = PP.empty

78 strMsg str span =

77 strMsg str span =

79 PP.vcat [ PP.text $ "Type error " ++ show span

78 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 @@

1{-# 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+-}

2module Type.ExtraChecks (mainType, occurs, portTypes) where

7module 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.

6

8

7import Control.Applicative ((<$>),(<*>))

9import Control.Applicative ((<$>),(<*>))

8import Control.Monad.State

10import Control.Monad.State

9import qualified Data.List as List

11import qualified Data.List as List

10import qualified Data.Map as Map

12import qualified Data.Map as Map

13+import qualified Data.Traversable as Traverse

11import qualified Data.UnionFind.IO as UF

14import 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

15import Text.PrettyPrint as P

16−import SourceSyntax.PrettyPrint (pretty)

16+

17−import qualified SourceSyntax.Helpers as Help

17+import qualified SourceSyntax.Annotation as A

18−import qualified SourceSyntax.Type as T

19import qualified SourceSyntax.Expression as E

18import 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

21import qualified Transform.Expression as Expr

22import 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

23

26

24throw err = Left [ P.vcat err ]

27throw err = Left [ P.vcat err ]

25

28

26−mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))

29+mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))

27−mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env

30+mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env

28 where

31 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)

30 mainCheck rules env =

33 mainCheck rules env =

31 case Map.lookup "main" env of

34 case Map.lookup "main" env of

32 Nothing -> Right env

35 Nothing -> Right env

@@ -37,40 +40,40 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env

37 acceptable = [ "Graphics.Element.Element"

40 acceptable = [ "Graphics.Element.Element"

38 , "Signal.Signal Graphics.Element.Element" ]

41 , "Signal.Signal Graphics.Element.Element" ]

39

42

40− tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType

43+ tipe = SPP.renderPretty $ Alias.canonicalRealias (fst rules) mainType

41 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

44 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

42 , P.text "Instead 'main' has type:\n"

45 , 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

44 , P.text " " ]

47 , P.text " " ]

45

48

46data Direction = In | Out

49data Direction = In | Out

47

50

48−portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()

51+portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()

49portTypes rules expr =

52portTypes rules expr =

50 const () <$> Expr.checkPorts (check In) (check Out) expr

53 const () <$> Expr.checkPorts (check In) (check Out) expr

51 where

54 where

52 check = isValid True False False

55 check = isValid True False False

53 isValid isTopLevel seenFunc seenSignal direction name tipe =

56 isValid isTopLevel seenFunc seenSignal direction name tipe =

54 case tipe of

57 case tipe of

55− T.Data ctor ts

58+ ST.Data ctor ts

56 | isJs ctor || isElm ctor -> mapM_ valid ts

59 | isJs ctor || isElm ctor -> mapM_ valid ts

57 | ctor == "Signal.Signal" -> handleSignal ts

60 | ctor == "Signal.Signal" -> handleSignal ts

58 | otherwise -> err' True "an unsupported type"

61 | otherwise -> err' True "an unsupported type"

59

62

60− T.Var _ -> err "free type variables"

63+ ST.Var _ -> err "free type variables"

61

64

62− T.Lambda _ _ ->

65+ ST.Lambda _ _ ->

63 case direction of

66 case direction of

64 In -> err "functions"

67 In -> err "functions"

65 Out | seenFunc -> err "higher-order functions"

68 Out | seenFunc -> err "higher-order functions"

66 | seenSignal -> err "signals that contain functions"

69 | seenSignal -> err "signals that contain functions"

67 | otherwise ->

70 | otherwise ->

68− forM_ (T.collectLambdas tipe)

71+ forM_ (ST.collectLambdas tipe)

69 (isValid' True seenSignal direction name)

72 (isValid' True seenSignal direction name)

70

73

71− T.Record _ (Just _) -> err "extended records with free type variables"

74+ ST.Record _ (Just _) -> err "extended records with free type variables"

72

75

73− T.Record fields Nothing ->

76+ ST.Record fields Nothing ->

74 mapM_ (\(k,v) -> (,) k <$> valid v) fields

77 mapM_ (\(k,v) -> (,) k <$> valid v) fields

75

78

76 where

79 where

@@ -100,7 +103,7 @@ portTypes rules expr =

100 [ txt [ "Type Error: the value ", dir "coming in" "sent out"

103 [ txt [ "Type Error: the value ", dir "coming in" "sent out"

101 , " through port '", name, "' is invalid." ]

104 , " through port '", name, "' is invalid." ]

102 , txt [ "It contains ", kind, ":\n" ]

105 , 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"

104 , txt [ "Acceptable values for ", dir "incoming" "outgoing"

107 , txt [ "Acceptable values for ", dir "incoming" "outgoing"

105 , " ports include JavaScript values and" ]

108 , " ports include JavaScript values and" ]

106 , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]

109 , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]

@@ -112,37 +115,37 @@ portTypes rules expr =

112 , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]

115 , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]

113 ]

116 ]

114

117

115−occurs :: (String, Variable) -> StateT TS.SolverState IO ()

118+occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()

116occurs (name, variable) =

119occurs (name, variable) =

117 do vars <- liftIO $ infiniteVars [] variable

120 do vars <- liftIO $ infiniteVars [] variable

118 case vars of

121 case vars of

119 [] -> return ()

122 [] -> return ()

120 var:_ -> do

123 var:_ -> do

121 desc <- liftIO $ UF.descriptor var

124 desc <- liftIO $ UF.descriptor var

122− case structure desc of

125+ case TT.structure desc of

123 Nothing ->

126 Nothing ->

124 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

127 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

125 Just _ ->

128 Just _ ->

126− do liftIO $ UF.setDescriptor var (desc { structure = Nothing })

129+ do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })

127 var' <- liftIO $ UF.fresh desc

130 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'

129 where

132 where

130 msg = "Infinite types are not allowed"

133 msg = "Infinite types are not allowed"

131 fallback _ = return $ P.text msg

134 fallback _ = return $ P.text msg

132

135

133− infiniteVars :: [Variable] -> Variable -> IO [Variable]

136+ infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]

134− infiniteVars seen var =

137+ infiniteVars seen var =

135 let go = infiniteVars (var:seen) in

138 let go = infiniteVars (var:seen) in

136 if var `elem` seen

139 if var `elem` seen

137 then return [var]

140 then return [var]

138 else do

141 else do

139 desc <- UF.descriptor var

142 desc <- UF.descriptor var

140− case structure desc of

143+ case TT.structure desc of

141 Nothing -> return []

144 Nothing -> return []

142 Just struct ->

145 Just struct ->

143 case struct of

146 case struct of

144− App1 a b -> (++) <$> go a <*> go b

147+ TT.App1 a b -> (++) <$> go a <*> go b

145− Fun1 a b -> (++) <$> go a <*> go b

148+ TT.Fun1 a b -> (++) <$> go a <*> go b

146− Var1 a -> go a

149+ TT.Var1 a -> go a

147− EmptyRecord1 -> return []

150+ TT.EmptyRecord1 -> return []

148− Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))

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

5

6import Type.Type

7import SourceSyntax.Pattern

8−import SourceSyntax.Location (noneNoDocs)

8+import SourceSyntax.Annotation (noneNoDocs)

9

10−data Fragment = Fragment {

10+data Fragment = Fragment

11− typeEnv :: Map.Map String Type,

11+ { typeEnv :: Map.Map String Type

12− vars :: [Variable],

12+ , vars :: [Variable]

13− typeConstraint :: TypeConstraint

13+ , typeConstraint :: TypeConstraint

14−} deriving Show

14+ } deriving Show

15

16emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)

17

18−joinFragment f1 f2 = Fragment {

18+joinFragment f1 f2 = Fragment

19− typeEnv = Map.union (typeEnv f1) (typeEnv f2),

19+ { typeEnv = Map.union (typeEnv f1) (typeEnv f2)

20− vars = vars f1 ++ vars f2,

20+ , vars = vars f1 ++ vars f2

21− typeConstraint = typeConstraint f1 /\ typeConstraint f2

21+ , typeConstraint = typeConstraint f1 /\ typeConstraint f2

22−}

22+ }

23

24joinFragments = List.foldl' (flip joinFragment) emptyFragment

25

26−

27toScheme fragment =

26toScheme 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

9import qualified Type.Solve as Solve

10

11import SourceSyntax.Module as Module

12−import SourceSyntax.Location (noneNoDocs)

12+import SourceSyntax.Annotation (noneNoDocs)

13import SourceSyntax.Type (Type)

14import Text.PrettyPrint

15import qualified Type.State as TS

compiler/Type/Solve.hs+19−19

@@ -3,15 +3,15 @@ module Type.Solve (solve) where

3

4import Control.Monad

5import Control.Monad.State

6−import qualified Data.UnionFind.IO as UF

6+import qualified Data.List as List

7import qualified Data.Map as Map

8import qualified Data.Traversable as Traversable

9−import qualified Data.List as List

9+import qualified Data.UnionFind.IO as UF

10import Type.Type

11import Type.Unify

12import qualified Type.ExtraChecks as Check

13import qualified Type.State as TS

14−import SourceSyntax.Location (Located(L), SrcSpan)

14+import qualified SourceSyntax.Annotation as A

15

16

17-- | Every variable has rank less than or equal to the maxRank of the pool.

@@ -96,7 +96,7 @@ adjustRank youngMark visitedMark groupRank variable =

96

97

98solve :: TypeConstraint -> StateT TS.SolverState IO ()

99−solve (L span constraint) =

99+solve (A.A region constraint) =

100 case constraint of

101 CTrue -> return ()

102

@@ -105,11 +105,11 @@ solve (L span constraint) =

105 CEqual term1 term2 -> do

106 t1 <- TS.flatten term1

107 t2 <- TS.flatten term2

108− unify span t1 t2

108+ unify region t1 t2

109

110 CAnd cs -> mapM_ solve cs

111

112− CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do

112+ CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) -> do

113 oldEnv <- TS.getEnv

114 mapM TS.introduce fqs

115 solve constraint'

@@ -117,7 +117,7 @@ solve (L span constraint) =

117

118 CLet schemes constraint' -> do

119 oldEnv <- TS.getEnv

120− headers <- Map.unions `fmap` mapM (solveScheme span) schemes

120+ headers <- Map.unions `fmap` mapM (solveScheme region) schemes

121 TS.modifyEnv $ \env -> Map.union headers env

122 solve constraint'

123 mapM Check.occurs $ Map.toList headers

@@ -134,10 +134,10 @@ solve (L span constraint) =

134 error ("Could not find '" ++ name ++ "' when solving type constraints.")

135

136 t <- TS.flatten term

137− unify span freshCopy t

137+ unify region freshCopy t

138

139−solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)

139+solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)

140−solveScheme span scheme =

140+solveScheme region scheme =

141 case scheme of

142 Scheme [] [] constraint header -> do

143 solve constraint

@@ -154,39 +154,39 @@ solveScheme span scheme =

154 header' <- Traversable.traverse TS.flatten header

155 solve constraint

156

157− allDistinct span rigidQuantifiers

157+ allDistinct region rigidQuantifiers

158 youngPool <- TS.getPool

159 TS.switchToPool oldPool

160 generalize youngPool

161− mapM (isGeneric span) rigidQuantifiers

161+ mapM (isGeneric region) rigidQuantifiers

162 return header'

163

164

165-- Checks that all of the given variables belong to distinct equivalence classes.

166-- Also checks that their structure is Nothing, so they represent a variable, not

167-- a more complex term.

168−allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()

168+allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()

169−allDistinct span vars = do

169+allDistinct region vars = do

170 seen <- TS.uniqueMark

171 let check var = do

172 desc <- liftIO $ UF.descriptor var

173 case structure desc of

174− Just _ -> TS.addError span (Just msg) var var

174+ Just _ -> TS.addError region (Just msg) var var

175 where msg = "Cannot generalize something that is not a type variable."

176

177 Nothing -> do

178 if mark desc == seen

179 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

181 else return ()

182 liftIO $ UF.setDescriptor var (desc { mark = seen })

183 mapM_ check vars

184

185-- Check that a variable has rank == noRank, meaning that it can be generalized.

186−isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()

186+isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()

187−isGeneric span var = do

187+isGeneric region var = do

188 desc <- liftIO $ UF.descriptor var

189 if rank desc == noRank

190 then return ()

191 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 @@

1{-# OPTIONS_GHC -W #-}

2module Type.State where

3

4−import Type.Type

5−import qualified Data.Map as Map

6−import qualified Data.UnionFind.IO as UF

7−import Control.Monad.State

8import Control.Applicative ((<$>),(<*>), Applicative)

4import Control.Applicative ((<$>),(<*>), Applicative)

5+import Control.Monad.State

6+import qualified Data.Map as Map

9import qualified Data.Traversable as Traversable

7import 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

11import SourceSyntax.PrettyPrint

12−import SourceSyntax.Location

12+import Text.PrettyPrint as P

13import qualified Type.Alias as Alias

14+import Type.Type

14

15

15-- Pool

16-- Pool

16-- Holds a bunch of variables

17-- Holds a bunch of variables

@@ -46,7 +47,7 @@ initialState = SS {

46modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }

47modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }

47modifyPool f = modify $ \state -> state { sPool = f (sPool state) }

48modifyPool f = modify $ \state -> state { sPool = f (sPool state) }

48

49

49−addError span hint t1 t2 =

50+addError region hint t1 t2 =

50 modify $ \state -> state { sErrors = makeError : sErrors state }

51 modify $ \state -> state { sErrors = makeError : sErrors state }

51 where

52 where

52 makeError rules = do

53 makeError rules = do

@@ -54,24 +55,15 @@ addError span hint t1 t2 =

54 t1' <- prettiest <$> toSrcType t1

55 t1' <- prettiest <$> toSrcType t1

55 t2' <- prettiest <$> toSrcType t2

56 t2' <- prettiest <$> toSrcType t2

56 return . P.vcat $

57 return . P.vcat $

57− [ P.text $ "Type error" ++ location ++ ":"

58+ [ P.text "Type error" <+> pretty region <> P.colon

58 , maybe P.empty P.text hint

59 , 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 ""

60 , P.text " Expected Type:" <+> t1'

63 , P.text " Expected Type:" <+> t1'

61 , P.text " Actual Type:" <+> t2'

64 , P.text " Actual Type:" <+> t2'

62 ]

65 ]

63

66

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−

75switchToPool pool = modifyPool (\_ -> pool)

67switchToPool pool = modifyPool (\_ -> pool)

76

68

77getPool :: StateT SolverState IO Pool

69getPool :: StateT SolverState IO Pool

compiler/Type/Type.hs+14−12

@@ -11,7 +11,7 @@ import Control.Applicative ((<$>),(<*>))

11import Control.Monad.State

12import Control.Monad.Error

13import Data.Traversable (traverse)

14−import SourceSyntax.Location

14+import SourceSyntax.Annotation

15import SourceSyntax.Helpers (isTuple)

16import qualified SourceSyntax.Type as Src

17

@@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

62infixl 8 /\

63

64(/\) :: Constraint a b -> Constraint a b -> Constraint a b

65−a@(L _ c1) /\ b@(L _ c2) =

65+a@(A _ c1) /\ b@(A _ c2) =

66 case (c1, c2) of

67 (CTrue, _) -> b

68 (_, CTrue) -> a

@@ -128,11 +128,13 @@ structuredVar structure = UF.fresh $ Descriptor {

128

129-- ex qs constraint == exists qs. constraint

130ex :: [Variable] -> TypeConstraint -> TypeConstraint

131+ex fqs constraint@(A ann _) =

131−ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s CTrue)

132+ A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)

132

133

133-- fl qs constraint == forall qs. constraint

134-- fl qs constraint == forall qs. constraint

134fl :: [Variable] -> TypeConstraint -> TypeConstraint

135fl :: [Variable] -> TypeConstraint -> TypeConstraint

136+fl rqs constraint@(A ann _) =

135−fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)

137+ A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)

136

138

137exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

139exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

138exists f = do

140exists f = do

@@ -148,8 +150,8 @@ instance PrettyType a => PrettyType (UF.Point a) where

148 pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)

150 pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)

149

151

150

152

151−instance PrettyType a => PrettyType (Located a) where

153+instance PrettyType t => PrettyType (Annotated a t) where

152− pretty when (L _ e) = pretty when e

154+ pretty when (A _ e) = pretty when e

153

155

154

156

155instance PrettyType a => PrettyType (Term1 a) where

157instance PrettyType a => PrettyType (Term1 a) where

@@ -212,12 +214,12 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where

212 CAnd cs ->

214 CAnd cs ->

213 P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)

215 P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)

214

216

215− CLet [Scheme [] fqs constraint header] (L _ CTrue) | Map.null header ->

217+ CLet [Scheme [] fqs constraint header] (A _ CTrue) | Map.null header ->

216 P.sep [ binder, pretty Never c ]

218 P.sep [ binder, pretty Never c ]

217 where

219 where

218− mergeExists vs (L _ c) =

220+ mergeExists vs (A _ c) =

219 case c of

221 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'

221 _ -> (vs, c)

223 _ -> (vs, c)

222

224

223 (fqs', c) = mergeExists fqs constraint

225 (fqs', c) = mergeExists fqs constraint

@@ -233,7 +235,7 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where

233 P.text name <+> P.text "<" <+> prty tipe

235 P.text name <+> P.text "<" <+> prty tipe

234

236

235instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where

237instance (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) =

237 P.sep [ forall, cs, headers' ]

239 P.sep [ forall, cs, headers' ]

238 where

240 where

239 prty = pretty Never

241 prty = pretty Never

@@ -297,8 +299,8 @@ class Crawl t where

297 -> t

299 -> t

298 -> StateT CrawlState IO t

300 -> StateT CrawlState IO t

299

301

300−instance Crawl a => Crawl (Located a) where

302+instance Crawl e => Crawl (Annotated a e) where

301− crawl nextState (L s e) = L s <$> crawl nextState e

303+ crawl nextState (A ann e) = A ann <$> crawl nextState e

302

304

303instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where

305instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where

304 crawl nextState constraint =

306 crawl nextState constraint =

compiler/Type/Unify.hs+15−15

@@ -1,27 +1,27 @@

1{-# OPTIONS_GHC -W #-}

2module Type.Unify (unify) where

3

4−import Type.Type

4+import Control.Monad.State

5−import qualified Data.UnionFind.IO as UF

6import qualified Data.Map as Map

5import qualified Data.Map as Map

7import qualified Data.Maybe as Maybe

6import qualified Data.Maybe as Maybe

7+import qualified Data.UnionFind.IO as UF

8+import qualified SourceSyntax.Annotation as A

8import qualified Type.State as TS

9import qualified Type.State as TS

9−import Control.Monad.State

10+import Type.Type

10−import SourceSyntax.Location

11import Type.PrettyPrint

12import Text.PrettyPrint (render)

13

14−unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()

14+unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()

15−unify span variable1 variable2 = do

15+unify region variable1 variable2 = do

16 equivalent <- liftIO $ UF.equivalent variable1 variable2

17 if equivalent then return ()

18− else actuallyUnify span variable1 variable2

18+ else actuallyUnify region variable1 variable2

19

20−actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()

20+actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()

21−actuallyUnify span variable1 variable2 = do

21+actuallyUnify region variable1 variable2 = do

22 desc1 <- liftIO $ UF.descriptor variable1

23 desc2 <- liftIO $ UF.descriptor variable2

24− let unify' = unify span

24+ let unify' = unify region

25

26 name' :: Maybe String

27 name' = case (name desc1, name desc2) of

@@ -79,11 +79,11 @@ actuallyUnify span variable1 variable2 = do

79

80 unifyNumber svar name

81 | 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

83 where hint = "A number must be an Int or Float."

84

85 comparableError maybe =

86− TS.addError span (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

86+ TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

87 where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."

88

89 unifyComparable var name

@@ -110,7 +110,7 @@ actuallyUnify span variable1 variable2 = do

110 List _ -> flexAndUnify varSuper

111 _ -> comparableError Nothing

112

113− rigidError variable = TS.addError span (Just hint) variable1 variable2

113+ rigidError variable = TS.addError region (Just hint) variable1 variable2

114 where

115 var = "'" ++ render (pretty Never variable) ++ "'"

116 hint = "Cannot unify rigid type variable " ++ var ++

@@ -141,7 +141,7 @@ actuallyUnify span variable1 variable2 = do

141

142 (Rigid, _, _, _) -> rigidError variable1

143 (_, Rigid, _, _) -> rigidError variable2

144− _ -> TS.addError span Nothing variable1 variable2

144+ _ -> TS.addError region Nothing variable1 variable2

145

146 case (structure desc1, structure desc2) of

147 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge

@@ -196,5 +196,5 @@ actuallyUnify span variable1 variable2 = do

196 eat (_:xs) (_:ys) = eat xs ys

197 eat xs _ = xs

198

199− _ -> TS.addError span Nothing variable1 variable2

199+ _ -> TS.addError region Nothing variable1 variable2

200

tests/Tests/Property.hs+17−16

@@ -10,7 +10,7 @@ import Text.Parsec.Combinator (eof)

10import Text.PrettyPrint as P

11

12import SourceSyntax.Literal as Lit

13−import SourceSyntax.Pattern as Pat

13+import qualified SourceSyntax.Pattern as P

14import SourceSyntax.PrettyPrint (Pretty, pretty)

15import Parse.Helpers (IParser, iParse)

16import Parse.Literal (literal)

@@ -31,24 +31,25 @@ propertyTests =

31 where

32 -- This test was autogenerated from the Pattern test and should be

33 -- left in all its ugly glory.

34− longPat = Pat.PData "I" [ Pat.PLiteral (Lit.Chr '+')

34+ longPat = P.Data "I" [ P.Literal (Lit.Chr '+')

35− , Pat.PRecord [

35+ , P.Record

36− "q7yclkcm7k_ikstrczv_"

36+ [ "q7yclkcm7k_ikstrczv_"

37− , "wQRv6gKsvvkjw4b5F"

37+ , "wQRv6gKsvvkjw4b5F"

38− ,"c9'eFfhk9FTvsMnwF_D"

38+ ,"c9'eFfhk9FTvsMnwF_D"

39− ,"yqxhEkHvRFwZ"

39+ ,"yqxhEkHvRFwZ"

40− ,"o"

40+ ,"o"

41− ,"nbUlCn3y3NnkVoxhW"

41+ ,"nbUlCn3y3NnkVoxhW"

42− ,"iJ0MNy3KZ_lrs"

42+ ,"iJ0MNy3KZ_lrs"

43− ,"ug"

43+ ,"ug"

44− ,"sHHsX"

44+ ,"sHHsX"

45− ,"mRKs9d"

45+ ,"mRKs9d"

46− ,"o2KiCX5'ZRzHJfRi8" ]

46+ ,"o2KiCX5'ZRzHJfRi8" ]

47− , Pat.PVar "su'BrrbPUK6I33Eq" ]

47+ , P.Var "su'BrrbPUK6I33Eq"

48+ ]

48

49

49prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool

50prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool

50prop_parse_print p x =

51prop_parse_print p x =

51 either (const False) (== x) . parse_print p $ x

52 either (const False) (== x) . parse_print p $ x

52

53

53parse_print :: (Pretty a) => IParser a -> a -> Either String a

54parse_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

8import qualified Data.Set as Set

9import qualified Parse.Helpers (reserveds)

10

11−import SourceSyntax.Literal

11+import qualified SourceSyntax.Literal as L

12−import SourceSyntax.Pattern

12+import qualified SourceSyntax.Pattern as P

13−import SourceSyntax.Type hiding (listOf)

13+import qualified SourceSyntax.Type as T

14−

14+

15−instance Arbitrary Literal where

15+instance Arbitrary L.Literal where

16+ arbitrary =

17+ oneof

16− arbitrary = oneof [ IntNum <$> arbitrary

18+ [ L.IntNum <$> arbitrary

17− , FloatNum <$> (arbitrary `suchThat` noE)

19+ , L.FloatNum <$> (arbitrary `suchThat` noE)

18− , Chr <$> arbitrary

20+ , L.Chr <$> arbitrary

19− -- This is too permissive

21+ -- This is too permissive

20− , Str <$> arbitrary

22+ , L.Str <$> arbitrary

21− -- Booleans aren't actually source syntax

23+ -- Booleans aren't actually source syntax

22− -- , Boolean <$> arbitrary

24+ -- , Boolean <$> arbitrary

23− ]

25+ ]

26+

24− shrink l = case l of

27+ shrink lit =

28+ case lit of

25− IntNum n -> IntNum <$> shrink n

29+ L.IntNum n -> L.IntNum <$> shrink n

26− FloatNum f -> FloatNum <$> (filter noE . shrink $ f)

30+ L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f)

27− Chr c -> Chr <$> shrink c

31+ L.Chr c -> L.Chr <$> shrink c

28− Str s -> Str <$> shrink s

32+ L.Str s -> L.Str <$> shrink s

29− Boolean b -> Boolean <$> shrink b

33+ L.Boolean b -> L.Boolean <$> shrink b

30

34

31noE :: Double -> Bool

35noE :: Double -> Bool

32noE = notElem 'e' . show

36noE = notElem 'e' . show

33

37

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

34

43

35−instance Arbitrary Pattern where

44+instance Arbitrary P.Pattern where

36 arbitrary = sized pat

45 arbitrary = sized pat

46+ where

37− where pat :: Int -> Gen Pattern

47+ pat :: Int -> Gen P.Pattern

38− pat n = oneof [ pure PAnything

48+ pat n =

49+ oneof

50+ [ pure P.Anything

39− , PVar <$> lowVar

51+ , P.Var <$> lowVar

40− , PRecord <$> (listOf1 lowVar)

52+ , P.Record <$> (listOf1 lowVar)

41− , PLiteral <$> arbitrary

53+ , P.Literal <$> arbitrary

42− , PAlias <$> lowVar <*> pat (n-1)

54+ , P.Alias <$> lowVar <*> pat (n-1)

43− , PData <$> capVar <*> sizedPats

55+ , P.Data <$> capVar <*> genVector n pat

44− ]

56+ ]

45− where sizedPats = do

57+

46− len <- choose (0,n)

47− let m = n `div` (len + 1)

48− vectorOf len $ pat m

49−

50− shrink pat = case pat of

58+ shrink pat =

51− PAnything -> []

59+ case pat of

60+ P.Anything -> []

52− PVar v -> PVar <$> shrinkWHead v

61+ P.Var v -> P.Var <$> shrinkWHead v

53− PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)

62+ P.Literal l -> P.Literal <$> shrink l

54− PLiteral l -> PLiteral <$> shrink l

55− PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)

63+ P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)

56− PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)

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

57

69

58shrinkWHead :: Arbitrary a => [a] -> [[a]]

70shrinkWHead :: Arbitrary a => [a] -> [[a]]

59shrinkWHead [] = error "Should be nonempty"

71shrinkWHead [] = error "Should be nonempty"

60shrinkWHead (x:xs) = (x:) <$> shrink xs

72shrinkWHead (x:xs) = (x:) <$> shrink xs

61

73

62−instance Arbitrary Type where

74+instance Arbitrary T.Type where

63 arbitrary = sized tipe

75 arbitrary = sized tipe

76+ where

64− where tipe :: Int -> Gen Type

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

65− tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe

85+ [ T.Lambda <$> depthTipe <*> depthTipe

66− , Var <$> lowVar

86+ , T.Var <$> lowVar

67− , Data <$> capVar <*> depthTipes

87+ , T.Data <$> capVar <*> genVector n tipe

68− , Record <$> fields <*> pure Nothing

88+ , T.Record <$> fields <*> pure Nothing

69− , Record <$> fields1 <*> (Just <$> lowVar)

89+ , T.Record <$> fields1 <*> (Just <$> lowVar)

70− ]

90+ ]

71− where depthTipe = choose (0,n) >>= tipe

91+

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

92+ shrink tipe =

93+ case tipe of

85− Lambda s t -> s : t : (Lambda <$> shrink s <*> shrink t)

94+ T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)

86− Var _ -> []

95+ T.Var _ -> []

87− Data n ts -> ts ++ (Data <$> shrinkWHead n <*> shrink ts)

96+ T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)

88− Record fs t -> map snd fs ++ case t of

97+ T.Record fs t -> map snd fs ++ record

98+ where

99+ record =

100+ case t of

89− Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing

101+ Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing

90− Just _ ->

102+ Just _ ->

91− do

92− fields <- filter (not . null) $ shrinkList shrinkField fs

103+ do fields <- filter (not . null) $ shrinkList shrinkField fs

93− return $ Record fields t

104+ return $ T.Record fields t

105+

94− where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t

106+ shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t

95

107

96lowVar :: Gen String

108lowVar :: Gen String

97lowVar = notReserved $ (:) <$> lower <*> listOf varLetter

109lowVar = notReserved $ (:) <$> lower <*> listOf varLetter

110+ where

98− where lower = elements ['a'..'z']

111+ lower = elements ['a'..'z']

99

112

100capVar :: Gen String

113capVar :: Gen String

101capVar = notReserved $ (:) <$> upper <*> listOf varLetter

114capVar = notReserved $ (:) <$> upper <*> listOf varLetter

115+ where

102− where upper = elements ['A'..'Z']

116+ upper = elements ['A'..'Z']

103

117

104varLetter :: Gen Char

118varLetter :: Gen Char

105varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']

119varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']

@@ -109,5 +123,6 @@ notReserved = flip exceptFor Parse.Helpers.reserveds

109

123

110exceptFor :: (Ord a) => Gen a -> [a] -> Gen a

124exceptFor :: (Ord a) => Gen a -> [a] -> Gen a

111exceptFor g xs = g `suchThat` notAnX

125exceptFor g xs = g `suchThat` notAnX

126+ where

112− where notAnX = flip Set.notMember xset

127+ notAnX = flip Set.notMember xset

113− xset = Set.fromList xs

128+ xset = Set.fromList xs