e9cfb68 · elk · git.iko.soy

elm-compiler.cabal+1−2

compare with master

unifiedsplit

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

1

2Name: elm-compiler

3−Version: 0.17.1

3+Version: 0.18

4

5Synopsis:

6 Values to help with elm-package, elm-make, and elm-lang.org.

@@ -130,7 +130,6 @@ Library

130 Type.Constrain.Literal,

131 Type.Constrain.Pattern,

132 Type.Environment,

133− Type.Fragment,

134 Type.Inference,

133 Type.Inference,

135 Type.Solve,

134 Type.Solve,

136 Type.State,

135 Type.State,

src/AST/Expression/Canonical.hs+1−12

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

2module AST.Expression.Canonical

3 ( Expr, Expr'

4 , Def(..)

5− , Facts(..), dummyFacts

6 , SortedDefs(..), toSortedDefs

5 , SortedDefs(..), toSortedDefs

7 )

6 )

8 where

7 where

@@ -27,17 +26,7 @@ type Expr' =

27

26

28

27

29data Def

28data Def

30− = Def Facts Pattern.Canonical Expr (Maybe (A.Located Type.Canonical))

29+ = Def R.Region Pattern.Canonical Expr (Maybe (A.Located Type.Canonical))

31−

32−

33−data Facts = Facts

34− { dependencies :: [Var.TopLevel]

35− }

36−

37−

38−dummyFacts :: Facts

39−dummyFacts =

40− Facts (error "This should be set by Canonicalize.Sort")

41

30

42

31

43

32

src/AST/Expression/General.hs+20−1

@@ -8,6 +8,8 @@ enrich the AST with more information.

8-}

9module AST.Expression.General where

10

11+import qualified Data.List as List

12+

11import qualified AST.Effects as Effects

13import qualified AST.Effects as Effects

12import qualified AST.Literal as Literal

14import qualified AST.Literal as Literal

13import qualified AST.Module.Name as ModuleName

15import qualified AST.Module.Name as ModuleName

@@ -42,7 +44,6 @@ type Expr annotation definition variable tipe =

42data Expr' ann def var typ

44data Expr' ann def var typ

43 = Literal Literal.Literal

45 = Literal Literal.Literal

44 | Var var

46 | Var var

45− | Range (Expr ann def var typ) (Expr ann def var typ)

46 | ExplicitList [Expr ann def var typ]

47 | ExplicitList [Expr ann def var typ]

47 | Binop var (Expr ann def var typ) (Expr ann def var typ)

48 | Binop var (Expr ann def var typ) (Expr ann def var typ)

48 | Lambda (Pattern.Pattern ann var) (Expr ann def var typ)

49 | Lambda (Pattern.Pattern ann var) (Expr ann def var typ)

@@ -89,6 +90,24 @@ tuple expressions =

89 Data ("_Tuple" ++ show (length expressions)) expressions

90 Data ("_Tuple" ++ show (length expressions)) expressions

90

91

92

93+collectFields :: (Var.ToString var) => Expr ann def var typ -> Maybe String

94+collectFields expr =

95+ collectFieldsHelp expr []

96+

97+

98+collectFieldsHelp :: (Var.ToString var) => Expr ann def var typ -> [String] -> Maybe String

99+collectFieldsHelp (A.A _ expr) fields =

100+ case expr of

101+ Var var ->

102+ Just (List.intercalate "." (Var.toString var : fields))

103+

104+ Access record field ->

105+ collectFieldsHelp record (field : fields)

106+

107+ _ ->

108+ Nothing

109+

110+

92collectApps :: Expr ann def var typ -> [Expr ann def var typ]

111collectApps :: Expr ann def var typ -> [Expr ann def var typ]

93collectApps annExpr@(A.A _ expr) =

112collectApps annExpr@(A.A _ expr) =

94 case expr of

113 case expr of

src/AST/Expression/Optimized.hs+1−3

@@ -24,13 +24,12 @@ data Def

24

25data Facts = Facts

26 { home :: Maybe ModuleName.Canonical

27− , dependencies :: [Var.TopLevel]

28 }

27 }

29

28

30

29

31dummyFacts :: Facts

30dummyFacts :: Facts

32dummyFacts =

31dummyFacts =

33− Facts Nothing []

32+ Facts Nothing

34

33

35

34

36-- EXPRESSIONS

35-- EXPRESSIONS

@@ -38,7 +37,6 @@ dummyFacts =

38data Expr

37data Expr

39 = Literal Literal.Literal

38 = Literal Literal.Literal

40 | Var Var.Canonical

39 | Var Var.Canonical

41− | Range Expr Expr

42 | ExplicitList [Expr]

40 | ExplicitList [Expr]

43 | Binop Var.Canonical Expr Expr

41 | Binop Var.Canonical Expr Expr

44 | Function [String] Expr

42 | Function [String] Expr

src/AST/Expression/Valid.hs+2−2

@@ -21,10 +21,10 @@ type Expr' =

21

22

23data Def =

24− Def Pattern.Raw Expr (Maybe Type.Raw)

24+ Def R.Region Pattern.Raw Expr (Maybe Type.Raw)

25

26

27getPattern :: Def -> Pattern.Raw

28−getPattern (Def pattern _ _) =

28+getPattern (Def _ pattern _ _) =

29 pattern

30

src/AST/Helpers.hs+1−1

@@ -29,4 +29,4 @@ isOp name =

29

30isSymbol :: Char -> Bool

31isSymbol c =

32− Char.isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"

32+ c /= '`' && (Char.isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!")

src/AST/Pattern.hs+42

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

1{-# OPTIONS_GHC -Wall #-}

2module AST.Pattern where

3

4+import qualified Data.List as List

4import qualified Data.Set as Set

5import qualified Data.Set as Set

5

6

6import qualified AST.Literal as L

7import qualified AST.Literal as L

@@ -107,3 +108,44 @@ boundVarList :: Pattern ann var -> [String]

107boundVarList pattern =

108boundVarList pattern =

108 Set.toList (boundVarSet pattern)

109 Set.toList (boundVarSet pattern)

109

110

111+

112+

113+-- TO STRING

114+

115+

116+toString :: Bool -> Canonical -> String

117+toString needsParens (A.A _ pattern) =

118+ case pattern of

119+ Var name ->

120+ name

121+

122+ Data name [] ->

123+ if Var.isTuple name then

124+ "()"

125+ else

126+ Var.toString name

127+

128+ Data name args ->

129+ if Var.isTuple name then

130+ "( " ++ List.intercalate ", " (map (toString False) args) ++ " )"

131+ else

132+ parensIf needsParens $

133+ Var.toString name ++ concatMap ((" "++) . toString True) args

134+

135+ Record fields ->

136+ "{" ++ List.intercalate "," fields ++ "}"

137+

138+ Alias alias subPattern ->

139+ parensIf needsParens $

140+ toString False subPattern ++ " as " ++ alias

141+

142+ Anything ->

143+ "_"

144+

145+ Literal literal ->

146+ L.toString literal

147+

148+

149+parensIf :: Bool -> String -> String

150+parensIf needsParens str =

151+ if needsParens then "(" ++ str ++ ")" else str

src/AST/Variable.hs−11

@@ -16,17 +16,6 @@ newtype Raw = Raw String

16

17

18

19−-- TOP LEVEL NAMES

20−

21−

22−data TopLevel = TopLevelVar

23− { topHome :: ModuleName.Canonical

24− , topName :: String

25− }

26− deriving (Eq, Ord)

27−

28−

29−

30-- CANONICAL NAMES

19-- CANONICAL NAMES

31

20

32

21

src/Canonicalize.hs+7−9

@@ -82,10 +82,11 @@ module' allCanonicalImports interfaces modul =

82 typeToPair (A.A _ (D.Type name args body)) =

83 ( name, (args, body) )

84

85− program =

85+ getProgram =

86 Body.flatten (Module.name modul) canonicalDecls canonicalEffects

87 in

88+ do program <- Result.mapError Error.Canonicalize getProgram

88− do canonicalImports <- filterImports uses imports

89+ canonicalImports <- filterImports uses imports

89 Result.accumulate (Result.One (Env.toDealiaser env)) $

90 Result.accumulate (Result.One (Env.toDealiaser env)) $

90 modul {

91 modul {

91 Module.info =

92 Module.info =

@@ -324,8 +325,8 @@ canonicalizeDecls env (D.Decls defs unions aliases infixes) =

324 annTraverse canEntry entries =

325 annTraverse canEntry entries =

325 traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries

326 traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries

326

327

327− canonicalizeDef (Valid.Def pat expr typ) =

328+ canonicalizeDef (Valid.Def region pat expr typ) =

328− Canonical.Def Canonical.dummyFacts

329+ Canonical.Def region

329 <$> canonicalizePattern env pat

330 <$> canonicalizePattern env pat

330 <*> canonicalizeExpr env expr

331 <*> canonicalizeExpr env expr

331 <*> traverse (canonicalizeRegionType env) typ

332 <*> traverse (canonicalizeRegionType env) typ

@@ -366,9 +367,6 @@ canonicalizeExpr env (A.A region validExpr) =

366 Literal lit ->

367 Literal lit ->

367 Result.ok (Literal lit)

368 Result.ok (Literal lit)

368

369

369− Range lowExpr highExpr ->

370− Range <$> go lowExpr <*> go highExpr

371−

372 Access record field ->

370 Access record field ->

373 Access <$> go record <*> Result.ok field

371 Access <$> go record <*> Result.ok field

374

372

@@ -411,8 +409,8 @@ canonicalizeExpr env (A.A region validExpr) =

411 env' =

409 env' =

412 foldr Env.addPattern env (map Valid.getPattern defs)

410 foldr Env.addPattern env (map Valid.getPattern defs)

413

411

414− rename' (Valid.Def p body mtipe) =

412+ rename' (Valid.Def defRegion p body mtipe) =

415− Canonical.Def Canonical.dummyFacts

413+ Canonical.Def defRegion

416 <$> canonicalizePattern env' p

414 <$> canonicalizePattern env' p

417 <*> canonicalizeExpr env' body

415 <*> canonicalizeExpr env' body

418 <*> traverse (canonicalizeRegionType env') mtipe

416 <*> traverse (canonicalizeRegionType env') mtipe

src/Canonicalize/Body.hs+11−4

@@ -13,11 +13,18 @@ import qualified AST.Type as Type

13import qualified AST.Variable as Var

14import qualified Canonicalize.Sort as Sort

15import qualified Reporting.Annotation as A

16+import Reporting.Error.Canonicalize (Error)

16−import qualified Reporting.Region as R

17+import Reporting.Region (Region)

18+import Reporting.Result (Result)

17

19

18

20

19

21

22+flatten

23+ :: (Monoid i)

20−flatten :: ModuleName.Canonical -> Decl.Canonical -> Effects.Canonical -> Canonical.Expr

24+ => ModuleName.Canonical

25+ -> Decl.Canonical

26+ -> Effects.Canonical

27+ -> Result i w Error Canonical.Expr

21flatten moduleName (Decl.Decls defs unions aliases _) effects =

28flatten moduleName (Decl.Decls defs unions aliases _) effects =

22 let

29 let

23 allDefs =

30 allDefs =

@@ -101,10 +108,10 @@ buildFunction vars body@(A.A ann _) =

101 (map (A.A ann . P.Var) vars)

108 (map (A.A ann . P.Var) vars)

102

109

103

110

104−definition :: String -> Canonical.Expr -> R.Region -> Type.Canonical -> Canonical.Def

111+definition :: String -> Canonical.Expr -> Region -> Type.Canonical -> Canonical.Def

105definition name expr@(A.A ann _) region tipe =

112definition name expr@(A.A ann _) region tipe =

106 Canonical.Def

113 Canonical.Def

107− Canonical.dummyFacts

114+ region

108 (A.A ann (P.Var name))

115 (A.A ann (P.Var name))

109 expr

116 expr

110 (Just (A.A region tipe))

117 (Just (A.A region tipe))

src/Canonicalize/Setup.hs+1−1

@@ -327,7 +327,7 @@ declsToPatches moduleName (D.Decls defs unions aliases _) =

327

328 -- TO PATCHES

329

330− defToPatches (A.A _ (Valid.Def pattern _ _)) =

330+ defToPatches (A.A _ (Valid.Def _ pattern _ _)) =

331 map topLevelValue (P.boundVarList pattern)

332

333 unionToPatches (A.A _ (D.Type name _ ctors)) =

src/Canonicalize/Sort.hs+234−123

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

1{-# OPTIONS_GHC -Wall #-}

2module Canonicalize.Sort (definitions) where

3

4−import Control.Monad.State

4+import qualified Data.Foldable as F

5import qualified Data.Graph as Graph

6import qualified Data.Map as Map

7import qualified Data.Maybe as Maybe

@@ -12,74 +12,117 @@ import qualified AST.Expression.Canonical as Canonical

12import qualified AST.Pattern as P

13import qualified AST.Variable as V

14import qualified Reporting.Annotation as A

15+import qualified Reporting.Error.Canonicalize as E

16+import qualified Reporting.Result as R

15

17

16

18

17

19

18−-- STARTING POINT

20+-- SORT DEFINITIONS

19

21

20

22

21−definitions :: Canonical.Expr -> Canonical.Expr

23+definitions :: (Monoid i) => Canonical.Expr -> R.Result i w E.Error Canonical.Expr

22definitions expression =

24definitions expression =

25+ let

26+ (R.Result _ warnings answer) =

23− evalState (reorder expression) Set.empty

27+ reorder expression

28+ in

29+ R.Result mempty warnings answer

30+

31+

32+data LocalVars =

33+ LocalVars

34+ { _immediate :: Set.Set String

35+ , _delayed :: Set.Set String

36+ , _tags :: Set.Set String

37+ }

38+

24

39

40+instance Monoid LocalVars where

41+ mempty =

42+ LocalVars Set.empty Set.empty Set.empty

25

43

26−free :: String -> State (Set.Set String) ()

44+ mappend (LocalVars i1 d1 t1) (LocalVars i2 d2 t2) =

27−free x =

45+ LocalVars (Set.union i1 i2) (Set.union d1 d2) (Set.union t1 t2)

28− modify (Set.insert x)

29

46

30

47

31−freeIfLocal :: V.Canonical -> State (Set.Set String) ()

48+addTag :: String -> a -> R.Result LocalVars w e a

49+addTag name value =

50+ R.accumulate (LocalVars Set.empty Set.empty (Set.singleton name)) value

51+

52+

53+addImmediate :: V.Canonical -> a -> R.Result LocalVars w e a

32−freeIfLocal (V.Canonical home name) =

54+addImmediate (V.Canonical home name) value =

33 case home of

55 case home of

34− V.Local -> free name

56+ V.Local ->

57+ R.accumulate (LocalVars (Set.singleton name) Set.empty Set.empty) value

58+

35− V.TopLevel _ -> free name

59+ V.TopLevel _ ->

60+ R.accumulate (LocalVars (Set.singleton name) Set.empty Set.empty) value

61+

36− V.BuiltIn -> return ()

62+ V.BuiltIn ->

63+ return value

64+

37− V.Module _ -> return ()

65+ V.Module _ ->

66+ return value

67+

68+

69+capture :: P.Canonical -> R.Result LocalVars w e a -> R.Result LocalVars w e a

70+capture pattern result =

71+ captureVars (P.boundVarSet pattern) result

72+

73+

74+captureVars :: Set.Set String -> R.Result LocalVars w e a -> R.Result LocalVars w e a

75+captureVars bound (R.Result (LocalVars immediate delayed tags) warnings result) =

76+ let

77+ localVars =

78+ LocalVars (Set.difference immediate bound) (Set.difference delayed bound) tags

79+ in

80+ R.Result localVars warnings result

81+

82+

83+delay :: R.Result LocalVars w e a -> R.Result LocalVars w e a

84+delay (R.Result (LocalVars immediate delayed tags) warnings result) =

85+ R.Result (LocalVars Set.empty (Set.union immediate delayed) tags) warnings result

38

86

39

87

40

88

41-- REORDER EXPRESSIONS

89-- REORDER EXPRESSIONS

42

90

43

91

44−reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr

92+reorder :: Canonical.Expr -> R.Result LocalVars w E.Error Canonical.Expr

45−reorder (A.A ann expression) =

93+reorder (A.A region expression) =

46− A.A ann <$>

94+ A.A region <$>

47 case expression of

95 case expression of

48− -- Be careful adding and restricting freeVars

49 Var var ->

96 Var var ->

50− do freeIfLocal var

51− return expression

97+ addImmediate var expression

52

98

53 Lambda pattern body ->

99 Lambda pattern body ->

100+ delay $

54− uncurry Lambda <$> bindingReorder (pattern,body)

101+ bindingReorder Lambda (pattern, body)

55

102

56 Binop op leftExpr rightExpr ->

103 Binop op leftExpr rightExpr ->

57− do freeIfLocal op

58− Binop op <$> reorder leftExpr <*> reorder rightExpr

104+ do binop <- Binop op <$> reorder leftExpr <*> reorder rightExpr

105+ addImmediate op binop

59

106

60 Case expr cases ->

107 Case expr cases ->

61− Case <$> reorder expr <*> mapM bindingReorder cases

108+ Case <$> reorder expr <*> traverse (bindingReorder (,)) cases

62

109

63 Data name exprs ->

110 Data name exprs ->

64− do free name

65− Data name <$> mapM reorder exprs

111+ addTag name =<< (Data name <$> traverse reorder exprs)

66

112

67 -- Just pipe the reorder though

113 -- Just pipe the reorder though

68 Literal _ ->

114 Literal _ ->

69 return expression

115 return expression

70

116

71− Range lowExpr highExpr ->

72− Range <$> reorder lowExpr <*> reorder highExpr

73−

74 ExplicitList es ->

117 ExplicitList es ->

75− ExplicitList <$> mapM reorder es

118+ ExplicitList <$> traverse reorder es

76

119

77 App func arg ->

120 App func arg ->

78 App <$> reorder func <*> reorder arg

121 App <$> reorder func <*> reorder arg

79

122

80 If branches finally ->

123 If branches finally ->

81 If

124 If

82− <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches

125+ <$> traverse (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches

83 <*> reorder finally

126 <*> reorder finally

84

127

85 Access record field ->

128 Access record field ->

@@ -90,11 +133,11 @@ reorder (A.A ann expression) =

90 Update record fields ->

133 Update record fields ->

91 Update

134 Update

92 <$> reorder record

135 <$> reorder record

93− <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields

136+ <*> traverse (traverse reorder) fields

94

137

95 Record fields ->

138 Record fields ->

96 Record

139 Record

97− <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields

140+ <$> traverse (traverse reorder) fields

98

141

99 Cmd _ ->

142 Cmd _ ->

100 return expression

143 return expression

@@ -119,117 +162,185 @@ reorder (A.A ann expression) =

119

162

120 -- Actually do some reordering

163 -- Actually do some reordering

121 Let defs body ->

164 Let defs body ->

122− do body' <- reorder body

165+ case reorderDefs defs of

166+ R.Result () warnings (R.Err errors) ->

167+ R.Result mempty warnings (R.Err errors)

168+

169+ R.Result () warnings (R.Ok (boundVars, defGroups, defLocals)) ->

170+ captureVars boundVars $

171+ do _ <- R.Result mempty warnings (R.Ok ())

172+ newBody <- reorder body

173+ R.accumulate defLocals $ A.drop $

174+ foldr (\defGroup expr -> A.A region (Let defGroup expr)) newBody defGroups

175+

176+

177+

178+-- BINDINGS

179+

180+

181+bindingReorder

182+ :: (P.Canonical -> Canonical.Expr -> a)

183+ -> (P.Canonical, Canonical.Expr)

184+ -> R.Result LocalVars w E.Error a

185+bindingReorder func (pattern, expr) =

186+ do answer <- func pattern <$> capture pattern (reorder expr)

187+ addPatternTags pattern answer

123

188

124− -- Sort defs into strongly connected components.This

125− -- allows the programmer to write definitions in whatever

126− -- order they please, we can still define things in order

127− -- and generalize polymorphic functions when appropriate.

128− sccs <- Graph.stronglyConnComp <$> buildDefGraph defs

129− let defss = map Graph.flattenSCC sccs

130

189

131− -- remove let-bound variables from the context

132− forM_ defs $ \(Canonical.Def _ pattern _ _) -> do

133− bound pattern

134− mapM free (ctors pattern)

135

190

136− let (A.A _ let') =

191+-- FREE CONSTRUCTORS

137− foldr (\ds bod -> A.A ann (Let ds bod)) body' defss

138

192

139− return let'

140

193

194+addPatternTags :: P.Canonical -> a -> R.Result LocalVars w e a

195+addPatternTags pattern value =

196+ R.accumulate (LocalVars Set.empty Set.empty (getPatternTags pattern)) value

141

197

198+

142−ctors :: P.Canonical -> [String]

199+getPatternTags :: P.Canonical -> Set.Set String

143−ctors (A.A _ pattern) =

200+getPatternTags (A.A _ pattern) =

144 case pattern of

201 case pattern of

145 P.Var _ ->

202 P.Var _ ->

146− []

203+ Set.empty

147

204

148− P.Alias _ p ->

205+ P.Alias _ subPattern ->

149− ctors p

206+ getPatternTags subPattern

150

207

151 P.Record _ ->

208 P.Record _ ->

152− []

209+ Set.empty

153

210

154 P.Anything ->

211 P.Anything ->

155− []

212+ Set.empty

156

213

157 P.Literal _ ->

214 P.Literal _ ->

158− []

215+ Set.empty

159

216

160− P.Data (V.Canonical home name) ps ->

217+ P.Data (V.Canonical home name) patterns ->

218+ let

219+ freeCtors =

220+ Set.unions (map getPatternTags patterns)

221+ in

161 case home of

222 case home of

162− V.Local -> name : rest

223+ V.Local ->

224+ Set.insert name freeCtors

225+

163− V.TopLevel _ -> name : rest

226+ V.TopLevel _ ->

227+ Set.insert name freeCtors

228+

164− V.BuiltIn -> rest

229+ V.BuiltIn ->

230+ freeCtors

231+

165− V.Module _ -> rest

232+ V.Module _ ->

166− where

233+ freeCtors

167− rest = concatMap ctors ps

234+

235+

236+

237+-- REORDER DEFINITIONS

238+

168

239

240+reorderDefs

241+ :: [Canonical.Def]

242+ -> R.Result () w E.Error (Set.Set String, [[Canonical.Def]], LocalVars)

243+reorderDefs defs =

244+ do rawNodes <- sequenceA $ zipWith toRawNode [0..] defs

245+ let boundVarDict = toBoundVarDict rawNodes

246+ _ <- detectLoops boundVarDict rawNodes

247+ return $ groupDefs boundVarDict rawNodes

169

248

170−bound :: P.Canonical -> State (Set.Set String) ()

249+

171−bound pattern =

250+toRawNode :: Int -> Canonical.Def -> R.Result () w E.Error (Canonical.Def, Int, LocalVars)

251+toRawNode index (Canonical.Def region pattern body maybeType) =

172 let

252 let

173− boundVars =

253+ (R.Result localVars warnings answer) =

174− P.boundVarSet pattern

254+ addPatternTags pattern =<< reorder body

255+

256+ toRawNodeHelp newBody =

257+ ( Canonical.Def region pattern newBody maybeType, index, localVars )

175 in

258 in

176− modify (\freeVars -> Set.difference freeVars boundVars)

259+ toRawNodeHelp <$> R.Result () warnings answer

177

260

178

261

179−bindingReorder

262+toBoundVarDict :: [(Canonical.Def, Int, a)] -> Map.Map String Int

180− :: (P.Canonical, Canonical.Expr)

263+toBoundVarDict defAndDeps =

181− -> State (Set.Set String) (P.Canonical, Canonical.Expr)

182−bindingReorder (pattern, expr) =

183− do expr' <- reorder expr

184− bound pattern

185− mapM_ free (ctors pattern)

186− return (pattern, expr')

187−

188−

189−

190−-- BUILD DEPENDENCY GRAPH BETWEEN DEFINITIONS

191−

192−

193−-- This also reorders the all of the sub-expressions in the Def list.

194−buildDefGraph

195− :: [Canonical.Def]

196− -> State (Set.Set String) [(Canonical.Def, Int, [Int])]

197−buildDefGraph defs =

198− do pdefsDeps <- mapM reorderAndGetDependencies defs

199− return $ realDeps (addKey pdefsDeps)

200− where

201− addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]

202− addKey =

203− zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

204−

205− variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]

206− variableToKey (Canonical.Def _ pattern _ _, key, _) =

207− [ (var, key) | var <- P.boundVarList pattern ]

208−

209− variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int

210− variableToKeyMap pdefsDeps =

211− Map.fromList (concatMap variableToKey pdefsDeps)

264+ Map.fromList (concatMap toBoundVarDictHelp defAndDeps)

212−

265+

266+

213− realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]

267+toBoundVarDictHelp :: (Canonical.Def, Int, a) -> [(String, Int)]

214− realDeps pdefsDeps =

268+toBoundVarDictHelp (Canonical.Def _ pattern _ _, key, _) =

215− map convert pdefsDeps

269+ map (\(A.A _ name) -> (name, key)) (P.boundVars pattern)

216− where

270+

217− varDict =

271+

218− variableToKeyMap pdefsDeps

272+

219−

273+-- BUILD GRAPHS

220− convert (pdef, key, deps) =

274+

275+

276+toNode

277+ :: (deps -> [String])

278+ -> Map.Map String Int

279+ -> (Canonical.Def, Int, deps)

280+ -> (Canonical.Def, Int, [Int])

281+toNode toVars boundVarDict (def, index, deps) =

282+ let

283+ localDeps =

221− (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)

284+ Maybe.mapMaybe (\var -> Map.lookup var boundVarDict) (toVars deps)

222−

285+ in

223−

286+ ( def, index, localDeps )

224−reorderAndGetDependencies

287+

225− :: Canonical.Def

288+

289+immediateOnly :: LocalVars -> [String]

290+immediateOnly (LocalVars immediate _ _) =

291+ Set.toList immediate

292+

293+

294+allVars :: LocalVars -> [String]

295+allVars (LocalVars immediate delayed tags) =

296+ Set.toList immediate ++ Set.toList delayed ++ Set.toList tags

297+

298+

299+

300+-- DETECT LOOPS

301+

302+

303+detectLoops

304+ :: Map.Map String Int

226− -> State (Set.Set String) (Canonical.Def, [String])

305+ -> [(Canonical.Def, Int, LocalVars)]

227−reorderAndGetDependencies (Canonical.Def facts pattern expr mType) =

306+ -> R.Result () w E.Error ()

228− do globalFrees <- get

307+detectLoops boundVarDict rawNodes =

229− -- work in a fresh environment

308+ F.traverse_ detectLoopsHelp $

230− put Set.empty

309+ Graph.stronglyConnComp $

231− expr' <- reorder expr

310+ map (toNode immediateOnly boundVarDict) rawNodes

232− localFrees <- get

311+

233− -- merge with global frees

312+

234− modify (Set.union globalFrees)

313+detectLoopsHelp :: Graph.SCC Canonical.Def -> R.Result () w E.Error ()

235− return (Canonical.Def facts pattern expr' mType, Set.toList localFrees)

314+detectLoopsHelp scc =

315+ case scc of

316+ Graph.AcyclicSCC _ ->

317+ R.ok ()

318+

319+ Graph.CyclicSCC defs ->

320+ case defs of

321+ [] ->

322+ R.ok ()

323+

324+ def@(Canonical.Def region (A.A nameRegion _) _ _) : rest ->

325+ R.throw region $ E.BadRecursion nameRegion def rest

326+

327+

328+

329+-- GROUP DEFINITIONS

330+

331+

332+groupDefs

333+ :: Map.Map String Int

334+ -> [(Canonical.Def, Int, LocalVars)]

335+ -> ( Set.Set String, [[Canonical.Def]], LocalVars )

336+groupDefs boundVarDict rawNodes =

337+ let

338+ allLocalVars =

339+ mconcat (map (\(_, _, localVars) -> localVars) rawNodes)

340+

341+ defGroups =

342+ map Graph.flattenSCC $

343+ Graph.stronglyConnComp $

344+ map (toNode allVars boundVarDict) rawNodes

345+ in

346+ ( Map.keysSet boundVarDict, defGroups, allLocalVars )

src/Canonicalize/Variable.hs+2−2

@@ -59,7 +59,7 @@ variable region env var =

59 logVar (Var.Canonical (Var.Module moduleName) varName)

60

61 _ ->

62− case Set.toList `fmap` Map.lookup var (Env._values env) of

62+ case Set.toList <$> Map.lookup var (Env._values env) of

63 Just [v] ->

64 logVar v

65

@@ -104,7 +104,7 @@ pvar

104 -> Int

105 -> Result Var.Canonical

106pvar region env var actualArgs =

107− case Set.toList `fmap` Map.lookup var (Env._patterns env) of

107+ case Set.toList <$> Map.lookup var (Env._patterns env) of

108 Just [value] ->

109 foundArgCheck value

110

src/Docs/Centralize.hs+3−3

@@ -46,7 +46,7 @@ defToEntry infixDict (A.A (_, maybeComment) (Canonical.Def _ pattern _ maybeType

46 value =

47 Docs.Value

48 maybeComment

49− (fmap (Extract.toAliasedType . A.drop) maybeType)

49+ (fmap (Extract.extract . A.drop) maybeType)

50 (Map.lookup name infixDict)

51 in

52 Just (name, A.A subregion value)

@@ -59,7 +59,7 @@ unionToEntry :: A.Commented (D.Union Type.Canonical) -> (String, A.Located Docs.

59unionToEntry (A.A (region, maybeComment) (D.Type name args ctors)) =

60 let

61 ctors' =

62− map (second (map Extract.toAliasedType)) ctors

62+ map (second (map Extract.extract)) ctors

63 in

64 (name, A.A region (Docs.Union maybeComment args ctors'))

65

@@ -67,7 +67,7 @@ unionToEntry (A.A (region, maybeComment) (D.Type name args ctors)) =

67aliasToEntry :: A.Commented (D.Alias Type.Canonical) -> (String, A.Located Docs.Alias)

68aliasToEntry (A.A (region, maybeComment) (D.Type name args tipe)) =

69 ( name

70− , A.A region (Docs.Alias maybeComment args (Extract.toAliasedType tipe))

70+ , A.A region (Docs.Alias maybeComment args (Extract.extract tipe))

71 )

72

73

src/Docs/Check.hs+3−2

@@ -11,8 +11,9 @@ import qualified AST.Variable as Var

11import qualified Docs.AST as Docs

12import qualified Elm.Compiler.Type as Type

13import Elm.Utils ((|>))

14+import Parse.Binop (infixOp)

14import Parse.Helpers

15import Parse.Helpers

15− ( addLocation, anyUntil, commaSep1, iParse, parens, simpleNewline, symOp

16+ ( addLocation, anyUntil, commaSep1, iParse, parens, simpleNewline

16 , var, whitespace

17 , var, whitespace

17 )

18 )

18import qualified Reporting.Annotation as A

19import qualified Reporting.Annotation as A

@@ -156,7 +157,7 @@ commentedNames (R.Region start _) comment =

156 choice

157 choice

157 [ do string "@docs"

158 [ do string "@docs"

158 whitespace

159 whitespace

159− commaSep1 (addLocation (var <|> parens symOp))

160+ commaSep1 (addLocation (var <|> parens infixOp))

160 , do anyUntil simpleNewline

161 , do anyUntil simpleNewline

161 return []

162 return []

162 ]

163 ]

src/Elm/Compiler.hs+28−16

@@ -18,8 +18,9 @@ import qualified AST.Module as Module

18import qualified AST.Module.Name as ModuleName

19import qualified Compile

20import qualified Docs.Check as Docs

21−import qualified Elm.Compiler.Version

21+import qualified Elm.Compiler.Imports as Imports

22import qualified Elm.Compiler.Module as PublicModule

23+import qualified Elm.Compiler.Version

23import qualified Elm.Docs as Docs

24import qualified Elm.Docs as Docs

24import qualified Elm.Package as Package

25import qualified Elm.Package as Package

25import qualified Generate.JavaScript as JS

26import qualified Generate.JavaScript as JS

@@ -53,26 +54,37 @@ data Tag

53 | Port

54 | Port

54

55

56

57+parseDependencies

58+ :: Package.Name

59+ -> String

56−parseDependencies :: String -> Either [Error] (Tag, PublicModule.Raw, [PublicModule.Raw])

60+ -> Either [Error] (Tag, PublicModule.Raw, [PublicModule.Raw])

57−parseDependencies sourceCode =

61+parseDependencies pkgName sourceCode =

58 let

62 let

59 (Result.Result _ _ answer) =

63 (Result.Result _ _ answer) =

60 Parse.parse sourceCode Parse.header

64 Parse.parse sourceCode Parse.header

65+ in

66+ Result.answerToEither (Error . A.map Error.Syntax) (getDeps pkgName) answer

61

67

68+

69+getDeps

70+ :: Package.Name

71+ -> Module.Header [Module.UserImport]

72+ -> (Tag, PublicModule.Raw, [PublicModule.Raw])

62− getDeps (Module.Header sourceTag name _ _ _ imports) =

73+getDeps pkgName (Module.Header sourceTag name _ _ _ imports) =

63− let

74+ let

64− tag =

75+ tag =

65− case sourceTag of

76+ case sourceTag of

66− Module.Normal -> Normal

77+ Module.Normal -> Normal

67− Module.Port _ -> Port

78+ Module.Port _ -> Port

68− Module.Effect _ -> Effect

79+ Module.Effect _ -> Effect

69− in

80+

70− ( tag

81+ deps =

71− , name

82+ if pkgName == Package.core then

72− , map (fst . A.drop) imports

83+ map (fst . A.drop) imports

73− )

84+ else

85+ map (fst . A.drop) imports ++ map fst Imports.defaults

74 in

86 in

75− Result.answerToEither (Error . A.map Error.Syntax) getDeps answer

87+ ( tag, name, deps )

76

88

77

89

78

90

src/Elm/Compiler/Module.hs+10−11

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -Wall #-}

1module Elm.Compiler.Module

2module Elm.Compiler.Module

2 ( Interface, Interfaces

3 ( Interface, Interfaces

3 , ModuleName.Raw

4 , ModuleName.Raw

@@ -5,8 +6,7 @@ module Elm.Compiler.Module

5 , nameToString, nameFromString

6 , nameToString, nameFromString

6 , hyphenate, dehyphenate

7 , hyphenate, dehyphenate

7 , RawForJson(RawForJson), fromJson

8 , RawForJson(RawForJson), fromJson

8− , defaultImports

9− , interfaceAliasedTypes

9+ , interfaceAliasedTypes, programTypes

10 , ModuleName.Canonical(..), qualifiedVar

11 )

12 where

@@ -20,8 +20,7 @@ import System.FilePath ((</>))

20

21import qualified AST.Module as Module

22import qualified AST.Module.Name as ModuleName

23−import qualified Elm.Compiler.Imports as Imports

23+import qualified Elm.Compiler.Type as PublicType

24−import qualified Elm.Compiler.Type as Type

25import qualified Elm.Compiler.Type.Extract as Extract

24import qualified Elm.Compiler.Type.Extract as Extract

26import qualified Generate.JavaScript.Variable as Gen

25import qualified Generate.JavaScript.Variable as Gen

27

26

@@ -36,9 +35,14 @@ type Interface = Module.Interface

36type Interfaces = Module.Interfaces

35type Interfaces = Module.Interfaces

37

36

38

37

39−interfaceAliasedTypes :: Interface -> Map.Map String Type.Type

38+interfaceAliasedTypes :: Interface -> Map.Map String PublicType.Type

40interfaceAliasedTypes interface =

39interfaceAliasedTypes interface =

41− Map.map Extract.toAliasedType (Module.iTypes interface)

40+ Map.map Extract.extract (Module.iTypes interface)

41+

42+

43+programTypes :: Interfaces -> ModuleName.Canonical -> Maybe PublicType.Program

44+programTypes =

45+ Extract.extractProgram

42

46

43

47

44

48

@@ -58,11 +62,6 @@ qualifiedVar =

58 Gen.qualified

62 Gen.qualified

59

63

60

64

61−defaultImports :: [ModuleName.Raw]

62−defaultImports =

63− map fst Imports.defaults

64−

65−

66

65

67-- STRING CONVERSIONS for RAW NAMES

66-- STRING CONVERSIONS for RAW NAMES

68

67

src/Elm/Compiler/Type.hs+57−5

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

1{-# LANGUAGE OverloadedStrings #-}

2module Elm.Compiler.Type

3− ( Type(..)

4− , toString

3+ ( Type(..), toString

4+ , Program(..)

5+ )

5− ) where

6+ where

6

7

7import Control.Arrow (second)

8import Control.Arrow (second)

8−import Data.Aeson ((.:))

9+import Data.Aeson ((.:), (.=))

9import qualified Data.Aeson as Json

10import qualified Data.Aeson as Json

10import qualified Data.Aeson.Types as Json

11import qualified Data.Aeson.Types as Json

11import qualified Data.ByteString.Lazy.Char8 as BS

12import qualified Data.ByteString.Lazy.Char8 as BS

@@ -20,6 +21,7 @@ import qualified Parse.Type as Type

20import qualified Reporting.Annotation as A

21import qualified Reporting.Annotation as A

21

22

23

24+

23data Type

25data Type

24 = Lambda Type Type

26 = Lambda Type Type

25 | Var String

27 | Var String

@@ -28,8 +30,18 @@ data Type

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

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

29

31

30

32

33+data Program =

34+ Program

35+ { _message :: Type

36+ , _aliases :: [( String, [String], Type )]

37+ , _unions :: [( String, [String], [(String, [Type])] )]

38+ }

39+

40+

41+

31-- TO STRING

42-- TO STRING

32

43

44+

33data Context = None | ADT | Function

45data Context = None | ADT | Function

34

46

35

47

@@ -127,8 +139,10 @@ flattenRecord tipe =

127 _ -> error "Trying to flatten ill-formed record."

139 _ -> error "Trying to flatten ill-formed record."

128

140

129

141

142+

130-- JSON for TYPE

143-- JSON for TYPE

131

144

145+

132instance Json.ToJSON Type where

146instance Json.ToJSON Type where

133 toJSON tipe =

147 toJSON tipe =

134 Json.String (Text.unwords (Text.words (Text.pack (toString tipe))))

148 Json.String (Text.unwords (Text.words (Text.pack (toString tipe))))

@@ -145,7 +159,7 @@ instance Json.FromJSON Type where

145 case value of

159 case value of

146 Json.String text ->

160 Json.String text ->

147 either failure (return . fromRawType)

161 either failure (return . fromRawType)

148− (Parse.iParse Type.expr (Text.unpack text))

162+ (Parse.iParse Type.expr (replacePrimes (Text.unpack text)))

149

163

150 Json.Object obj ->

164 Json.Object obj ->

151 fromObject obj

165 fromObject obj

@@ -154,6 +168,11 @@ instance Json.FromJSON Type where

154 failure ()

168 failure ()

155

169

156

170

171+replacePrimes :: String -> String

172+replacePrimes string =

173+ map (\c -> if c == '\'' then '_' else c) string

174+

175+

157fromObject :: Json.Object -> Json.Parser Type

176fromObject :: Json.Object -> Json.Parser Type

158fromObject obj =

177fromObject obj =

159 do tag <- obj .: "tag"

178 do tag <- obj .: "tag"

@@ -195,3 +214,36 @@ fromRawType (A.A _ astType) =

195 Type.RRecord fields ext ->

214 Type.RRecord fields ext ->

196 Record (map (second fromRawType) fields) (fmap fromRawType ext)

215 Record (map (second fromRawType) fields) (fmap fromRawType ext)

197

216

217+

218+

219+-- JSON for PROGRAM

220+

221+

222+instance Json.ToJSON Program where

223+ toJSON (Program msg aliases unions) =

224+ Json.object

225+ [ "message" .= msg

226+ , "aliases" .= Json.object (map toAliasField aliases)

227+ , "unions" .= Json.object (map toUnionField unions)

228+ ]

229+

230+

231+toAliasField :: ( String, [String], Type ) -> Json.Pair

232+toAliasField ( name, args, tipe ) =

233+ Text.pack name .= Json.object

234+ [ "args" .= args

235+ , "type" .= tipe

236+ ]

237+

238+

239+toUnionField :: ( String, [String], [(String, [Type])] ) -> Json.Pair

240+toUnionField ( name, args, constructors ) =

241+ Text.pack name .= Json.object

242+ [ "args" .= args

243+ , "tags" .= Json.object (map toCtorObject constructors)

244+ ]

245+

246+

247+toCtorObject :: (String, [Type]) -> Json.Pair

248+toCtorObject (name, args) =

249+ Text.pack name .= args

src/Elm/Compiler/Type/Extract.hs+145−29

@@ -1,45 +1,161 @@

1+{-# OPTIONS_GHC -Wall #-}

1−module Elm.Compiler.Type.Extract (toFullType, toAliasedType) where

2+module Elm.Compiler.Type.Extract

3+ ( extract

4+ , extractProgram

5+ )

6+ where

2

7

3−import Control.Arrow (second)

8+import qualified Control.Monad.Writer as Writer

9+import qualified Data.Map as Map

10+import qualified Data.Maybe as Maybe

11+import qualified Data.Set as Set

4−import qualified AST.Type as Type

12+import qualified AST.Module as Module

13+import qualified AST.Module.Name as ModuleName

14+import qualified AST.Type as T

5import qualified AST.Variable as Var

15import qualified AST.Variable as Var

6−import qualified Elm.Compiler.Type as T

16+import Elm.Compiler.Type (Type(..), Program(Program))

7

17

8

18

9−toFullType :: Type.Canonical -> T.Type

10−toFullType astType =

11− toType False astType

12

19

20+-- EXTRACTION

13

21

14−toAliasedType :: Type.Canonical -> T.Type

15−toAliasedType astType =

16− toType True astType

17

22

23+extract :: T.Canonical -> Type

24+extract astType =

25+ fst $ Writer.runWriter $ extractHelp astType

18

26

19−toType :: Bool -> Type.Canonical -> T.Type

27+

20−toType useAliases astType =

28+type Deps =

29+ ( Set.Set Var.Canonical -- aliases

30+ , Set.Set Var.Canonical -- unions

31+ )

32+

33+

34+diff :: Deps -> Deps -> Deps

35+diff (oldAliases, oldUnions) (newAliases, newUnions) =

36+ ( Set.difference newAliases oldAliases

37+ , Set.difference newUnions oldUnions

38+ )

39+

40+

41+extractHelp :: T.Canonical -> Writer.Writer Deps Type

42+extractHelp astType =

43+ case astType of

44+ T.Lambda arg result ->

45+ Lambda <$> extractHelp arg <*> extractHelp result

46+

47+ T.Var x ->

48+ return $ Var x

49+

50+ T.Type var ->

51+ do Writer.tell ( Set.empty, Set.singleton var )

52+ return $ Type $ Var.toString var

53+

54+ T.App constructor args ->

55+ App <$> extractHelp constructor <*> traverse extractHelp args

56+

57+ T.Record fields ext ->

58+ Record

59+ <$> traverse (traverse extractHelp) fields

60+ <*> traverse extractHelp ext

61+

62+ T.Aliased name args aliasedType ->

63+ do Writer.tell ( Set.singleton name, Set.empty )

64+ _ <- extractHelp (T.dealias args aliasedType)

65+ App (Type (Var.toString name)) <$> traverse (extractHelp . snd) args

66+

67+

68+

69+-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES

70+

71+

72+extractProgram :: Module.Interfaces -> ModuleName.Canonical -> Maybe Program

73+extractProgram interfaces name =

74+ do iface <- Map.lookup name interfaces

75+ mainType <- Map.lookup "main" (Module.iTypes iface)

76+ case mainType of

77+ T.App _program [_flags, _model, msg] ->

78+ let

79+ (msgType, msgDeps) =

80+ Writer.runWriter (extractHelp msg)

81+

82+ (aliases, unions) =

83+ extractTransitive interfaces mempty msgDeps

84+ in

85+ Just $ Program msgType aliases unions

86+

87+ _ ->

88+ Nothing

89+

90+

91+type Alias =

92+ ( String, [String], Type )

93+

94+

95+type Union =

96+ ( String, [String], [(String, [Type])] )

97+

98+

99+extractTransitive :: Module.Interfaces -> Deps -> Deps -> ( [Alias], [Union] )

100+extractTransitive interfaces oldDeps currentDeps =

21 let

101 let

22− go = toType useAliases

102+ (aliases, unions) =

103+ diff oldDeps currentDeps

23 in

104 in

24− case astType of

105+ if Set.null aliases && Set.null unions then

25− Type.Lambda t1 t2 ->

106+ ( [], [] )

26− T.Lambda (go t1) (go t2)

107+

108+ else

109+ let

110+ (result, newDeps) =

111+ Writer.runWriter $ do

112+ publicAliases <- mapM (extractAlias interfaces) (Set.toList aliases)

113+ publicUnions <- mapM (extractUnion interfaces) (Set.toList unions)

114+ return ( Maybe.catMaybes publicAliases, Maybe.catMaybes publicUnions )

115+

116+ remainingResult =

117+ extractTransitive interfaces (mappend oldDeps currentDeps) newDeps

118+ in

119+ mappend result remainingResult

120+

121+

122+extractAlias :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps (Maybe Alias)

123+extractAlias interfaces var =

124+ let

125+ toAlias (args, tipe) =

126+ (,,) (Var.toString var) args <$> extractHelp tipe

127+ in

128+ traverse toAlias (get Module.iAliases interfaces var)

129+

130+

131+extractUnion :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps (Maybe Union)

132+extractUnion interfaces var =

133+ let

134+ toUnion (args, constructors) =

135+ (,,) (Var.toString var) args

136+ <$> traverse (traverse (traverse extractHelp)) constructors

137+ in

138+ traverse toUnion (get Module.iUnions interfaces var)

139+

27

140

28− Type.Var x ->

141+get :: (Module.Interface -> Map.Map String a) -> Module.Interfaces -> Var.Canonical -> Maybe a

29− T.Var x

142+get getInfo interfaces var =

143+ do (home, name) <- getHome var

144+ iface <- Map.lookup home interfaces

145+ Map.lookup name (getInfo iface)

30

146

31− Type.Type var ->

32− T.Type (Var.toString var)

33

147

34− Type.App t ts ->

148+getHome :: Var.Canonical -> Maybe (ModuleName.Canonical, String)

35− T.App (go t) (map go ts)

149+getHome (Var.Canonical home name) =

150+ case home of

151+ Var.BuiltIn ->

152+ Nothing

36

153

37− Type.Record fields ext ->

154+ Var.Module moduleName ->

38− T.Record (map (second go) fields) (fmap go ext)

155+ Just (moduleName, name)

39

156

40− Type.Aliased name args t ->

157+ Var.TopLevel moduleName ->

41− if useAliases then

158+ Just (moduleName, name)

42− T.App (T.Type (Var.toString name)) (map (go . snd) args)

43

159

44− else

160+ Var.Local ->

45− go (Type.dealias args t)

161+ Nothing

src/Elm/Utils.hs+3−2

@@ -12,6 +12,7 @@ import qualified Data.List as List

12import System.Exit (ExitCode(ExitSuccess, ExitFailure))

13import System.Process (readProcessWithExitCode)

14

15+import qualified AST.Expression.Source as Source

15import qualified AST.Pattern as Pattern

16import qualified AST.Pattern as Pattern

16import qualified Parse.Helpers as Parse

17import qualified Parse.Helpers as Parse

17import qualified Parse.Expression as Parse

18import qualified Parse.Expression as Parse

@@ -99,8 +100,8 @@ missingExe command =

99

100

100isDeclaration :: String -> Maybe String

101isDeclaration :: String -> Maybe String

101isDeclaration string =

102isDeclaration string =

102− case Parse.iParse (Parse.definition (,)) string of

103+ case Parse.iParse Parse.def string of

103− Right (A.A _ (pattern, _)) ->

104+ Right (A.A _ (Source.Definition pattern _)) ->

104 Just (List.intercalate "$" (Pattern.boundVarList pattern))

105 Just (List.intercalate "$" (Pattern.boundVarList pattern))

105

106

106 _ ->

107 _ ->

src/Generate/JavaScript.hs+1−1

@@ -48,7 +48,7 @@ generateEffectManager moduleName effects =

48 Effects.Manager pkgName (Effects.Info _ _ _ _ managerType) ->

49 let

50 managers =

51− Var.native (ModuleName.inCore ["Native","Platform"]) "effectManagers"

51+ Var.coreNative "Platform" "effectManagers"

52

53 managerName =

54 JS.StringLit () (ModuleName.canonicalToString moduleName)

src/Generate/JavaScript/BuiltIn.hs+1−6

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

1module Generate.JavaScript.BuiltIn

2 ( character, string

3− , list, range

3+ , list

4 , recordUpdate

5 , eq, cmp

6 , effect, outgoingPort, incomingPort

@@ -50,11 +50,6 @@ list elements =

50 nativeList "fromArray" [ JS.ArrayLit () elements ]

51

52

53−range :: JS.Expression () -> JS.Expression () -> JS.Expression ()

54−range low high =

55− nativeList "range" [ low, high ]

56−

57−

58

53

59-- RECORDS

54-- RECORDS

60

55

src/Generate/JavaScript/Expression.hs+102−29

@@ -87,10 +87,10 @@ generateDef :: Opt.Def -> State Int [Statement ()]

87generateDef def =

88 do (home, name, jsBody) <-

89 case def of

90− Opt.TailDef (Opt.Facts home _) name argNames body ->

90+ Opt.TailDef (Opt.Facts home) name argNames body ->

91 (,,) home name <$> generateTailFunction name argNames body

92

93− Opt.Def (Opt.Facts home _) name body ->

93+ Opt.Def (Opt.Facts home) name body ->

94 (,,) home name <$> generateJsExpr body

95

96 return (Var.define home name jsBody)

@@ -114,11 +114,6 @@ generateCode expr =

114 Literal lit ->

115 jsExpr (Literal.literal lit)

116

117− Range lo hi ->

118− do lo' <- generateJsExpr lo

119− hi' <- generateJsExpr hi

120− jsExpr $ BuiltIn.range lo' hi'

121−

122 Access record field ->

117 Access record field ->

123 do record' <- generateJsExpr record

118 do record' <- generateJsExpr record

124 jsExpr $ DotRef () record' (var (Var.safe field))

119 jsExpr $ DotRef () record' (var (Var.safe field))

@@ -149,17 +144,7 @@ generateCode expr =

149 generateFunction args body

144 generateFunction args body

150

145

151 Call func args ->

146 Call func args ->

152− let

147+ generateCall func args

153− arity = length args

154− aN = "A" ++ show arity

155− in

156− do jsFunc <- generateJsExpr func

157− jsArgs <- mapM generateJsExpr args

158− jsExpr $

159− if 2 <= arity && arity <= 9 then

160− ref aN `call` (jsFunc:jsArgs)

161− else

162− foldl1 (<|) (jsFunc:jsArgs)

163

148

164 TailCall name argNames args ->

149 TailCall name argNames args ->

165 let

150 let

@@ -233,19 +218,19 @@ generateCode expr =

233

218

234generateProgram :: Expr.Main Type.Canonical -> Opt.Expr -> State Int Code

219generateProgram :: Expr.Main Type.Canonical -> Opt.Expr -> State Int Code

235generateProgram kind body =

220generateProgram kind body =

236− let

237− gen fields =

238− generateCode $ Record (("main", body) : fields)

239− in

240− case kind of

221+ case kind of

241− Expr.VDom ->

222+ Expr.VDom ->

242− gen []

223+ do html <- generateJsExpr body

224+ jsExpr (Var.coreNative "Platform" "htmlToProgram" <| html)

243

225

244− Expr.NoFlags ->

226+ Expr.NoFlags ->

245− gen []

227+ do almostProgram <- generateJsExpr body

228+ jsExpr (almostProgram `call` [])

246

229

247− Expr.Flags tipe ->

230+ Expr.Flags tipe ->

231+ do almostProgram <- generateJsExpr body

248− gen [ ("flags", Foreign.decode tipe) ]

232+ flagDecoder <- generateJsExpr (Foreign.decode tipe)

233+ jsExpr (almostProgram <| flagDecoder)

249

234

250

235

251

236

@@ -287,6 +272,94 @@ generateFunctionWithArity rawArgs code =

287

272

288

273

289

274

275+-- GENERATE CALL

276+

277+

278+generateCall :: Opt.Expr -> [Opt.Expr] -> State Int Code

279+generateCall func args =

280+ case (func, args) of

281+ (Opt.Var var, [arg]) ->

282+ case getUnaryOp var of

283+ Just op ->

284+ do jsArg <- generateJsExpr arg

285+ jsExpr $ PrefixExpr () op jsArg

286+

287+ Nothing ->

288+ generateCallHelp func args

289+

290+ (Opt.Var var, [left, right]) ->

291+ case getBinaryOp var of

292+ Just op ->

293+ do jsLeft <- generateJsExpr left

294+ jsRight <- generateJsExpr right

295+ jsExpr $ InfixExpr () op jsLeft jsRight

296+

297+ Nothing ->

298+ generateCallHelp func args

299+

300+ _ ->

301+ generateCallHelp func args

302+

303+

304+generateCallHelp :: Opt.Expr -> [Opt.Expr] -> State Int Code

305+generateCallHelp func args =

306+ let

307+ arity = length args

308+ aN = "A" ++ show arity

309+ in

310+ do jsFunc <- generateJsExpr func

311+ jsArgs <- mapM generateJsExpr args

312+ jsExpr $

313+ if 2 <= arity && arity <= 9 then

314+ ref aN `call` (jsFunc:jsArgs)

315+ else

316+ foldl1 (<|) (jsFunc:jsArgs)

317+

318+

319+getUnaryOp :: Var.Canonical -> Maybe PrefixOp

320+getUnaryOp var =

321+ if var == bitwiseComplement then

322+ Just PrefixBNot

323+

324+ else if var == basicsNot then

325+ Just PrefixLNot

326+

327+ else

328+ Nothing

329+

330+

331+getBinaryOp :: Var.Canonical -> Maybe InfixOp

332+getBinaryOp (Var.Canonical home name) =

333+ if home /= bitwise then

334+ Nothing

335+

336+ else

337+ case name of

338+ "and" -> Just OpBAnd

339+ "or" -> Just OpBOr

340+ "xor" -> Just OpBXor

341+ "shiftLeftBy" -> Just OpLShift

342+ "shiftRightBy" -> Just OpSpRShift

343+ "shiftRightZfBy" -> Just OpZfRShift

344+ _ -> Nothing

345+

346+

347+bitwiseComplement :: Var.Canonical

348+bitwiseComplement =

349+ Var.inCore ["Bitwise"] "complement"

350+

351+

352+basicsNot :: Var.Canonical

353+basicsNot =

354+ Var.inCore ["Basics"] "not"

355+

356+

357+bitwise :: Var.Home

358+bitwise =

359+ Var.Module (ModuleName.inCore ["Bitwise"])

360+

361+

362+

290-- GENERATE IFS

363-- GENERATE IFS

291

364

292

365

src/Generate/JavaScript/Foreign.hs+4−4

@@ -156,9 +156,9 @@ to name =

156 Opt.Var (inJsonDecode name)

157

158

159−(=:) :: String -> Opt.Expr -> Opt.Expr

159+field :: String -> Opt.Expr -> Opt.Expr

160−(=:) name decoder =

160+field name decoder =

161− Opt.Binop (inJsonDecode ":=") (Opt.Literal (Literal.Str name)) decoder

161+ to "field" <== [ Opt.Literal (Literal.Str name), decoder ]

162

163

164(<==) :: Opt.Expr -> [Opt.Expr] -> Opt.Expr

@@ -214,6 +214,6 @@ toRecord fields =

214 to "succeed" <== [ Opt.Record (map toFieldExpr fields) ]

215

216 andThen (key, tipe) decoder =

217− to "andThen" <== [ key =: decode tipe, Opt.Function [key] decoder ]

217+ to "andThen" <== [ Opt.Function [key] decoder, field key (decode tipe) ]

218 in

219 List.foldr andThen finalDecoder fields

src/Nitpick/PatternMatches.hs−3

@@ -135,9 +135,6 @@ checkExpression tagDict (A.A region expression) =

135 E.Var _ ->

136 Result.ok ()

137

138− E.Range low high ->

139− go2 low high

140−

141 E.ExplicitList listExprs ->

138 E.ExplicitList listExprs ->

142 F.traverse_ go listExprs

139 F.traverse_ go listExprs

143

140

src/Nitpick/TopLevelTypes.hs+5−4

@@ -86,16 +86,17 @@ checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =

86

87 getMainKind =

88 case Type.deepDealias mainType of

89− Type.App name [arg]

89+ Type.App name [_]

90 | name == vdomNode ->

91 return Expr.VDom

92

93+ Type.App name [flags, _, _]

93− | name == program && arg == never ->

94+ | name == program && flags == never ->

94 return Expr.NoFlags

95 return Expr.NoFlags

95

96

96 | name == program ->

97 | name == program ->

97− return (Expr.Flags arg)

98+ return (Expr.Flags flags)

98− <* Effects.checkPortType makeError arg

99+ <* Effects.checkPortType makeError flags

99

100

100 _ ->

101 _ ->

101 Result.throw region (Error.BadMain mainType)

102 Result.throw region (Error.BadMain mainType)

src/Optimize.hs+8−18

@@ -32,7 +32,7 @@ optimize variantDict home defs =

32

33

34optimizeDef :: Bool -> Can.Def -> Env.Optimizer [Opt.Def]

35−optimizeDef isRoot (Can.Def (Can.Facts deps) pattern expression _) =

35+optimizeDef isRoot (Can.Def _ pattern expression _) =

36 let

37 (args, canBody) =

38 Expr.collectLambdas expression

@@ -45,20 +45,19 @@ optimizeDef isRoot (Can.Def (Can.Facts deps) pattern expression _) =

45 return Nothing

46 in

47 do home <- maybeGetHome

48− optimizeDefHelp home deps pattern args canBody

48+ optimizeDefHelp home pattern args canBody

49

50

51optimizeDefHelp

52 :: Maybe ModuleName.Canonical

53− -> [Var.TopLevel]

54 -> P.Canonical

53 -> P.Canonical

55 -> [P.Canonical]

54 -> [P.Canonical]

56 -> Can.Expr

55 -> Can.Expr

57 -> Env.Optimizer [Opt.Def]

56 -> Env.Optimizer [Opt.Def]

58−optimizeDefHelp home deps pattern@(A.A _ ptrn) args rawBody =

57+optimizeDefHelp home pattern@(A.A _ ptrn) args rawBody =

59 let

58 let

60 facts =

59 facts =

61− Opt.Facts home deps

60+ Opt.Facts home

62 in

61 in

63 case (ptrn, args) of

62 case (ptrn, args) of

64 (P.Var name, _ : _) ->

63 (P.Var name, _ : _) ->

@@ -125,20 +124,16 @@ depatternArgs (names, rawExpr) ptrn =

125patternToDefs :: Maybe ModuleName.Canonical -> String -> P.Canonical -> [Opt.Def]

124patternToDefs :: Maybe ModuleName.Canonical -> String -> P.Canonical -> [Opt.Def]

126patternToDefs home rootName pattern =

125patternToDefs home rootName pattern =

127 let

126 let

128− (deps, rootExpr) =

127+ rootExpr =

129 case home of

128 case home of

130 Nothing ->

129 Nothing ->

131− ( []

132− , Opt.Var (Var.local rootName)

130+ Opt.Var (Var.local rootName)

133− )

134

131

135 Just moduleName ->

132 Just moduleName ->

136− ( [ Var.TopLevelVar moduleName rootName ]

137− , Opt.Var (Var.topLevel moduleName rootName)

133+ Opt.Var (Var.topLevel moduleName rootName)

138− )

139

134

140 toDef (name, accessExpr) =

135 toDef (name, accessExpr) =

141− Opt.Def (Opt.Facts home deps) name accessExpr

136+ Opt.Def (Opt.Facts home) name accessExpr

142 in

137 in

143 map toDef (patternToSubstitutions rootExpr pattern)

138 map toDef (patternToSubstitutions rootExpr pattern)

144

139

@@ -206,11 +201,6 @@ optimizeExpr context annExpr@(A.A region expression) =

206 else

201 else

207 pure (Opt.Var name)

202 pure (Opt.Var name)

208

203

209− Expr.Range lowExpr highExpr ->

210− Opt.Range

211− <$> justConvert lowExpr

212− <*> justConvert highExpr

213−

214 Expr.ExplicitList elements ->

204 Expr.ExplicitList elements ->

215 Opt.ExplicitList

205 Opt.ExplicitList

216 <$> T.traverse justConvert elements

206 <$> T.traverse justConvert elements

src/Optimize/Inline.hs−6

@@ -100,9 +100,6 @@ count expression =

100 Var.TopLevel _ ->

101 Map.empty

102

103− Range lo hi ->

104− count2 lo hi

105−

106 ExplicitList exprs ->

103 ExplicitList exprs ->

107 countMany exprs

104 countMany exprs

108

105

@@ -210,9 +207,6 @@ replace substitutions expression =

210 Var _ ->

207 Var _ ->

211 expression

208 expression

212

209

213− Range lo hi ->

214− Range (go lo) (go hi)

215−

216 ExplicitList exprs ->

210 ExplicitList exprs ->

217 ExplicitList (map go exprs)

211 ExplicitList (map go exprs)

218

212

src/Parse/Binop.hs+50−7

@@ -1,17 +1,61 @@

1−module Parse.Binop (binops, OpTable) where

1+module Parse.Binop (infixOp, binops, OpTable) where

2

3import qualified Data.List as List

4import qualified Data.Map as Map

5−import Text.Parsec ((<|>), choice, getState, try)

5+import Text.Parsec

6+ ( (<|>), choice, getState, lookAhead, lower, many1

7+ , notFollowedBy, satisfy, string, try

8+ )

6

9

7import AST.Declaration (Assoc(L, N, R))

10import AST.Declaration (Assoc(L, N, R))

8import AST.Expression.General (Expr'(Binop))

11import AST.Expression.General (Expr'(Binop))

9import qualified AST.Expression.Source as Source

12import qualified AST.Expression.Source as Source

13+import qualified AST.Helpers as Help

10import qualified AST.Variable as Var

14import qualified AST.Variable as Var

11−import Parse.Helpers (IParser, OpTable, commitIf, failure, whitespace)

15+import Parse.Helpers (IParser, OpTable, commitIf, expecting, failure, whitespace)

12import qualified Reporting.Annotation as A

16import qualified Reporting.Annotation as A

13

17

14

18

19+

20+-- INFIX OPERATORS

21+

22+

23+infixOp :: IParser String

24+infixOp =

25+ infixOpWith notReserved

26+

27+

28+infixOpWith :: IParser String -> IParser String

29+infixOpWith checker =

30+ expecting "an infix operator like (+)" $

31+ do op <- checker <|> many1 (satisfy Help.isSymbol)

32+ case op of

33+ "." -> notFollowedBy lower >> return op

34+ _ -> return op

35+

36+

37+failOn :: String -> String -> IParser a

38+failOn op msg =

39+ do try $ lookAhead $ do

40+ string op

41+ notFollowedBy (satisfy Help.isSymbol)

42+ failure msg

43+

44+

45+notReserved :: IParser a

46+notReserved =

47+ choice

48+ [ failOn "=" "The = operator is reserved for defining variables. Maybe you want == instead? Or maybe you are defining a variable, but there is whitespace before it?"

49+ , failOn "->" "Arrows are reserved for cases and anonymous functions. Maybe you want > or >= instead?"

50+ , failOn "|" "Vertical bars are reserved for use in union type declarations. Maybe you want || instead?"

51+ , failOn ":" "A singe colon is for type annotations. Maybe you want :: instead? Or maybe you are defining a type annotation, but there is whitespace before it?"

52+ ]

53+

54+

55+

56+-- BINARY EXPRESSIONS

57+

58+

15opLevel :: OpTable -> String -> Int

59opLevel :: OpTable -> String -> Int

16opLevel table op =

60opLevel table op =

17 fst $ Map.findWithDefault (9,L) op table

61 fst $ Map.findWithDefault (9,L) op table

@@ -30,18 +74,17 @@ hasLevel table n (op,_) =

30binops

74binops

31 :: IParser Source.Expr

75 :: IParser Source.Expr

32 -> IParser Source.Expr

76 -> IParser Source.Expr

33− -> IParser String

34 -> IParser Source.Expr

77 -> IParser Source.Expr

35−binops term last anyOp =

78+binops term last =

36 do e <- term

79 do e <- term

37 table <- getState

80 table <- getState

38 split table 0 e =<< nextOps

81 split table 0 e =<< nextOps

39 where

82 where

40 nextOps =

83 nextOps =

41 choice

84 choice

42− [ commitIf (whitespace >> anyOp) $

85+ [ commitIf (whitespace >> infixOpWith (fail "")) $

43 do whitespace

86 do whitespace

44− op <- anyOp

87+ op <- infixOp

45 whitespace

88 whitespace

46 expr <- Left <$> try term <|> Right <$> last

89 expr <- Left <$> try term <|> Right <$> last

47 case expr of

90 case expr of

src/Parse/Declaration.hs+3−2

@@ -4,6 +4,7 @@ module Parse.Declaration where

4import Text.Parsec ( (<?>), choice, digit, optionMaybe, string, try )

5

6import qualified AST.Declaration as Decl

7+import qualified Parse.Binop as Binop

7import qualified Parse.Expression as Expr

8import qualified Parse.Expression as Expr

8import Parse.Helpers as Help

9import Parse.Helpers as Help

9import qualified Parse.Type as Type

10import qualified Parse.Type as Type

@@ -35,7 +36,7 @@ commentOr parser =

35

36

36definition :: IParser Decl.Raw

37definition :: IParser Decl.Raw

37definition =

38definition =

38− do def <- Expr.def <?> "a value definition"

39+ do def <- Expr.def <?> "a definition or type annotation"

39 return $ Decl.Def def

40 return $ Decl.Def def

40

41

42

@@ -79,7 +80,7 @@ infixDecl =

79 forcedWS

80 forcedWS

80 n <- digit

81 n <- digit

81 forcedWS

82 forcedWS

82− op <- anyOp

83+ op <- Binop.infixOp

83 return $ Decl.Fixity (Decl.Infix op assoc (read [n]))

84 return $ Decl.Fixity (Decl.Infix op assoc (read [n]))

84

85

86

src/Parse/Expression.hs+42−54

@@ -1,4 +1,4 @@

1−module Parse.Expression (term, annotation, definition, expr, def) where

1+module Parse.Expression (term, expr, def) where

2

3import qualified Data.List as List

4import Text.Parsec hiding (newline, spaces)

@@ -15,7 +15,6 @@ import qualified AST.Expression.General as E

15import qualified AST.Expression.Source as Source

16import qualified AST.Literal as L

17import qualified AST.Pattern as P

18−import qualified AST.Type as T

19import qualified AST.Variable as Var

18import qualified AST.Variable as Var

20import qualified Reporting.Annotation as A

19import qualified Reporting.Annotation as A

21

20

@@ -79,18 +78,13 @@ negative =

79

78

80listTerm :: IParser Source.Expr'

79listTerm :: IParser Source.Expr'

81listTerm =

80listTerm =

82− shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)

81+ choice

83− where

84− range =

85− do lo <- expr

86− padded (string "..")

87− E.Range lo <$> expr

88−

89− shader' =

90− do pos <- getPosition

82+ [ do pos <- getPosition

91 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

83 let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos)

92 (rawSrc, tipe) <- Help.shader

84 (rawSrc, tipe) <- Help.shader

93 return $ E.GLShader uid (filter (/='\r') rawSrc) tipe

85 return $ E.GLShader uid (filter (/='\r') rawSrc) tipe

86+ , braces (E.ExplicitList <$> commaSep expr)

87+ ]

94

88

95

89

96parensTerm :: IParser Source.Expr

90parensTerm :: IParser Source.Expr

@@ -121,7 +115,7 @@ parensTerm =

121 in

115 in

122 do (start, mkExpr, end) <-

116 do (start, mkExpr, end) <-

123 located $ choice $

117 located $ choice $

124− [ mkBinop <$> try (parens symOp)

118+ [ mkBinop <$> try (parens Binop.infixOp)

125 , parens (tupleFn <|> parenedExpr)

119 , parens (tupleFn <|> parenedExpr)

126 ]

120 ]

127 return (mkExpr start end)

121 return (mkExpr start end)

@@ -202,7 +196,7 @@ expr =

202

196

203binaryExpr :: IParser Source.Expr

197binaryExpr :: IParser Source.Expr

204binaryExpr =

198binaryExpr =

205− Binop.binops appExpr lastExpr anyOp

199+ Binop.binops appExpr lastExpr

206 where

200 where

207 lastExpr =

201 lastExpr =

208 addLocation (choice [ letExpr, caseExpr, ifExpr ])

202 addLocation (choice [ letExpr, caseExpr, ifExpr ])

@@ -272,8 +266,7 @@ letExpr :: IParser Source.Expr'

272letExpr =

266letExpr =

273 do try (reserved "let")

267 do try (reserved "let")

274 whitespace

268 whitespace

275− defs <-

276− Indent.block (def <* whitespace)

269+ defs <- Indent.block (def <* whitespace)

277 whitespace

270 whitespace

278 reserved "in"

271 reserved "in"

279 whitespace

272 whitespace

@@ -282,49 +275,44 @@ letExpr =

282

275

283def :: IParser Source.Def

276def :: IParser Source.Def

284def =

277def =

278+ addLocation $ Indent.withPos $

279+ do start <- defStart

280+ whitespace

281+ case start of

282+ A.A _ (P.Var name) ->

283+ choice

284+ [ do hasType

285+ whitespace

286+ tipe <- Type.expr

287+ return $ Source.Annotation name tipe

288+ , defEnd start []

289+ ]

290+

291+ _ ->

292+ defEnd start []

293+

294+

295+defStart :: IParser P.Raw

296+defStart =

285 choice

297 choice

286− [ annotation Source.Annotation

298+ [ addLocation (try (P.Var <$> parens Binop.infixOp))

287− , definition Source.Definition

299+ , Pattern.term

288 ]

300 ]

289

301

290

302

291−

303+defEnd :: P.Raw -> [P.Raw] -> IParser Source.Def'

292−-- TYPE ANNOTATION

304+defEnd start revArgs =

293−

305+ choice

294−

306+ [ do arg <- Pattern.term

295−annotation :: (String -> T.Raw -> a) -> IParser (A.Located a)

307+ whitespace

296−annotation creator =

308+ defEnd start (arg : revArgs)

297− let

298− start =

299− do v <- lowVar <|> parens symOp

300− padded hasType

301− return v

302− in

303− addLocation (creator <$> try start <*> Type.expr)

304−

305−

306−

307−-- DEFINITION

308−

309−

310−definition :: (P.Raw -> Source.Expr -> a) -> IParser (A.Located a)

311−definition creator =

312− addLocation $

313− Indent.withPos $

314− do (name, args) <- defStart

315− padded equals

309+ , do equals

310+ whitespace

316− body <- expr

311+ body <- expr

317− return . creator name $ makeFunction args body

312+ return $ Source.Definition start (makeFunction revArgs body)

313+ ]

318

314

319

315

320makeFunction :: [P.Raw] -> Source.Expr -> Source.Expr

316makeFunction :: [P.Raw] -> Source.Expr -> Source.Expr

321−makeFunction args body@(A.A ann _) =

317+makeFunction revArgs body@(A.A ann _) =

322− foldr (\arg body' -> A.A ann $ E.Lambda arg body') body args

318+ List.foldl' (\expr arg -> A.A ann $ E.Lambda arg expr) body revArgs

323−

324−

325−defStart :: IParser (P.Raw, [P.Raw])

326−defStart =

327− expecting "the definition of a value (x = ...)" $

328− do starter <- try Pattern.term <|> addLocation (P.Var <$> parens symOp)

329− args <- spacePrefix Pattern.term

330− return (starter, args)

src/Parse/Helpers.hs+113−74

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

1module Parse.Helpers where

2

3import Prelude hiding (until)

4−import Control.Monad (guard, join)

4+import Control.Monad (join)

5import Control.Monad.State (State)

6import Data.Char (isUpper)

7import qualified Data.Map as Map

@@ -14,7 +14,6 @@ import qualified Text.Parsec.Token as T

14import qualified AST.Declaration as Decl

15import qualified AST.Expression.General as E

16import qualified AST.Expression.Source as Source

17−import qualified AST.Helpers as Help

18import qualified AST.Literal as L

17import qualified AST.Literal as L

19import qualified AST.Variable as Variable

18import qualified AST.Variable as Variable

20import qualified Reporting.Annotation as A

19import qualified Reporting.Annotation as A

@@ -22,6 +21,7 @@ import qualified Reporting.Error.Syntax as Syntax

22import qualified Reporting.Region as R

21import qualified Reporting.Region as R

23

22

24

23

24+

25reserveds :: [String]

26reserveds =

27 [ "if", "then", "else"

@@ -35,13 +35,17 @@ reserveds =

35 ]

36

37

38+

38-- ERROR HELP

39-- ERROR HELP

39

40

41+

40expecting = flip (<?>)

42expecting = flip (<?>)

41

43

42

44

45+

43-- SETUP

46-- SETUP

44

47

48+

45type OpTable = Map.Map String (Int, Decl.Assoc)

49type OpTable = Map.Map String (Int, Decl.Assoc)

46type SourceM = State SourcePos

50type SourceM = State SourcePos

47type IParser a = ParsecT String OpTable SourceM a

51type IParser a = ParsecT String OpTable SourceM a

@@ -86,45 +90,38 @@ rLabel = lowVar

86

90

87innerVarChar :: IParser Char

91innerVarChar :: IParser Char

88innerVarChar =

92innerVarChar =

89− alphaNum <|> char '_' <|> char '\'' <?> "more letters in this name"

93+ alphaNum <|> char '_' <?> "more letters in this name"

90

94

91

95

92makeVar :: IParser Char -> IParser String

96makeVar :: IParser Char -> IParser String

93makeVar firstChar =

97makeVar firstChar =

94 do variable <- (:) <$> firstChar <*> many innerVarChar

98 do variable <- (:) <$> firstChar <*> many innerVarChar

99+ choice

100+ [ do lookAhead (char '\'')

101+ failure (Syntax.prime variable)

95− if variable `elem` reserveds

102+ , if variable `elem` reserveds then

96− then fail (Syntax.keyword variable)

103+ failure (Syntax.keyword variable)

104+ else

97− else return variable

105+ return variable

106+ ]

98

107

99

108

100reserved :: String -> IParser String

109reserved :: String -> IParser String

101reserved word =

110reserved word =

102 expecting ("reserved word `" ++ word ++ "`") $

111 expecting ("reserved word `" ++ word ++ "`") $

103 do string word

112 do string word

113+ choice

114+ [ do lookAhead (char '\'')

115+ failure (Syntax.prime word)

104− notFollowedBy innerVarChar

116+ , do notFollowedBy innerVarChar

105− return word

117+ return word

106−

118+ ]

107

119

108−-- INFIX OPERATORS

109−

110−anyOp :: IParser String

111−anyOp =

112− betwixt '`' '`' qualifiedVar

113− <|> symOp

114− <?> "an infix operator like (+)"

115−

116−

117−symOp :: IParser String

118−symOp =

119− do op <- many1 (satisfy (\c -> Help.isSymbol c && c /= '`'))

120− guard (op `notElem` [ "=", "..", "->", "--", "|", ":" ])

121− case op of

122− "." -> notFollowedBy lower >> return op

123− _ -> return op

124

120

125

121

126-- COMMON SYMBOLS

122-- COMMON SYMBOLS

127

123

124+

128equals :: IParser String

125equals :: IParser String

129equals =

126equals =

130 string "=" <?> "an equals sign '='"

127 string "=" <?> "an equals sign '='"

@@ -147,8 +144,10 @@ commitIf check p =

147 try (lookAhead check) >> p

144 try (lookAhead check) >> p

148

145

149

146

147+

150-- SEPARATORS

148-- SEPARATORS

151

149

150+

152spaceySepBy1 :: IParser b -> IParser a -> IParser [a]

151spaceySepBy1 :: IParser b -> IParser a -> IParser [a]

153spaceySepBy1 sep parser =

152spaceySepBy1 sep parser =

154 do value <- parser

153 do value <- parser

@@ -216,8 +215,10 @@ constrainedSpacePrefix parser constraint =

216 indented

215 indented

217

216

218

217

218+

219-- SURROUNDED BY

220

221+

221followedBy a b =

222followedBy a b =

222 do x <- a

223 do x <- a

223 b

224 b

@@ -255,8 +256,10 @@ brackets =

255 surround '{' '}' "bracket"

256 surround '{' '}' "bracket"

256

257

258

259+

258-- HELPERS FOR EXPRESSIONS

260-- HELPERS FOR EXPRESSIONS

259

261

262+

260getMyPosition :: IParser R.Position

263getMyPosition :: IParser R.Position

261getMyPosition =

264getMyPosition =

262 R.fromSourcePos <$> getPosition

265 R.fromSourcePos <$> getPosition

@@ -307,8 +310,10 @@ dot =

307 notFollowedBy (char '.')

310 notFollowedBy (char '.')

308

311

309

312

313+

310-- WHITESPACE

314-- WHITESPACE

311

315

316+

312padded :: IParser a -> IParser a

317padded :: IParser a -> IParser a

313padded p =

318padded p =

314 do whitespace

319 do whitespace

@@ -417,8 +422,10 @@ closeComment =

417 ]

422 ]

418

423

419

424

425+

420-- ODD COMBINATORS

426-- ODD COMBINATORS

421

427

428+

422failure msg = do

429failure msg = do

423 inp <- getInput

430 inp <- getInput

424 setInput ('x':inp)

431 setInput ('x':inp)

@@ -492,7 +499,9 @@ anyUntilPos pos =

492 else (:) <$> anyChar <*> anyUntilPos pos

499 else (:) <$> anyChar <*> anyUntilPos pos

493

500

494

501

495−-- BASIC LANGUAGE LITERALS

502+

503+-- SHADERS

504+

496

505

497shader :: IParser (String, L.GLShaderTipe)

506shader :: IParser (String, L.GLShaderTipe)

498shader =

507shader =

@@ -565,38 +574,84 @@ glSource src =

565 _ -> []

574 _ -> []

566

575

567

576

577+

578+-- STRINGS AND CHARACTERS

579+

580+

568str :: IParser String

581str :: IParser String

569str =

582str =

570− expecting "a string" $

583+ expecting "a string like \"hello\"" $

571− do s <- choice [ multiStr, singleStr ]

584+ do charSeq <- choice [ multiStr, singleStr ]

585+ either (fail . show) return $

572− processAs T.stringLiteral . sandwich '\"' $ concat s

586+ processAs T.stringLiteral ('"' : charSeq ++ "\"")

573− where

587+

574− rawString quote insides =

575− quote >> manyTill insides quote

576

588

577− multiStr = rawString (try (string "\"\"\"")) multilineStringChar

589+delimitedSequence :: IParser a -> IParser String -> IParser String

578− singleStr = rawString (char '"') stringChar

590+delimitedSequence quote insides =

591+ do quote

592+ concat <$> manyTill insides quote

579

593

580− stringChar :: IParser String

581− stringChar = choice [ newlineChar, escaped '\"', (:[]) <$> satisfy (/= '\"') ]

582

594

583− multilineStringChar :: IParser String

595+multiStr :: IParser String

584− multilineStringChar =

596+multiStr =

585− do noEnd

597+ delimitedSequence (try (string "\"\"\"")) multilineStringChar

586− choice [ newlineChar, escaped '\"', expandQuote <$> anyChar ]

587− where

588− noEnd = notFollowedBy (string "\"\"\"")

589− expandQuote c = if c == '\"' then "\\\"" else [c]

590

598

591− newlineChar :: IParser String

592− newlineChar =

593− choice [ char '\n' >> return "\\n"

594− , char '\r' >> return "\\r" ]

595

599

600+singleStr :: IParser String

601+singleStr =

602+ delimitedSequence (char '"') (charWithin '"')

596

603

597−sandwich :: Char -> String -> String

604+

598−sandwich delim s =

605+chr :: IParser Char

606+chr =

607+ expecting "a character like 'x'" $

608+ do char '\''

609+ charSeq <- concat <$> many1 (charWithin '\'') <?> "a character"

610+ case processAs T.charLiteral ("'" ++ charSeq ++ "'") of

611+ Right character ->

612+ do char '\''

613+ return character

614+

615+ Left _ ->

616+ failure $

617+ "Elm uses double quotes for strings. Switch\

618+ \ the ' to \" on both ends of the string and\

619+ \ you should be all set!"

620+

621+

622+

623+-- CHARACTER HELPERS

624+

625+

626+charWithin :: Char -> IParser String

627+charWithin delim =

628+ choice

599− delim : s ++ [delim]

629+ [ escaped delim

630+ , (:[]) <$> satisfy (/= delim)

631+ ]

632+

633+

634+multilineStringChar :: IParser String

635+multilineStringChar =

636+ do notFollowedBy (string "\"\"\"")

637+ choice

638+ [ newlineChar

639+ , escaped '\"'

640+ , escapeQuotes <$> anyChar

641+ ]

642+

643+

644+escapeQuotes :: Char -> String

645+escapeQuotes c =

646+ if c == '\"' then "\\\"" else [c]

647+

648+

649+newlineChar :: IParser String

650+newlineChar =

651+ choice

652+ [ char '\n' >> return "\\n"

653+ , char '\r' >> return "\\r"

654+ ]

600

655

601

656

602escaped :: Char -> IParser String

657escaped :: Char -> IParser String

@@ -607,32 +662,16 @@ escaped delim =

607 return ['\\', c]

662 return ['\\', c]

608

663

609

664

610−chr :: IParser Char

665+processAs

611−chr =

612− betwixt '\'' '\'' character <?> "a character"

613− where

614− nonQuote = satisfy (/='\'')

615−

616− character =

617− do c <- choice

618− [ escaped '\''

619− , (:) <$> char '\\' <*> many1 nonQuote

620− , (:[]) <$> nonQuote

621− ]

622−

623− processAs T.charLiteral $ sandwich '\'' c

624−

625−

626−processAs :: (T.GenTokenParser String u SourceM -> IParser a) -> String -> IParser a

666+ :: (T.GenTokenParser String u SourceM -> IParser a)

667+ -> String

668+ -> Either ParseError a

627−processAs processor s =

669+processAs processor string =

628− calloutParser s (processor lexer)

670+ iParse (processor lexer) string

629 where

671 where

630− calloutParser :: String -> IParser a -> IParser a

631− calloutParser inp p =

632− either (fail . show) return (iParse p inp)

633−

634 lexer :: T.GenTokenParser String u SourceM

672 lexer :: T.GenTokenParser String u SourceM

673+ lexer =

635− lexer = T.makeTokenParser elmDef

674+ T.makeTokenParser elmDef

636

675

637 -- I don't know how many of these are necessary for charLiteral/stringLiteral

676 -- I don't know how many of these are necessary for charLiteral/stringLiteral

638 elmDef :: T.GenLanguageDef String u SourceM

677 elmDef :: T.GenLanguageDef String u SourceM

src/Parse/Module.hs+2−1

@@ -3,6 +3,7 @@ module Parse.Module (moduleDecl, header, getModuleName) where

3

4import Text.Parsec hiding (newline, spaces)

5

6+import Parse.Binop (infixOp)

6import Parse.Helpers

7import Parse.Helpers

7import qualified AST.Module as Module

8import qualified AST.Module as Module

8import qualified AST.Module.Name as ModuleName

9import qualified AST.Module.Name as ModuleName

@@ -168,7 +169,7 @@ value =

168 val <|> tipe <?> "a value or type to expose"

169 val <|> tipe <?> "a value or type to expose"

169 where

170 where

170 val =

171 val =

171− Var.Value <$> (lowVar <|> parens symOp)

172+ Var.Value <$> (lowVar <|> parens infixOp)

172

173

173 tipe =

174 tipe =

174 do name <- capVar

175 do name <- capVar

src/Reporting/Error/Canonicalize.hs+73

@@ -5,7 +5,9 @@ import Control.Arrow (second)

5import qualified Data.Char as Char

6import Text.PrettyPrint.ANSI.Leijen (indent, text)

7

8+import qualified AST.Expression.Canonical as Canonical

8import qualified AST.Module.Name as ModuleName

9import qualified AST.Module.Name as ModuleName

10+import qualified AST.Pattern as P

9import qualified AST.Type as Type

11import qualified AST.Type as Type

10import qualified AST.Variable as Var

12import qualified AST.Variable as Var

11import qualified Reporting.Annotation as A

13import qualified Reporting.Annotation as A

@@ -17,6 +19,7 @@ import qualified Reporting.Report as Report

17

19

18data Error

20data Error

19 = Var VarError

21 = Var VarError

22+ | BadRecursion Region.Region Canonical.Def [Canonical.Def]

20 | Pattern PatternError

23 | Pattern PatternError

21 | Alias AliasError

24 | Alias AliasError

22 | Import ModuleName.Raw ImportError

25 | Import ModuleName.Raw ImportError

@@ -154,6 +157,15 @@ toReport localizer err =

154 ("Cannot find " ++ var)

157 ("Cannot find " ++ var)

155 (Help.maybeYouWant suggestions)

158 (Help.maybeYouWant suggestions)

156

159

160+ BadRecursion region def defs ->

161+ case defs of

162+ [] ->

163+ badSelfRecursion region (defToString def)

164+

165+ _ ->

166+ badMutualRecursion region (defToString def) (map (defToString) defs)

167+

168+

157 Pattern patternError ->

169 Pattern patternError ->

158 case patternError of

170 case patternError of

159 PatternArgMismatch var expected actual ->

171 PatternArgMismatch var expected actual ->

@@ -281,6 +293,9 @@ extractSuggestions err =

281 Var (VarError _ _ _ suggestions) ->

293 Var (VarError _ _ _ suggestions) ->

282 Just suggestions

294 Just suggestions

283

295

296+ BadRecursion _ _ _ ->

297+ Nothing

298+

284 Pattern _ ->

299 Pattern _ ->

285 Nothing

300 Nothing

286

301

@@ -326,3 +341,61 @@ unsafePromote (A.A _ rawType) =

326 Type.RRecord fields ext ->

341 Type.RRecord fields ext ->

327 Type.Record (map (second unsafePromote) fields) (fmap unsafePromote ext)

342 Type.Record (map (second unsafePromote) fields) (fmap unsafePromote ext)

328

343

344+

345+

346+-- BAD RECURSION

347+

348+

349+badSelfRecursion :: Region.Region -> String -> Report.Report

350+badSelfRecursion region name =

351+ let

352+ header =

353+ Help.functionName name ++ " is defined diretly in terms of itself, causing an infinite loop."

354+ in

355+ Report.report "BAD RECURSION" (Just region) header $

356+ Help.stack

357+ [ Help.reflowParagraph $

358+ "To define " ++ Help.functionName name ++ " we need to know what "

359+ ++ Help.functionName name ++ " is, so let’s just expand that!\

360+ \ Wait, but now we need to know what " ++ Help.functionName name

361+ ++ " is, so let’s expand that..."

362+ , Help.reflowParagraph $

363+ "Check out the following links for more info on this situation and how to fix it: "

364+ ++ Help.hintLink "bad-recursion"

365+ ++ " <http://package.elm-lang.org/packages/elm-lang/core/latest/Json-Decode#lazy>"

366+ ]

367+

368+

369+badMutualRecursion :: Region.Region -> String -> [String] -> Report.Report

370+badMutualRecursion region name names =

371+ let

372+ header =

373+ Help.functionName name ++ " is defined in terms of itself in a sneaky way, causing an infinite loop."

374+

375+ otherDefs =

376+ if length names == 1 then

377+ "one other definition"

378+ else

379+ show (length names) ++ " other definitions"

380+ in

381+ Report.report "BAD RECURSION" (Just region) header $

382+ Help.stack

383+ [ Help.reflowParagraph $

384+ "The following definitions depend directly on each other:"

385+ , indent 4 $ Help.drawCycle (name : names)

386+ , Help.reflowParagraph $

387+ "So to define " ++ Help.functionName name

388+ ++ " we go through " ++ otherDefs ++ " before needing to know what "

389+ ++ Help.functionName name

390+ ++ " is. We can expand it again, but then we need to know what "

391+ ++ Help.functionName name ++ " is... This will keep going infinitely!"

392+ , Help.reflowParagraph $

393+ "Check out the following links for more info on this situation and how to fix it: "

394+ ++ Help.hintLink "bad-recursion"

395+ ++ " <http://package.elm-lang.org/packages/elm-lang/core/latest/Json-Decode#lazy>"

396+ ]

397+

398+

399+defToString :: Canonical.Def -> String

400+defToString (Canonical.Def _ pattern _ _) =

401+ P.toString False pattern

src/Reporting/Error/Helpers.hs+16−5

@@ -1,9 +1,10 @@

1{-# OPTIONS_GHC -Wall #-}

2module Reporting.Error.Helpers

3 ( (|>)

4+ , functionName, args

4− , functionName, hintLink, stack, reflowParagraph

5+ , hintLink, stack, reflowParagraph

5 , commaSep, capitalize, ordinalize, drawCycle

6 , commaSep, capitalize, ordinalize, drawCycle

6− , findPotentialTypos, vetTypos

7+ , findPotentialTypos, findTypoPairs, vetTypos

7 , nearbyNames, distance, maybeYouWant

8 , nearbyNames, distance, maybeYouWant

8 )

9 )

9 where

10 where

@@ -47,6 +48,11 @@ functionName opName =

47 "`" ++ opName ++ "`"

48 "`" ++ opName ++ "`"

48

49

50

51+args :: Int -> String

52+args n =

53+ show n ++ if n == 1 then " argument" else " arguments"

54+

55+

50hintLink :: String -> String

56hintLink :: String -> String

51hintLink fileName =

57hintLink fileName =

52 "<https://github.com/elm-lang/elm-compiler/blob/"

58 "<https://github.com/elm-lang/elm-compiler/blob/"

@@ -132,11 +138,16 @@ drawCycle strings =

132-- FIND TYPOS

138-- FIND TYPOS

133

139

134

140

135−findPotentialTypos :: [String] -> [String] -> [(String, String)]

141+findPotentialTypos :: [String] -> String -> [String]

142+findPotentialTypos knownNames badName =

143+ filter ((==1) . distance badName) knownNames

144+

145+

146+findTypoPairs :: [String] -> [String] -> [(String, String)]

136−findPotentialTypos leftOnly rightOnly =

147+findTypoPairs leftOnly rightOnly =

137 let

148 let

138 veryNear leftName =

149 veryNear leftName =

139− map ((,) leftName) (filter ((==1) . distance leftName) rightOnly)

150+ map ((,) leftName) (findPotentialTypos rightOnly leftName)

140 in

151 in

141 concatMap veryNear leftOnly

152 concatMap veryNear leftOnly

142

153

src/Reporting/Error/Syntax.hs+16

@@ -328,8 +328,14 @@ keyword kwd =

328 "KEYWORD=" ++ kwd

329

330

331+prime :: String -> String

332+prime var =

333+ "PRIME=" ++ var

334+

335+

331data SpecialMessage

336data SpecialMessage

332 = MsgKeyword String

337 = MsgKeyword String

338+ | MsgPrime String

333 | MsgTab

339 | MsgTab

334

340

335

341

@@ -338,6 +344,9 @@ extractSpecialMessage message =

338 if List.isPrefixOf "KEYWORD=" message then

344 if List.isPrefixOf "KEYWORD=" message then

339 Just $ MsgKeyword (drop (length "KEYWORD=") message)

345 Just $ MsgKeyword (drop (length "KEYWORD=") message)

340

346

347+ else if List.isPrefixOf "PRIME=" message then

348+ Just $ MsgPrime (drop (length "PRIME=") message)

349+

341 else if tab == message then

350 else if tab == message then

342 Just MsgTab

351 Just MsgTab

343

352

@@ -388,6 +397,13 @@ parseErrorReport messages =

388 , Just "Rename it to something else."

397 , Just "Rename it to something else."

389 )

398 )

390

399

400+ Just (MsgPrime var) ->

401+ ( "Ran into a single quote in a variable name. This was removed in 0.18!"

402+ , Just $

403+ "Change it to a number or an underscore, like " ++ var ++ "_ or " ++ var

404+ ++ "1\n\nOr better yet, choose a more descriptive name!"

405+ )

406+

391 Just MsgTab ->

407 Just MsgTab ->

392 ( "A tab character was found, but all whitespace (including indentation) must be spaces not tabs."

408 ( "A tab character was found, but all whitespace (including indentation) must be spaces not tabs."

393 , Just "I am looking for spaces, not tabs."

409 , Just "I am looking for spaces, not tabs."

src/Reporting/Error/Type.hs+317−85

@@ -1,11 +1,13 @@

1{-# OPTIONS_GHC -Wall #-}

2module Reporting.Error.Type where

3

4+import Control.Arrow (first, second)

5+import qualified Data.List as List

4import qualified Data.Map as Map

6import qualified Data.Map as Map

5import qualified Data.Maybe as Maybe

7import qualified Data.Maybe as Maybe

6import Text.PrettyPrint.ANSI.Leijen

8import Text.PrettyPrint.ANSI.Leijen

7 ( Doc, (<>), (<+>), colon, dullyellow

9 ( Doc, (<>), (<+>), colon, dullyellow

8− , fillSep, hang, indent, text, underline, vcat

10+ , fillSep, indent, text, underline, vcat

9 )

11 )

10

12

11import qualified AST.Type as Type

13import qualified AST.Type as Type

@@ -36,9 +38,11 @@ data Mismatch = MismatchInfo

36

38

37

39

38data Reason

40data Reason

41+ = BadFields [(String, Maybe Reason)]

39− = MessyFields [String] [String]

42+ | MessyFields [String] [String] [String]

40 | IntFloat

43 | IntFloat

41 | TooLongComparableTuple Int

44 | TooLongComparableTuple Int

45+ | MissingArgs Int

42 | BadVar (Maybe VarType) (Maybe VarType)

46 | BadVar (Maybe VarType) (Maybe VarType)

43

47

44

48

@@ -65,13 +69,13 @@ data Hint

65 | Function (Maybe Var.Canonical)

69 | Function (Maybe Var.Canonical)

66 | UnexpectedArg (Maybe Var.Canonical) Int Int Region.Region

70 | UnexpectedArg (Maybe Var.Canonical) Int Int Region.Region

67 | FunctionArity (Maybe Var.Canonical) Int Int Region.Region

71 | FunctionArity (Maybe Var.Canonical) Int Int Region.Region

68− | BadTypeAnnotation String

72+ | ReturnType String Int Int Region.Region

69 | Instance String

73 | Instance String

70 | Literal String

74 | Literal String

71 | Pattern Pattern

75 | Pattern Pattern

72 | Shader

76 | Shader

73− | Range

74 | Lambda

77 | Lambda

78+ | Access (Maybe String) String

75 | Record

79 | Record

76 -- effect manager problems

80 -- effect manager problems

77 | Manager String

81 | Manager String

@@ -142,11 +146,12 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =

142 report =

146 report =

143 Report.report "TYPE MISMATCH"

147 Report.report "TYPE MISMATCH"

144

148

149+ typicalHints =

150+ Maybe.maybeToList (reasonToString =<< maybeReason)

151+

145 cmpHint leftWords rightWords extraHints =

152 cmpHint leftWords rightWords extraHints =

146 comparisonHint localizer leftType rightType leftWords rightWords

153 comparisonHint localizer leftType rightType leftWords rightWords

147− ( Maybe.maybeToList (reasonToString =<< maybeReason)

148− ++ map toHint extraHints

154+ (typicalHints ++ map toHint extraHints)

149− )

150 in

155 in

151 case hint of

156 case hint of

152 CaseBranch branchNumber region ->

157 CaseBranch branchNumber region ->

@@ -227,12 +232,14 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =

227 ListElement elementNumber region ->

232 ListElement elementNumber region ->

228 report

233 report

229 (Just region)

234 (Just region)

230− ("The " ++ ordinalPair elementNumber ++ " elements are different types of values.")

235+ ("The " ++ ordinalPair elementNumber ++ " entries in this list are different types of values.")

231 ( cmpHint

236 ( cmpHint

232− ("The " ++ Help.ordinalize (elementNumber - 1) ++ " element has this type:")

237+ ("The " ++ Help.ordinalize (elementNumber - 1) ++ " entry has this type:")

233 ("But the "++ Help.ordinalize elementNumber ++ " is:")

238 ("But the "++ Help.ordinalize elementNumber ++ " is:")

234− [ "All elements should be the same type of value so that we can\

239+ [ "Every entry in a list needs to be the same type of value.\

235− \ iterate through the list without running into unexpected values."

240+ \ This way you never run into unexpected values partway through.\

241+ \ To mix different types in a single list, create a \"union type\" as\

242+ \ described in: <http://guide.elm-lang.org/types/union_types.html>"

236 ]

243 ]

237 )

244 )

238

245

@@ -261,14 +268,14 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =

261 BinopRight op region ->

268 BinopRight op region ->

262 report

269 report

263 (Just region)

270 (Just region)

264− ("The right argument of " ++ prettyName op ++ " is causing a type mismatch.")

271+ ("The right side of " ++ prettyName op ++ " is causing a type mismatch.")

265 ( cmpHint

272 ( cmpHint

266− (prettyName op ++ " is expecting the right argument to be a:")

273+ (prettyName op ++ " is expecting the right side to be a:")

267− "But the right argument is:"

274+ "But the right side is:"

268 ( binopHint op leftType rightType

275 ( binopHint op leftType rightType

269 ++

276 ++

270− [ "I always figure out the type of the left argument first and if it is\

277+ [ "With binary operations, I always figure out the left side first. If it\

271− \ acceptable on its own, I assume it is \"correct\" in subsequent checks.\

278+ \ seems fine, I assume it is \"correct\" in subsequent checks.\

272 \ So the problem may actually be in how the left and right arguments interact."

279 \ So the problem may actually be in how the left and right arguments interact."

273 ]

280 ]

274 )

281 )

@@ -301,7 +308,7 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =

301 UnexpectedArg maybeName 1 1 region ->

308 UnexpectedArg maybeName 1 1 region ->

302 report

309 report

303 (Just region)

310 (Just region)

304− ("The argument to " ++ funcName maybeName ++ " is causing a mismatch.")

311+ ("The argument to " ++ funcName maybeName ++ " is causing a mismatch.")

305 ( cmpHint

312 ( cmpHint

306 (Help.capitalize (funcName maybeName) ++ " is expecting the argument to be:")

313 (Help.capitalize (funcName maybeName) ++ " is expecting the argument to be:")

307 "But it is:"

314 "But it is:"

@@ -351,24 +358,34 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =

351 (text "Maybe you forgot some parentheses? Or a comma?")

358 (text "Maybe you forgot some parentheses? Or a comma?")

352

359

353 FunctionArity maybeName expected actual region ->

360 FunctionArity maybeName expected actual region ->

354− let

355− s = if expected == 1 then "" else "s"

356− in

357− report

361+ report

358− (Just region)

362+ (Just region)

359− ( Help.capitalize (funcName maybeName) ++ " is expecting " ++ show expected

363+ ( Help.capitalize (funcName maybeName) ++ " is expecting "

360− ++ " argument" ++ s ++ ", but was given " ++ show actual ++ "."

364+ ++ Help.args expected ++ ", but was given " ++ show actual ++ "."

361− )

365+ )

362− (text "Maybe you forgot some parentheses? Or a comma?")

366+ (text "Maybe you forgot some parentheses? Or a comma?")

363

367

364− BadTypeAnnotation name ->

368+ ReturnType name typeArity argArity region ->

369+ if typeArity == 0 || argArity == 0 then

365 report

370 report

366− Nothing

371+ (Just region)

367− ("The implementation of " ++ Help.functionName name ++ " does not match its type annotation.")

372+ ("The definition of " ++ Help.functionName name ++ " does not match its type annotation.")

368 ( cmpHint

373 ( cmpHint

369− "The type annotation is saying:"

374+ ( "The type annotation for " ++ Help.functionName name ++ " says it is a:"

370− "But I am inferring that the definition has this type:"

375+ )

371− []

376+ "But the definition (shown above) is a:"

377+ (arityHint typeArity argArity)

378+ )

379+

380+ else

381+ report

382+ (Just region)

383+ ("The definition of " ++ Help.functionName name ++ " does not match its type annotation.")

384+ ( cmpHint

385+ ( "The type annotation for " ++ Help.functionName name ++ " says it always returns:"

386+ )

387+ "But the returned value (shown above) is a:"

388+ (arityHint typeArity argArity)

372 )

389 )

373

390

374 Instance name ->

391 Instance name ->

@@ -421,16 +438,6 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =

421 []

438 []

422 )

439 )

423

440

424− Range ->

425− report

426− Nothing

427− "The low and high members of this list range are not the same type of value."

428− ( cmpHint

429− "The low end of the range has type:"

430− "But the high end is:"

431− []

432− )

433−

434 Lambda ->

441 Lambda ->

435 report

442 report

436 Nothing

443 Nothing

@@ -441,6 +448,30 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =

441 []

448 []

442 )

449 )

443

450

451+ Access (Just body) field ->

452+ let

453+ header =

454+ "`" ++ body ++ "` does not have a field named `" ++ field ++ "`."

455+ in

456+ report Nothing header $ Help.stack $

457+ [ Help.reflowParagraph $ "The type of `" ++ body ++ "` is:"

458+ , indent 4 $ dullyellow $ RenderType.toDoc localizer leftType

459+ , Help.reflowParagraph $ "Which does not contain a field named `" ++ field ++ "`."

460+ ]

461+ ++ typicalHints

462+

463+ Access Nothing field ->

464+ let

465+ header =

466+ "Cannot access a field named `" ++ field ++ "`."

467+ in

468+ report Nothing header $ Help.stack $

469+ [ Help.reflowParagraph $ "You are trying to get `" ++ field ++ "` from a value with this type:"

470+ , indent 4 $ dullyellow $ RenderType.toDoc localizer leftType

471+ , Help.reflowParagraph $ "It is not in there!"

472+ ]

473+ ++ typicalHints

474+

444 Record ->

475 Record ->

445 report

476 report

446 Nothing

477 Nothing

@@ -563,6 +594,36 @@ functionHint maybeName =

563

594

564

595

565

596

597+-- ARITY HINTS

598+

599+

600+arityHint :: Int -> Int -> [String]

601+arityHint typeArity argArity =

602+ if typeArity == argArity then

603+ []

604+

605+ else

606+ [ "The type annotation says there " ++ sayArgs typeArity

607+ ++ ", but there " ++ sayArgs argArity ++ " named in the definition."

608+ ++ " It is best practice for each argument in the type to correspond"

609+ ++ " to a named argument in the definition, so try that first!"

610+ ]

611+

612+

613+sayArgs :: Int -> String

614+sayArgs n =

615+ case n of

616+ 0 ->

617+ "are NO arguments"

618+

619+ 1 ->

620+ "is 1 argument"

621+

622+ _ ->

623+ "are " ++ show n ++ " arguments"

624+

625+

626+

566-- MISMATCH HELPERS

627-- MISMATCH HELPERS

567

628

568

629

@@ -593,8 +654,11 @@ funcName maybeVar =

593flipReason :: Reason -> Reason

654flipReason :: Reason -> Reason

594flipReason reason =

655flipReason reason =

595 case reason of

656 case reason of

657+ BadFields fields ->

658+ BadFields (map (second (fmap flipReason)) fields)

659+

596− MessyFields leftOnly rightOnly ->

660+ MessyFields both left right ->

597− MessyFields rightOnly leftOnly

661+ MessyFields both right left

598

662

599 IntFloat ->

663 IntFloat ->

600 IntFloat

664 IntFloat

@@ -602,24 +666,78 @@ flipReason reason =

602 TooLongComparableTuple len ->

666 TooLongComparableTuple len ->

603 TooLongComparableTuple len

667 TooLongComparableTuple len

604

668

669+ MissingArgs num ->

670+ MissingArgs num

671+

605 BadVar left right ->

672 BadVar left right ->

606 BadVar right left

673 BadVar right left

607

674

608

675

609reasonToString :: Reason -> Maybe Doc

676reasonToString :: Reason -> Maybe Doc

610reasonToString reason =

677reasonToString reason =

678+ let

679+ (fields, maybeDeepReason) =

680+ collectFields reason

681+

682+ maybeDocs =

683+ reasonToStringHelp =<< maybeDeepReason

684+

685+ starter =

686+ case fields of

687+ [] ->

688+ Nothing

689+

690+ [field] ->

691+ Just $ "Problem in the `" ++ field ++ "` field. "

692+

693+ _ ->

694+ Just $ "Problem at `" ++ List.intercalate "." fields ++ "`. "

695+ in

696+ case (starter, maybeDocs) of

697+ (Nothing, Nothing) ->

698+ Nothing

699+

700+ (Just msg, Nothing) ->

701+ Just $ toHint (msg ++ badFieldElaboration)

702+

703+ (_, Just (firstLine, docs)) ->

704+ Just $ vcat $

705+ toHint (maybe firstLine (++firstLine) starter)

706+ : map (indent 4) docs

707+

708+

709+

710+collectFields :: Reason -> ([String], Maybe Reason)

711+collectFields reason =

712+ case reason of

713+ BadFields [(field, Nothing)] ->

714+ ([field], Nothing)

715+

716+ BadFields [(field, Just subReason)] ->

717+ first (field:) (collectFields subReason)

718+

719+ _ ->

720+ ([], Just reason)

721+

722+

723+reasonToStringHelp :: Reason -> Maybe (String, [Doc])

724+reasonToStringHelp reason =

611 let

725 let

612 go msg =

726 go msg =

613− Just (toHint msg)

727+ Just (msg, [])

614 in

728 in

615 case reason of

729 case reason of

730+ BadFields fields ->

731+ go $

732+ "I am seeing issues with the "

733+ ++ Help.commaSep (map fst fields) ++ " fields. "

734+ ++ badFieldElaboration

735+

616− MessyFields leftOnly rightOnly ->

736+ MessyFields both leftOnly rightOnly ->

617− do let typos = Help.findPotentialTypos leftOnly rightOnly

737+ messyFieldsHelp both leftOnly rightOnly

618− _ <- Help.vetTypos typos

619− misspellingMessage typos

620

738

621 IntFloat ->

739 IntFloat ->

622− go

740+ go $

623 "Elm does not automatically convert between Ints and Floats. Use\

741 "Elm does not automatically convert between Ints and Floats. Use\

624 \ `toFloat` and `round` to do specific conversions.\

742 \ `toFloat` and `round` to do specific conversions.\

625 \ <http://package.elm-lang.org/packages/elm-lang/core/latest/Basics#toFloat>"

743 \ <http://package.elm-lang.org/packages/elm-lang/core/latest/Basics#toFloat>"

@@ -629,6 +747,11 @@ reasonToString reason =

629 "Although tuples are comparable, this is currently only supported\

747 "Although tuples are comparable, this is currently only supported\

630 \ for tuples with 6 or fewer entries, not " ++ show len ++ "."

748 \ for tuples with 6 or fewer entries, not " ++ show len ++ "."

631

749

750+ MissingArgs num ->

751+ go $

752+ "It looks like a function needs " ++ show num ++ " more "

753+ ++ (if num == 1 then "argument" else "arguments") ++ "."

754+

632 BadVar (Just Comparable) _ ->

755 BadVar (Just Comparable) _ ->

633 go "Only ints, floats, chars, strings, lists, and tuples are comparable."

756 go "Only ints, floats, chars, strings, lists, and tuples are comparable."

634

757

@@ -638,31 +761,64 @@ reasonToString reason =

638 BadVar (Just CompAppend) _ ->

761 BadVar (Just CompAppend) _ ->

639 go "Only strings and lists are both comparable and appendable."

762 go "Only strings and lists are both comparable and appendable."

640

763

641− BadVar (Just (Rigid _)) (Just (Rigid _)) ->

764+ BadVar (Just (Rigid maybeLeftName)) (Just (Rigid maybeRightName)) ->

642− go doubleRigidError

765+ go $ doubleRigidError maybeLeftName maybeRightName

643

766

644− BadVar (Just (Rigid _)) _ ->

767+ BadVar (Just (Rigid maybeName)) _ ->

645− go singleRigidError

768+ go $ singleRigidError maybeName

646

769

647− BadVar _ (Just (Rigid _)) ->

770+ BadVar _ (Just (Rigid maybeName)) ->

648− go singleRigidError

771+ go $ singleRigidError maybeName

649

772

650 BadVar _ _ ->

773 BadVar _ _ ->

651 Nothing

774 Nothing

652

775

653

776

654−singleRigidError :: String

777+badFieldElaboration :: String

655−singleRigidError =

778+badFieldElaboration =

656− "A type annotation is too generic. You can probably just switch to the\

779+ "I always figure out field types in alphabetical order. If a field\

657− \ type I inferred. These issues can be subtle though, so read more about it. "

780+ \ seems fine, I assume it is \"correct\" in subsequent checks.\

658− ++ Help.hintLink "type-annotations"

781+ \ So the problem may actually be a weird interaction with previous fields."

659

782

660

783

661−doubleRigidError :: String

784+weirdRigidError :: String

662−doubleRigidError =

785+weirdRigidError =

663− "A type annotation is clashing with itself or with a sub-annotation.\

786+ "You are having a problem with \"rigid\" type variables. That usually\

664− \ This can be particularly tricky, so read more about it. "

787+ \ means you have a type annotation that says it accepts anything, but\

788+ \ in fact, it accepts a much more specific type. More info at: "

789+ ++ Help.hintLink "type-annotations" ++

790+ ". This case is weird though, so please turn it into an <http://sscce.org>\

791+ \ and report it to <https://github.com/elm-lang/error-message-catalog>."

792+

793+

794+singleRigidError :: Maybe String -> String

795+singleRigidError maybeName =

796+ case maybeName of

797+ Just name ->

798+ "Your type annotation uses type variable `" ++ name ++

799+ "` which means any type of value can flow through. Your code is saying\

800+ \ it CANNOT be anything though! Maybe change your type annotation to\

801+ \ be more specific? Maybe the code has a problem? More at: "

802+ ++ Help.hintLink "type-annotations"

803+

804+ Nothing ->

805+ weirdRigidError

806+

807+

808+doubleRigidError :: Maybe String -> Maybe String -> String

809+doubleRigidError maybeLeftName maybeRightName =

810+ case (maybeLeftName, maybeRightName) of

811+ (Just leftName, Just rightName) ->

812+ "Your type annotation uses `" ++ leftName ++ "` and `" ++ rightName ++

813+ "` as separate type variables. Each one can be any type of value,\

814+ \ but because they have separate names, there is no guarantee that they\

815+ \ are equal to each other. Your code seems to be saying they ARE the\

816+ \ same though! Maybe they should be the same in your type annotation?\

817+ \ Maybe your code uses them in a weird way? More at: "

665− ++ Help.hintLink "type-annotations"

818+ ++ Help.hintLink "type-annotations"

819+

820+ _ ->

821+ weirdRigidError

666

822

667

823

668hintDoc :: Doc

824hintDoc :: Doc

@@ -675,28 +831,104 @@ toHint str =

675 fillSep (hintDoc : map text (words str))

831 fillSep (hintDoc : map text (words str))

676

832

677

833

678−misspellingMessage :: [(String,String)] -> Maybe Doc

834+messyFieldsHelp :: [String] -> [String] -> [String] -> Maybe (String, [Doc])

679−misspellingMessage typos =

835+messyFieldsHelp both leftOnly rightOnly =

680− if null typos then

836+ case (leftOnly, rightOnly) of

681− Nothing

837+ ([], [missingField]) ->

838+ oneMissingField both missingField

682

839

683− else

840+ ([missingField], []) ->

841+ oneMissingField both missingField

842+

843+ ([], missingFields) ->

844+ manyMissingFields both missingFields

845+

846+ (missingFields, []) ->

847+ manyMissingFields both missingFields

848+

849+ _ ->

684 let

850 let

685− maxLen =

851+ typoPairs =

686− maximum (map (length . fst) typos)

852+ case Help.findTypoPairs leftOnly rightOnly of

853+ [] ->

854+ Help.findTypoPairs (both ++ leftOnly) (both ++ rightOnly)

855+

856+ pairs ->

857+ pairs

687 in

858 in

859+ if null typoPairs then

860+ Just

861+ ( "The record fields do not match up. One has "

862+ ++ Help.commaSep leftOnly ++ ". The other has "

863+ ++ Help.commaSep rightOnly ++ "."

864+ , []

865+ )

866+

867+ else

868+ Just

869+ ( "The record fields do not match up. Maybe you made one of these typos?"

870+ , typoDocs "<->" typoPairs

871+ )

872+

873+

874+oneMissingField :: [String] -> String -> Maybe (String, [Doc])

875+oneMissingField knownFields missingField =

876+ case Help.findPotentialTypos knownFields missingField of

877+ [] ->

878+ Just

879+ ( "Looks like a record is missing the `" ++ missingField ++ "` field."

880+ , []

881+ )

882+

883+ [typo] ->

884+ Just

885+ ( "Looks like a record is missing the `" ++ missingField

886+ ++ "` field. Maybe it is a typo?"

887+ , typoDocs "->" [(missingField, typo)]

888+ )

889+

890+ typos ->

891+ Just

892+ ( "Looks like a record is missing the `" ++ missingField

893+ ++ "` field. It is close to names like "

894+ ++ Help.commaSep typos ++ " so maybe it is a typo?"

895+ , []

896+ )

897+

898+

899+manyMissingFields :: [String] -> [String] -> Maybe (String, [Doc])

900+manyMissingFields knownFields missingFields =

901+ case Help.findTypoPairs missingFields knownFields of

902+ [] ->

688− Just $ hang 4 $ vcat $

903+ Just

689− toHint "I compared the record fields and found some potential typos."

904+ ( "Looks like a record is missing these fields: "

690− : text ""

905+ ++ Help.commaSep missingFields

691− : map (pad maxLen) typos

906+ , []

692−

907+ )

693−

908+

909+ typoPairs ->

910+ Just

911+ ( "Looks like a record is missing these fields: " ++ Help.commaSep missingFields

912+ ++ ". Potential typos include:"

913+ , typoDocs "->" typoPairs

914+ )

915+

916+

917+typoDocs :: String -> [(String, String)] -> [Doc]

918+typoDocs arrow typoPairs =

919+ let

920+ maxLen =

921+ maximum (map (length . fst) typoPairs)

922+ in

923+ text "" : map (padTypo arrow maxLen) typoPairs

924+

925+

694−pad :: Int -> (String, String) -> Doc

926+padTypo :: String -> Int -> (String, String) -> Doc

695−pad maxLen (leftField, rightField) =

927+padTypo arrow maxLen (missingField, knownField) =

696− text (replicate (maxLen - length leftField) ' ')

928+ text (replicate (maxLen - length missingField) ' ')

697− <> dullyellow (text leftField)

929+ <> dullyellow (text missingField)

698− <+> text "<->"

930+ <+> text arrow

699− <+> dullyellow (text rightField)

931+ <+> dullyellow (text knownField)

700

932

701

933

702

934

src/Reporting/Render/Type.hs+41−24

@@ -169,19 +169,15 @@ diff localizer context leftType rightType =

169 go = diff localizer

170 in

171 case (leftType, rightType) of

172− (Type.Lambda _ _, Type.Lambda _ _) ->

172+ (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->

173− let

173+ docAppHelp localizer context leftName

174− leftParts = Type.collectLambdas leftType

174+ <$> sequenceA (zipWith (go App) (map snd leftArgs) (map snd rightArgs))

175− rightParts = Type.collectLambdas rightType

176− in

177

175

178− if length leftParts /= length rightParts then

176+ (Type.Lambda _ _, _) ->

179− difference

177+ diffLambda localizer context leftType rightType

180− (docLambda context (map (docType localizer Func) leftParts))

181− (docLambda context (map (docType localizer Func) rightParts))

182

178

183− else

179+ (_, Type.Lambda _ _) ->

184− docLambda context <$> sequenceA (zipWith (go Func) leftParts rightParts)

180+ diffLambda localizer context leftType rightType

185

181

186 (Type.Var x, Type.Var y) | x == y ->

182 (Type.Var x, Type.Var y) | x == y ->

187 pure (text x)

183 pure (text x)

@@ -216,16 +212,6 @@ diff localizer context leftType rightType =

216 in

212 in

217 diffRecord localizer leftFields leftExt rightFields rightExt

213 diffRecord localizer leftFields leftExt rightFields rightExt

218

214

219− (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->

220− docAppHelp localizer context leftName

221− <$> sequenceA (zipWith (go App) (map snd leftArgs) (map snd rightArgs))

222−

223− (Type.Aliased _ args real, _) ->

224− go context (Type.dealias args real) rightType

225−

226− (_, Type.Aliased _ args real) ->

227− go context leftType (Type.dealias args real)

228−

229 (_, _) ->

215 (_, _) ->

230 difference

216 difference

231 (docType localizer context leftType)

217 (docType localizer context leftType)

@@ -238,6 +224,37 @@ difference leftDoc rightDoc =

238

224

239

225

240

226

227+-- FUNCTION DIFFS

228+

229+

230+diffLambda :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc

231+diffLambda localizer context leftType rightType =

232+ let

233+ leftArgs = reverse $ Type.collectLambdas leftType

234+ rightArgs = reverse $ Type.collectLambdas rightType

235+

236+ extraToDoc types =

237+ map (dullyellow . docType localizer Func) types

238+

239+ extraLefts = reverse $ extraToDoc $ drop (length rightArgs) leftArgs

240+ extraRights = reverse $ extraToDoc $ drop (length leftArgs) rightArgs

241+

242+ alignedArgDiff =

243+ reverse <$> sequenceA (zipWith (diff localizer Func) leftArgs rightArgs)

244+ in

245+ docLambda context <$>

246+ case (extraLefts, extraRights, alignedArgDiff) of

247+ ([], [], _) ->

248+ alignedArgDiff

249+

250+ (_, _, Same docs) ->

251+ Diff (extraLefts ++ docs) (extraRights ++ docs)

252+

253+ (_, _, Diff lefts rights) ->

254+ Diff (extraLefts ++ lefts) (extraRights ++ rights)

255+

256+

257+

241-- RECORD DIFFS

258-- RECORD DIFFS

242

259

243

260

@@ -304,8 +321,8 @@ unzipDiffs diffPairs =

304analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )

321analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )

305analyzeFields leftOnly rightOnly =

322analyzeFields leftOnly rightOnly =

306 let

323 let

307− potentialTypos =

324+ typoPairs =

308− Help.findPotentialTypos leftOnly rightOnly

325+ Help.findTypoPairs leftOnly rightOnly

309

326

310 mkField func name =

327 mkField func name =

311 ( func (text name), text "..." )

328 ( func (text name), text "..." )

@@ -313,7 +330,7 @@ analyzeFields leftOnly rightOnly =

313 mkFieldWith counts name =

330 mkFieldWith counts name =

314 mkField (if Set.member name counts then dullyellow else id) name

331 mkField (if Set.member name counts then dullyellow else id) name

315 in

332 in

316− case Help.vetTypos potentialTypos of

333+ case Help.vetTypos typoPairs of

317 Just (leftTypos, rightTypos) ->

334 Just (leftTypos, rightTypos) ->

318 ( map (mkFieldWith leftTypos) leftOnly

335 ( map (mkFieldWith leftTypos) leftOnly

319 , map (mkFieldWith rightTypos) rightOnly

336 , map (mkFieldWith rightTypos) rightOnly

src/Type/Constrain/Effects.hs+3−11

@@ -14,11 +14,7 @@ import Type.Type

14 )

15

16

17−constrain

18− :: Env.Environment

19− -> ModuleName.Canonical

17+constrain :: Env.Env -> ModuleName.Canonical -> Effects.Canonical -> IO TypeConstraint

20− -> Effects.Canonical

21− -> IO TypeConstraint

22constrain env moduleName effects =

18constrain env moduleName effects =

23 case effects of

19 case effects of

24 Effects.None ->

20 Effects.None ->

@@ -31,11 +27,7 @@ constrain env moduleName effects =

31 constrainHelp env moduleName info

27 constrainHelp env moduleName info

32

28

33

29

34−constrainHelp

35− :: Env.Environment

36− -> ModuleName.Canonical

30+constrainHelp :: Env.Env -> ModuleName.Canonical -> Effects.Info -> IO TypeConstraint

37− -> Effects.Info

38− -> IO TypeConstraint

39constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =

31constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =

40 let

32 let

41 task t =

33 task t =

@@ -87,7 +79,7 @@ constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =

87

79

88

80

89addEffectArgs

81addEffectArgs

90− :: Env.Environment

82+ :: Env.Env

91 -> ModuleName.Canonical

83 -> ModuleName.Canonical

92 -> Effects.ManagerType

84 -> Effects.ManagerType

93 -> Variable

85 -> Variable

src/Type/Constrain/Expression.hs+96−91

@@ -18,21 +18,12 @@ import qualified Type.Constrain.Effects as Effects

18import qualified Type.Constrain.Literal as Literal

19import qualified Type.Constrain.Pattern as Pattern

20import qualified Type.Environment as Env

21−import qualified Type.Fragment as Fragment

22import Type.Type hiding (Descriptor(..))

21import Type.Type hiding (Descriptor(..))

23

22

24

23

25

24

26−constrain

27− :: Env.Environment

28− -> Canonical.Expr

29− -> Type

30− -> IO TypeConstraint

25+constrain :: Env.Env -> Canonical.Expr -> Type -> IO TypeConstraint

31constrain env annotatedExpr@(A.A region expression) tipe =

26constrain env annotatedExpr@(A.A region expression) tipe =

32− let

33− list t =

34− Env.getType env "List" <| t

35− in

36 case expression of

27 case expression of

37 E.Literal lit ->

28 E.Literal lit ->

38 Literal.constrain env region lit tipe

29 Literal.constrain env region lit tipe

@@ -82,16 +73,6 @@ constrain env annotatedExpr@(A.A region expression) tipe =

82 E.Var var ->

73 E.Var var ->

83 return (CInstance region (V.toString var) tipe)

74 return (CInstance region (V.toString var) tipe)

84

75

85− E.Range lowExpr highExpr ->

86− existsNumber $ \n ->

87− do lowCon <- constrain env lowExpr n

88− highCon <- constrain env highExpr n

89− return $ CAnd

90− [ lowCon

91− , highCon

92− , CEqual Error.Range region (list n) tipe

93− ]

94−

95 E.ExplicitList exprs ->

76 E.ExplicitList exprs ->

96 constrainList env region exprs tipe

77 constrainList env region exprs tipe

97

78

@@ -101,14 +82,11 @@ constrain env annotatedExpr@(A.A region expression) tipe =

101 E.Lambda pattern body ->

82 E.Lambda pattern body ->

102 exists $ \argType ->

83 exists $ \argType ->

103 exists $ \resType ->

84 exists $ \resType ->

104− do fragment <- Pattern.constrain env pattern argType

85+ do (Pattern.Info headers vars cons) <- Pattern.constrain env pattern argType

105 bodyCon <- constrain env body resType

86 bodyCon <- constrain env body resType

106− let con =

87+ return $

107− ex (Fragment.vars fragment)

88+ ex vars (CLet [monoscheme headers] (cons /\ bodyCon))

108− (CLet [monoscheme (Fragment.typeEnv fragment)]

109− (Fragment.typeConstraint fragment /\ bodyCon)

110− )

111− return $ con /\ CEqual Error.Lambda region (argType ==> resType) tipe

89+ /\ CEqual Error.Lambda region (argType ==> resType) tipe

112

90

113 E.App _ _ ->

91 E.App _ _ ->

114 let

92 let

@@ -132,9 +110,14 @@ constrain env annotatedExpr@(A.A region expression) tipe =

132 do c' <- constrain env e x

110 do c' <- constrain env e x

133 return (x ==> t, c /\ c')

111 return (x ==> t, c /\ c')

134

112

135− E.Access expr label ->

113+ E.Access expr field ->

114+ exists $ \recordType ->

136− exists $ \t ->

115+ exists $ \ext ->

116+ do recordCon <- constrain env expr recordType

117+ let maybeBody = E.collectFields expr

137− constrain env expr (record (Map.singleton label tipe) t)

118+ let desiredType = record (Map.singleton field tipe) ext

119+ let fieldCon = CEqual (Error.Access maybeBody field) region recordType desiredType

120+ return $ recordCon /\ fieldCon

138

121

139 E.Update expr fields ->

122 E.Update expr fields ->

140 exists $ \t ->

123 exists $ \t ->

@@ -181,7 +164,7 @@ constrain env annotatedExpr@(A.A region expression) tipe =

181

164

182

165

183constrainApp

166constrainApp

184− :: Env.Environment

167+ :: Env.Env

185 -> R.Region

168 -> R.Region

186 -> Canonical.Expr

169 -> Canonical.Expr

187 -> [Canonical.Expr]

170 -> [Canonical.Expr]

@@ -210,7 +193,7 @@ constrainApp env region f args tipe =

210

193

211

194

212argConstraints

195argConstraints

213− :: Env.Environment

196+ :: Env.Env

214 -> Maybe V.Canonical

197 -> Maybe V.Canonical

215 -> R.Region

198 -> R.Region

216 -> Int

199 -> Int

@@ -264,7 +247,7 @@ argConstraints env name region totalArgs overallVar index args =

264

247

265

248

266constrainBinop

249constrainBinop

267− :: Env.Environment

250+ :: Env.Env

268 -> R.Region

251 -> R.Region

269 -> V.Canonical

252 -> V.Canonical

270 -> Canonical.Expr

253 -> Canonical.Expr

@@ -299,12 +282,7 @@ constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightReg

299-- CONSTRAIN LISTS

282-- CONSTRAIN LISTS

300

283

301

284

302−constrainList

303− :: Env.Environment

304− -> R.Region

305− -> [Canonical.Expr]

306− -> Type

307− -> IO TypeConstraint

285+constrainList :: Env.Env -> R.Region -> [Canonical.Expr] -> Type -> IO TypeConstraint

308constrainList env region exprs tipe =

286constrainList env region exprs tipe =

309 do (exprInfo, exprCons) <-

287 do (exprInfo, exprCons) <-

310 unzip <$> mapM elementConstraint exprs

288 unzip <$> mapM elementConstraint exprs

@@ -327,7 +305,7 @@ constrainList env region exprs tipe =

327

305

328

306

329constrainIf

307constrainIf

330− :: Env.Environment

308+ :: Env.Env

331 -> R.Region

309 -> R.Region

332 -> [(Canonical.Expr, Canonical.Expr)]

310 -> [(Canonical.Expr, Canonical.Expr)]

333 -> Canonical.Expr

311 -> Canonical.Expr

@@ -386,7 +364,7 @@ constrainIf env region branches finally tipe =

386

364

387

365

388constrainCase

366constrainCase

389− :: Env.Environment

367+ :: Env.Env

390 -> R.Region

368 -> R.Region

391 -> Canonical.Expr

369 -> Canonical.Expr

392 -> [(P.Canonical, Canonical.Expr)]

370 -> [(P.Canonical, Canonical.Expr)]

@@ -405,11 +383,11 @@ constrainCase env region expr branches tipe =

405 where

383 where

406 branch patternType (pattern, branchExpr@(A.A branchRegion _)) =

384 branch patternType (pattern, branchExpr@(A.A branchRegion _)) =

407 do branchVar <- mkVar Nothing

385 do branchVar <- mkVar Nothing

408− fragment <- Pattern.constrain env pattern patternType

386+ scheme <- Pattern.infoToScheme <$> Pattern.constrain env pattern patternType

409 branchCon <- constrain env branchExpr (VarN branchVar)

387 branchCon <- constrain env branchExpr (VarN branchVar)

410 return

388 return

411 ( (branchVar, branchRegion)

389 ( (branchVar, branchRegion)

412− , CLet [Fragment.toScheme fragment] branchCon

390+ , CLet [scheme] branchCon

413 )

391 )

414

392

415 varToCon var =

393 varToCon var =

@@ -516,83 +494,110 @@ data Info = Info

516 }

494 }

517

495

518

496

519−constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info

497+constrainDef :: Env.Env -> Info -> Canonical.Def -> IO Info

520−constrainDef env info (Canonical.Def _ (A.A patternRegion pattern) expr maybeTipe) =

498+constrainDef env info (Canonical.Def defRegion (A.A patternRegion pattern) expr maybeTipe) =

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

522− in

523 case (pattern, maybeTipe) of

499 case (pattern, maybeTipe) of

524− (P.Var name, Just (A.A typeRegion tipe)) ->

525− constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe

526−

527 (P.Var name, Nothing) ->

500 (P.Var name, Nothing) ->

528− constrainUnannotatedDef env info qs patternRegion name expr

501+ constrainUnannotatedDef env patternRegion name expr info

502+

503+ (P.Var name, Just (A.A _ tipe)) ->

504+ constrainAnnotatedDef env defRegion patternRegion name expr tipe info

529

505

530 _ ->

506 _ ->

531 error "canonical definitions must not have complex patterns as names in the contstraint generation phase"

507 error "canonical definitions must not have complex patterns as names in the contstraint generation phase"

532

508

533

509

534−constrainAnnotatedDef

510+constrainUnannotatedDef

535− :: Env.Environment

511+ :: Env.Env

512+ -> R.Region

513+ -> String

514+ -> Canonical.Expr

536 -> Info

515 -> Info

537− -> [String]

516+ -> IO Info

517+constrainUnannotatedDef env patternRegion name expr info =

518+ do v <- mkVar Nothing

519+ let tipe = VarN v

520+ defCon <- constrain env expr tipe

521+ return $ info

522+ { iFlex = v : iFlex info

523+ , iHeaders = Map.insert name (A.A patternRegion tipe) (iHeaders info)

524+ , iC2 = defCon /\ iC2 info

525+ }

526+

527+

528+constrainAnnotatedDef

529+ :: Env.Env

538 -> R.Region

530 -> R.Region

539 -> R.Region

531 -> R.Region

540 -> String

532 -> String

541 -> Canonical.Expr

533 -> Canonical.Expr

542 -> ST.Canonical

534 -> ST.Canonical

535+ -> Info

543 -> IO Info

536 -> IO Info

544−constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe =

537+constrainAnnotatedDef env defRegion region name expr tipe info =

545− do -- Some mistake may be happening here. Currently, qs is always [].

546− rigidVars <- mapM mkRigid qs

547−

548− flexiVars <- mapM mkNamedVar qs

549−

550− let env' = Env.addValues env (zip qs flexiVars)

551−

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

538+ do (flexType, flexVars) <- Env.instantiateType Flex env tipe

553

539

554 let scheme =

540 let scheme =

555 Scheme

541 Scheme

556 { _rigidQuantifiers = []

542 { _rigidQuantifiers = []

557− , _flexibleQuantifiers = flexiVars ++ vars

543+ , _flexibleQuantifiers = Map.elems flexVars

558 , _constraint = CTrue

544 , _constraint = CTrue

559− , _header = Map.singleton name (A.A patternRegion typ)

545+ , _header = Map.singleton name (A.A region flexType)

560 }

546 }

561

547

562− var <- mkVar Nothing

548+ defCon <- constrainAnnDefHelp expr tipe (ArgInfo name defRegion env [] [])

563− defCon <- constrain env' expr (VarN var)

564− let annCon =

565− CEqual (Error.BadTypeAnnotation name) typeRegion typ (VarN var)

566

549

567 return $ info

550 return $ info

568 { iSchemes = scheme : iSchemes info

551 { iSchemes = scheme : iSchemes info

569− , iC1 = iC1 info /\ ex [var] (defCon /\ fl rigidVars annCon)

552+ , iC1 = iC1 info /\ defCon

570 }

553 }

571

554

572

555

573−constrainUnannotatedDef

556+data ArgInfo =

574− :: Env.Environment

557+ ArgInfo

575− -> Info

576− -> [String]

558+ { _name :: String

577− -> R.Region

559+ , _def :: R.Region

578− -> String

560+ , _env :: Env.Env

579− -> Canonical.Expr

561+ , _args :: [(P.Canonical, Type)]

580− -> IO Info

562+ , _vars :: [Variable]

581−constrainUnannotatedDef env info qs patternRegion name expr =

563+ }

582− do -- Some mistake may be happening here. Currently, qs is always [].

583− rigidVars <- mapM mkRigid qs

584

564

585− v <- mkVar Nothing

586

565

587− let tipe = VarN v

566+constrainAnnDefHelp :: Canonical.Expr -> ST.Canonical -> ArgInfo -> IO TypeConstraint

567+constrainAnnDefHelp expr tipe (ArgInfo name defRegion env args vars) =

568+ case (expr, tipe) of

569+ (A.A _ (E.Lambda arg result), ST.Lambda argType resultType) ->

570+ do (rigidArgType, newVars) <- Env.instantiateType Rigid env argType

588

571

572+ constrainAnnDefHelp result resultType $

573+ ArgInfo

574+ { _name = name

575+ , _def = defRegion

589− let env' = Env.addValues env (zip qs rigidVars)

576+ , _env = Env.addValues newVars env

577+ , _args = (arg, rigidArgType) : args

578+ , _vars = Map.elems newVars ++ vars

579+ }

590

580

591− con <- constrain env' expr tipe

581+ (A.A region _, _) ->

582+ do (rigidType, newVars) <- Env.instantiateType Rigid env tipe

592

583

593− return $ info

584+ let finalEnv = Env.addValues newVars env

594− { iRigid = rigidVars ++ iRigid info

585+ let finalArgs = reverse args

595− , iFlex = v : iFlex info

586+ let rigidVars = Map.elems newVars ++ vars

596− , iHeaders = Map.insert name (A.A patternRegion tipe) (iHeaders info)

587+

597− , iC2 = con /\ iC2 info

588+ (Pattern.Info headers argVars argCons) <-

598− }

589+ Pattern.joinInfos <$> mapM (uncurry (Pattern.constrain finalEnv)) finalArgs

590+

591+ resultVar <- mkVar Nothing

592+ let resultType = VarN resultVar

593+ defCon <- constrain finalEnv expr resultType

594+

595+ let sharedArity = length args

596+ let typeArity = sharedArity + length (ST.collectLambdas tipe) - 1

597+ let argsArity = sharedArity + length (fst (E.collectLambdas expr))

598+ let hint = Error.ReturnType name typeArity argsArity region

599+ let resultCon =

600+ CEqual hint defRegion rigidType resultType

601+

602+ return $ forall rigidVars $ ex (resultVar : argVars) $ CLet [monoscheme headers] $

603+ CAnd [ argCons, defCon, resultCon ]

src/Type/Constrain/Literal.hs+1−6

@@ -7,12 +7,7 @@ import qualified Type.Type as T

7import qualified Type.Environment as Env

8

9

10−constrain

11− :: Env.Environment

12− -> R.Region

13− -> L.Literal

14− -> T.Type

15− -> IO T.TypeConstraint

10+constrain :: Env.Env -> R.Region -> L.Literal -> T.Type -> IO T.TypeConstraint

16constrain env region literal tipe =

11constrain env region literal tipe =

17 do definiteType <- litType

12 do definiteType <- litType

18 return (T.CEqual (Error.Literal name) region definiteType tipe)

13 return (T.CEqual (Error.Literal name) region definiteType tipe)

src/Type/Constrain/Pattern.hs+73−33

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

1+{-# OPTIONS_GHC -Wall #-}

1−module Type.Constrain.Pattern where

2+module Type.Constrain.Pattern (Info(..), joinInfos, infoToScheme, constrain) where

2

3

3import Control.Arrow (second)

4import Control.Arrow (second)

4import qualified Control.Monad as Monad

5import qualified Control.Monad as Monad

6+import qualified Data.List as List

5import qualified Data.Map as Map

7import qualified Data.Map as Map

6

8

7import qualified AST.Pattern as P

9import qualified AST.Pattern as P

@@ -10,11 +12,50 @@ import qualified Reporting.Annotation as A

10import qualified Reporting.Error.Type as Error

12import qualified Reporting.Error.Type as Error

11import qualified Type.Constrain.Literal as Literal

13import qualified Type.Constrain.Literal as Literal

12import qualified Type.Environment as Env

14import qualified Type.Environment as Env

13−import Type.Fragment

14import Type.Type

15import Type.Type

15

16

17

18+

19+-- PATTERN INFO

20+

21+

22+data Info =

23+ Info

24+ { _headers :: Map.Map String (A.Located Type)

25+ , _vars :: [Variable]

26+ , _cons :: TypeConstraint

27+ }

28+

29+

30+emptyInfo :: Info

31+emptyInfo =

32+ Info Map.empty [] CTrue

33+

34+

35+joinInfo :: Info -> Info -> Info

36+joinInfo (Info headers1 vars1 cons1) (Info headers2 vars2 cons2) =

37+ Info

38+ { _headers = Map.union headers1 headers2

39+ , _vars = vars1 ++ vars2

40+ , _cons = cons1 /\ cons2

41+ }

42+

43+

44+joinInfos :: [Info] -> Info

45+joinInfos infos =

46+ List.foldl' (flip joinInfo) emptyInfo infos

47+

48+

49+infoToScheme :: Info -> Scheme Type Variable

50+infoToScheme (Info headers vars cons) =

51+ Scheme [] vars cons headers

52+

53+

54+

55+-- CONSTRAIN PATTERN

56+

57+

17−constrain :: Env.Environment -> P.Canonical -> Type -> IO Fragment

58+constrain :: Env.Env -> P.Canonical -> Type -> IO Info

18constrain env (A.A region pattern) tipe =

59constrain env (A.A region pattern) tipe =

19 let

60 let

20 equal patternError leftType rightType =

61 equal patternError leftType rightType =

@@ -23,50 +64,49 @@ constrain env (A.A region pattern) tipe =

23 rvar v =

64 rvar v =

24 A.A region (VarN v)

65 A.A region (VarN v)

25 in

66 in

26− case pattern of

67+ case pattern of

27− P.Anything ->

68+ P.Anything ->

28− return emptyFragment

69+ return emptyInfo

29

70

30− P.Literal lit ->

71+ P.Literal lit ->

31 do c <- Literal.constrain env region lit tipe

72 do c <- Literal.constrain env region lit tipe

32− return $ emptyFragment { typeConstraint = c }

73+ return $ emptyInfo { _cons = c }

33

74

34− P.Var name ->

75+ P.Var name ->

35 do variable <- mkVar Nothing

76 do variable <- mkVar Nothing

36− return $ Fragment

77+ return $ Info

37− { typeEnv = Map.singleton name (rvar variable)

78+ { _headers = Map.singleton name (rvar variable)

38− , vars = [variable]

79+ , _vars = [variable]

39− , typeConstraint =

40− equal (Error.PVar name) (VarN variable) tipe

80+ , _cons = equal (Error.PVar name) (VarN variable) tipe

41 }

81 }

42

82

43− P.Alias name p ->

83+ P.Alias name ptrn ->

44 do variable <- mkVar Nothing

84 do variable <- mkVar Nothing

45− fragment <- constrain env p tipe

85+ info <- constrain env ptrn tipe

46− return $ fragment

86+ return $ info

47− { typeEnv = Map.insert name (rvar variable) (typeEnv fragment)

87+ { _headers = Map.insert name (rvar variable) (_headers info)

48− , vars = variable : vars fragment

88+ , _vars = variable : _vars info

49− , typeConstraint =

89+ , _cons =

50 equal (Error.PAlias name) (VarN variable) tipe

90 equal (Error.PAlias name) (VarN variable) tipe

51− /\ typeConstraint fragment

91+ /\ _cons info

52 }

92 }

53

93

54− P.Data name patterns ->

94+ P.Data name patterns ->

55 do let stringName = V.toString name

95 do let stringName = V.toString name

56

96

57 (_kind, cvars, args, result) <-

97 (_kind, cvars, args, result) <-

58 Env.freshDataScheme env stringName

98 Env.freshDataScheme env stringName

59

99

60 fragList <- Monad.zipWithM (constrain env) patterns args

100 fragList <- Monad.zipWithM (constrain env) patterns args

61− let fragment = joinFragments fragList

101+ let info = joinInfos fragList

62− return $ fragment

102+ return $ info

63− { vars = cvars ++ vars fragment

103+ { _vars = cvars ++ _vars info

64− , typeConstraint =

104+ , _cons =

65− typeConstraint fragment

66− /\ equal (Error.PData stringName) tipe result

105+ equal (Error.PData stringName) result tipe

106+ /\ _cons info

67 }

107 }

68

108

69− P.Record fields ->

109+ P.Record fields ->

70 do pairs <-

110 do pairs <-

71 mapM (\name -> (,) name <$> mkVar Nothing) fields

111 mapM (\name -> (,) name <$> mkVar Nothing) fields

72

112

@@ -79,8 +119,8 @@ constrain env (A.A region pattern) tipe =

79 con <- exists $ \t ->

119 con <- exists $ \t ->

80 return (equal Error.PRecord tipe (record unannotatedTenv t))

120 return (equal Error.PRecord tipe (record unannotatedTenv t))

81

121

82− return $ Fragment

122+ return $ Info

83− { typeEnv = tenv

123+ { _headers = tenv

84− , vars = map snd pairs

124+ , _vars = map snd pairs

85− , typeConstraint = con

125+ , _cons = con

86 }

126 }

src/Type/Environment.hs+38−40

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

1{-# OPTIONS_GHC -Wall #-}

2module Type.Environment

3− ( Environment

3+ ( Env

4 , initialize

5 , getType, freshDataScheme, ctorNames

6 , addValues

@@ -9,7 +9,6 @@ module Type.Environment

9 where

10

11import qualified Control.Monad.State as State

12−import qualified Data.List as List

13import Data.Map ((!))

12import Data.Map ((!))

14import qualified Data.Map as Map

13import qualified Data.Map as Map

15import qualified Data.Set as Set

14import qualified Data.Set as Set

@@ -24,18 +23,18 @@ type TypeDict = Map.Map String Type

24type VarDict = Map.Map String Variable

23type VarDict = Map.Map String Variable

25

24

26

25

27−data Environment = Environment

26+data Env = Env

28 { _constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))

27 { _constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))

29 , _types :: TypeDict

28 , _types :: TypeDict

30 , _value :: TypeDict

29 , _value :: TypeDict

31 }

30 }

32

31

33

32

34−initialize :: [Module.CanonicalUnion] -> IO Environment

33+initialize :: [Module.CanonicalUnion] -> IO Env

35initialize datatypes =

34initialize datatypes =

36 do types <- makeTypes datatypes

35 do types <- makeTypes datatypes

37 let env =

36 let env =

38− Environment

37+ Env

39 { _constructor = Map.empty

38 { _constructor = Map.empty

40 , _value = Map.empty

39 , _value = Map.empty

41 , _types = types

40 , _types = types

@@ -72,7 +71,7 @@ makeTypes datatypes =

72

71

73

72

74makeConstructors

73makeConstructors

75− :: Environment

74+ :: Env

76 -> [Module.CanonicalUnion]

75 -> [Module.CanonicalUnion]

77 -> Map.Map String (IO (Int, [Variable], [Type], Type))

76 -> Map.Map String (IO (Int, [Variable], [Type], Type))

78makeConstructors env datatypes =

77makeConstructors env datatypes =

@@ -100,7 +99,7 @@ makeConstructors env datatypes =

100

99

101

100

102ctorToType

101ctorToType

103− :: Environment

102+ :: Env

104 -> (V.Canonical, Module.UnionInfo V.Canonical)

103 -> (V.Canonical, Module.UnionInfo V.Canonical)

105 -> [(String, IO (Int, [Variable], [Type], Type))]

104 -> [(String, IO (Int, [Variable], [Type], Type))]

106ctorToType env (name, (tvars, ctors)) =

105ctorToType env (name, (tvars, ctors)) =

@@ -114,8 +113,8 @@ ctorToType env (name, (tvars, ctors)) =

114

113

115 go :: (V.Canonical, [T.Canonical]) -> State.StateT VarDict IO ([Type], Type)

114 go :: (V.Canonical, [T.Canonical]) -> State.StateT VarDict IO ([Type], Type)

116 go (_, args) =

115 go (_, args) =

117− do types <- mapM (instantiator env) args

116+ do types <- mapM (instantiator Flex env) args

118− returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))

117+ returnType <- instantiator Flex env (T.App (T.Type name) (map T.Var tvars))

119 return (types, returnType)

118 return (types, returnType)

120

119

121

120

@@ -123,62 +122,56 @@ ctorToType env (name, (tvars, ctors)) =

123-- ACCESS TYPES

122-- ACCESS TYPES

124

123

125

124

126−get :: (Environment -> Map.Map String a) -> Environment -> String -> a

125+get :: (Env -> Map.Map String a) -> Env -> String -> a

127get subDict env key =

126get subDict env key =

128 Map.findWithDefault (error msg) key (subDict env)

127 Map.findWithDefault (error msg) key (subDict env)

129 where

128 where

130 msg = "Could not find type constructor `" ++ key ++ "` while checking types."

129 msg = "Could not find type constructor `" ++ key ++ "` while checking types."

131

130

132

131

133−getType :: Environment -> String -> Type

132+getType :: Env -> String -> Type

134getType =

133getType =

135 get _types

134 get _types

136

135

137

136

138−freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

137+freshDataScheme :: Env -> String -> IO (Int, [Variable], [Type], Type)

139freshDataScheme =

138freshDataScheme =

140 get _constructor

139 get _constructor

141

140

142

141

143−ctorNames :: Environment -> [String]

142+ctorNames :: Env -> [String]

144ctorNames env =

143ctorNames env =

145 Map.keys (_constructor env)

144 Map.keys (_constructor env)

146

145

147

146

147+

148-- UPDATE ENVIRONMENT

149

150

151−addValues :: Environment -> [(String, Variable)] -> Environment

151+addValues :: VarDict -> Env -> Env

152−addValues env newValues =

152+addValues newValues env =

153− env

153+ env { _value = Map.union (_value env) (Map.map VarN newValues) }

154− { _value =

155− List.foldl'

156− (\dict (name, var) -> Map.insert name (VarN var) dict)

157− (_value env)

158− newValues

159− }

160

154

161

155

162

156

163-- INSTANTIATE TYPES

157-- INSTANTIATE TYPES

164

158

165

159

166−instantiateType :: Environment -> T.Canonical -> VarDict -> IO ([Variable], Type)

160+instantiateType :: Flex -> Env -> T.Canonical -> IO (Type, VarDict)

167−instantiateType env sourceType dict =

161+instantiateType flex env sourceType =

168− do (tipe, dict') <- State.runStateT (instantiator env sourceType) dict

162+ State.runStateT (instantiator flex env sourceType) Map.empty

169− return (Map.elems dict', tipe)

170

163

171

164

172−instantiator :: Environment -> T.Canonical -> State.StateT VarDict IO Type

165+instantiator :: Flex -> Env -> T.Canonical -> State.StateT VarDict IO Type

173−instantiator env sourceType =

166+instantiator flex env sourceType =

174− instantiatorHelp env Set.empty sourceType

167+ instantiatorHelp flex env Set.empty sourceType

175

168

176

169

177−instantiatorHelp :: Environment -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type

170+instantiatorHelp :: Flex -> Env -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type

178−instantiatorHelp env aliasVars sourceType =

171+instantiatorHelp flex env aliasVars sourceType =

179 let

172 let

180 go =

173 go =

181− instantiatorHelp env aliasVars

174+ instantiatorHelp flex env aliasVars

182 in

175 in

183 case sourceType of

176 case sourceType of

184 T.Lambda t1 t2 ->

177 T.Lambda t1 t2 ->

@@ -190,24 +183,29 @@ instantiatorHelp env aliasVars sourceType =

190

183

191 else

184 else

192 do dict <- State.get

185 do dict <- State.get

193− case Map.lookup name dict of

186+ case Map.lookup name (_value env) of

194− Just variable ->

187+ Just tipe ->

195− return (VarN variable)

188+ return tipe

196

189

197 Nothing ->

190 Nothing ->

191+ case Map.lookup name dict of

192+ Just variable ->

193+ return (VarN variable)

194+

195+ Nothing ->

198− do variable <- State.liftIO (mkNamedVar name)

196+ do variable <- State.liftIO (mkNamedVar flex name)

199− State.put (Map.insert name variable dict)

197+ State.put (Map.insert name variable dict)

200− return (VarN variable)

198+ return (VarN variable)

201

199

202 T.Aliased name args aliasType ->

200 T.Aliased name args aliasType ->

203 do targs <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args

201 do targs <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args

204 realType <-

202 realType <-

205 case aliasType of

203 case aliasType of

206 T.Filled tipe ->

204 T.Filled tipe ->

207− instantiatorHelp env Set.empty tipe

205+ instantiatorHelp flex env Set.empty tipe

208

206

209 T.Holey tipe ->

207 T.Holey tipe ->

210− instantiatorHelp env (Set.fromList (map fst args)) tipe

208+ instantiatorHelp flex env (Set.fromList (map fst args)) tipe

211

209

212 return (AliasN name targs realType)

210 return (AliasN name targs realType)

213

211

src/Type/Fragment.hsdeleted−44

@@ -1,44 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Type.Fragment where

3−

4−import qualified Data.List as List

5−import qualified Data.Map as Map

6−

7−import Reporting.Annotation as A

8−import Type.Type

9−

10−

11−data Fragment = Fragment

12− { typeEnv :: Map.Map String (A.Located Type)

13− , vars :: [Variable]

14− , typeConstraint :: TypeConstraint

15− }

16−

17−

18−emptyFragment :: Fragment

19−emptyFragment =

20− Fragment Map.empty [] CTrue

21−

22−

23−joinFragment :: Fragment -> Fragment -> Fragment

24−joinFragment f1 f2 =

25− Fragment

26− { typeEnv =

27− Map.union (typeEnv f1) (typeEnv f2)

28−

29− , vars =

30− vars f1 ++ vars f2

31−

32− , typeConstraint =

33− typeConstraint f1 /\ typeConstraint f2

34− }

35−

36−

37−joinFragments :: [Fragment] -> Fragment

38−joinFragments =

39− List.foldl' (flip joinFragment) emptyFragment

40−

41−

42−toScheme :: Fragment -> Scheme Type Variable

43−toScheme fragment =

44− Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)

src/Type/Inference.hs+6−4

@@ -68,15 +68,17 @@ genConstraints interfaces modul =

68

69

70canonicalizeValues

71− :: Env.Environment

71+ :: Env.Env

72 -> (ModuleName.Canonical, Module.Interface)

73 -> IO [(String, ([T.Variable], T.Type))]

74canonicalizeValues env (moduleName, iface) =

75− forM (Map.toList (Module.iTypes iface)) $ \(name,tipe) ->

75+ forM (Map.toList (Module.iTypes iface)) $ \(name, tipe) ->

76− do tipe' <- Env.instantiateType env tipe Map.empty

76+ do (flexType, flexVars) <- Env.instantiateType T.Flex env tipe

77 return

78 ( ModuleName.canonicalToString moduleName ++ "." ++ name

79− , tipe'

79+ , ( Map.elems flexVars

80+ , flexType

81+ )

80 )

82 )

81

83

82

84

src/Type/Solve.hs+14−42

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -Wall #-}

1module Type.Solve (solve) where

2module Type.Solve (solve) where

2

3

3import Control.Monad

4import Control.Monad

@@ -5,7 +6,7 @@ import Control.Monad.State (execStateT, liftIO)

5import Control.Monad.Except (ExceptT, throwError)

6import Control.Monad.Except (ExceptT, throwError)

6import qualified Data.List as List

7import qualified Data.List as List

7import qualified Data.Map as Map

8import qualified Data.Map as Map

8−import qualified Data.Traversable as T

9+import qualified Data.Foldable as F

9import qualified Data.UnionFind.IO as UF

10import qualified Data.UnionFind.IO as UF

10

11

11import qualified Reporting.Annotation as A

12import qualified Reporting.Annotation as A

@@ -35,7 +36,7 @@ generalize youngPool =

35 -- start at low ranks so that we only have to pass

36 -- start at low ranks so that we only have to pass

36 -- over the information once.

37 -- over the information once.

37 visitedMark <- TS.uniqueMark

38 visitedMark <- TS.uniqueMark

38− forM (Map.toList rankDict) $ \(poolRank, vars) ->

39+ forM_ (Map.toList rankDict) $ \(poolRank, vars) ->

39 mapM (adjustRank youngMark visitedMark poolRank) vars

40 mapM (adjustRank youngMark visitedMark poolRank) vars

40

41

41 -- For variables that have rank lowerer than youngRank, register them in

42 -- For variables that have rank lowerer than youngRank, register them in

@@ -45,7 +46,7 @@ generalize youngPool =

45 if isRedundant then return var else TS.register var

46 if isRedundant then return var else TS.register var

46

47

47 let rankDict' = Map.delete youngRank rankDict

48 let rankDict' = Map.delete youngRank rankDict

48− T.traverse (mapM registerIfNotRedundant) rankDict'

49+ F.traverse_ (mapM registerIfNotRedundant) rankDict'

49

50

50 -- For variables with rank youngRank

51 -- For variables with rank youngRank

51 -- If rank < youngRank: register in oldPool

52 -- If rank < youngRank: register in oldPool

@@ -71,8 +72,8 @@ generalize youngPool =

71rigidify :: Content -> Content

72rigidify :: Content -> Content

72rigidify content =

73rigidify content =

73 case content of

74 case content of

74− Var Flex maybeSuper _ ->

75+ Var Flex maybeSuper maybeName ->

75− Var Rigid maybeSuper Nothing

76+ Var Rigid maybeSuper maybeName

76

77

77 _ ->

78 _ ->

78 content

79 content

@@ -178,7 +179,7 @@ actuallySolve constraint =

178

179

179 CLet [Scheme [] fqs constraint' _] CTrue ->

180 CLet [Scheme [] fqs constraint' _] CTrue ->

180 do oldEnv <- TS.getEnv

181 do oldEnv <- TS.getEnv

181− mapM TS.introduce fqs

182+ mapM_ TS.introduce fqs

182 actuallySolve constraint'

183 actuallySolve constraint'

183 TS.modifyEnv (\_ -> oldEnv)

184 TS.modifyEnv (\_ -> oldEnv)

184

185

@@ -187,7 +188,7 @@ actuallySolve constraint =

187 headers <- Map.unions <$> mapM solveScheme schemes

188 headers <- Map.unions <$> mapM solveScheme schemes

188 TS.modifyEnv $ \env -> Map.union headers env

189 TS.modifyEnv $ \env -> Map.union headers env

189 actuallySolve constraint'

190 actuallySolve constraint'

190− mapM occurs $ Map.toList headers

191+ mapM_ occurs $ Map.toList headers

191 TS.modifyEnv (\_ -> oldEnv)

192 TS.modifyEnv (\_ -> oldEnv)

192

193

193 CInstance region name term ->

194 CInstance region name term ->

@@ -217,7 +218,7 @@ solveScheme scheme =

217 case scheme of

218 case scheme of

218 Scheme [] [] constraint header ->

219 Scheme [] [] constraint header ->

219 do actuallySolve constraint

220 do actuallySolve constraint

220− T.traverse flatten header

221+ traverse flatten header

221

222

222 Scheme rigidQuantifiers flexibleQuantifiers constraint header ->

223 Scheme rigidQuantifiers flexibleQuantifiers constraint header ->

223 do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers

224 do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers

@@ -226,48 +227,19 @@ solveScheme scheme =

226 -- fill in a new pool when working on this scheme's constraints

227 -- fill in a new pool when working on this scheme's constraints

227 freshPool <- TS.nextRankPool

228 freshPool <- TS.nextRankPool

228 TS.switchToPool freshPool

229 TS.switchToPool freshPool

229− mapM TS.introduce quantifiers

230+ mapM_ TS.introduce quantifiers

230− header' <- T.traverse flatten header

231+ header' <- traverse flatten header

231 actuallySolve constraint

232 actuallySolve constraint

232

233

233− allDistinct rigidQuantifiers

234 youngPool <- TS.getPool

235 TS.switchToPool oldPool

236 generalize youngPool

237− mapM isGeneric rigidQuantifiers

237+ mapM_ isGeneric rigidQuantifiers

238 return header'

239

240

241-- ADDITIONAL CHECKS

242

243−-- Checks that all of the given variables belong to distinct equivalence classes.

244−-- Also checks that their structure is Nothing, so they represent a variable, not

245−-- a more complex term.

246−allDistinct :: [Variable] -> TS.Solver ()

247−allDistinct vars =

248− do seenMark <- TS.uniqueMark

249− forM_ vars $ \var ->

250− do desc <- liftIO $ UF.descriptor var

251− case _content desc of

252− Structure _ ->

253− crash "Can only generalize type variables, not structures."

254−

255− Atom _ ->

256− crash "Can only generalize type variables, not structures."

257−

258− Alias _ _ _ ->

259− crash "Can only generalize type variables, not aliases."

260−

261− Error ->

262− crash "Can only generalize type variables, not error types."

263−

264− Var _ _ _ ->

265− if _mark desc == seenMark then

266− crash "Duplicate variable during generalization."

267−

268− else

269− liftIO (UF.setDescriptor var (desc { _mark = seenMark }))

270−

271

243

272-- Check that a variable has rank == noRank, meaning that it can be generalized.

244-- Check that a variable has rank == noRank, meaning that it can be generalized.

273isGeneric :: Variable -> TS.Solver ()

245isGeneric :: Variable -> TS.Solver ()

@@ -293,8 +265,8 @@ crash msg =

293

265

294occurs :: (String, A.Located Variable) -> TS.Solver ()

266occurs :: (String, A.Located Variable) -> TS.Solver ()

295occurs (name, A.A region variable) =

267occurs (name, A.A region variable) =

296− do isInfinite <- liftIO $ occursHelp [] variable

268+ do hasOccurred <- liftIO $ occursHelp [] variable

297− case isInfinite of

269+ case hasOccurred of

298 False ->

270 False ->

299 return ()

271 return ()

300

272

src/Type/State.hs+2−2

@@ -223,8 +223,8 @@ makeCopyHelp descriptor alreadyCopiedMark variable =

223 Atom _ ->

224 return oldContent

225

226− Var Rigid maybeSuper _ ->

226+ Var Rigid maybeSuper maybeName ->

227− return (Var Flex maybeSuper Nothing)

227+ return (Var Flex maybeSuper maybeName)

228

229 Var Flex _ _ ->

230 return oldContent

src/Type/Type.hs+132−87

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

1{-# OPTIONS_GHC -Wall #-}

2module Type.Type where

3

4+import Control.Monad (when)

4import Control.Monad.State (StateT, liftIO)

5import Control.Monad.State (StateT, liftIO)

5import qualified Control.Monad.State as State

6import qualified Control.Monad.State as State

7+import qualified Data.Char as Char

6import qualified Data.List as List

8import qualified Data.List as List

7import qualified Data.Map as Map

9import qualified Data.Map as Map

8−import qualified Data.Set as Set

9−import qualified Data.Traversable as Traverse (traverse)

10import qualified Data.UnionFind.IO as UF

11

12import qualified AST.Type as T

@@ -183,14 +183,9 @@ mkVar maybeSuper =

183 UF.fresh $ mkDescriptor (Var Flex maybeSuper Nothing)

184

185

186−mkNamedVar :: String -> IO Variable

187−mkNamedVar name =

188− UF.fresh $ mkDescriptor (Var Flex (toSuper name) Nothing)

189−

190−

191−mkRigid :: String -> IO Variable

186+mkNamedVar :: Flex -> String -> IO Variable

192−mkRigid name =

187+mkNamedVar flex name =

193− UF.fresh $ mkDescriptor (Var Rigid (toSuper name) (Just name))

188+ UF.fresh $ mkDescriptor $ Var flex (toSuper name) (Just name)

194

189

195

190

196toSuper :: String -> Maybe Super

191toSuper :: String -> Maybe Super

@@ -233,9 +228,8 @@ ex fqs constraint =

233 CLet [Scheme [] fqs constraint Map.empty] CTrue

228 CLet [Scheme [] fqs constraint Map.empty] CTrue

234

229

235

230

236−-- fl qs constraint == forall qs. constraint

237−fl :: [Variable] -> TypeConstraint -> TypeConstraint

231+forall :: [Variable] -> TypeConstraint -> TypeConstraint

238−fl rqs constraint =

232+forall rqs constraint =

239 CLet [Scheme rqs [] constraint Map.empty] CTrue

233 CLet [Scheme rqs [] constraint Map.empty] CTrue

240

234

241

235

@@ -259,8 +253,8 @@ existsNumber f =

259-- never have to do extra work, particularly nice for aliased types

253-- never have to do extra work, particularly nice for aliased types

260toSrcType :: Variable -> IO T.Canonical

254toSrcType :: Variable -> IO T.Canonical

261toSrcType variable =

255toSrcType variable =

262− do usedNames <- getVarNames variable

256+ do takenNames <- State.execStateT (getVarNames variable) Map.empty

263− State.evalStateT (variableToSrcType variable) (makeNameState usedNames)

257+ State.evalStateT (variableToSrcType variable) (makeNameState takenNames)

264

258

265

259

266variableToSrcType :: Variable -> StateT NameState IO T.Canonical

260variableToSrcType :: Variable -> StateT NameState IO T.Canonical

@@ -297,7 +291,7 @@ contentToSrcType variable content =

297 return (T.Var freshName)

291 return (T.Var freshName)

298

292

299 Alias name args realVariable ->

293 Alias name args realVariable ->

300− do srcArgs <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType tvar) args

294+ do srcArgs <- traverse (traverse variableToSrcType) args

301 srcType <- variableToSrcType realVariable

295 srcType <- variableToSrcType realVariable

302 return (T.Aliased name srcArgs (T.Filled srcType))

296 return (T.Aliased name srcArgs (T.Filled srcType))

303

297

@@ -327,7 +321,7 @@ termToSrcType term =

327 return $ T.Record [] Nothing

321 return $ T.Record [] Nothing

328

322

329 Record1 fields extension ->

323 Record1 fields extension ->

330− do srcFields <- Map.toList <$> Traverse.traverse variableToSrcType fields

324+ do srcFields <- Map.toList <$> traverse variableToSrcType fields

331 srcExt <- T.iteratedDealias <$> variableToSrcType extension

325 srcExt <- T.iteratedDealias <$> variableToSrcType extension

332 return $

326 return $

333 case srcExt of

327 case srcExt of

@@ -346,112 +340,163 @@ termToSrcType term =

346

340

347

341

348data NameState = NameState

342data NameState = NameState

349− { _freeNames :: [String]

343+ { _taken :: TakenNames

350− , _numberPrimes :: Int

344+ , _normals :: Int

351− , _comparablePrimes :: Int

345+ , _numbers :: Int

352− , _appendablePrimes :: Int

346+ , _comparables :: Int

353− , _compAppendPrimes :: Int

347+ , _appendables :: Int

348+ , _compAppends :: Int

354 }

349 }

355

350

356

351

357−makeNameState :: Set.Set String -> NameState

352+type TakenNames = Map.Map String Variable

358−makeNameState usedNames =

359− let

360− makeName suffix =

361− map (:suffix) ['a'..'z']

362

353

363− allNames =

364− concatMap makeName ("" : map show [ (1 :: Int) .. ])

365

354

366− freeNames =

355+makeNameState :: TakenNames -> NameState

367− filter (\name -> Set.notMember name usedNames) allNames

356+makeNameState taken =

368− in

369− NameState freeNames 0 0 0 0

357+ NameState taken 0 0 0 0 0

370

358

371

359

372getFreshName :: (Monad m) => Maybe Super -> StateT NameState m String

360getFreshName :: (Monad m) => Maybe Super -> StateT NameState m String

373getFreshName maybeSuper =

361getFreshName maybeSuper =

374 case maybeSuper of

362 case maybeSuper of

375 Nothing ->

363 Nothing ->

376− do names <- State.gets _freeNames

364+ do index <- State.gets _normals

365+ taken <- State.gets _taken

366+ let (uniqueName, newIndex) = getFreshNormal index taken

377− State.modify (\state -> state { _freeNames = tail names })

367+ State.modify (\state -> state { _normals = newIndex })

378− return (head names)

368+ return uniqueName

379

369

380 Just Number ->

370 Just Number ->

381− do primes <- State.gets _numberPrimes

371+ getFreshSuper "number" _numbers (\index state -> state { _numbers = index })

382− State.modify (\state -> state { _numberPrimes = primes + 1 })

383− return ("number" ++ replicate primes '\'')

384

372

385 Just Comparable ->

373 Just Comparable ->

386− do primes <- State.gets _comparablePrimes

374+ getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })

387− State.modify (\state -> state { _comparablePrimes = primes + 1 })

388− return ("comparable" ++ replicate primes '\'')

389

375

390 Just Appendable ->

376 Just Appendable ->

391− do primes <- State.gets _appendablePrimes

377+ getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })

392− State.modify (\state -> state { _appendablePrimes = primes + 1 })

393− return ("appendable" ++ replicate primes '\'')

394

378

395 Just CompAppend ->

379 Just CompAppend ->

396− do primes <- State.gets _compAppendPrimes

380+ getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })

397− State.modify (\state -> state { _compAppendPrimes = primes + 1 })

381+

398− return ("compappend" ++ replicate primes '\'')

382+

383+getFreshNormal :: Int -> TakenNames -> (String, Int)

384+getFreshNormal index taken =

385+ let

386+ (postfix, letter) =

387+ quotRem index 26

388+

389+ name =

390+ Char.chr (97 + letter) : if postfix <= 0 then "" else show postfix

391+ in

392+ if Map.member name taken then

393+ getFreshNormal (index + 1) taken

394+

395+ else

396+ (name, index + 1)

397+

398+

399+getFreshSuper

400+ :: (Monad m)

401+ => String

402+ -> (NameState -> Int)

403+ -> (Int -> NameState -> NameState)

404+ -> StateT NameState m String

405+getFreshSuper name getter setter =

406+ do index <- State.gets getter

407+ taken <- State.gets _taken

408+ let (uniqueName, newIndex) = getFreshSuperHelp name index taken

409+ State.modify (setter newIndex)

410+ return uniqueName

411+

412+

413+getFreshSuperHelp :: String -> Int -> TakenNames -> (String, Int)

414+getFreshSuperHelp name index taken =

415+ let

416+ newName =

417+ if index <= 0 then name else name ++ show index

418+ in

419+ if Map.member newName taken then

420+ getFreshSuperHelp name (index + 1) taken

421+

422+ else

423+ (newName, index + 1)

399

424

400

425

401

426

402-- GET ALL VARIABLE NAMES

427-- GET ALL VARIABLE NAMES

403

428

404

429

405−getVarNames :: Variable -> IO (Set.Set String)

430+getVarNames :: Variable -> StateT TakenNames IO ()

406getVarNames var =

431getVarNames var =

407− do desc <- UF.descriptor var

432+ do desc <- liftIO $ UF.descriptor var

408− if _mark desc == getVarNamesMark

433+ case _mark desc == getVarNamesMark of

409− then

434+ True ->

410− return Set.empty

435+ return ()

411

436

412− else

437+ False ->

413− do UF.setDescriptor var (desc { _mark = getVarNamesMark })

438+ do liftIO $ UF.setDescriptor var (desc { _mark = getVarNamesMark })

414− getVarNamesHelp (_content desc)

439+ case _content desc of

440+ Atom _ ->

441+ return ()

415

442

443+ Error ->

444+ return ()

416

445

417−getVarNamesHelp :: Content -> IO (Set.Set String)

418−getVarNamesHelp content =

419− case content of

420− Var _ _ (Just name) ->

446+ Var _ _ Nothing ->

421− return (Set.singleton name)

447+ return ()

422

448

423− Var _ _ Nothing ->

449+ Var flex maybeSuper (Just name) ->

424− return Set.empty

450+ do oldTaken <- State.get

451+ newTaken <- liftIO $ addVarName 0 name var flex maybeSuper oldTaken

452+ State.put newTaken

425

453

426− Structure term ->

454+ Alias _ args realVar ->

427− getVarNamesTerm term

455+ do mapM_ (getVarNames . snd) args

456+ getVarNames realVar

428

457

429− Alias _name args realVar ->

458+ Structure (App1 func arg) ->

430− do let argSet = Set.fromList (map fst args)

431− realSet <- getVarNames realVar

459+ do getVarNames func

432− sets <- mapM (getVarNames . snd) args

460+ getVarNames arg

433− return (Set.unions (realSet : argSet : sets))

434

461

435− Atom _ ->

462+ Structure (Fun1 arg body) ->

436− return Set.empty

463+ do getVarNames arg

464+ getVarNames body

437

465

438− Error ->

466+ Structure EmptyRecord1 ->

439− return Set.empty

467+ return ()

440

468

469+ Structure (Record1 fields extension) ->

470+ do mapM_ getVarNames fields

471+ getVarNames extension

441

472

442−getVarNamesTerm :: Term1 Variable -> IO (Set.Set String)

443−getVarNamesTerm term =

444− let go = getVarNames in

445− case term of

446− App1 a b ->

447− Set.union <$> go a <*> go b

448

473

449− Fun1 a b ->

474+addVarName :: Int -> String -> Variable -> Flex -> Maybe Super -> TakenNames -> IO TakenNames

450− Set.union <$> go a <*> go b

475+addVarName index givenName var flex maybeSuper taken =

476+ let

477+ name =

478+ makeIndexedName givenName index

479+ in

480+ case Map.lookup name taken of

481+ Nothing ->

482+ do when (name /= givenName) $ UF.modifyDescriptor var $ \desc ->

483+ desc { _content = Var flex maybeSuper (Just name) }

484+ return $ Map.insert name var taken

451

485

452− EmptyRecord1 ->

486+ Just otherVar ->

453− return Set.empty

487+ do same <- UF.equivalent var otherVar

488+ if same

489+ then return taken

490+ else addVarName (index + 1) givenName var flex maybeSuper taken

454

491

455− Record1 fields extension ->

492+

456− do fieldVars <- Set.unions <$> mapM go (Map.elems fields)

493+makeIndexedName :: String -> Int -> String

457− Set.union fieldVars <$> go extension

494+makeIndexedName name index =

495+ if index <= 0 then

496+ name

497+

498+ else if Char.isDigit (last name) then

499+ name ++ '_' : show index

500+

501+ else

502+ name ++ show index

src/Type/Unify.hs+75−20

@@ -4,6 +4,7 @@ module Type.Unify (unify) where

4import Control.Monad (zipWithM_)

5import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)

6import qualified Data.Map as Map

7+import qualified Data.Maybe as Maybe

7import qualified Data.UnionFind.IO as UF

8import qualified Data.UnionFind.IO as UF

8

9

9import qualified AST.Variable as Var

10import qualified AST.Variable as Var

@@ -21,10 +22,10 @@ unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()

21unify hint region expected actual =

22unify hint region expected actual =

22 do result <- runExceptT (guardedUnify ExpectedActual expected actual)

23 do result <- runExceptT (guardedUnify ExpectedActual expected actual)

23 case result of

24 case result of

24− Right state ->

25+ Right () ->

25− return state

26+ return ()

26

27

27− Left (Mismatch _subExpected _subActual maybeReason) ->

28+ Left (Mismatch maybeReason) ->

28 let

29 let

29 mkError =

30 mkError =

30 do expectedSrcType <- Type.toSrcType expected

31 do expectedSrcType <- Type.toSrcType expected

@@ -71,22 +72,35 @@ reorient (Context orientation var1 desc1 var2 desc2) =

71-- ERROR MESSAGES

72-- ERROR MESSAGES

72

73

74

74−data Mismatch

75+newtype Mismatch =

75− = Mismatch Variable Variable (Maybe Error.Reason)

76+ Mismatch (Maybe Error.Reason)

76

77

78

78mismatch :: Context -> Maybe Error.Reason -> Unify a

79mismatch :: Context -> Maybe Error.Reason -> Unify a

79−mismatch (Context orientation first _ second _) maybeReason =

80+mismatch context@(Context orientation var1 _ var2 _) maybeReason =

80− let

81+ do args1 <- liftIO $ collectArgs var1

81− (expected, actual, orientedReason) =

82+ args2 <- liftIO $ collectArgs var2

82− case orientation of

83− ExpectedActual ->

84− (first, second, maybeReason)

85

83

86− ActualExpected ->

84+ let numArgs1 = length args1

85+ let numArgs2 = length args2

86+

87+ if numArgs1 == numArgs2

88+ then

89+ mismatchHelp orientation maybeReason

90+ else

91+ do zipWithM_ (\arg1 arg2 -> lift $ runExceptT $ subUnify context arg1 arg2) args1 args2

92+ mismatchHelp orientation $ Just $ Error.MissingArgs $ abs (numArgs2 - numArgs1)

93+

94+

95+mismatchHelp :: Orientation -> Maybe Error.Reason -> Unify a

96+mismatchHelp orientation maybeReason =

97+ throwError $ Mismatch $

98+ case orientation of

99+ ExpectedActual ->

100+ maybeReason

101+

102+ ActualExpected ->

87− (second, first, Error.flipReason <$> maybeReason)

103+ Error.flipReason <$> maybeReason

88− in

89− throwError (Mismatch expected actual orientedReason)

90

104

91

105

92badRigid :: Maybe String -> Error.Reason

106badRigid :: Maybe String -> Error.Reason

@@ -446,6 +460,22 @@ collectAppsHelp args content =

446 return Other

460 return Other

447

461

448

462

463+collectArgs :: Variable -> IO [Variable]

464+collectArgs variable =

465+ collectArgsHelp [] variable

466+

467+

468+collectArgsHelp :: [Variable] -> Variable -> IO [Variable]

469+collectArgsHelp revArgs variable =

470+ do content <- getContent variable

471+ case content of

472+ Structure (Fun1 arg returnType) ->

473+ collectArgsHelp (arg : revArgs) returnType

474+

475+ _ ->

476+ return $ variable : revArgs

477+

478+

449getContent :: Variable -> IO Content

479getContent :: Variable -> IO Content

450getContent variable =

480getContent variable =

451 _content <$> UF.descriptor variable

481 _content <$> UF.descriptor variable

@@ -516,7 +546,6 @@ unifyAlias context name args realVar otherContent =

516 Atom _ ->

546 Atom _ ->

517 subUnify context realVar (_second context)

547 subUnify context realVar (_second context)

518

548

519−

520 Alias otherName otherArgs otherRealVar ->

549 Alias otherName otherArgs otherRealVar ->

521 if name == otherName then

550 if name == otherName then

522 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)

551 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)

@@ -593,11 +622,12 @@ unifyRecord context firstStructure secondStructure =

593 do let (RecordStructure expFields expVar expStruct) = firstStructure

622 do let (RecordStructure expFields expVar expStruct) = firstStructure

594 let (RecordStructure actFields actVar actStruct) = secondStructure

623 let (RecordStructure actFields actVar actStruct) = secondStructure

595

624

625+ let sharedFields = Map.intersectionWith (,) expFields actFields

626+

596 -- call after unifying extension, make sure record shape matches before

627 -- call after unifying extension, make sure record shape matches before

597 -- looking into whether the particular field types match.

628 -- looking into whether the particular field types match.

598 let unifySharedFields otherFields ext =

629 let unifySharedFields otherFields ext =

599− do let sharedFields = Map.intersectionWith (,) expFields actFields

600− _ <- traverse (uncurry (subUnify context)) sharedFields

630+ do unifySharedFieldsHelp context sharedFields

601 let allFields = Map.union (Map.map fst sharedFields) otherFields

631 let allFields = Map.union (Map.map fst sharedFields) otherFields

602 merge context (Structure (Record1 allFields ext))

632 merge context (Structure (Record1 allFields ext))

603

633

@@ -610,10 +640,12 @@ unifyRecord context firstStructure secondStructure =

610 unifySharedFields Map.empty expVar

640 unifySharedFields Map.empty expVar

611

641

612 (Empty, _, _, False) ->

642 (Empty, _, _, False) ->

643+ mismatch context $ Just $

613− mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))

644+ Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)

614

645

615 (_, False, Empty, _) ->

646 (_, False, Empty, _) ->

647+ mismatch context $ Just $

616− mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))

648+ Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)

617

649

618 (_, False, _, True) ->

650 (_, False, _, True) ->

619 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))

651 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))

@@ -636,6 +668,29 @@ unifyRecord context firstStructure secondStructure =

636

668

637

669

638

670

671+unifySharedFieldsHelp :: Context -> Map.Map String (Variable, Variable) -> Unify ()

672+unifySharedFieldsHelp context sharedFields =

673+ do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)

674+ case Maybe.catMaybes maybeBadFields of

675+ [] ->

676+ return ()

677+

678+ badFields ->

679+ mismatch context (Just (Error.BadFields (reverse badFields)))

680+

681+

682+unifyField :: Context -> (String, (Variable, Variable)) -> Unify (Maybe (String, Maybe Error.Reason))

683+unifyField context (field, (expected, actual)) =

684+ do result <- lift $ runExceptT $ subUnify context expected actual

685+ case result of

686+ Right () ->

687+ return $ Nothing

688+

689+ Left (Mismatch maybeReason) ->

690+ return $ Just (field, maybeReason)

691+

692+

693+

639-- GATHER RECORD STRUCTURE

694-- GATHER RECORD STRUCTURE

640

695

641

696

src/Validate.hs+14−18

@@ -208,7 +208,7 @@ checkManager tagRegion managerType validDefs =

208getSimpleDefRegion :: A.Commented Valid.Def -> Maybe (String, R.Region)

209getSimpleDefRegion decl =

210 case decl of

211− A.A (region, _) (Valid.Def (A.A _ (Pattern.Var name)) _ _) ->

211+ A.A _ (Valid.Def region (A.A _ (Pattern.Var name)) _ _) ->

212 Just (name, region)

213

214 _ ->

@@ -353,15 +353,15 @@ vrdDefHelp remainingDecls (A.A ann def) ports structure =

353 case def of

354 Source.Definition pat expr ->

355 addDef

356− <$> validateDef pat expr Nothing

356+ <$> validateDef (fst ann) pat expr Nothing

357 <*> vrdHelp remainingDecls ports structure

358

359 Source.Annotation name tipe ->

360 case remainingDecls of

361− A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest

361+ A.A _ (D.Def (A.A defRegion (Source.Definition pat expr))) : rest

362 | Pattern.isVar name pat ->

363 addDef

364− <$> validateDef pat expr (Just tipe)

364+ <$> validateDef (R.merge (fst ann) defRegion) pat expr (Just tipe)

365 <*> vrdHelp rest ports structure

366

367 _ ->

@@ -391,32 +391,33 @@ definitionsHelp sourceDefs =

391 [] ->

392 return []

393

394− A.A _ (Source.Definition pat expr) : rest ->

394+ A.A defRegion (Source.Definition pat expr) : rest ->

395 (:)

396− <$> validateDef pat expr Nothing

396+ <$> validateDef defRegion pat expr Nothing

397 <*> definitionsHelp rest

398

399− A.A region (Source.Annotation name tipe) : rest ->

399+ A.A annRegion (Source.Annotation name tipe) : rest ->

400 case rest of

401− A.A _ (Source.Definition pat expr) : rest'

401+ A.A defRegion (Source.Definition pat expr) : rest'

402 | Pattern.isVar name pat ->

403 (:)

404− <$> validateDef pat expr (Just tipe)

404+ <$> validateDef (R.merge annRegion defRegion) pat expr (Just tipe)

405 <*> definitionsHelp rest'

406

407 _ ->

408− Result.throw region (Error.TypeWithoutDefinition name)

408+ Result.throw annRegion (Error.TypeWithoutDefinition name)

409

410

411validateDef

412+ :: R.Region

412− :: Pattern.Raw

413+ -> Pattern.Raw

413 -> Source.Expr

414 -> Source.Expr

414 -> Maybe Type.Raw

415 -> Maybe Type.Raw

415 -> Result wrn Valid.Def

416 -> Result wrn Valid.Def

416−validateDef pat expr maybeType =

417+validateDef region pat expr maybeType =

417 do validExpr <- expression expr

418 do validExpr <- expression expr

418 validateDefPattern pat validExpr

419 validateDefPattern pat validExpr

419− return $ Valid.Def pat validExpr maybeType

420+ return $ Valid.Def region pat validExpr maybeType

420

421

422

422validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result wrn ()

423validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result wrn ()

@@ -486,11 +487,6 @@ expression (A.A ann sourceExpression) =

486 Literal lit ->

487 Literal lit ->

487 return (Literal lit)

488 return (Literal lit)

488

489

489− Range lowExpr highExpr ->

490− Range

491− <$> expression lowExpr

492− <*> expression highExpr

493−

494 ExplicitList expressions ->

490 ExplicitList expressions ->

495 ExplicitList

491 ExplicitList

496 <$> T.traverse expression expressions

492 <$> T.traverse expression expressions