e9cfb68 · elk · git.iko.soy

elm-compiler.cabal+1−2

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

11

22Name: elm-compiler

3−Version: 0.17.1

3+Version: 0.18

44

55Synopsis:

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

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

130130 Type.Constrain.Literal,

131131 Type.Constrain.Pattern,

132132 Type.Environment,

133− Type.Fragment,

134133 Type.Inference,

135134 Type.Solve,

136135 Type.State,

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

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

22module AST.Expression.Canonical

33 ( Expr, Expr'

44 , Def(..)

5− , Facts(..), dummyFacts

65 , SortedDefs(..), toSortedDefs

76 )

87 where

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

2726

2827

2928data Def

30− = Def Facts 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")

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

4130

4231

4332

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

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

88-}

99module AST.Expression.General where

1010

11+import qualified Data.List as List

12+

1113import qualified AST.Effects as Effects

1214import qualified AST.Literal as Literal

1315import qualified AST.Module.Name as ModuleName

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

4244data Expr' ann def var typ

4345 = Literal Literal.Literal

4446 | Var var

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

4647 | ExplicitList [Expr ann def var typ]

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

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

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

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

9091

9192

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+

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

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

94113 case expr of

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

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

2424

2525data Facts = Facts

2626 { home :: Maybe ModuleName.Canonical

27− , dependencies :: [Var.TopLevel]

2827 }

2928

3029

3130dummyFacts :: Facts

3231dummyFacts =

33− Facts Nothing []

32+ Facts Nothing

3433

3534

3635-- EXPRESSIONS

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

3837data Expr

3938 = Literal Literal.Literal

4039 | Var Var.Canonical

41− | Range Expr Expr

4240 | ExplicitList [Expr]

4341 | Binop Var.Canonical Expr Expr

4442 | Function [String] Expr

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

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

2121

2222

2323data Def =

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

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

2525

2626

2727getPattern :: Def -> Pattern.Raw

28−getPattern (Def pattern _ _) =

28+getPattern (Def _ pattern _ _) =

2929 pattern

3030

src/AST/Helpers.hs+1−1

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

2929

3030isSymbol :: Char -> Bool

3131isSymbol c =

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

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

src/AST/Pattern.hs+42

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

11{-# OPTIONS_GHC -Wall #-}

22module AST.Pattern where

33

4+import qualified Data.List as List

45import qualified Data.Set as Set

56

67import qualified AST.Literal as L

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

107108boundVarList pattern =

108109 Set.toList (boundVarSet pattern)

109110

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

1616

1717

1818

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−

3019-- CANONICAL NAMES

3120

3221

src/Canonicalize.hs+7−9

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

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

8383 ( name, (args, body) )

8484

85− program =

85+ getProgram =

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

8787 in

88− do canonicalImports <- filterImports uses imports

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

89+ canonicalImports <- filterImports uses imports

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

9091 modul {

9192 Module.info =

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

324325 annTraverse canEntry entries =

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

326327

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

328− Canonical.Def Canonical.dummyFacts

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

329+ Canonical.Def region

329330 <$> canonicalizePattern env pat

330331 <*> canonicalizeExpr env expr

331332 <*> traverse (canonicalizeRegionType env) typ

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

366367 Literal lit ->

367368 Result.ok (Literal lit)

368369

369− Range lowExpr highExpr ->

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

371−

372370 Access record field ->

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

374372

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

411409 env' =

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

413411

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

415− Canonical.Def Canonical.dummyFacts

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

413+ Canonical.Def defRegion

416414 <$> canonicalizePattern env' p

417415 <*> canonicalizeExpr env' body

418416 <*> traverse (canonicalizeRegionType env') mtipe

src/Canonicalize/Body.hs+11−4

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

1313import qualified AST.Variable as Var

1414import qualified Canonicalize.Sort as Sort

1515import qualified Reporting.Annotation as A

16−import qualified Reporting.Region as R

16+import Reporting.Error.Canonicalize (Error)

17+import Reporting.Region (Region)

18+import Reporting.Result (Result)

1719

1820

1921

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

22+flatten

23+ :: (Monoid i)

24+ => ModuleName.Canonical

25+ -> Decl.Canonical

26+ -> Effects.Canonical

27+ -> Result i w Error Canonical.Expr

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

2229 let

2330 allDefs =

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

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

102109

103110

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

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

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

106113 Canonical.Def

107− Canonical.dummyFacts

114+ region

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

109116 expr

110117 (Just (A.A region tipe))

src/Canonicalize/Setup.hs+1−1

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

327327

328328 -- TO PATCHES

329329

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

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

331331 map topLevelValue (P.boundVarList pattern)

332332

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

src/Canonicalize/Sort.hs+234−123

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

11{-# OPTIONS_GHC -Wall #-}

22module Canonicalize.Sort (definitions) where

33

4−import Control.Monad.State

4+import qualified Data.Foldable as F

55import qualified Data.Graph as Graph

66import qualified Data.Map as Map

77import qualified Data.Maybe as Maybe

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

1212import qualified AST.Pattern as P

1313import qualified AST.Variable as V

1414import qualified Reporting.Annotation as A

15+import qualified Reporting.Error.Canonicalize as E

16+import qualified Reporting.Result as R

1517

1618

1719

18−-- STARTING POINT

20+-- SORT DEFINITIONS

1921

2022

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

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

2224definitions expression =

23− evalState (reorder expression) Set.empty

25+ let

26+ (R.Result _ warnings answer) =

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+

2439

40+instance Monoid LocalVars where

41+ mempty =

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

2543

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

27−free x =

28− modify (Set.insert x)

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

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

2946

3047

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

32−freeIfLocal (V.Canonical home name) =

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

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

3355 case home of

34− V.Local -> free name

35− V.TopLevel _ -> free name

36− V.BuiltIn -> return ()

37− V.Module _ -> return ()

56+ V.Local ->

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

58+

59+ V.TopLevel _ ->

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

61+

62+ V.BuiltIn ->

63+ return value

64+

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

3886

3987

4088

4189-- REORDER EXPRESSIONS

4290

4391

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

45−reorder (A.A ann expression) =

46− A.A ann <$>

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

93+reorder (A.A region expression) =

94+ A.A region <$>

4795 case expression of

48− -- Be careful adding and restricting freeVars

4996 Var var ->

50− do freeIfLocal var

51− return expression

97+ addImmediate var expression

5298

5399 Lambda pattern body ->

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

100+ delay $

101+ bindingReorder Lambda (pattern, body)

55102

56103 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

59106

60107 Case expr cases ->

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

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

62109

63110 Data name exprs ->

64− do free name

65− Data name <$> mapM reorder exprs

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

66112

67113 -- Just pipe the reorder though

68114 Literal _ ->

69115 return expression

70116

71− Range lowExpr highExpr ->

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

73−

74117 ExplicitList es ->

75− ExplicitList <$> mapM reorder es

118+ ExplicitList <$> traverse reorder es

76119

77120 App func arg ->

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

79122

80123 If branches finally ->

81124 If

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

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

83126 <*> reorder finally

84127

85128 Access record field ->

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

90133 Update record fields ->

91134 Update

92135 <$> reorder record

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

136+ <*> traverse (traverse reorder) fields

94137

95138 Record fields ->

96139 Record

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

140+ <$> traverse (traverse reorder) fields

98141

99142 Cmd _ ->

100143 return expression

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

119162

120163 -- Actually do some reordering

121164 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

123188

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

130189

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

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

133− bound pattern

134− mapM free (ctors pattern)

135190

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

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

191+-- FREE CONSTRUCTORS

138192

139− return let'

140193

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

141197

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

143−ctors (A.A _ pattern) =

198+

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

200+getPatternTags (A.A _ pattern) =

144201 case pattern of

145202 P.Var _ ->

146− []

203+ Set.empty

147204

148− P.Alias _ p ->

149− ctors p

205+ P.Alias _ subPattern ->

206+ getPatternTags subPattern

150207

151208 P.Record _ ->

152− []

209+ Set.empty

153210

154211 P.Anything ->

155− []

212+ Set.empty

156213

157214 P.Literal _ ->

158− []

215+ Set.empty

159216

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

161222 case home of

162− V.Local -> name : rest

163− V.TopLevel _ -> name : rest

164− V.BuiltIn -> rest

165− V.Module _ -> rest

166− where

167− rest = concatMap ctors ps

223+ V.Local ->

224+ Set.insert name freeCtors

225+

226+ V.TopLevel _ ->

227+ Set.insert name freeCtors

228+

229+ V.BuiltIn ->

230+ freeCtors

231+

232+ V.Module _ ->

233+ freeCtors

234+

235+

236+

237+-- REORDER DEFINITIONS

238+

168239

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

169248

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

171−bound pattern =

249+

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

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

172252 let

173− boundVars =

174− P.boundVarSet pattern

253+ (R.Result localVars warnings answer) =

254+ addPatternTags pattern =<< reorder body

255+

256+ toRawNodeHelp newBody =

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

175258 in

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

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

177260

178261

179−bindingReorder

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

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)

212−

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

214− realDeps pdefsDeps =

215− map convert pdefsDeps

216− where

217− varDict =

218− variableToKeyMap pdefsDeps

219−

220− convert (pdef, key, deps) =

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

222−

223−

224−reorderAndGetDependencies

225− :: Canonical.Def

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

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

228− do globalFrees <- get

229− -- work in a fresh environment

230− put Set.empty

231− expr' <- reorder expr

232− localFrees <- get

233− -- merge with global frees

234− modify (Set.union globalFrees)

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

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

263+toBoundVarDict defAndDeps =

264+ Map.fromList (concatMap toBoundVarDictHelp defAndDeps)

265+

266+

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

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

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

270+

271+

272+

273+-- BUILD GRAPHS

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 =

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

285+ in

286+ ( def, index, localDeps )

287+

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

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

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

307+detectLoops boundVarDict rawNodes =

308+ F.traverse_ detectLoopsHelp $

309+ Graph.stronglyConnComp $

310+ map (toNode immediateOnly boundVarDict) rawNodes

311+

312+

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

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 =

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

6060

6161 _ ->

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

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

6363 Just [v] ->

6464 logVar v

6565

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

104104 -> Int

105105 -> Result Var.Canonical

106106pvar 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

108108 Just [value] ->

109109 foundArgCheck value

110110

src/Docs/Centralize.hs+3−3

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

4646 value =

4747 Docs.Value

4848 maybeComment

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

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

5050 (Map.lookup name infixDict)

5151 in

5252 Just (name, A.A subregion value)

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

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

6060 let

6161 ctors' =

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

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

6363 in

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

6565

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

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

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

6969 ( name

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

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

7171 )

7272

7373

src/Docs/Check.hs+3−2

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

1111import qualified Docs.AST as Docs

1212import qualified Elm.Compiler.Type as Type

1313import Elm.Utils ((|>))

14+import Parse.Binop (infixOp)

1415import Parse.Helpers

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

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

1617 , var, whitespace

1718 )

1819import qualified Reporting.Annotation as A

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

156157 choice

157158 [ do string "@docs"

158159 whitespace

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

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

160161 , do anyUntil simpleNewline

161162 return []

162163 ]

src/Elm/Compiler.hs+28−16

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

1818import qualified AST.Module.Name as ModuleName

1919import qualified Compile

2020import qualified Docs.Check as Docs

21−import qualified Elm.Compiler.Version

21+import qualified Elm.Compiler.Imports as Imports

2222import qualified Elm.Compiler.Module as PublicModule

23+import qualified Elm.Compiler.Version

2324import qualified Elm.Docs as Docs

2425import qualified Elm.Package as Package

2526import qualified Generate.JavaScript as JS

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

5354 | Port

5455

5556

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

57−parseDependencies sourceCode =

57+parseDependencies

58+ :: Package.Name

59+ -> String

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

61+parseDependencies pkgName sourceCode =

5862 let

5963 (Result.Result _ _ answer) =

6064 Parse.parse sourceCode Parse.header

65+ in

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

6167

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

63− let

64− tag =

65− case sourceTag of

66− Module.Normal -> Normal

67− Module.Port _ -> Port

68− Module.Effect _ -> Effect

69− in

70− ( tag

71− , name

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

73− )

68+

69+getDeps

70+ :: Package.Name

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

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

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

74+ let

75+ tag =

76+ case sourceTag of

77+ Module.Normal -> Normal

78+ Module.Port _ -> Port

79+ Module.Effect _ -> Effect

80+

81+ deps =

82+ if pkgName == Package.core then

83+ map (fst . A.drop) imports

84+ else

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

7486 in

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

87+ ( tag, name, deps )

7688

7789

7890

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

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

1+{-# OPTIONS_GHC -Wall #-}

12module Elm.Compiler.Module

23 ( Interface, Interfaces

34 , ModuleName.Raw

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

56 , nameToString, nameFromString

67 , hyphenate, dehyphenate

78 , RawForJson(RawForJson), fromJson

8− , defaultImports

9− , interfaceAliasedTypes

9+ , interfaceAliasedTypes, programTypes

1010 , ModuleName.Canonical(..), qualifiedVar

1111 )

1212 where

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

2020

2121import qualified AST.Module as Module

2222import qualified AST.Module.Name as ModuleName

23−import qualified Elm.Compiler.Imports as Imports

24−import qualified Elm.Compiler.Type as Type

23+import qualified Elm.Compiler.Type as PublicType

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

2625import qualified Generate.JavaScript.Variable as Gen

2726

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

3635type Interfaces = Module.Interfaces

3736

3837

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

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

4039interfaceAliasedTypes 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

4246

4347

4448

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

5862 Gen.qualified

5963

6064

61−defaultImports :: [ModuleName.Raw]

62−defaultImports =

63− map fst Imports.defaults

64−

65−

6665

6766-- STRING CONVERSIONS for RAW NAMES

6867

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

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

11{-# LANGUAGE OverloadedStrings #-}

22module Elm.Compiler.Type

3− ( Type(..)

4− , toString

5− ) where

3+ ( Type(..), toString

4+ , Program(..)

5+ )

6+ where

67

78import Control.Arrow (second)

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

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

910import qualified Data.Aeson as Json

1011import qualified Data.Aeson.Types as Json

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

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

2021import qualified Reporting.Annotation as A

2122

2223

24+

2325data Type

2426 = Lambda Type Type

2527 | Var String

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

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

2931

3032

33+data Program =

34+ Program

35+ { _message :: Type

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

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

38+ }

39+

40+

41+

3142-- TO STRING

3243

44+

3345data Context = None | ADT | Function

3446

3547

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

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

128140

129141

142+

130143-- JSON for TYPE

131144

145+

132146instance Json.ToJSON Type where

133147 toJSON tipe =

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

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

145159 case value of

146160 Json.String text ->

147161 either failure (return . fromRawType)

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

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

149163

150164 Json.Object obj ->

151165 fromObject obj

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

154168 failure ()

155169

156170

171+replacePrimes :: String -> String

172+replacePrimes string =

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

174+

175+

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

158177fromObject obj =

159178 do tag <- obj .: "tag"

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

195214 Type.RRecord fields ext ->

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

197216

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−module Elm.Compiler.Type.Extract (toFullType, toAliasedType) where

1+{-# OPTIONS_GHC -Wall #-}

2+module Elm.Compiler.Type.Extract

3+ ( extract

4+ , extractProgram

5+ )

6+ where

27

3−import Control.Arrow (second)

4−import qualified AST.Type as Type

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

12+import qualified AST.Module as Module

13+import qualified AST.Module.Name as ModuleName

14+import qualified AST.Type as T

515import qualified AST.Variable as Var

6−import qualified Elm.Compiler.Type as T

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

717

818

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

10−toFullType astType =

11− toType False astType

1219

20+-- EXTRACTION

1321

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

15−toAliasedType astType =

16− toType True astType

1722

23+extract :: T.Canonical -> Type

24+extract astType =

25+ fst $ Writer.runWriter $ extractHelp astType

1826

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

20−toType useAliases astType =

27+

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 =

21101 let

22− go = toType useAliases

102+ (aliases, unions) =

103+ diff oldDeps currentDeps

23104 in

24− case astType of

25− Type.Lambda t1 t2 ->

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

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

106+ ( [], [] )

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+

27140

28− Type.Var x ->

29− T.Var x

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

142+get getInfo interfaces var =

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

144+ iface <- Map.lookup home interfaces

145+ Map.lookup name (getInfo iface)

30146

31− Type.Type var ->

32− T.Type (Var.toString var)

33147

34− Type.App t ts ->

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

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

149+getHome (Var.Canonical home name) =

150+ case home of

151+ Var.BuiltIn ->

152+ Nothing

36153

37− Type.Record fields ext ->

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

154+ Var.Module moduleName ->

155+ Just (moduleName, name)

39156

40− Type.Aliased name args t ->

41− if useAliases then

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

157+ Var.TopLevel moduleName ->

158+ Just (moduleName, name)

43159

44− else

45− go (Type.dealias args t)

160+ Var.Local ->

161+ Nothing

src/Elm/Utils.hs+3−2

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

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

1313import System.Process (readProcessWithExitCode)

1414

15+import qualified AST.Expression.Source as Source

1516import qualified AST.Pattern as Pattern

1617import qualified Parse.Helpers as Parse

1718import qualified Parse.Expression as Parse

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

99100

100101isDeclaration :: String -> Maybe String

101102isDeclaration string =

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

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

103+ case Parse.iParse Parse.def string of

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

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

105106

106107 _ ->

src/Generate/JavaScript.hs+1−1

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

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

4949 let

5050 managers =

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

51+ Var.coreNative "Platform" "effectManagers"

5252

5353 managerName =

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

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

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

11module Generate.JavaScript.BuiltIn

22 ( character, string

3− , list, range

3+ , list

44 , recordUpdate

55 , eq, cmp

66 , effect, outgoingPort, incomingPort

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

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

5151

5252

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

54−range low high =

55− nativeList "range" [ low, high ]

56−

57−

5853

5954-- RECORDS

6055

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

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

8787generateDef def =

8888 do (home, name, jsBody) <-

8989 case def of

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

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

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

9292

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

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

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

9595

9696 return (Var.define home name jsBody)

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

114114 Literal lit ->

115115 jsExpr (Literal.literal lit)

116116

117− Range lo hi ->

118− do lo' <- generateJsExpr lo

119− hi' <- generateJsExpr hi

120− jsExpr $ BuiltIn.range lo' hi'

121−

122117 Access record field ->

123118 do record' <- generateJsExpr record

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

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

149144 generateFunction args body

150145

151146 Call func args ->

152− let

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)

147+ generateCall func args

163148

164149 TailCall name argNames args ->

165150 let

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

233218

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

235220generateProgram kind body =

236− let

237− gen fields =

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

239− in

240− case kind of

241− Expr.VDom ->

242− gen []

221+ case kind of

222+ Expr.VDom ->

223+ do html <- generateJsExpr body

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

243225

244− Expr.NoFlags ->

245− gen []

226+ Expr.NoFlags ->

227+ do almostProgram <- generateJsExpr body

228+ jsExpr (almostProgram `call` [])

246229

247− Expr.Flags tipe ->

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

230+ Expr.Flags tipe ->

231+ do almostProgram <- generateJsExpr body

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

233+ jsExpr (almostProgram <| flagDecoder)

249234

250235

251236

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

287272

288273

289274

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+

290363-- GENERATE IFS

291364

292365

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

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

156156 Opt.Var (inJsonDecode name)

157157

158158

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

160−(=:) name decoder =

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

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

160+field name decoder =

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

162162

163163

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

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

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

215215

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

218218 in

219219 List.foldr andThen finalDecoder fields

src/Nitpick/PatternMatches.hs−3

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

135135 E.Var _ ->

136136 Result.ok ()

137137

138− E.Range low high ->

139− go2 low high

140−

141138 E.ExplicitList listExprs ->

142139 F.traverse_ go listExprs

143140

src/Nitpick/TopLevelTypes.hs+5−4

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

8686

8787 getMainKind =

8888 case Type.deepDealias mainType of

89− Type.App name [arg]

89+ Type.App name [_]

9090 | name == vdomNode ->

9191 return Expr.VDom

9292

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

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

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

9495 return Expr.NoFlags

9596

9697 | name == program ->

97− return (Expr.Flags arg)

98− <* Effects.checkPortType makeError arg

98+ return (Expr.Flags flags)

99+ <* Effects.checkPortType makeError flags

99100

100101 _ ->

101102 Result.throw region (Error.BadMain mainType)

src/Optimize.hs+8−18

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

3232

3333

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

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

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

3636 let

3737 (args, canBody) =

3838 Expr.collectLambdas expression

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

4545 return Nothing

4646 in

4747 do home <- maybeGetHome

48− optimizeDefHelp home deps pattern args canBody

48+ optimizeDefHelp home pattern args canBody

4949

5050

5151optimizeDefHelp

5252 :: Maybe ModuleName.Canonical

53− -> [Var.TopLevel]

5453 -> P.Canonical

5554 -> [P.Canonical]

5655 -> Can.Expr

5756 -> Env.Optimizer [Opt.Def]

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

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

5958 let

6059 facts =

61− Opt.Facts home deps

60+ Opt.Facts home

6261 in

6362 case (ptrn, args) of

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

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

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

126125patternToDefs home rootName pattern =

127126 let

128− (deps, rootExpr) =

127+ rootExpr =

129128 case home of

130129 Nothing ->

131− ( []

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

133− )

130+ Opt.Var (Var.local rootName)

134131

135132 Just moduleName ->

136− ( [ Var.TopLevelVar moduleName rootName ]

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

138− )

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

139134

140135 toDef (name, accessExpr) =

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

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

142137 in

143138 map toDef (patternToSubstitutions rootExpr pattern)

144139

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

206201 else

207202 pure (Opt.Var name)

208203

209− Expr.Range lowExpr highExpr ->

210− Opt.Range

211− <$> justConvert lowExpr

212− <*> justConvert highExpr

213−

214204 Expr.ExplicitList elements ->

215205 Opt.ExplicitList

216206 <$> T.traverse justConvert elements

src/Optimize/Inline.hs−6

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

100100 Var.TopLevel _ ->

101101 Map.empty

102102

103− Range lo hi ->

104− count2 lo hi

105−

106103 ExplicitList exprs ->

107104 countMany exprs

108105

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

210207 Var _ ->

211208 expression

212209

213− Range lo hi ->

214− Range (go lo) (go hi)

215−

216210 ExplicitList exprs ->

217211 ExplicitList (map go exprs)

218212

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

22

33import qualified Data.List as List

44import 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+ )

69

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

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

912import qualified AST.Expression.Source as Source

13+import qualified AST.Helpers as Help

1014import qualified AST.Variable as Var

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

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

1216import qualified Reporting.Annotation as A

1317

1418

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+

1559opLevel :: OpTable -> String -> Int

1660opLevel table op =

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

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

3074binops

3175 :: IParser Source.Expr

3276 -> IParser Source.Expr

33− -> IParser String

3477 -> IParser Source.Expr

35−binops term last anyOp =

78+binops term last =

3679 do e <- term

3780 table <- getState

3881 split table 0 e =<< nextOps

3982 where

4083 nextOps =

4184 choice

42− [ commitIf (whitespace >> anyOp) $

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

4386 do whitespace

44− op <- anyOp

87+ op <- infixOp

4588 whitespace

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

4790 case expr of

src/Parse/Declaration.hs+3−2

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

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

55

66import qualified AST.Declaration as Decl

7+import qualified Parse.Binop as Binop

78import qualified Parse.Expression as Expr

89import Parse.Helpers as Help

910import qualified Parse.Type as Type

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

3536

3637definition :: IParser Decl.Raw

3738definition =

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

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

3940 return $ Decl.Def def

4041

4142

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

7980 forcedWS

8081 n <- digit

8182 forcedWS

82− op <- anyOp

83+ op <- Binop.infixOp

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

8485

8586

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

22

33import qualified Data.List as List

44import Text.Parsec hiding (newline, spaces)

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

1515import qualified AST.Expression.Source as Source

1616import qualified AST.Literal as L

1717import qualified AST.Pattern as P

18−import qualified AST.Type as T

1918import qualified AST.Variable as Var

2019import qualified Reporting.Annotation as A

2120

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

7978

8079listTerm :: IParser Source.Expr'

8180listTerm =

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

83− where

84− range =

85− do lo <- expr

86− padded (string "..")

87− E.Range lo <$> expr

88−

89− shader' =

90− do pos <- getPosition

81+ choice

82+ [ do pos <- getPosition

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

9284 (rawSrc, tipe) <- Help.shader

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

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

87+ ]

9488

9589

9690parensTerm :: IParser Source.Expr

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

121115 in

122116 do (start, mkExpr, end) <-

123117 located $ choice $

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

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

125119 , parens (tupleFn <|> parenedExpr)

126120 ]

127121 return (mkExpr start end)

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

202196

203197binaryExpr :: IParser Source.Expr

204198binaryExpr =

205− Binop.binops appExpr lastExpr anyOp

199+ Binop.binops appExpr lastExpr

206200 where

207201 lastExpr =

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

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

272266letExpr =

273267 do try (reserved "let")

274268 whitespace

275− defs <-

276− Indent.block (def <* whitespace)

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

277270 whitespace

278271 reserved "in"

279272 whitespace

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

282275

283276def :: IParser Source.Def

284277def =

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 =

285297 choice

286− [ annotation Source.Annotation

287− , definition Source.Definition

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

299+ , Pattern.term

288300 ]

289301

290302

291−

292−-- TYPE ANNOTATION

293−

294−

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

296−annotation creator =

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

316− body <- expr

317− return . creator name $ makeFunction args body

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

304+defEnd start revArgs =

305+ choice

306+ [ do arg <- Pattern.term

307+ whitespace

308+ defEnd start (arg : revArgs)

309+ , do equals

310+ whitespace

311+ body <- expr

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

313+ ]

318314

319315

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

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

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

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)

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

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

src/Parse/Helpers.hs+113−74

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

11module Parse.Helpers where

22

33import Prelude hiding (until)

4−import Control.Monad (guard, join)

4+import Control.Monad (join)

55import Control.Monad.State (State)

66import Data.Char (isUpper)

77import qualified Data.Map as Map

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

1414import qualified AST.Declaration as Decl

1515import qualified AST.Expression.General as E

1616import qualified AST.Expression.Source as Source

17−import qualified AST.Helpers as Help

1817import qualified AST.Literal as L

1918import qualified AST.Variable as Variable

2019import qualified Reporting.Annotation as A

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

2221import qualified Reporting.Region as R

2322

2423

24+

2525reserveds :: [String]

2626reserveds =

2727 [ "if", "then", "else"

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

3535 ]

3636

3737

38+

3839-- ERROR HELP

3940

41+

4042expecting = flip (<?>)

4143

4244

45+

4346-- SETUP

4447

48+

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

4650type SourceM = State SourcePos

4751type IParser a = ParsecT String OpTable SourceM a

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

8690

8791innerVarChar :: IParser Char

8892innerVarChar =

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

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

9094

9195

9296makeVar :: IParser Char -> IParser String

9397makeVar firstChar =

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

95− if variable `elem` reserveds

96− then fail (Syntax.keyword variable)

97− else return variable

99+ choice

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

101+ failure (Syntax.prime variable)

102+ , if variable `elem` reserveds then

103+ failure (Syntax.keyword variable)

104+ else

105+ return variable

106+ ]

98107

99108

100109reserved :: String -> IParser String

101110reserved word =

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

103112 do string word

104− notFollowedBy innerVarChar

105− return word

106−

113+ choice

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

115+ failure (Syntax.prime word)

116+ , do notFollowedBy innerVarChar

117+ return word

118+ ]

107119

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

124120

125121

126122-- COMMON SYMBOLS

127123

124+

128125equals :: IParser String

129126equals =

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

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

147144 try (lookAhead check) >> p

148145

149146

147+

150148-- SEPARATORS

151149

150+

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

153152spaceySepBy1 sep parser =

154153 do value <- parser

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

216215 indented

217216

218217

218+

219219-- SURROUNDED BY

220220

221+

221222followedBy a b =

222223 do x <- a

223224 b

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

255256 surround '{' '}' "bracket"

256257

257258

259+

258260-- HELPERS FOR EXPRESSIONS

259261

262+

260263getMyPosition :: IParser R.Position

261264getMyPosition =

262265 R.fromSourcePos <$> getPosition

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

307310 notFollowedBy (char '.')

308311

309312

313+

310314-- WHITESPACE

311315

316+

312317padded :: IParser a -> IParser a

313318padded p =

314319 do whitespace

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

417422 ]

418423

419424

425+

420426-- ODD COMBINATORS

421427

428+

422429failure msg = do

423430 inp <- getInput

424431 setInput ('x':inp)

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

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

493500

494501

495−-- BASIC LANGUAGE LITERALS

502+

503+-- SHADERS

504+

496505

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

498507shader =

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

565574 _ -> []

566575

567576

577+

578+-- STRINGS AND CHARACTERS

579+

580+

568581str :: IParser String

569582str =

570− expecting "a string" $

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

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

573− where

574− rawString quote insides =

575− quote >> manyTill insides quote

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

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

585+ either (fail . show) return $

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

587+

576588

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

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

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

590+delimitedSequence quote insides =

591+ do quote

592+ concat <$> manyTill insides quote

579593

580− stringChar :: IParser String

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

582594

583− multilineStringChar :: IParser String

584− multilineStringChar =

585− do noEnd

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

587− where

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

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

595+multiStr :: IParser String

596+multiStr =

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

590598

591− newlineChar :: IParser String

592− newlineChar =

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

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

595599

600+singleStr :: IParser String

601+singleStr =

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

596603

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

598−sandwich delim s =

599− delim : s ++ [delim]

604+

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

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

600655

601656

602657escaped :: Char -> IParser String

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

607662 return ['\\', c]

608663

609664

610−chr :: IParser Char

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

627−processAs processor s =

628− calloutParser s (processor lexer)

665+processAs

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

667+ -> String

668+ -> Either ParseError a

669+processAs processor string =

670+ iParse (processor lexer) string

629671 where

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

631− calloutParser inp p =

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

633−

634672 lexer :: T.GenTokenParser String u SourceM

635− lexer = T.makeTokenParser elmDef

673+ lexer =

674+ T.makeTokenParser elmDef

636675

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

638677 elmDef :: T.GenLanguageDef String u SourceM

src/Parse/Module.hs+2−1

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

33

44import Text.Parsec hiding (newline, spaces)

55

6+import Parse.Binop (infixOp)

67import Parse.Helpers

78import qualified AST.Module as Module

89import qualified AST.Module.Name as ModuleName

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

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

169170 where

170171 val =

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

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

172173

173174 tipe =

174175 do name <- capVar

src/Reporting/Error/Canonicalize.hs+73

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

55import qualified Data.Char as Char

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

77

8+import qualified AST.Expression.Canonical as Canonical

89import qualified AST.Module.Name as ModuleName

10+import qualified AST.Pattern as P

911import qualified AST.Type as Type

1012import qualified AST.Variable as Var

1113import qualified Reporting.Annotation as A

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

1719

1820data Error

1921 = Var VarError

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

2023 | Pattern PatternError

2124 | Alias AliasError

2225 | Import ModuleName.Raw ImportError

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

154157 ("Cannot find " ++ var)

155158 (Help.maybeYouWant suggestions)

156159

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+

157169 Pattern patternError ->

158170 case patternError of

159171 PatternArgMismatch var expected actual ->

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

281293 Var (VarError _ _ _ suggestions) ->

282294 Just suggestions

283295

296+ BadRecursion _ _ _ ->

297+ Nothing

298+

284299 Pattern _ ->

285300 Nothing

286301

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

326341 Type.RRecord fields ext ->

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

328343

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

11{-# OPTIONS_GHC -Wall #-}

22module Reporting.Error.Helpers

33 ( (|>)

4− , functionName, hintLink, stack, reflowParagraph

4+ , functionName, args

5+ , hintLink, stack, reflowParagraph

56 , commaSep, capitalize, ordinalize, drawCycle

6− , findPotentialTypos, vetTypos

7+ , findPotentialTypos, findTypoPairs, vetTypos

78 , nearbyNames, distance, maybeYouWant

89 )

910 where

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

4748 "`" ++ opName ++ "`"

4849

4950

51+args :: Int -> String

52+args n =

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

54+

55+

5056hintLink :: String -> String

5157hintLink fileName =

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

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

132138-- FIND TYPOS

133139

134140

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

136−findPotentialTypos leftOnly rightOnly =

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

142+findPotentialTypos knownNames badName =

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

144+

145+

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

147+findTypoPairs leftOnly rightOnly =

137148 let

138149 veryNear leftName =

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

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

140151 in

141152 concatMap veryNear leftOnly

142153

src/Reporting/Error/Syntax.hs+16

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

328328 "KEYWORD=" ++ kwd

329329

330330

331+prime :: String -> String

332+prime var =

333+ "PRIME=" ++ var

334+

335+

331336data SpecialMessage

332337 = MsgKeyword String

338+ | MsgPrime String

333339 | MsgTab

334340

335341

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

338344 if List.isPrefixOf "KEYWORD=" message then

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

340346

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

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

349+

341350 else if tab == message then

342351 Just MsgTab

343352

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

388397 , Just "Rename it to something else."

389398 )

390399

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+

391407 Just MsgTab ->

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

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

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

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

11{-# OPTIONS_GHC -Wall #-}

22module Reporting.Error.Type where

33

4+import Control.Arrow (first, second)

5+import qualified Data.List as List

46import qualified Data.Map as Map

57import qualified Data.Maybe as Maybe

68import Text.PrettyPrint.ANSI.Leijen

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

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

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

911 )

1012

1113import qualified AST.Type as Type

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

3638

3739

3840data Reason

39− = MessyFields [String] [String]

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

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

4043 | IntFloat

4144 | TooLongComparableTuple Int

45+ | MissingArgs Int

4246 | BadVar (Maybe VarType) (Maybe VarType)

4347

4448

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

6569 | Function (Maybe Var.Canonical)

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

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

68− | BadTypeAnnotation String

72+ | ReturnType String Int Int Region.Region

6973 | Instance String

7074 | Literal String

7175 | Pattern Pattern

7276 | Shader

73− | Range

7477 | Lambda

78+ | Access (Maybe String) String

7579 | Record

7680 -- effect manager problems

7781 | Manager String

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

142146 report =

143147 Report.report "TYPE MISMATCH"

144148

149+ typicalHints =

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

151+

145152 cmpHint leftWords rightWords extraHints =

146153 comparisonHint localizer leftType rightType leftWords rightWords

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

148− ++ map toHint extraHints

149− )

154+ (typicalHints ++ map toHint extraHints)

150155 in

151156 case hint of

152157 CaseBranch branchNumber region ->

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

227232 ListElement elementNumber region ->

228233 report

229234 (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.")

231236 ( cmpHint

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

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

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

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

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

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

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

236243 ]

237244 )

238245

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

261268 BinopRight op region ->

262269 report

263270 (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.")

265272 ( cmpHint

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

267− "But the right argument is:"

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

274+ "But the right side is:"

268275 ( binopHint op leftType rightType

269276 ++

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

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

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

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

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

273280 ]

274281 )

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

301308 UnexpectedArg maybeName 1 1 region ->

302309 report

303310 (Just region)

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

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

305312 ( cmpHint

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

307314 "But it is:"

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

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

352359

353360 FunctionArity maybeName expected actual region ->

354− let

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

356− in

357− report

358− (Just region)

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

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

361− )

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

361+ report

362+ (Just region)

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

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

365+ )

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

363367

364− BadTypeAnnotation name ->

368+ ReturnType name typeArity argArity region ->

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

365370 report

366− Nothing

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

371+ (Just region)

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

368373 ( cmpHint

369− "The type annotation is saying:"

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

371− []

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

375+ )

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)

372389 )

373390

374391 Instance name ->

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

421438 []

422439 )

423440

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−

434441 Lambda ->

435442 report

436443 Nothing

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

441448 []

442449 )

443450

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+

444475 Record ->

445476 report

446477 Nothing

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

563594

564595

565596

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+

566627-- MISMATCH HELPERS

567628

568629

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

593654flipReason :: Reason -> Reason

594655flipReason reason =

595656 case reason of

596− MessyFields leftOnly rightOnly ->

597− MessyFields rightOnly leftOnly

657+ BadFields fields ->

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

659+

660+ MessyFields both left right ->

661+ MessyFields both right left

598662

599663 IntFloat ->

600664 IntFloat

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

602666 TooLongComparableTuple len ->

603667 TooLongComparableTuple len

604668

669+ MissingArgs num ->

670+ MissingArgs num

671+

605672 BadVar left right ->

606673 BadVar right left

607674

608675

609676reasonToString :: Reason -> Maybe Doc

610677reasonToString 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 =

611725 let

612726 go msg =

613− Just (toHint msg)

727+ Just (msg, [])

614728 in

615729 case reason of

616− MessyFields leftOnly rightOnly ->

617− do let typos = Help.findPotentialTypos leftOnly rightOnly

618− _ <- Help.vetTypos typos

619− misspellingMessage typos

730+ BadFields fields ->

731+ go $

732+ "I am seeing issues with the "

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

734+ ++ badFieldElaboration

735+

736+ MessyFields both leftOnly rightOnly ->

737+ messyFieldsHelp both leftOnly rightOnly

620738

621739 IntFloat ->

622− go

740+ go $

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

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

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

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

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

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

631749

750+ MissingArgs num ->

751+ go $

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

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

754+

632755 BadVar (Just Comparable) _ ->

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

634757

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

638761 BadVar (Just CompAppend) _ ->

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

640763

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

642− go doubleRigidError

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

765+ go $ doubleRigidError maybeLeftName maybeRightName

643766

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

645− go singleRigidError

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

768+ go $ singleRigidError maybeName

646769

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

648− go singleRigidError

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

771+ go $ singleRigidError maybeName

649772

650773 BadVar _ _ ->

651774 Nothing

652775

653776

654−singleRigidError :: String

655−singleRigidError =

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

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

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

777+badFieldElaboration :: String

778+badFieldElaboration =

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

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

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

659782

660783

661−doubleRigidError :: String

662−doubleRigidError =

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

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

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

784+weirdRigidError :: String

785+weirdRigidError =

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

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

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

819+

820+ _ ->

821+ weirdRigidError

666822

667823

668824hintDoc :: Doc

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

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

676832

677833

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

679−misspellingMessage typos =

680− if null typos then

681− Nothing

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

835+messyFieldsHelp both leftOnly rightOnly =

836+ case (leftOnly, rightOnly) of

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

838+ oneMissingField both missingField

682839

683− else

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

841+ oneMissingField both missingField

842+

843+ ([], missingFields) ->

844+ manyMissingFields both missingFields

845+

846+ (missingFields, []) ->

847+ manyMissingFields both missingFields

848+

849+ _ ->

684850 let

685− maxLen =

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

851+ typoPairs =

852+ case Help.findTypoPairs leftOnly rightOnly of

853+ [] ->

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

855+

856+ pairs ->

857+ pairs

687858 in

688− Just $ hang 4 $ vcat $

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

690− : text ""

691− : map (pad maxLen) typos

692−

693−

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

695−pad maxLen (leftField, rightField) =

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

697− <> dullyellow (text leftField)

698− <+> text "<->"

699− <+> dullyellow (text rightField)

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

903+ Just

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

905+ ++ Help.commaSep missingFields

906+ , []

907+ )

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+

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

927+padTypo arrow maxLen (missingField, knownField) =

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

929+ <> dullyellow (text missingField)

930+ <+> text arrow

931+ <+> dullyellow (text knownField)

700932

701933

702934

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

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

169169 go = diff localizer

170170 in

171171 case (leftType, rightType) of

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

173− let

174− leftParts = Type.collectLambdas leftType

175− rightParts = Type.collectLambdas rightType

176− in

172+ (Type.Aliased leftName leftArgs _, Type.Aliased rightName rightArgs _) | leftName == rightName ->

173+ docAppHelp localizer context leftName

174+ <$> sequenceA (zipWith (go App) (map snd leftArgs) (map snd rightArgs))

177175

178− if length leftParts /= length rightParts then

179− difference

180− (docLambda context (map (docType localizer Func) leftParts))

181− (docLambda context (map (docType localizer Func) rightParts))

176+ (Type.Lambda _ _, _) ->

177+ diffLambda localizer context leftType rightType

182178

183− else

184− docLambda context <$> sequenceA (zipWith (go Func) leftParts rightParts)

179+ (_, Type.Lambda _ _) ->

180+ diffLambda localizer context leftType rightType

185181

186182 (Type.Var x, Type.Var y) | x == y ->

187183 pure (text x)

@@ -216,16 +212,6 @@ diff localizer context leftType rightType =

216212 in

217213 diffRecord localizer leftFields leftExt rightFields rightExt

218214

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−

229215 (_, _) ->

230216 difference

231217 (docType localizer context leftType)

@@ -238,6 +224,37 @@ difference leftDoc rightDoc =

238224

239225

240226

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+

241258-- RECORD DIFFS

242259

243260

@@ -304,8 +321,8 @@ unzipDiffs diffPairs =

304321analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )

305322analyzeFields leftOnly rightOnly =

306323 let

307− potentialTypos =

308− Help.findPotentialTypos leftOnly rightOnly

324+ typoPairs =

325+ Help.findTypoPairs leftOnly rightOnly

309326

310327 mkField func name =

311328 ( func (text name), text "..." )

@@ -313,7 +330,7 @@ analyzeFields leftOnly rightOnly =

313330 mkFieldWith counts name =

314331 mkField (if Set.member name counts then dullyellow else id) name

315332 in

316− case Help.vetTypos potentialTypos of

333+ case Help.vetTypos typoPairs of

317334 Just (leftTypos, rightTypos) ->

318335 ( map (mkFieldWith leftTypos) leftOnly

319336 , map (mkFieldWith rightTypos) rightOnly

src/Type/Constrain/Effects.hs+3−11

@@ -14,11 +14,7 @@ import Type.Type

1414 )

1515

1616

17−constrain

18− :: Env.Environment

19− -> ModuleName.Canonical

20− -> Effects.Canonical

21− -> IO TypeConstraint

17+constrain :: Env.Env -> ModuleName.Canonical -> Effects.Canonical -> IO TypeConstraint

2218constrain env moduleName effects =

2319 case effects of

2420 Effects.None ->

@@ -31,11 +27,7 @@ constrain env moduleName effects =

3127 constrainHelp env moduleName info

3228

3329

34−constrainHelp

35− :: Env.Environment

36− -> ModuleName.Canonical

37− -> Effects.Info

38− -> IO TypeConstraint

30+constrainHelp :: Env.Env -> ModuleName.Canonical -> Effects.Info -> IO TypeConstraint

3931constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =

4032 let

4133 task t =

@@ -87,7 +79,7 @@ constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =

8779

8880

8981addEffectArgs

90− :: Env.Environment

82+ :: Env.Env

9183 -> ModuleName.Canonical

9284 -> Effects.ManagerType

9385 -> Variable

src/Type/Constrain/Expression.hs+96−91

@@ -18,21 +18,12 @@ import qualified Type.Constrain.Effects as Effects

1818import qualified Type.Constrain.Literal as Literal

1919import qualified Type.Constrain.Pattern as Pattern

2020import qualified Type.Environment as Env

21−import qualified Type.Fragment as Fragment

2221import Type.Type hiding (Descriptor(..))

2322

2423

2524

26−constrain

27− :: Env.Environment

28− -> Canonical.Expr

29− -> Type

30− -> IO TypeConstraint

25+constrain :: Env.Env -> Canonical.Expr -> Type -> IO TypeConstraint

3126constrain env annotatedExpr@(A.A region expression) tipe =

32− let

33− list t =

34− Env.getType env "List" <| t

35− in

3627 case expression of

3728 E.Literal lit ->

3829 Literal.constrain env region lit tipe

@@ -82,16 +73,6 @@ constrain env annotatedExpr@(A.A region expression) tipe =

8273 E.Var var ->

8374 return (CInstance region (V.toString var) tipe)

8475

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−

9576 E.ExplicitList exprs ->

9677 constrainList env region exprs tipe

9778

@@ -101,14 +82,11 @@ constrain env annotatedExpr@(A.A region expression) tipe =

10182 E.Lambda pattern body ->

10283 exists $ \argType ->

10384 exists $ \resType ->

104− do fragment <- Pattern.constrain env pattern argType

85+ do (Pattern.Info headers vars cons) <- Pattern.constrain env pattern argType

10586 bodyCon <- constrain env body resType

106− let con =

107− ex (Fragment.vars fragment)

108− (CLet [monoscheme (Fragment.typeEnv fragment)]

109− (Fragment.typeConstraint fragment /\ bodyCon)

110− )

111− return $ con /\ CEqual Error.Lambda region (argType ==> resType) tipe

87+ return $

88+ ex vars (CLet [monoscheme headers] (cons /\ bodyCon))

89+ /\ CEqual Error.Lambda region (argType ==> resType) tipe

11290

11391 E.App _ _ ->

11492 let

@@ -132,9 +110,14 @@ constrain env annotatedExpr@(A.A region expression) tipe =

132110 do c' <- constrain env e x

133111 return (x ==> t, c /\ c')

134112

135− E.Access expr label ->

136− exists $ \t ->

137− constrain env expr (record (Map.singleton label tipe) t)

113+ E.Access expr field ->

114+ exists $ \recordType ->

115+ exists $ \ext ->

116+ do recordCon <- constrain env expr recordType

117+ let maybeBody = E.collectFields expr

118+ let desiredType = record (Map.singleton field tipe) ext

119+ let fieldCon = CEqual (Error.Access maybeBody field) region recordType desiredType

120+ return $ recordCon /\ fieldCon

138121

139122 E.Update expr fields ->

140123 exists $ \t ->

@@ -181,7 +164,7 @@ constrain env annotatedExpr@(A.A region expression) tipe =

181164

182165

183166constrainApp

184− :: Env.Environment

167+ :: Env.Env

185168 -> R.Region

186169 -> Canonical.Expr

187170 -> [Canonical.Expr]

@@ -210,7 +193,7 @@ constrainApp env region f args tipe =

210193

211194

212195argConstraints

213− :: Env.Environment

196+ :: Env.Env

214197 -> Maybe V.Canonical

215198 -> R.Region

216199 -> Int

@@ -264,7 +247,7 @@ argConstraints env name region totalArgs overallVar index args =

264247

265248

266249constrainBinop

267− :: Env.Environment

250+ :: Env.Env

268251 -> R.Region

269252 -> V.Canonical

270253 -> Canonical.Expr

@@ -299,12 +282,7 @@ constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightReg

299282-- CONSTRAIN LISTS

300283

301284

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

308286constrainList env region exprs tipe =

309287 do (exprInfo, exprCons) <-

310288 unzip <$> mapM elementConstraint exprs

@@ -327,7 +305,7 @@ constrainList env region exprs tipe =

327305

328306

329307constrainIf

330− :: Env.Environment

308+ :: Env.Env

331309 -> R.Region

332310 -> [(Canonical.Expr, Canonical.Expr)]

333311 -> Canonical.Expr

@@ -386,7 +364,7 @@ constrainIf env region branches finally tipe =

386364

387365

388366constrainCase

389− :: Env.Environment

367+ :: Env.Env

390368 -> R.Region

391369 -> Canonical.Expr

392370 -> [(P.Canonical, Canonical.Expr)]

@@ -405,11 +383,11 @@ constrainCase env region expr branches tipe =

405383 where

406384 branch patternType (pattern, branchExpr@(A.A branchRegion _)) =

407385 do branchVar <- mkVar Nothing

408− fragment <- Pattern.constrain env pattern patternType

386+ scheme <- Pattern.infoToScheme <$> Pattern.constrain env pattern patternType

409387 branchCon <- constrain env branchExpr (VarN branchVar)

410388 return

411389 ( (branchVar, branchRegion)

412− , CLet [Fragment.toScheme fragment] branchCon

390+ , CLet [scheme] branchCon

413391 )

414392

415393 varToCon var =

@@ -516,83 +494,110 @@ data Info = Info

516494 }

517495

518496

519−constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info

520−constrainDef env info (Canonical.Def _ (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

497+constrainDef :: Env.Env -> Info -> Canonical.Def -> IO Info

498+constrainDef env info (Canonical.Def defRegion (A.A patternRegion pattern) expr maybeTipe) =

523499 case (pattern, maybeTipe) of

524− (P.Var name, Just (A.A typeRegion tipe)) ->

525− constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe

526−

527500 (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

529505

530506 _ ->

531507 error "canonical definitions must not have complex patterns as names in the contstraint generation phase"

532508

533509

534−constrainAnnotatedDef

535− :: Env.Environment

510+constrainUnannotatedDef

511+ :: Env.Env

512+ -> R.Region

513+ -> String

514+ -> Canonical.Expr

536515 -> 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

538530 -> R.Region

539531 -> R.Region

540532 -> String

541533 -> Canonical.Expr

542534 -> ST.Canonical

535+ -> Info

543536 -> IO Info

544−constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe =

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

537+constrainAnnotatedDef env defRegion region name expr tipe info =

538+ do (flexType, flexVars) <- Env.instantiateType Flex env tipe

553539

554540 let scheme =

555541 Scheme

556542 { _rigidQuantifiers = []

557− , _flexibleQuantifiers = flexiVars ++ vars

543+ , _flexibleQuantifiers = Map.elems flexVars

558544 , _constraint = CTrue

559− , _header = Map.singleton name (A.A patternRegion typ)

545+ , _header = Map.singleton name (A.A region flexType)

560546 }

561547

562− var <- mkVar Nothing

563− defCon <- constrain env' expr (VarN var)

564− let annCon =

565− CEqual (Error.BadTypeAnnotation name) typeRegion typ (VarN var)

548+ defCon <- constrainAnnDefHelp expr tipe (ArgInfo name defRegion env [] [])

566549

567550 return $ info

568551 { iSchemes = scheme : iSchemes info

569− , iC1 = iC1 info /\ ex [var] (defCon /\ fl rigidVars annCon)

552+ , iC1 = iC1 info /\ defCon

570553 }

571554

572555

573−constrainUnannotatedDef

574− :: Env.Environment

575− -> Info

576− -> [String]

577− -> R.Region

578− -> String

579− -> Canonical.Expr

580− -> IO Info

581−constrainUnannotatedDef env info qs patternRegion name expr =

582− do -- Some mistake may be happening here. Currently, qs is always [].

583− rigidVars <- mapM mkRigid qs

556+data ArgInfo =

557+ ArgInfo

558+ { _name :: String

559+ , _def :: R.Region

560+ , _env :: Env.Env

561+ , _args :: [(P.Canonical, Type)]

562+ , _vars :: [Variable]

563+ }

584564

585− v <- mkVar Nothing

586565

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

588571

589− let env' = Env.addValues env (zip qs rigidVars)

572+ constrainAnnDefHelp result resultType $

573+ ArgInfo

574+ { _name = name

575+ , _def = defRegion

576+ , _env = Env.addValues newVars env

577+ , _args = (arg, rigidArgType) : args

578+ , _vars = Map.elems newVars ++ vars

579+ }

590580

591− con <- constrain env' expr tipe

581+ (A.A region _, _) ->

582+ do (rigidType, newVars) <- Env.instantiateType Rigid env tipe

592583

593− return $ info

594− { iRigid = rigidVars ++ iRigid info

595− , iFlex = v : iFlex info

596− , iHeaders = Map.insert name (A.A patternRegion tipe) (iHeaders info)

597− , iC2 = con /\ iC2 info

598− }

584+ let finalEnv = Env.addValues newVars env

585+ let finalArgs = reverse args

586+ let rigidVars = Map.elems newVars ++ vars

587+

588+ (Pattern.Info headers argVars argCons) <-

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

77import qualified Type.Environment as Env

88

99

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

1611constrain env region literal tipe =

1712 do definiteType <- litType

1813 return (T.CEqual (Error.Literal name) region definiteType tipe)

src/Type/Constrain/Pattern.hs+73−33

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

1−module Type.Constrain.Pattern where

1+{-# OPTIONS_GHC -Wall #-}

2+module Type.Constrain.Pattern (Info(..), joinInfos, infoToScheme, constrain) where

23

34import Control.Arrow (second)

45import qualified Control.Monad as Monad

6+import qualified Data.List as List

57import qualified Data.Map as Map

68

79import qualified AST.Pattern as P

@@ -10,11 +12,50 @@ import qualified Reporting.Annotation as A

1012import qualified Reporting.Error.Type as Error

1113import qualified Type.Constrain.Literal as Literal

1214import qualified Type.Environment as Env

13−import Type.Fragment

1415import Type.Type

1516

1617

17−constrain :: Env.Environment -> P.Canonical -> Type -> IO Fragment

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+

58+constrain :: Env.Env -> P.Canonical -> Type -> IO Info

1859constrain env (A.A region pattern) tipe =

1960 let

2061 equal patternError leftType rightType =

@@ -23,50 +64,49 @@ constrain env (A.A region pattern) tipe =

2364 rvar v =

2465 A.A region (VarN v)

2566 in

26− case pattern of

27− P.Anything ->

28− return emptyFragment

67+ case pattern of

68+ P.Anything ->

69+ return emptyInfo

2970

30− P.Literal lit ->

71+ P.Literal lit ->

3172 do c <- Literal.constrain env region lit tipe

32− return $ emptyFragment { typeConstraint = c }

73+ return $ emptyInfo { _cons = c }

3374

34− P.Var name ->

75+ P.Var name ->

3576 do variable <- mkVar Nothing

36− return $ Fragment

37− { typeEnv = Map.singleton name (rvar variable)

38− , vars = [variable]

39− , typeConstraint =

40− equal (Error.PVar name) (VarN variable) tipe

77+ return $ Info

78+ { _headers = Map.singleton name (rvar variable)

79+ , _vars = [variable]

80+ , _cons = equal (Error.PVar name) (VarN variable) tipe

4181 }

4282

43− P.Alias name p ->

83+ P.Alias name ptrn ->

4484 do variable <- mkVar Nothing

45− fragment <- constrain env p tipe

46− return $ fragment

47− { typeEnv = Map.insert name (rvar variable) (typeEnv fragment)

48− , vars = variable : vars fragment

49− , typeConstraint =

85+ info <- constrain env ptrn tipe

86+ return $ info

87+ { _headers = Map.insert name (rvar variable) (_headers info)

88+ , _vars = variable : _vars info

89+ , _cons =

5090 equal (Error.PAlias name) (VarN variable) tipe

51− /\ typeConstraint fragment

91+ /\ _cons info

5292 }

5393

54− P.Data name patterns ->

94+ P.Data name patterns ->

5595 do let stringName = V.toString name

5696

5797 (_kind, cvars, args, result) <-

5898 Env.freshDataScheme env stringName

5999

60100 fragList <- Monad.zipWithM (constrain env) patterns args

61− let fragment = joinFragments fragList

62− return $ fragment

63− { vars = cvars ++ vars fragment

64− , typeConstraint =

65− typeConstraint fragment

66− /\ equal (Error.PData stringName) tipe result

101+ let info = joinInfos fragList

102+ return $ info

103+ { _vars = cvars ++ _vars info

104+ , _cons =

105+ equal (Error.PData stringName) result tipe

106+ /\ _cons info

67107 }

68108

69− P.Record fields ->

109+ P.Record fields ->

70110 do pairs <-

71111 mapM (\name -> (,) name <$> mkVar Nothing) fields

72112

@@ -79,8 +119,8 @@ constrain env (A.A region pattern) tipe =

79119 con <- exists $ \t ->

80120 return (equal Error.PRecord tipe (record unannotatedTenv t))

81121

82− return $ Fragment

83− { typeEnv = tenv

84− , vars = map snd pairs

85− , typeConstraint = con

122+ return $ Info

123+ { _headers = tenv

124+ , _vars = map snd pairs

125+ , _cons = con

86126 }

src/Type/Environment.hs+38−40

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

11{-# OPTIONS_GHC -Wall #-}

22module Type.Environment

3− ( Environment

3+ ( Env

44 , initialize

55 , getType, freshDataScheme, ctorNames

66 , addValues

@@ -9,7 +9,6 @@ module Type.Environment

99 where

1010

1111import qualified Control.Monad.State as State

12−import qualified Data.List as List

1312import Data.Map ((!))

1413import qualified Data.Map as Map

1514import qualified Data.Set as Set

@@ -24,18 +23,18 @@ type TypeDict = Map.Map String Type

2423type VarDict = Map.Map String Variable

2524

2625

27−data Environment = Environment

26+data Env = Env

2827 { _constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))

2928 , _types :: TypeDict

3029 , _value :: TypeDict

3130 }

3231

3332

34−initialize :: [Module.CanonicalUnion] -> IO Environment

33+initialize :: [Module.CanonicalUnion] -> IO Env

3534initialize datatypes =

3635 do types <- makeTypes datatypes

3736 let env =

38− Environment

37+ Env

3938 { _constructor = Map.empty

4039 , _value = Map.empty

4140 , _types = types

@@ -72,7 +71,7 @@ makeTypes datatypes =

7271

7372

7473makeConstructors

75− :: Environment

74+ :: Env

7675 -> [Module.CanonicalUnion]

7776 -> Map.Map String (IO (Int, [Variable], [Type], Type))

7877makeConstructors env datatypes =

@@ -100,7 +99,7 @@ makeConstructors env datatypes =

10099

101100

102101ctorToType

103− :: Environment

102+ :: Env

104103 -> (V.Canonical, Module.UnionInfo V.Canonical)

105104 -> [(String, IO (Int, [Variable], [Type], Type))]

106105ctorToType env (name, (tvars, ctors)) =

@@ -114,8 +113,8 @@ ctorToType env (name, (tvars, ctors)) =

114113

115114 go :: (V.Canonical, [T.Canonical]) -> State.StateT VarDict IO ([Type], Type)

116115 go (_, args) =

117− do types <- mapM (instantiator env) args

118− returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))

116+ do types <- mapM (instantiator Flex env) args

117+ returnType <- instantiator Flex env (T.App (T.Type name) (map T.Var tvars))

119118 return (types, returnType)

120119

121120

@@ -123,62 +122,56 @@ ctorToType env (name, (tvars, ctors)) =

123122-- ACCESS TYPES

124123

125124

126−get :: (Environment -> Map.Map String a) -> Environment -> String -> a

125+get :: (Env -> Map.Map String a) -> Env -> String -> a

127126get subDict env key =

128127 Map.findWithDefault (error msg) key (subDict env)

129128 where

130129 msg = "Could not find type constructor `" ++ key ++ "` while checking types."

131130

132131

133−getType :: Environment -> String -> Type

132+getType :: Env -> String -> Type

134133getType =

135134 get _types

136135

137136

138−freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

137+freshDataScheme :: Env -> String -> IO (Int, [Variable], [Type], Type)

139138freshDataScheme =

140139 get _constructor

141140

142141

143−ctorNames :: Environment -> [String]

142+ctorNames :: Env -> [String]

144143ctorNames env =

145144 Map.keys (_constructor env)

146145

147146

147+

148148-- UPDATE ENVIRONMENT

149149

150150

151−addValues :: Environment -> [(String, Variable)] -> Environment

152−addValues env newValues =

153− env

154− { _value =

155− List.foldl'

156− (\dict (name, var) -> Map.insert name (VarN var) dict)

157− (_value env)

158− newValues

159− }

151+addValues :: VarDict -> Env -> Env

152+addValues newValues env =

153+ env { _value = Map.union (_value env) (Map.map VarN newValues) }

160154

161155

162156

163157-- INSTANTIATE TYPES

164158

165159

166−instantiateType :: Environment -> T.Canonical -> VarDict -> IO ([Variable], Type)

167−instantiateType env sourceType dict =

168− do (tipe, dict') <- State.runStateT (instantiator env sourceType) dict

169− return (Map.elems dict', tipe)

160+instantiateType :: Flex -> Env -> T.Canonical -> IO (Type, VarDict)

161+instantiateType flex env sourceType =

162+ State.runStateT (instantiator flex env sourceType) Map.empty

170163

171164

172−instantiator :: Environment -> T.Canonical -> State.StateT VarDict IO Type

173−instantiator env sourceType =

174− instantiatorHelp env Set.empty sourceType

165+instantiator :: Flex -> Env -> T.Canonical -> State.StateT VarDict IO Type

166+instantiator flex env sourceType =

167+ instantiatorHelp flex env Set.empty sourceType

175168

176169

177−instantiatorHelp :: Environment -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type

178−instantiatorHelp env aliasVars sourceType =

170+instantiatorHelp :: Flex -> Env -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type

171+instantiatorHelp flex env aliasVars sourceType =

179172 let

180173 go =

181− instantiatorHelp env aliasVars

174+ instantiatorHelp flex env aliasVars

182175 in

183176 case sourceType of

184177 T.Lambda t1 t2 ->

@@ -190,24 +183,29 @@ instantiatorHelp env aliasVars sourceType =

190183

191184 else

192185 do dict <- State.get

193− case Map.lookup name dict of

194− Just variable ->

195− return (VarN variable)

186+ case Map.lookup name (_value env) of

187+ Just tipe ->

188+ return tipe

196189

197190 Nothing ->

198− do variable <- State.liftIO (mkNamedVar name)

199− State.put (Map.insert name variable dict)

200− return (VarN variable)

191+ case Map.lookup name dict of

192+ Just variable ->

193+ return (VarN variable)

194+

195+ Nothing ->

196+ do variable <- State.liftIO (mkNamedVar flex name)

197+ State.put (Map.insert name variable dict)

198+ return (VarN variable)

201199

202200 T.Aliased name args aliasType ->

203201 do targs <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args

204202 realType <-

205203 case aliasType of

206204 T.Filled tipe ->

207− instantiatorHelp env Set.empty tipe

205+ instantiatorHelp flex env Set.empty tipe

208206

209207 T.Holey tipe ->

210− instantiatorHelp env (Set.fromList (map fst args)) tipe

208+ instantiatorHelp flex env (Set.fromList (map fst args)) tipe

211209

212210 return (AliasN name targs realType)

213211

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 =

6868

6969

7070canonicalizeValues

71− :: Env.Environment

71+ :: Env.Env

7272 -> (ModuleName.Canonical, Module.Interface)

7373 -> IO [(String, ([T.Variable], T.Type))]

7474canonicalizeValues env (moduleName, iface) =

75− forM (Map.toList (Module.iTypes iface)) $ \(name,tipe) ->

76− do tipe' <- Env.instantiateType env tipe Map.empty

75+ forM (Map.toList (Module.iTypes iface)) $ \(name, tipe) ->

76+ do (flexType, flexVars) <- Env.instantiateType T.Flex env tipe

7777 return

7878 ( ModuleName.canonicalToString moduleName ++ "." ++ name

79− , tipe'

79+ , ( Map.elems flexVars

80+ , flexType

81+ )

8082 )

8183

8284

src/Type/Solve.hs+14−42

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

1+{-# OPTIONS_GHC -Wall #-}

12module Type.Solve (solve) where

23

34import Control.Monad

@@ -5,7 +6,7 @@ import Control.Monad.State (execStateT, liftIO)

56import Control.Monad.Except (ExceptT, throwError)

67import qualified Data.List as List

78import qualified Data.Map as Map

8−import qualified Data.Traversable as T

9+import qualified Data.Foldable as F

910import qualified Data.UnionFind.IO as UF

1011

1112import qualified Reporting.Annotation as A

@@ -35,7 +36,7 @@ generalize youngPool =

3536 -- start at low ranks so that we only have to pass

3637 -- over the information once.

3738 visitedMark <- TS.uniqueMark

38− forM (Map.toList rankDict) $ \(poolRank, vars) ->

39+ forM_ (Map.toList rankDict) $ \(poolRank, vars) ->

3940 mapM (adjustRank youngMark visitedMark poolRank) vars

4041

4142 -- For variables that have rank lowerer than youngRank, register them in

@@ -45,7 +46,7 @@ generalize youngPool =

4546 if isRedundant then return var else TS.register var

4647

4748 let rankDict' = Map.delete youngRank rankDict

48− T.traverse (mapM registerIfNotRedundant) rankDict'

49+ F.traverse_ (mapM registerIfNotRedundant) rankDict'

4950

5051 -- For variables with rank youngRank

5152 -- If rank < youngRank: register in oldPool

@@ -71,8 +72,8 @@ generalize youngPool =

7172rigidify :: Content -> Content

7273rigidify content =

7374 case content of

74− Var Flex maybeSuper _ ->

75− Var Rigid maybeSuper Nothing

75+ Var Flex maybeSuper maybeName ->

76+ Var Rigid maybeSuper maybeName

7677

7778 _ ->

7879 content

@@ -178,7 +179,7 @@ actuallySolve constraint =

178179

179180 CLet [Scheme [] fqs constraint' _] CTrue ->

180181 do oldEnv <- TS.getEnv

181− mapM TS.introduce fqs

182+ mapM_ TS.introduce fqs

182183 actuallySolve constraint'

183184 TS.modifyEnv (\_ -> oldEnv)

184185

@@ -187,7 +188,7 @@ actuallySolve constraint =

187188 headers <- Map.unions <$> mapM solveScheme schemes

188189 TS.modifyEnv $ \env -> Map.union headers env

189190 actuallySolve constraint'

190− mapM occurs $ Map.toList headers

191+ mapM_ occurs $ Map.toList headers

191192 TS.modifyEnv (\_ -> oldEnv)

192193

193194 CInstance region name term ->

@@ -217,7 +218,7 @@ solveScheme scheme =

217218 case scheme of

218219 Scheme [] [] constraint header ->

219220 do actuallySolve constraint

220− T.traverse flatten header

221+ traverse flatten header

221222

222223 Scheme rigidQuantifiers flexibleQuantifiers constraint header ->

223224 do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers

@@ -226,48 +227,19 @@ solveScheme scheme =

226227 -- fill in a new pool when working on this scheme's constraints

227228 freshPool <- TS.nextRankPool

228229 TS.switchToPool freshPool

229− mapM TS.introduce quantifiers

230− header' <- T.traverse flatten header

230+ mapM_ TS.introduce quantifiers

231+ header' <- traverse flatten header

231232 actuallySolve constraint

232233

233− allDistinct rigidQuantifiers

234234 youngPool <- TS.getPool

235235 TS.switchToPool oldPool

236236 generalize youngPool

237− mapM isGeneric rigidQuantifiers

237+ mapM_ isGeneric rigidQuantifiers

238238 return header'

239239

240240

241241-- ADDITIONAL CHECKS

242242

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−

271243

272244-- Check that a variable has rank == noRank, meaning that it can be generalized.

273245isGeneric :: Variable -> TS.Solver ()

@@ -293,8 +265,8 @@ crash msg =

293265

294266occurs :: (String, A.Located Variable) -> TS.Solver ()

295267occurs (name, A.A region variable) =

296− do isInfinite <- liftIO $ occursHelp [] variable

297− case isInfinite of

268+ do hasOccurred <- liftIO $ occursHelp [] variable

269+ case hasOccurred of

298270 False ->

299271 return ()

300272

src/Type/State.hs+2−2

@@ -223,8 +223,8 @@ makeCopyHelp descriptor alreadyCopiedMark variable =

223223 Atom _ ->

224224 return oldContent

225225

226− Var Rigid maybeSuper _ ->

227− return (Var Flex maybeSuper Nothing)

226+ Var Rigid maybeSuper maybeName ->

227+ return (Var Flex maybeSuper maybeName)

228228

229229 Var Flex _ _ ->

230230 return oldContent

src/Type/Type.hs+132−87

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

11{-# OPTIONS_GHC -Wall #-}

22module Type.Type where

33

4+import Control.Monad (when)

45import Control.Monad.State (StateT, liftIO)

56import qualified Control.Monad.State as State

7+import qualified Data.Char as Char

68import qualified Data.List as List

79import qualified Data.Map as Map

8−import qualified Data.Set as Set

9−import qualified Data.Traversable as Traverse (traverse)

1010import qualified Data.UnionFind.IO as UF

1111

1212import qualified AST.Type as T

@@ -183,14 +183,9 @@ mkVar maybeSuper =

183183 UF.fresh $ mkDescriptor (Var Flex maybeSuper Nothing)

184184

185185

186−mkNamedVar :: String -> IO Variable

187−mkNamedVar name =

188− UF.fresh $ mkDescriptor (Var Flex (toSuper name) Nothing)

189−

190−

191−mkRigid :: String -> IO Variable

192−mkRigid name =

193− UF.fresh $ mkDescriptor (Var Rigid (toSuper name) (Just name))

186+mkNamedVar :: Flex -> String -> IO Variable

187+mkNamedVar flex name =

188+ UF.fresh $ mkDescriptor $ Var flex (toSuper name) (Just name)

194189

195190

196191toSuper :: String -> Maybe Super

@@ -233,9 +228,8 @@ ex fqs constraint =

233228 CLet [Scheme [] fqs constraint Map.empty] CTrue

234229

235230

236−-- fl qs constraint == forall qs. constraint

237−fl :: [Variable] -> TypeConstraint -> TypeConstraint

238−fl rqs constraint =

231+forall :: [Variable] -> TypeConstraint -> TypeConstraint

232+forall rqs constraint =

239233 CLet [Scheme rqs [] constraint Map.empty] CTrue

240234

241235

@@ -259,8 +253,8 @@ existsNumber f =

259253-- never have to do extra work, particularly nice for aliased types

260254toSrcType :: Variable -> IO T.Canonical

261255toSrcType variable =

262− do usedNames <- getVarNames variable

263− State.evalStateT (variableToSrcType variable) (makeNameState usedNames)

256+ do takenNames <- State.execStateT (getVarNames variable) Map.empty

257+ State.evalStateT (variableToSrcType variable) (makeNameState takenNames)

264258

265259

266260variableToSrcType :: Variable -> StateT NameState IO T.Canonical

@@ -297,7 +291,7 @@ contentToSrcType variable content =

297291 return (T.Var freshName)

298292

299293 Alias name args realVariable ->

300− do srcArgs <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType tvar) args

294+ do srcArgs <- traverse (traverse variableToSrcType) args

301295 srcType <- variableToSrcType realVariable

302296 return (T.Aliased name srcArgs (T.Filled srcType))

303297

@@ -327,7 +321,7 @@ termToSrcType term =

327321 return $ T.Record [] Nothing

328322

329323 Record1 fields extension ->

330− do srcFields <- Map.toList <$> Traverse.traverse variableToSrcType fields

324+ do srcFields <- Map.toList <$> traverse variableToSrcType fields

331325 srcExt <- T.iteratedDealias <$> variableToSrcType extension

332326 return $

333327 case srcExt of

@@ -346,112 +340,163 @@ termToSrcType term =

346340

347341

348342data NameState = NameState

349− { _freeNames :: [String]

350− , _numberPrimes :: Int

351− , _comparablePrimes :: Int

352− , _appendablePrimes :: Int

353− , _compAppendPrimes :: Int

343+ { _taken :: TakenNames

344+ , _normals :: Int

345+ , _numbers :: Int

346+ , _comparables :: Int

347+ , _appendables :: Int

348+ , _compAppends :: Int

354349 }

355350

356351

357−makeNameState :: Set.Set String -> NameState

358−makeNameState usedNames =

359− let

360− makeName suffix =

361− map (:suffix) ['a'..'z']

352+type TakenNames = Map.Map String Variable

362353

363− allNames =

364− concatMap makeName ("" : map show [ (1 :: Int) .. ])

365354

366− freeNames =

367− filter (\name -> Set.notMember name usedNames) allNames

368− in

369− NameState freeNames 0 0 0 0

355+makeNameState :: TakenNames -> NameState

356+makeNameState taken =

357+ NameState taken 0 0 0 0 0

370358

371359

372360getFreshName :: (Monad m) => Maybe Super -> StateT NameState m String

373361getFreshName maybeSuper =

374362 case maybeSuper of

375363 Nothing ->

376− do names <- State.gets _freeNames

377− State.modify (\state -> state { _freeNames = tail names })

378− return (head names)

364+ do index <- State.gets _normals

365+ taken <- State.gets _taken

366+ let (uniqueName, newIndex) = getFreshNormal index taken

367+ State.modify (\state -> state { _normals = newIndex })

368+ return uniqueName

379369

380370 Just Number ->

381− do primes <- State.gets _numberPrimes

382− State.modify (\state -> state { _numberPrimes = primes + 1 })

383− return ("number" ++ replicate primes '\'')

371+ getFreshSuper "number" _numbers (\index state -> state { _numbers = index })

384372

385373 Just Comparable ->

386− do primes <- State.gets _comparablePrimes

387− State.modify (\state -> state { _comparablePrimes = primes + 1 })

388− return ("comparable" ++ replicate primes '\'')

374+ getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })

389375

390376 Just Appendable ->

391− do primes <- State.gets _appendablePrimes

392− State.modify (\state -> state { _appendablePrimes = primes + 1 })

393− return ("appendable" ++ replicate primes '\'')

377+ getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })

394378

395379 Just CompAppend ->

396− do primes <- State.gets _compAppendPrimes

397− State.modify (\state -> state { _compAppendPrimes = primes + 1 })

398− return ("compappend" ++ replicate primes '\'')

380+ getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })

381+

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)

399424

400425

401426

402427-- GET ALL VARIABLE NAMES

403428

404429

405−getVarNames :: Variable -> IO (Set.Set String)

430+getVarNames :: Variable -> StateT TakenNames IO ()

406431getVarNames var =

407− do desc <- UF.descriptor var

408− if _mark desc == getVarNamesMark

409− then

410− return Set.empty

432+ do desc <- liftIO $ UF.descriptor var

433+ case _mark desc == getVarNamesMark of

434+ True ->

435+ return ()

411436

412− else

413− do UF.setDescriptor var (desc { _mark = getVarNamesMark })

414− getVarNamesHelp (_content desc)

437+ False ->

438+ do liftIO $ UF.setDescriptor var (desc { _mark = getVarNamesMark })

439+ case _content desc of

440+ Atom _ ->

441+ return ()

415442

443+ Error ->

444+ return ()

416445

417−getVarNamesHelp :: Content -> IO (Set.Set String)

418−getVarNamesHelp content =

419− case content of

420− Var _ _ (Just name) ->

421− return (Set.singleton name)

446+ Var _ _ Nothing ->

447+ return ()

422448

423− Var _ _ Nothing ->

424− return Set.empty

449+ Var flex maybeSuper (Just name) ->

450+ do oldTaken <- State.get

451+ newTaken <- liftIO $ addVarName 0 name var flex maybeSuper oldTaken

452+ State.put newTaken

425453

426− Structure term ->

427− getVarNamesTerm term

454+ Alias _ args realVar ->

455+ do mapM_ (getVarNames . snd) args

456+ getVarNames realVar

428457

429− Alias _name args realVar ->

430− do let argSet = Set.fromList (map fst args)

431− realSet <- getVarNames realVar

432− sets <- mapM (getVarNames . snd) args

433− return (Set.unions (realSet : argSet : sets))

458+ Structure (App1 func arg) ->

459+ do getVarNames func

460+ getVarNames arg

434461

435− Atom _ ->

436− return Set.empty

462+ Structure (Fun1 arg body) ->

463+ do getVarNames arg

464+ getVarNames body

437465

438− Error ->

439− return Set.empty

466+ Structure EmptyRecord1 ->

467+ return ()

440468

469+ Structure (Record1 fields extension) ->

470+ do mapM_ getVarNames fields

471+ getVarNames extension

441472

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

448473

449− Fun1 a b ->

450− Set.union <$> go a <*> go b

474+addVarName :: Int -> String -> Variable -> Flex -> Maybe Super -> TakenNames -> IO TakenNames

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

451485

452− EmptyRecord1 ->

453− return Set.empty

486+ Just otherVar ->

487+ do same <- UF.equivalent var otherVar

488+ if same

489+ then return taken

490+ else addVarName (index + 1) givenName var flex maybeSuper taken

454491

455− Record1 fields extension ->

456− do fieldVars <- Set.unions <$> mapM go (Map.elems fields)

457− Set.union fieldVars <$> go extension

492+

493+makeIndexedName :: String -> Int -> String

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

44import Control.Monad (zipWithM_)

55import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)

66import qualified Data.Map as Map

7+import qualified Data.Maybe as Maybe

78import qualified Data.UnionFind.IO as UF

89

910import qualified AST.Variable as Var

@@ -21,10 +22,10 @@ unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()

2122unify hint region expected actual =

2223 do result <- runExceptT (guardedUnify ExpectedActual expected actual)

2324 case result of

24− Right state ->

25− return state

25+ Right () ->

26+ return ()

2627

27− Left (Mismatch _subExpected _subActual maybeReason) ->

28+ Left (Mismatch maybeReason) ->

2829 let

2930 mkError =

3031 do expectedSrcType <- Type.toSrcType expected

@@ -71,22 +72,35 @@ reorient (Context orientation var1 desc1 var2 desc2) =

7172-- ERROR MESSAGES

7273

7374

74−data Mismatch

75− = Mismatch Variable Variable (Maybe Error.Reason)

75+newtype Mismatch =

76+ Mismatch (Maybe Error.Reason)

7677

7778

7879mismatch :: Context -> Maybe Error.Reason -> Unify a

79−mismatch (Context orientation first _ second _) maybeReason =

80− let

81− (expected, actual, orientedReason) =

82− case orientation of

83− ExpectedActual ->

84− (first, second, maybeReason)

80+mismatch context@(Context orientation var1 _ var2 _) maybeReason =

81+ do args1 <- liftIO $ collectArgs var1

82+ args2 <- liftIO $ collectArgs var2

8583

86− ActualExpected ->

87− (second, first, Error.flipReason <$> maybeReason)

88− in

89− throwError (Mismatch expected actual orientedReason)

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

103+ Error.flipReason <$> maybeReason

90104

91105

92106badRigid :: Maybe String -> Error.Reason

@@ -446,6 +460,22 @@ collectAppsHelp args content =

446460 return Other

447461

448462

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+

449479getContent :: Variable -> IO Content

450480getContent variable =

451481 _content <$> UF.descriptor variable

@@ -516,7 +546,6 @@ unifyAlias context name args realVar otherContent =

516546 Atom _ ->

517547 subUnify context realVar (_second context)

518548

519−

520549 Alias otherName otherArgs otherRealVar ->

521550 if name == otherName then

522551 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)

@@ -593,11 +622,12 @@ unifyRecord context firstStructure secondStructure =

593622 do let (RecordStructure expFields expVar expStruct) = firstStructure

594623 let (RecordStructure actFields actVar actStruct) = secondStructure

595624

625+ let sharedFields = Map.intersectionWith (,) expFields actFields

626+

596627 -- call after unifying extension, make sure record shape matches before

597628 -- looking into whether the particular field types match.

598629 let unifySharedFields otherFields ext =

599− do let sharedFields = Map.intersectionWith (,) expFields actFields

600− _ <- traverse (uncurry (subUnify context)) sharedFields

630+ do unifySharedFieldsHelp context sharedFields

601631 let allFields = Map.union (Map.map fst sharedFields) otherFields

602632 merge context (Structure (Record1 allFields ext))

603633

@@ -610,10 +640,12 @@ unifyRecord context firstStructure secondStructure =

610640 unifySharedFields Map.empty expVar

611641

612642 (Empty, _, _, False) ->

613− mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))

643+ mismatch context $ Just $

644+ Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)

614645

615646 (_, False, Empty, _) ->

616− mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))

647+ mismatch context $ Just $

648+ Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)

617649

618650 (_, False, _, True) ->

619651 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))

@@ -636,6 +668,29 @@ unifyRecord context firstStructure secondStructure =

636668

637669

638670

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+

639694-- GATHER RECORD STRUCTURE

640695

641696

src/Validate.hs+14−18

@@ -208,7 +208,7 @@ checkManager tagRegion managerType validDefs =

208208getSimpleDefRegion :: A.Commented Valid.Def -> Maybe (String, R.Region)

209209getSimpleDefRegion decl =

210210 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)) _ _) ->

212212 Just (name, region)

213213

214214 _ ->

@@ -353,15 +353,15 @@ vrdDefHelp remainingDecls (A.A ann def) ports structure =

353353 case def of

354354 Source.Definition pat expr ->

355355 addDef

356− <$> validateDef pat expr Nothing

356+ <$> validateDef (fst ann) pat expr Nothing

357357 <*> vrdHelp remainingDecls ports structure

358358

359359 Source.Annotation name tipe ->

360360 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

362362 | Pattern.isVar name pat ->

363363 addDef

364− <$> validateDef pat expr (Just tipe)

364+ <$> validateDef (R.merge (fst ann) defRegion) pat expr (Just tipe)

365365 <*> vrdHelp rest ports structure

366366

367367 _ ->

@@ -391,32 +391,33 @@ definitionsHelp sourceDefs =

391391 [] ->

392392 return []

393393

394− A.A _ (Source.Definition pat expr) : rest ->

394+ A.A defRegion (Source.Definition pat expr) : rest ->

395395 (:)

396− <$> validateDef pat expr Nothing

396+ <$> validateDef defRegion pat expr Nothing

397397 <*> definitionsHelp rest

398398

399− A.A region (Source.Annotation name tipe) : rest ->

399+ A.A annRegion (Source.Annotation name tipe) : rest ->

400400 case rest of

401− A.A _ (Source.Definition pat expr) : rest'

401+ A.A defRegion (Source.Definition pat expr) : rest'

402402 | Pattern.isVar name pat ->

403403 (:)

404− <$> validateDef pat expr (Just tipe)

404+ <$> validateDef (R.merge annRegion defRegion) pat expr (Just tipe)

405405 <*> definitionsHelp rest'

406406

407407 _ ->

408− Result.throw region (Error.TypeWithoutDefinition name)

408+ Result.throw annRegion (Error.TypeWithoutDefinition name)

409409

410410

411411validateDef

412− :: Pattern.Raw

412+ :: R.Region

413+ -> Pattern.Raw

413414 -> Source.Expr

414415 -> Maybe Type.Raw

415416 -> Result wrn Valid.Def

416−validateDef pat expr maybeType =

417+validateDef region pat expr maybeType =

417418 do validExpr <- expression expr

418419 validateDefPattern pat validExpr

419− return $ Valid.Def pat validExpr maybeType

420+ return $ Valid.Def region pat validExpr maybeType

420421

421422

422423validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result wrn ()

@@ -486,11 +487,6 @@ expression (A.A ann sourceExpression) =

486487 Literal lit ->

487488 return (Literal lit)

488489

489− Range lowExpr highExpr ->

490− Range

491− <$> expression lowExpr

492− <*> expression highExpr

493−

494490 ExplicitList expressions ->

495491 ExplicitList

496492 <$> T.traverse expression expressions