8bc9edd · elk · git.iko.soy

git.iko.soy/elk

Merge pull request #1114 from elm-lang/type-fixes

Revamp unification and error messages

commit8bc9edd18b06eaead4e5acb805bd2e2e5d72bf2e authorEvan Czaplicki <info@elm-lang.org> dateThu 22 Oct 2015, 19:16 (11 years ago) parent5a1caab b90883e

42 files changed+3232−2652

compare with master

unifiedsplit

elm-compiler.cabal+4−3 src/AST/Expression/Canonical.hs−24 src/AST/Expression/General.hs+2−152 src/AST/Expression/Source.hs+1−1 src/AST/Expression/Valid.hs+1−1 src/AST/Helpers.hs+4−1 src/AST/Literal.hs+3−11 src/AST/Pattern.hs+2−46 src/AST/Type.hs+27−234 src/AST/Variable.hs+18−45 src/Elm/Compiler.hs+32−29 src/Elm/Compiler/Version.hs+2−1 src/Generate/JavaScript/Port.hs+3−3 src/Nitpick/Pattern.hs+15−2 src/Parse/Expression.hs+28−36 src/Reporting/Annotation.hs−8 src/Reporting/Error.hs+18−25 src/Reporting/Error/Canonicalize.hs+89−43 src/Reporting/Error/Docs.hs+32−19 src/Reporting/Error/Helpers.hs+161−2 src/Reporting/Error/Pattern.hs+45−88 src/Reporting/Error/Syntax.hs+130−107 src/Reporting/Error/Type.hs+503−176 src/Reporting/PrettyPrint.hs−46 src/Reporting/Render/Code.hs+113 src/Reporting/Render/Type.hs+494 src/Reporting/Report.hs+50−195 src/Reporting/Result.hs+3−3 src/Reporting/Warning.hs+22−35 src/Type/Constrain/Expression.hs+82−85 src/Type/Constrain/Literal.hs+27−16 src/Type/Constrain/Pattern.hs+11−12 src/Type/Environment.hs+104−93 src/Type/Inference.hs+5−6 src/Type/PrettyPrint.hs−20 src/Type/Solve.hs+152−98 src/Type/State.hs+197−136 src/Type/Type.hs+219−444 src/Type/Unify.hs+619−402 src/Validate.hs+2−2 tests/Test/Compiler.hs+11−1 tests/test-files/good-expected-js/Declarations/Ports.elm.js+1−1

elm-compiler.cabal+4−3

@@ -108,8 +108,9 @@ Library

108108 Reporting.Error.Pattern,

109109 Reporting.Error.Syntax,

110110 Reporting.Error.Type,

111− Reporting.PrettyPrint,

112111 Reporting.Region,

112+ Reporting.Render.Code,

113+ Reporting.Render.Type,

113114 Reporting.Report,

114115 Reporting.Result,

115116 Reporting.Warning,

@@ -119,7 +120,6 @@ Library

119120 Type.Environment,

120121 Type.Fragment,

121122 Type.Inference,

122− Type.PrettyPrint,

123123 Type.Solve,

124124 Type.State,

125125 Type.Type,

@@ -131,6 +131,7 @@ Library

131131 aeson >= 0.7 && < 0.9,

132132 aeson-pretty >= 0.7 && < 0.8,

133133 ansi-terminal >= 0.6.2.1 && < 0.7,

134+ ansi-wl-pprint >= 0.6.7 && < 0.7,

134135 base >=4.2 && <5,

135136 binary >= 0.7.0.0 && < 0.8,

136137 bytestring >= 0.9 && < 0.11,

@@ -190,7 +191,6 @@ Test-Suite compiler-tests

190191 Test.Property.Arbitrary

191192 AST.Helpers

192193 AST.Literal

193− Reporting.PrettyPrint

194194

195195 build-depends:

196196 test-framework > 0.8 && < 0.9,

@@ -201,6 +201,7 @@ Test-Suite compiler-tests

201201 aeson >= 0.7 && < 0.9,

202202 aeson-pretty >= 0.7 && < 0.8,

203203 ansi-terminal >= 0.6.2.1 && < 0.7,

204+ ansi-wl-pprint >= 0.6.7 && < 0.7,

204205 base >=4.2 && <5,

205206 binary >= 0.7.0.0 && < 0.8,

206207 bytestring >= 0.9 && < 0.11,

src/AST/Expression/Canonical.hs−24

@@ -1,14 +1,11 @@

11{-# OPTIONS_GHC -Wall #-}

22module AST.Expression.Canonical where

4−import Text.PrettyPrint as P

5−

64import qualified AST.Expression.General as General

75import qualified AST.Pattern as Pattern

86import qualified AST.Type as Type

97import qualified AST.Variable as Var

108import qualified Reporting.Annotation as A

11−import qualified Reporting.PrettyPrint as P

129import qualified Reporting.Region as R

1310

1411

@@ -25,35 +22,14 @@ type Expr' =

2522

2623data Def

2724 = Definition Facts Pattern.CanonicalPattern Expr (Maybe (A.Located Type.Canonical))

28− deriving (Show)

2925

3026

3127data Facts = Facts

3228 { dependencies :: [Var.TopLevel]

3329 }

34− deriving (Eq, Ord, Show)

3530

3631

3732dummyFacts :: Facts

3833dummyFacts =

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

4035

41−

42−instance P.Pretty Def where

43− pretty dealiaser _ (Definition _ pattern expr maybeTipe) =

44− P.vcat [ annotation, definition ]

45− where

46− definition =

47− P.pretty dealiaser True pattern

48− <+> P.equals

49− <+> P.pretty dealiaser False expr

50−

51− annotation =

52− case maybeTipe of

53− Nothing ->

54− P.empty

55−

56− Just tipe ->

57− P.pretty dealiaser True pattern

58− <+> P.colon

59− <+> P.pretty dealiaser False tipe

src/AST/Expression/General.hs+2−152

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

88-}

99module AST.Expression.General where

1010

11−import Text.PrettyPrint as P

12−

13−import qualified AST.Helpers as Help

1411import qualified AST.Literal as Literal

1512import qualified AST.Pattern as Pattern

1613import qualified AST.Type as Type

1714import qualified AST.Variable as Var

1815import qualified Reporting.Annotation as A

19−import qualified Reporting.PrettyPrint as P

2016

2117

2218---- GENERAL AST ----

@@ -58,7 +54,6 @@ data Expr' ann def var typ

5854 -- for type checking and code gen only

5955 | Port (PortImpl (Expr ann def var typ) typ)

6056 | GLShader String String Literal.GLShaderTipe

61− deriving (Show)

6257

6358

6459-- PORTS

@@ -67,7 +62,7 @@ data PortImpl expr tipe

6762 = In String (Type.Port tipe)

6863 | Out String expr (Type.Port tipe)

6964 | Task String expr (Type.Port tipe)

70− deriving (Eq, Show)

65+ deriving (Eq)

7166

7267

7368portName :: PortImpl expr tipe -> String

@@ -100,7 +95,7 @@ saveEnvName =

10095 "_save_the_environment!!!"

10196

10297

103−dummyLet :: (P.Pretty def) => [def] -> Expr ann def Var.Canonical typ

98+dummyLet :: [def] -> Expr ann def Var.Canonical typ

10499dummyLet defs =

105100 let body =

106101 A.A undefined (Var (Var.builtin saveEnvName))

@@ -108,151 +103,6 @@ dummyLet defs =

108103 A.A undefined (Let defs body)

109104

110105

111−-- PRETTY PRINTING

112−

113−instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann def var typ) where

114− pretty dealiaser needsParens expression =

115− case expression of

116− Literal literal ->

117− P.pretty dealiaser needsParens literal

118−

119− Var x ->

120− P.pretty dealiaser needsParens x

121−

122− Range lowExpr highExpr ->

123− P.brackets $

124− P.pretty dealiaser False lowExpr

125− <> P.text ".."

126− <> P.pretty dealiaser False highExpr

127−

128− ExplicitList elements ->

129− P.brackets (P.commaCat (map (P.pretty dealiaser False) elements))

130−

131− Binop op (A.A _ (Literal (Literal.IntNum 0))) expr

132− | Var.toString op == "-" ->

133− P.text "-" <> P.pretty dealiaser True expr

134−

135− Binop op leftExpr rightExpr ->

136− P.parensIf needsParens $

137− P.hang

138− (P.pretty dealiaser True leftExpr)

139− 2

140− (P.text op'' <+> P.pretty dealiaser True rightExpr)

141− where

142− op' = Var.toString op

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

144−

145− Lambda pattern expr ->

146− P.parensIf needsParens $

147− P.text "\\" <> args <+> P.text "->" <+> P.pretty dealiaser False body

148− where

149− (patterns, body) =

150− collectLambdas expr

151−

152− args =

153− P.sep (map (P.pretty dealiaser True) (pattern : patterns))

154−

155− App expr arg ->

156− P.parensIf needsParens $

157− P.hang func 2 (P.sep args)

158− where

159− func:args =

160− map (P.pretty dealiaser True) (collectApps expr ++ [arg])

161−

162− If branches finally ->

163− let

164− prettyFinally =

165− P.nest 4 (P.pretty dealiaser False finally)

166−

167− prettyBranch (condition, thenBranch) (firstLine, rest) =

168− ( P.text "if" <+> P.pretty dealiaser False condition <+> P.text "then"

169− ,

170− [ P.nest 4 (P.pretty dealiaser False thenBranch)

171− , P.text "else" <+> firstLine

172− ]

173− ++ rest

174− )

175− in

176− P.parensIf needsParens $ P.sep $ uncurry (:) $

177− foldr

178− prettyBranch

179− ( P.empty, [prettyFinally] )

180− branches

181−

182− Let defs body ->

183− P.parensIf needsParens $

184− P.sep

185− [ P.hang

186− (P.text "let")

187− 4

188− (P.vcat (map (P.pretty dealiaser False) defs))

189− , P.text "in" <+> P.pretty dealiaser False body

190− ]

191−

192− Case expr branches ->

193− P.parensIf needsParens $

194− P.hang pexpr 2 (P.vcat (map pretty' branches))

195− where

196− pexpr =

197− P.text "case" <+> P.pretty dealiaser False expr <+> P.text "of"

198−

199− pretty' (pattern, branch) =

200− P.pretty dealiaser False pattern

201− <+> P.text "->"

202− <+> P.pretty dealiaser False branch

203−

204− Data "::" [hd,tl] ->

205− P.parensIf needsParens $

206− P.pretty dealiaser True hd <+> P.text "::" <+> P.pretty dealiaser True tl

207−

208− Data "[]" [] ->

209− P.text "[]"

210−

211− Data name exprs ->

212− if Help.isTuple name

213− then

214− P.parens (P.commaCat (map (P.pretty dealiaser False) exprs))

215− else

216− P.parensIf (needsParens && not (null exprs)) $

217− P.hang

218− (P.text name)

219− 2

220− (P.sep (map (P.pretty dealiaser True) exprs))

221−

222− Access record field ->

223− P.pretty dealiaser True record <> P.text "." <> P.text field

224−

225− Update record fields ->

226− P.braces $

227− P.hang

228− (P.pretty dealiaser False record <+> P.text "|")

229− 4

230− (P.commaSep $ map prettyField fields)

231− where

232− prettyField (field, expr) =

233− P.text field <+> P.text "<-" <+> P.pretty dealiaser False expr

234−

235− Record fields ->

236− P.sep

237− [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map field fields))

238− , P.rbrace

239− ]

240− where

241− field (name, expr) =

242− P.text name <+> P.equals <+> P.pretty dealiaser False expr

243−

244− GLShader _ _ _ ->

245− P.text "[glsl| ... |]"

246−

247− Port portImpl ->

248− P.pretty dealiaser needsParens portImpl

249−

250−

251−instance P.Pretty (PortImpl expr tipe) where

252− pretty _ _ impl =

253− P.text ("<port:" ++ portName impl ++ ">")

254−

255−

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

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

258108 case expr of

src/AST/Expression/Source.hs+1−1

@@ -28,4 +28,4 @@ type Def =

2828data Def'

2929 = Definition Pattern.RawPattern Expr

3030 | TypeAnnotation String Type.Raw

31− deriving (Show)

31+

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

@@ -22,4 +22,4 @@ type Expr' =

2222

2323data Def

2424 = Definition Pattern.RawPattern Expr (Maybe Type.Raw)

25− deriving (Show)

25+

src/AST/Helpers.hs+4−1

@@ -3,6 +3,8 @@ module AST.Helpers where

44import qualified Data.Char as Char

68splitDots :: String -> [String]

79splitDots variable =

810 go [] variable

@@ -16,7 +18,8 @@ splitDots variable =

1618

1719isTuple :: String -> Bool

1820isTuple name =

19− take 6 name == "_Tuple" && all Char.isDigit (drop 6 name)

21+ take 6 name == "_Tuple"

22+ && all Char.isDigit (drop 6 name)

2023

2124

2225isOp :: String -> Bool

src/AST/Literal.hs+3−11

@@ -2,9 +2,6 @@

22module AST.Literal where

44import qualified Data.Map as Map

5−import qualified Text.PrettyPrint as P

6−

7−import qualified Reporting.PrettyPrint as P

107data Literal

@@ -13,12 +10,7 @@ data Literal

1310 | Chr Char

1411 | Str String

1512 | Boolean Bool

16− deriving (Eq, Ord, Show)

17−

18−

19−instance P.Pretty Literal where

20− pretty _ _ literal =

21− P.text (toString literal)

13+ deriving (Eq, Ord)

2214

2315

2416toString :: Literal -> String

@@ -39,7 +31,7 @@ data GLTipe

3931 | V4

4032 | M4

4133 | Texture

42− deriving (Eq, Show)

34+ deriving (Eq)

4335

4436

4537glTipeName :: GLTipe -> String

@@ -59,4 +51,4 @@ data GLShaderTipe = GLShaderTipe

5951 , uniform :: Map.Map String GLTipe

6052 , varying :: Map.Map String GLTipe

6153 }

62− deriving (Eq, Show)

54+ deriving (Eq)

src/AST/Pattern.hs+2−46

@@ -2,13 +2,10 @@

22module AST.Pattern where

44import qualified Data.Set as Set

5−import Text.PrettyPrint as P

7−import qualified AST.Helpers as Help

86import qualified AST.Literal as L

97import qualified AST.Variable as Var

108import qualified Reporting.Annotation as A

11−import qualified Reporting.PrettyPrint as P

129import qualified Reporting.Region as R

1310

1411

@@ -23,7 +20,6 @@ data Pattern' ann var

2320 | Var String

2421 | Anything

2522 | Literal L.Literal

26− deriving (Show)

2723

2824

2925type RawPattern =

@@ -61,8 +57,10 @@ tuple patterns =

6157 Data (Var.Raw ("_Tuple" ++ show (length patterns))) patterns

6258

6359

60+

6461-- FIND VARIABLES

6562

63+

6664boundVars :: Pattern ann var -> [A.Annotated ann String]

6765boundVars (A.A ann pattern) =

6866 case pattern of

@@ -99,45 +97,3 @@ boundVarList :: Pattern ann var -> [String]

9997boundVarList pattern =

10098 Set.toList (boundVarSet pattern)

10199

102−

103−-- PRETTY PRINTING

104−

105−instance Var.ToString var => P.Pretty (Pattern' ann var) where

106− pretty dealiaser needsParens pattern =

107− case pattern of

108− Var name ->

109− P.text name

110−

111− Literal literal ->

112− P.pretty dealiaser needsParens literal

113−

114− Record fields ->

115− P.braces (P.commaCat (map P.text fields))

116−

117− Alias x ptrn ->

118− P.parensIf needsParens $

119− P.pretty dealiaser True ptrn <+> P.text "as" <+> P.text x

120−

121− Anything ->

122− P.text "_"

123−

124− Data name [A.A _ hd, A.A _ tl]

125− | Var.toString name == "::" ->

126− P.parensIf isCons (P.pretty dealiaser False hd)

127− <+> P.text "::"

128− <+> P.pretty dealiaser False tl

129− where

130− isCons =

131− case hd of

132− Data ctor _ -> Var.toString ctor == "::"

133− _ -> False

134−

135− Data name patterns ->

136− let name' = Var.toString name

137− in

138− if Help.isTuple name'

139− then

140− P.parens (P.commaCat (map (P.pretty dealiaser False) patterns))

141− else

142− P.parensIf needsParens $

143− P.hsep (P.text name' : map (P.pretty dealiaser True) patterns)

src/AST/Type.hs+27−234

@@ -2,27 +2,24 @@ module AST.Type

22 ( Raw, Raw'(..)

33 , Canonical(..), Aliased(..)

44 , Port(..), getPortType

5− , deepDealias, dealias

5+ , deepDealias, iteratedDealias, dealias

66 , collectLambdas

7− , fieldMap

87 , tuple

98 ) where

109

1110import Control.Arrow (second)

1211import Data.Binary

1312import qualified Data.Map as Map

14−import qualified Data.Maybe as Maybe

15−import Text.PrettyPrint as P

1613

1714import qualified AST.Variable as Var

18−import qualified AST.Helpers as Help

1915import qualified Reporting.Annotation as A

20−import qualified Reporting.PrettyPrint as P

2116import qualified Reporting.Region as R

2217

2318

19+

2420-- DEFINITION

2521

22+

2623type Raw =

2724 A.Located Raw'

2825

@@ -33,7 +30,6 @@ data Raw'

3330 | RType Var.Raw

3431 | RApp Raw [Raw]

3532 | RRecord [(String, Raw)] (Maybe Raw)

36− deriving (Show)

3733

3834

3935data Canonical

@@ -43,19 +39,19 @@ data Canonical

4339 | App Canonical [Canonical]

4440 | Record [(String, Canonical)] (Maybe Canonical)

4541 | Aliased Var.Canonical [(String, Canonical)] (Aliased Canonical)

46− deriving (Eq, Ord, Show)

42+ deriving (Eq, Ord)

4743

4844

4945data Aliased t

5046 = Holey t

5147 | Filled t

52− deriving (Eq, Ord, Show)

48+ deriving (Eq, Ord)

5349

5450

5551data Port t

5652 = Normal t

5753 | Signal { root :: t, arg :: t }

58− deriving (Eq, Show)

54+ deriving (Eq)

5955

6056

6157getPortType :: Port tipe -> tipe

@@ -65,24 +61,6 @@ getPortType portType =

6561 Signal tipe _ -> tipe

6662

6763

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

69−fieldMap fields =

70− let add r (field,tipe) =

71− Map.insertWith (++) field [tipe] r

72− in

73− foldl add Map.empty fields

74−

75−{--

76−recordOf :: [(String, Type var)] -> Type var

77−recordOf fields =

78− Record fields Nothing

79−

80−

81−listOf :: RawType -> RawType

82−listOf tipe =

83− App (Type (Var.Raw "List")) [tipe]

84−--}

85−

8664tuple :: R.Region -> [Raw] -> Raw

8765tuple region types =

8866 let name = Var.Raw ("_Tuple" ++ show (length types))

@@ -90,20 +68,21 @@ tuple region types =

9068 A.A region (RApp (A.A region (RType name)) types)

9169

9270

71+

9372-- DEALIASING

9473

74+

9575deepDealias :: Canonical -> Canonical

9676deepDealias tipe =

97− let go = deepDealias in

9877 case tipe of

9978 Lambda a b ->

100− Lambda (go a) (go b)

79+ Lambda (deepDealias a) (deepDealias b)

10180

10281 Var _ ->

10382 tipe

10483

10584 Record fields ext ->

106− Record (map (second go) fields) (fmap go ext)

85+ Record (map (second deepDealias) fields) (fmap deepDealias ext)

10786

10887 Aliased _name args tipe' ->

10988 deepDealias (dealias args tipe')

@@ -112,7 +91,17 @@ deepDealias tipe =

11291 tipe

11392

11493 App f args ->

115− App (go f) (map go args)

94+ App (deepDealias f) (map deepDealias args)

95+

96+

97+iteratedDealias :: Canonical -> Canonical

98+iteratedDealias tipe =

99+ case tipe of

100+ Aliased _ args realType ->

101+ iteratedDealias (dealias args realType)

102+

103+ _ ->

104+ tipe

116105

117106

118107dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical

@@ -148,220 +137,24 @@ dealiasHelp typeTable tipe =

148137 App (go f) (map go args)

149138

150139

151−-- PRETTY PRINTING

152−

153−instance (P.Pretty t) => P.Pretty (Port t) where

154− pretty dealiaser needsParens portType =

155− P.pretty dealiaser needsParens (getPortType portType)

156−

157−

158−instance P.Pretty Raw' where

159− pretty dealiaser needsParens tipe =

160− case tipe of

161− RLambda arg body ->

162− P.parensIf needsParens (prettyLambda dealiaser getRawLambda arg body)

163−

164− RVar x ->

165− P.text x

166−

167− RType var ->

168− prettyType dealiaser var

169−

170− RApp func args ->

171− let

172− isTuple (A.A _ (RType name)) = Help.isTuple (Var.toString name)

173− isTuple _ = False

174− in

175− prettyApp dealiaser needsParens isTuple func args

176−

177− RRecord fields ext ->

178− prettyRecord dealiaser (flattenRawRecord fields ext)

179−

180−

181−instance P.Pretty Canonical where

182− pretty dealiaser needsParens tipe =

183− case tipe of

184− Lambda arg body ->

185− P.parensIf needsParens (prettyLambda dealiaser getCanLambda arg body)

186−

187− Var x ->

188− P.text x

189−

190− Type var ->

191− prettyType dealiaser var

192−

193− App func args ->

194− let

195− isTuple (Type name) = Help.isTuple (Var.toString name)

196− isTuple _ = False

197− in

198− prettyApp dealiaser needsParens isTuple func args

199−

200− Record fields ext ->

201− prettyRecord dealiaser (flattenCanRecord fields ext)

202−

203− Aliased name args _ ->

204− P.parensIf (needsParens && not (null args)) $

205− P.hang

206− (P.pretty dealiaser False name)

207− 2

208− (P.sep (map (P.pretty dealiaser True . snd) args))

209−

210140

211−-- PRETTY HELPERS

212−

213−prettyType :: (Var.ToString var) => P.Dealiaser -> var -> P.Doc

214−prettyType dealiaser var =

215− let

216− v = Var.toString var

217− in

218− P.text $

219− if v == "_Tuple0" then

220− "()"

221− else

222− maybe v id (Map.lookup v dealiaser)

223−

224−

225−-- PRETTY LAMBDAS

226−

227−prettyLambda :: (P.Pretty t) => P.Dealiaser -> (t -> Maybe (t,t)) -> t -> t -> P.Doc

228−prettyLambda dealiaser getLambda arg body =

229− let

230− rest =

231− gatherLambda getLambda body

232−

233− prettyArg t =

234− P.pretty dealiaser (Maybe.isJust (getLambda t)) t

235− in

236− P.sep

237− [ prettyArg arg

238− , P.sep (map (\t -> P.text "->" <+> prettyArg t) rest)

239− ]

240−

241−

242−getRawLambda :: Raw -> Maybe (Raw, Raw)

243−getRawLambda (A.A _ tipe) =

244− case tipe of

245− RLambda arg body -> Just (arg, body)

246− _ -> Nothing

247−

248−

249−getCanLambda :: Canonical -> Maybe (Canonical, Canonical)

250−getCanLambda tipe =

251− case tipe of

252− Lambda arg body -> Just (arg, body)

253− _ -> Nothing

254−

255−

256−gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]

257−gatherLambda get tipe =

258− case get tipe of

259− Just (arg, body) ->

260− arg : gatherLambda get body

261−

262− Nothing ->

263− [tipe]

141+-- COLLECT LAMBDAS

264142

265143

266144collectLambdas :: Canonical -> [Canonical]

267145collectLambdas tipe =

268− gatherLambda getCanLambda tipe

269−

270−

271−-- PRETTY APP

272−

273−prettyApp :: (P.Pretty t) => P.Dealiaser -> Bool -> (t -> Bool) -> t -> [t] -> P.Doc

274−prettyApp dealiaser needsParens isTuple func args

275− | isTuple func =

276− P.parens $ P.sep $

277− P.punctuate P.comma (map (P.pretty dealiaser False) args)

278−

279− | null args =

280− P.pretty dealiaser needsParens func

281−

282− | otherwise =

283− P.parensIf needsParens $

284− P.hang

285− (P.pretty dealiaser True func)

286− 2

287− (P.sep (map (P.pretty dealiaser True) args))

288−

289−

290−-- PRETTY RECORD

291−

292−prettyRecord :: (P.Pretty t) => P.Dealiaser -> ([(String, t)], Maybe String) -> P.Doc

293−prettyRecord dealiaser recordInfo =

294− let

295− prettyField (field, tipe) =

296− P.hang

297− (P.text field <+> P.text ":")

298− 4

299− (P.pretty dealiaser False tipe)

300− in

301− case recordInfo of

302− ([], Nothing) ->

303− P.text "{}"

304−

305− (fields, Nothing) ->

306− P.sep

307− [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))

308− , P.rbrace

309− ]

310−

311− (fields, Just x) ->

312− P.hang

313− (P.lbrace <+> P.text x <+> P.text "|")

314− 4

315− (P.sep

316− [ P.sep (P.punctuate P.comma (map prettyField fields))

317− , P.rbrace

318− ]

319− )

320−

321−

322−flattenRawRecord

323− :: [(String, Raw)]

324− -> Maybe Raw

325− -> ( [(String, Raw)], Maybe String )

326−flattenRawRecord fields ext =

327− case ext of

328− Nothing ->

329− (fields, Nothing)

330−

331− Just (A.A _ (RVar x)) ->

332− (fields, Just x)

333−

334− Just (A.A _ (RRecord fields' ext')) ->

335− flattenRawRecord (fields' ++ fields) ext'

146+ case tipe of

147+ Lambda arg result ->

148+ arg : collectLambdas result

336149

337150 _ ->

338− error "Trying to flatten ill-formed record."

339−

340−

341−flattenCanRecord

342− :: [(String, Canonical)]

343− -> Maybe Canonical

344− -> ( [(String, Canonical)], Maybe String )

345−flattenCanRecord fields ext =

346− case ext of

347− Nothing ->

348− (fields, Nothing)

349−

350− Just (Var x) ->

351− (fields, Just x)

352−

353− Just (Record fields' ext') ->

354− flattenCanRecord (fields' ++ fields) ext'

355−

356− Just (Aliased _ args tipe) ->

357− flattenCanRecord fields (Just (dealias args tipe))

151+ [tipe]

358152

359− _ ->

360− error "Trying to flatten ill-formed record."

361153

362154

363155-- BINARY

364156

157+

365158instance Binary Canonical where

366159 put tipe =

367160 case tipe of

src/AST/Variable.hs+18−45

@@ -1,46 +1,48 @@

11module AST.Variable where

33import Data.Binary

4−import qualified Data.Map as Map

54import qualified Data.Maybe as Maybe

6−import Text.PrettyPrint as P

86import qualified AST.Helpers as Help

97import qualified AST.Module.Name as ModuleName

10−import qualified Reporting.PrettyPrint as P

119

1210

1311-- RAW NAMES

1412

13+

1514newtype Raw = Raw String

16− deriving (Eq, Ord, Show)

15+ deriving (Eq, Ord)

16+

1717

1818

1919-- TOP LEVEL NAMES

2020

21+

2122data TopLevel = TopLevelVar

2223 { topHome :: ModuleName.Canonical

2324 , topName :: String

2425 }

25− deriving (Eq, Ord, Show)

26+ deriving (Eq, Ord)

2627

2728

2829

2930-- CANONICAL NAMES

3031

32+

3133data Home

3234 = BuiltIn

3335 | Module ModuleName.Canonical

3436 | TopLevel ModuleName.Canonical

3537 | Local

36− deriving (Eq, Ord, Show)

38+ deriving (Eq, Ord)

3739

3840

3941data Canonical = Canonical

4042 { home :: !Home

4143 , name :: !String

4244 }

43− deriving (Eq, Ord, Show)

45+ deriving (Eq, Ord)

4446

4547

4648local :: String -> Canonical

@@ -68,8 +70,10 @@ inCore home name =

6870 Canonical (Module (ModuleName.inCore home)) name

6971

7072

73+

7174-- VARIABLE RECOGNIZERS

7275

76+

7377isLocalHome :: Home -> Bool

7478isLocalHome home =

7579 case home of

@@ -190,14 +194,16 @@ instance ToString Canonical where

190194 name

191195

192196

197+

193198-- LISTINGS

194199

200+

195201-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)

196202data Listing a = Listing

197203 { _explicits :: [a]

198204 , _open :: Bool

199205 }

200− deriving (Eq, Ord, Show)

206+ deriving (Eq, Ord)

201207

202208

203209openListing :: Listing a

@@ -220,11 +226,13 @@ data Value

220226 = Value !String

221227 | Alias !String

222228 | Union !String !(Listing String)

223− deriving (Eq, Ord, Show)

229+ deriving (Eq, Ord)

230+

224231

225232

226233-- CATEGORIZING VALUES

227234

235+

228236getValues :: [Value] -> [String]

229237getValues values =

230238 Maybe.mapMaybe getValue values

@@ -264,45 +272,10 @@ getUnion value =

264272 Union name ctors -> Just (name, ctors)

265273

266274

267−-- PRETTY VARIABLES

268−

269−instance P.Pretty Raw where

270− pretty _ _ (Raw name) =

271− if Help.isOp name

272− then P.parens (P.text name)

273− else P.text name

274−

275−

276−instance P.Pretty Canonical where

277− pretty dealiaser _ var =

278− let

279− name = toString var

280− in

281− P.text (maybe name id (Map.lookup name dealiaser))

282−

283−

284−instance P.Pretty a => P.Pretty (Listing a) where

285− pretty dealiaser _ (Listing explicits open) =

286− let dots = [if open then P.text ".." else P.empty]

287− in

288− P.parens (P.commaCat (map (P.pretty dealiaser False) explicits ++ dots))

289−

290−

291−instance P.Pretty Value where

292− pretty dealiaser _ portable =

293− case portable of

294− Value name ->

295− P.text name

296−

297− Alias name ->

298− P.text name

299−

300− Union name ctors ->

301− P.text name <> P.pretty dealiaser False ctors

302−

303275

304276-- BINARY SERIALIZATION

305277

278+

306279instance Binary Canonical where

307280 put (Canonical home name) =

308281 case home of

src/Elm/Compiler.hs+32−29

@@ -3,13 +3,15 @@ module Elm.Compiler

33 ( version

44 , parseDependencies

55 , compile, Context(..), Result(..)

6− , Dealiaser, dummyDealiaser

6+ , Localizer, dummyLocalizer

77 , Error, errorToString, errorToJson, printError

88 , Warning, warningToString, warningToJson, printWarning

9− ) where

9+ )

10+ where

1011

1112import qualified Data.Aeson as Json

1213import qualified Data.Map as Map

14+import System.IO (Handle)

1315

1416import qualified AST.Module as Module

1517import qualified AST.Module.Name as ModuleName

@@ -24,7 +26,8 @@ import qualified Parse.Module as Parse

2426import qualified Parse.Parse as Parse

2527import qualified Reporting.Annotation as A

2628import qualified Reporting.Error as Error

27−import qualified Reporting.PrettyPrint as P

29+import qualified Reporting.Render.Type as RenderType

30+import qualified Reporting.Report as Report

2831import qualified Reporting.Result as Result

2932import qualified Reporting.Warning as Warning

3033

@@ -64,14 +67,14 @@ compile

6467 :: Context

6568 -> String

6669 -> PublicModule.Interfaces

67− -> (Dealiaser, [Warning], Either [Error] Result)

70+ -> (Localizer, [Warning], Either [Error] Result)

6871

6972compile context source interfaces =

7073 let

7174 (Context packageName isRoot isExposed dependencies) =

7275 context

7376

74− (Result.Result (dealiaser, warnings) rawResult) =

77+ (Result.Result (localizer, warnings) rawResult) =

7578 do modul <- Compile.compile packageName isRoot dependencies interfaces source

7679 docs <- docsGen isExposed modul

7780

@@ -80,7 +83,7 @@ compile context source interfaces =

8083

8184 return (Result docs interface javascript)

8285 in

83− ( maybe dummyDealiaser Dealiaser dealiaser

86+ ( maybe dummyLocalizer Localizer localizer

8487 , map Warning warnings

8588 , Result.destruct (Left . map Error) Right rawResult

8689 )

@@ -124,13 +127,13 @@ docsGen isExposed modul =

124127

125128-- DEALIASER

126129

127−newtype Dealiaser =

128− Dealiaser P.Dealiaser

130+newtype Localizer =

131+ Localizer RenderType.Localizer

129132

130133

131−dummyDealiaser :: Dealiaser

132−dummyDealiaser =

133− Dealiaser Map.empty

134+dummyLocalizer :: Localizer

135+dummyLocalizer =

136+ Localizer Map.empty

134137

135138

136139-- ERRORS

@@ -139,19 +142,19 @@ newtype Error =

139142 Error (A.Located Error.Error)

140143

141144

142−errorToString :: Dealiaser -> String -> String -> Error -> String

143−errorToString (Dealiaser dealiaser) location source (Error err) =

144− Error.toString dealiaser location source err

145+errorToString :: Localizer -> String -> String -> Error -> String

146+errorToString (Localizer localizer) location source (Error (A.A region err)) =

147+ Report.toString location region (Error.toReport localizer err) source

145148

146149

147−printError :: Dealiaser -> String -> String -> Error -> IO ()

148−printError (Dealiaser dealiaser) location source (Error err) =

149− Error.print dealiaser location source err

150+printError :: Handle -> Localizer -> String -> String -> Error -> IO ()

151+printError handle (Localizer localizer) location source (Error (A.A region err)) =

152+ Report.toHandle handle location region (Error.toReport localizer err) source

150153

151154

152−errorToJson :: Dealiaser -> String -> Error -> Json.Value

153−errorToJson (Dealiaser dealiaser) location (Error err) =

154− Error.toJson dealiaser location err

155+errorToJson :: Localizer -> String -> Error -> Json.Value

156+errorToJson (Localizer localizer) location (Error err) =

157+ Error.toJson localizer location err

155158

156159

157160-- WARNINGS

@@ -160,18 +163,18 @@ newtype Warning =

160163 Warning (A.Located Warning.Warning)

161164

162165

163−warningToString :: Dealiaser -> String -> String -> Warning -> String

164−warningToString (Dealiaser dealiaser) location source (Warning err) =

165− Warning.toString dealiaser location source err

166+warningToString :: Localizer -> String -> String -> Warning -> String

167+warningToString (Localizer localizer) location source (Warning (A.A region wrn)) =

168+ Report.toString location region (Warning.toReport localizer wrn) source

166169

167170

168−printWarning :: Dealiaser -> String -> String -> Warning -> IO ()

169−printWarning (Dealiaser dealiaser) location source (Warning err) =

170− Warning.print dealiaser location source err

171+printWarning :: Handle -> Localizer -> String -> String -> Warning -> IO ()

172+printWarning handle (Localizer localizer) location source (Warning (A.A region wrn)) =

173+ Report.toHandle handle location region (Warning.toReport localizer wrn) source

171174

172175

173−warningToJson :: Dealiaser -> String -> Warning -> Json.Value

174−warningToJson (Dealiaser dealiaser) location (Warning err) =

175− Warning.toJson dealiaser location err

176+warningToJson :: Localizer -> String -> Warning -> Json.Value

177+warningToJson (Localizer localizer) location (Warning wrn) =

178+ Warning.toJson localizer location wrn

176179

177180

src/Elm/Compiler/Version.hs+2−1

@@ -3,13 +3,14 @@ module Elm.Compiler.Version (version) where

44import qualified Data.Version as Version

55import qualified Paths_elm_compiler as This

6−import Elm.Package

6+import Elm.Package (Version(Version))

99rawVersion :: [Int]

1010rawVersion =

1111 Version.versionBranch This.version

1212

13+

1314version :: Version

1415version =

1516 case rawVersion of

src/Generate/JavaScript/Port.hs+3−3

@@ -7,7 +7,7 @@ import Language.ECMAScript3.Syntax

77import qualified AST.Type as T

88import qualified AST.Variable as Var

99import Generate.JavaScript.Helpers

10−import qualified Reporting.PrettyPrint as P

10+import qualified Reporting.Render.Type as RenderType

1111

1212

1313-- TASK

@@ -97,14 +97,14 @@ inbound name portType =

9797 T.Normal tipe ->

9898 _Port "inbound" `call`

9999 [ StringLit () name

100− , StringLit () (show (P.pretty Map.empty False tipe))

100+ , StringLit () (show (RenderType.toDoc Map.empty tipe))

101101 , toTypeFunction tipe

102102 ]

103103

104104 T.Signal _root arg ->

105105 _Port "inboundSignal" `call`

106106 [ StringLit () name

107− , StringLit () (show (P.pretty Map.empty False arg))

107+ , StringLit () (show (RenderType.toDoc Map.empty arg))

108108 , toTypeFunction arg

109109 ]

110110

src/Nitpick/Pattern.hs+15−2

@@ -17,7 +17,7 @@ data Pattern

1717 | Anything

1818 | Literal L.Literal

1919 | AnythingBut (Set.Set L.Literal)

20− deriving (Show, Eq)

20+ deriving (Eq)

2121

2222

2323fromCanonicalPattern :: P.CanonicalPattern -> Pattern

@@ -83,7 +83,20 @@ toString needsParens pattern =

8383 L.toString literal

8484

8585 AnythingBut literalSet ->

86− List.intercalate " " ("<values besides:" : map L.toString (Set.toList literalSet) ++ [">"])

86+ case map L.toString (Set.toList literalSet) of

87+ [] ->

88+ error "should not have an AnythingBut with no literals"

89+

90+ [x] ->

91+ "<values besides " ++ x ++ ">"

92+

93+ [x,y] ->

94+ "<values besides " ++ x ++ " and " ++ y ++ ">"

95+

96+ literals ->

97+ "<values besides "

98+ ++ List.intercalate ", " (init literals)

99+ ++ ", and " ++ last literals ++ ">"

87100

88101

89102addParensIf :: Bool -> String -> String

src/Parse/Expression.hs+28−36

@@ -90,45 +90,37 @@ listTerm =

9090

9191parensTerm :: IParser Source.Expr

9292parensTerm =

93− choice

94− [ try (parens opFn)

95− , parens (tupleFn <|> parened)

96− ]

97− where

98− lambda start end x body =

99− A.at start end (E.Lambda (A.at start end (P.Var x)) body)

100−

101− var start end x =

102− A.at start end (E.rawVar x)

93+ let

94+ mkFunc args realBody start end =

95+ foldr

96+ (\arg body -> A.at start end (E.Lambda (A.at start end (P.Var arg)) body))

97+ (A.at start end (realBody (A.at start end . E.rawVar)))

98+ args

10399

104− opFn =

105− do (start, op, end) <- located symOp

106− return $

107− lambda start end "x" $

108− lambda start end "y" $

109− A.at start end $

110− E.Binop (Var.Raw op) (var start end "x") (var start end "y")

100+ mkBinop op =

101+ mkFunc ["x","y"] (\var -> E.Binop (Var.Raw op) (var "x") (var "y"))

111102

112103 tupleFn =

113− do (start, commas, end) <-

114− located (comma >> many (whitespace >> comma))

115−

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

117−

118− return $

119− foldr

120− (lambda start end)

121− (A.at start end (E.tuple (map (var start end) vars)))

122− vars

123−

124− parened =

125− do (start, expressions, end) <- located (commaSep expr)

126− return $

127− case expressions of

128− [expression] ->

129− expression

130− _ ->

131− A.at start end (E.tuple expressions)

104+ do commas <- many1 comma

105+ let args = map (('v':) . show) [ 0 .. length commas ]

106+ return $ mkFunc args (\var -> E.tuple (map var args))

107+

108+ parenedExpr =

109+ do expressions <- padded (commaSep expr)

110+ return $ \start end ->

111+ case expressions of

112+ [expression] ->

113+ expression

114+ _ ->

115+ A.at start end (E.tuple expressions)

116+ in

117+ do (start, mkExpr, end) <-

118+ located $ choice $

119+ [ mkBinop <$> try (parens symOp)

120+ , parens (tupleFn <|> parenedExpr)

121+ ]

122+ return (mkExpr start end)

123+

132124

133125

134126recordTerm :: IParser Source.Expr

src/Reporting/Annotation.hs−8

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

11module Reporting.Annotation where

33import Prelude hiding (map)

4−import qualified Reporting.PrettyPrint as P

54import qualified Reporting.Region as R

@@ -9,7 +8,6 @@ import qualified Reporting.Region as R

109data Annotated annotation a

1110 = A annotation a

12− deriving (Show)

1311

1412

1513type Located a =

@@ -48,9 +46,3 @@ drop :: Annotated info a -> a

4846drop (A _ value) =

4947 value

5048

51−

52−-- PRETTY PRINT

53−

54−instance (P.Pretty a) => P.Pretty (Annotated info a) where

55− pretty dealiaser parens (A _ value) =

56− P.pretty dealiaser parens value

src/Reporting/Error.hs+18−25

@@ -4,7 +4,6 @@ module Reporting.Error where

55import Data.Aeson ((.=))

66import qualified Data.Aeson as Json

7−import Prelude hiding (print)

98import qualified Reporting.Annotation as A

109import qualified Reporting.Error.Canonicalize as Canonicalize

@@ -12,12 +11,14 @@ import qualified Reporting.Error.Docs as Docs

1211import qualified Reporting.Error.Pattern as Pattern

1312import qualified Reporting.Error.Syntax as Syntax

1413import qualified Reporting.Error.Type as Type

15−import qualified Reporting.PrettyPrint as P

14+import qualified Reporting.Render.Type as RenderType

1615import qualified Reporting.Report as Report

1716

1817

18+

1919-- ALL POSSIBLE ERRORS

2020

21+

2122data Error

2223 = Syntax Syntax.Error

2324 | Canonicalize Canonicalize.Error

@@ -26,48 +27,40 @@ data Error

2627 | Docs Docs.Error

2728

2829

30+

2931-- TO REPORT

3032

31−toReport :: P.Dealiaser -> Error -> Report.Report

32−toReport dealiaser err =

33+

34+toReport :: RenderType.Localizer -> Error -> Report.Report

35+toReport localizer err =

3336 case err of

3437 Syntax syntaxError ->

35− Syntax.toReport dealiaser syntaxError

38+ Syntax.toReport localizer syntaxError

3639

3740 Canonicalize canonicalizeError ->

38− Canonicalize.toReport dealiaser canonicalizeError

41+ Canonicalize.toReport localizer canonicalizeError

3942

4043 Type typeError ->

41− Type.toReport dealiaser typeError

44+ Type.toReport localizer typeError

4245

4346 Pattern patternError ->

44− Pattern.toReport dealiaser patternError

47+ Pattern.toReport localizer patternError

4548

4649 Docs docsError ->

4750 Docs.toReport docsError

4851

4952

50−-- TO STRING

51−

52−toString :: P.Dealiaser -> String -> String -> A.Located Error -> String

53−toString dealiaser location source (A.A region err) =

54− Report.toString location region (toReport dealiaser err) source

55−

56−

57−print :: P.Dealiaser -> String -> String -> A.Located Error -> IO ()

58−print dealiaser location source (A.A region err) =

59− Report.printError location region (toReport dealiaser err) source

60−

6153

6254-- TO JSON

6355

64−toJson :: P.Dealiaser -> FilePath -> A.Located Error -> Json.Value

65−toJson dealiaser filePath (A.A region err) =

56+

57+toJson :: RenderType.Localizer -> FilePath -> A.Located Error -> Json.Value

58+toJson localizer filePath (A.A region err) =

6659 let

6760 (maybeRegion, additionalFields) =

6861 case err of

6962 Syntax syntaxError ->

70− Report.toJson [] (Syntax.toReport dealiaser syntaxError)

63+ Report.toJson [] (Syntax.toReport localizer syntaxError)

7164

7265 Canonicalize canonicalizeError ->

7366 let

@@ -76,13 +69,13 @@ toJson dealiaser filePath (A.A region err) =

7669 (\s -> ["suggestions" .= s])

7770 (Canonicalize.extractSuggestions canonicalizeError)

7871 in

79− Report.toJson suggestions (Canonicalize.toReport dealiaser canonicalizeError)

72+ Report.toJson suggestions (Canonicalize.toReport localizer canonicalizeError)

8073

8174 Type typeError ->

82− Report.toJson [] (Type.toReport dealiaser typeError)

75+ Report.toJson [] (Type.toReport localizer typeError)

8376

8477 Pattern patternError ->

85− Report.toJson [] (Pattern.toReport dealiaser patternError)

78+ Report.toJson [] (Pattern.toReport localizer patternError)

8679

8780 Docs docsError ->

8881 Report.toJson [] (Docs.toReport docsError)

src/Reporting/Error/Canonicalize.hs+89−43

@@ -1,14 +1,16 @@

11{-# OPTIONS_GHC -Wall #-}

22module Reporting.Error.Canonicalize where

4−import qualified Text.PrettyPrint as P

4+import Control.Arrow (second)

5+import Text.PrettyPrint.ANSI.Leijen (indent, text)

67import qualified AST.Module.Name as ModuleName

78import qualified AST.Type as Type

89import qualified AST.Variable as Var

10+import qualified Reporting.Annotation as A

911import qualified Reporting.Error.Helpers as Help

10−import qualified Reporting.PrettyPrint as P

1112import qualified Reporting.Region as Region

13+import qualified Reporting.Render.Type as RenderType

1214import qualified Reporting.Report as Report

1315

1416

@@ -22,8 +24,10 @@ data Error

2224 | Port PortError

2325

2426

27+

2528-- VARIABLES

2629

30+

2731data VarError = VarError

2832 { varKind :: String

2933 , varName :: String

@@ -44,8 +48,10 @@ variable kind name problem suggestions =

4448 Var (VarError kind name problem suggestions)

4549

4650

51+

4752-- PATTERN

4853

54+

4955data PatternError

5056 = PatternArgMismatch Var.Canonical Int Int

5157

@@ -55,8 +61,10 @@ argMismatch name expected actual =

5561 Pattern (PatternArgMismatch name expected actual)

5662

5763

64+

5865-- IMPORTS

5966

67+

6068data ImportError

6169 = ModuleNotFound [ModuleName.Raw]

6270 | ValueNotFound String [String]

@@ -72,8 +80,10 @@ valueNotFound name value possibilities =

7280 Import name (ValueNotFound value possibilities)

7381

7482

83+

7584-- ALIASES

7685

86+

7787data AliasError

7888 = ArgMismatch Var.Canonical Int Int

7989 | SelfRecursive String [String] Type.Raw

@@ -85,8 +95,10 @@ alias name expected actual =

8595 Alias (ArgMismatch name expected actual)

8696

8797

98+

8899-- PORTS

89100

101+

90102data PortError = PortError

91103 { portName :: String

92104 , portIsInbound :: Bool

@@ -107,15 +119,17 @@ port name isInbound rootType localType maybeMessage =

107119 Port (PortError name isInbound rootType localType maybeMessage)

108120

109121

122+

110123-- TO REPORT

111124

125+

112126namingError :: String -> String -> Report.Report

113127namingError pre post =

114− Report.simple "NAMING ERROR" pre post

128+ Report.report "NAMING ERROR" Nothing pre (text post)

115129

116130

117−toReport :: P.Dealiaser -> Error -> Report.Report

118−toReport dealiaser err =

131+toReport :: RenderType.Localizer -> Error -> Report.Report

132+toReport localizer err =

119133 case err of

120134 Var (VarError kind name problem suggestions) ->

121135 let var = kind ++ " `" ++ name ++ "`"

@@ -156,26 +170,37 @@ toReport dealiaser err =

156170 argMismatchReport "Type" var expected actual

157171

158172 SelfRecursive name tvars tipe ->

159− Report.simple "ALIAS PROBLEM" "This type alias is recursive, forming an infinite type!" $

160− "Type aliases are just names for more fundamental types, so I go through\n"

161− ++ "and expand them all to know the real underlying type. The problem is that\n"

162− ++ "when I expand a recursive type alias, it keeps getting bigger and bigger.\n"

163− ++ "Dealiasing results in an infinitely large type! Try this instead:\n\n"

164− ++ " type " ++ name ++ concatMap (' ':) tvars ++ " ="

165− ++ P.render (P.nest 8 (P.hang (P.text name) 2 (P.pretty dealiaser True tipe)))

166− ++ "\n\nThis creates a brand new type that cannot be expanded. It is similar types\n"

167− ++ "like List which are recursive, but do not get expanded into infinite types."

173+ Report.report

174+ "ALIAS PROBLEM"

175+ Nothing

176+ "This type alias is recursive, forming an infinite type!"

177+ (

178+ Help.stack

179+ [ Help.reflowParagraph $

180+ "When I expand a recursive type alias, it just keeps getting bigger and bigger.\

181+ \ So dealiasing results in an infinitely large type! Try this instead:"

182+ , indent 4 $

183+ RenderType.decl localizer name tvars [(name, [unsafePromote tipe])]

184+ , text $

185+ "This creates a brand new type that cannot be expanded. Read more about this at:\n"

186+ ++ Help.hintLink "infinite-alias"

187+ ]

188+ )

168189

169190 MutuallyRecursive aliases ->

170− Report.simple "ALIAS PROBLEM" "This type alias is part of a mutually recursive set of type aliases." $

171− "The following type aliases all depend on each other in some way:\n"

172− ++ concatMap showName aliases ++ "\n\n"

173− ++ "The problem is that when you try to expand any of these type aliases, they\n"

174− ++ "expand infinitely! To fix, first try to centralize them into one alias."

175− where

176− showName (Region.Region start _, name, _, _) =

177− "\n " ++ name ++ replicate (65 - length name) ' '

178− ++ "line " ++ show (Region.line start)

191+ Report.report

192+ "ALIAS PROBLEM"

193+ Nothing

194+ "This type alias is part of a mutually recursive set of type aliases."

195+ ( Help.stack

196+ [ text "The following type aliases are mutually recursive:"

197+ , Help.drawCycle (map (\(_, name, _, _) -> name) aliases)

198+ , Help.reflowParagraph $

199+ "You need to convert at least one `type alias` into a `type`. This is a kind of\

200+ \ subtle distinction, so definitely read how to fix it and have great code:"

201+ ++ Help.hintLink "infinite-alias"

202+ ]

203+ )

179204

180205 Import name importError ->

181206 let moduleName = ModuleName.toString name

@@ -205,33 +230,34 @@ toReport dealiaser err =

205230 let

206231 boundPort =

207232 if isInbound then "inbound port" else "outbound port"

208−

209− preHint =

210− "Trying to send " ++ maybe "an unsupported type" id maybeMessage

211− ++ " through " ++ boundPort ++ " `" ++ name ++ "`"

212−

213− postHint =

214− "The specific unsupported type is:\n\n"

215− ++ P.render (P.nest 4 (P.pretty dealiaser False localType)) ++ "\n\n"

216− ++ "The types of values that can flow through " ++ boundPort ++ "s include:\n"

217− ++ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples,\n"

218− ++ "Json.Values, and concrete records."

219233 in

220− Report.simple "PORT ERROR" preHint postHint

234+ Report.report

235+ "PORT ERROR"

236+ Nothing

237+ ("Trying to send " ++ maybe "an unsupported type" id maybeMessage

238+ ++ " through " ++ boundPort ++ " `" ++ name ++ "`"

239+ )

240+ ( Help.stack

241+ [ text "The specific unsupported type is:"

242+ , indent 4 (RenderType.toDoc localizer localType)

243+ , text ("The types of values that can flow through " ++ boundPort ++ "s include:")

244+ , indent 4 $ Help.reflowParagraph $

245+ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\

246+ \ Tuples, Json.Values, and concrete records."

247+ ]

248+ )

221249

222250

223251argMismatchReport :: String -> Var.Canonical -> Int -> Int -> Report.Report

224252argMismatchReport kind var expected actual =

225− let

226− preHint =

227− kind ++ " " ++ Var.toString var ++ " has too "

253+ Report.report

254+ "ARGUMENT"

255+ Nothing

256+ ( kind ++ " " ++ Var.toString var ++ " has too "

228257 ++ (if actual < expected then "few" else "many")

229258 ++ " arguments."

230−

231− postHint =

232− "Expecting " ++ show expected ++ ", but got " ++ show actual ++ "."

233− in

234− Report.simple "ARGUMENT" preHint postHint

259+ )

260+ (text ("Expecting " ++ show expected ++ ", but got " ++ show actual ++ "."))

235261

236262

237263extractSuggestions :: Error -> Maybe [String]

@@ -262,3 +288,23 @@ extractSuggestions err =

262288

263289 Port _ ->

264290 Nothing

291+

292+

293+unsafePromote :: Type.Raw -> Type.Canonical

294+unsafePromote (A.A _ rawType) =

295+ case rawType of

296+ Type.RLambda arg result ->

297+ Type.Lambda (unsafePromote arg) (unsafePromote result)

298+

299+ Type.RVar x ->

300+ Type.Var x

301+

302+ Type.RType (Var.Raw name) ->

303+ Type.Type (Var.local name)

304+

305+ Type.RApp func args ->

306+ Type.App (unsafePromote func) (map unsafePromote args)

307+

308+ Type.RRecord fields ext ->

309+ Type.Record (map (second unsafePromote) fields) (fmap unsafePromote ext)

310+

src/Reporting/Error/Docs.hs+32−19

@@ -1,10 +1,13 @@

11{-# OPTIONS_GHC -Wall #-}

22module Reporting.Error.Docs where

4+import Text.PrettyPrint.ANSI.Leijen (text)

46import qualified Reporting.Error.Helpers as Help

57import qualified Reporting.Report as Report

10+

811data Error

912 = NoDocs

1013 | OnlyInDocs String [String]

@@ -13,49 +16,59 @@ data Error

1316 | NoType String

1417

1518

19+

1620-- TO REPORT

1721

22+

1823toReport :: Error -> Report.Report

1924toReport err =

2025 case err of

2126 NoDocs ->

22− Report.simple "DOCUMENTATION ERROR"

27+ Report.report

28+ "DOCUMENTATION ERROR"

29+ Nothing

2330 ( "You must have a documentation comment between the module declaration and the\n"

2431 ++ "imports."

2532 )

26− "Learn how at <http://package.elm-lang.org/help/documentation-format>"

33+ ( text "Learn more at <http://package.elm-lang.org/help/documentation-format>"

34+ )

2735

2836 OnlyInDocs name suggestions ->

29− Report.simple "DOCUMENTATION ERROR"

37+ Report.report

38+ "DOCUMENTATION ERROR"

39+ Nothing

3040 ("Your module documentation includes `" ++ name ++ "` which is not exported.")

31− ("Is it misspelled? Should it be exported? " ++ Help.maybeYouWant suggestions)

41+ ( text $

42+ "Is it misspelled? Should it be exported? "

43+ ++ Help.maybeYouWant suggestions

44+ )

3245

3346 OnlyInExports names ->

34− Report.simple

47+ Report.report

3548 "DOCUMENTATION ERROR"

49+ Nothing

3650 ( "The following exports do not appear in your module documentation:\n"

3751 ++ concatMap ("\n " ++) names

3852 )

39− ( "All exports must be listed in the module documentation after a @docs keyword.\n"

40− ++ "Learn how at <http://package.elm-lang.org/help/documentation-format>"

53+ ( text $

54+ "All exports must be listed in the module documentation after a @docs keyword.\n"

55+ ++ "Learn more at <http://package.elm-lang.org/help/documentation-format>"

4156 )

4257

4358 NoComment name ->

44− Report.simple "DOCUMENTATION ERROR"

59+ Report.report

60+ "DOCUMENTATION ERROR"

61+ Nothing

4562 ("The value `" ++ name ++ "` does not have a documentation comment.")

46− ( "Documentation comments start with {-| and end with -}. They should provide a\n"

47− ++ "clear description of how they work, and ideally a small code example. This is\n"

48− ++ "extremely valuable for users checking out your package!\n\n"

49− ++ "If you think the docs are clearer without any words, you can use an empty\n"

50− ++ "comment {-|-} which should be used sparingly. Maybe you have a section of 20\n"

51− ++ "values all with the exact same type. The docs may read better if they are all\n"

52− ++ "described in one place.\n\n"

53− ++ "Learn more at <http://package.elm-lang.org/help/documentation-format>"

63+ ( text "Learn more at <http://package.elm-lang.org/help/documentation-format>"

5464 )

5565

5666 NoType name ->

57− Report.simple "MISSING ANNOTATION"

67+ Report.report

68+ "MISSING ANNOTATION"

69+ Nothing

5870 ("The value `" ++ name ++ "` does not have a type annotation.")

59− ( "Adding type annotations is best practice and it gives you a chance to name\n"

60− ++ "types and type variables so they are as easy as possible to understand!"

71+ ( text $

72+ "Adding type annotations is best practice and it gives you a chance to name\n"

73+ ++ "types and type variables so they are as easy as possible to understand!"

6174 )

src/Reporting/Error/Helpers.hs+161−2

@@ -1,15 +1,174 @@

11{-# OPTIONS_GHC -Wall #-}

2−module Reporting.Error.Helpers where

2+module Reporting.Error.Helpers

3+ ( (|>)

4+ , functionName, hintLink, stack, reflowParagraph

5+ , commaSep, capitalize, ordinalize, drawCycle

6+ , findPotentialTypos, vetTypos

7+ , nearbyNames, distance, maybeYouWant

8+ )

9+ where

310

411import Data.Function (on)

12+import qualified Data.Char as Char

513import qualified Data.List as List

14+import qualified Data.Map as Map

15+import qualified Data.Set as Set

616import qualified Text.EditDistance as Dist

17+import Text.PrettyPrint.ANSI.Leijen

18+ ( Doc, (<>), dullyellow, fillSep, hardline, text, vcat )

19+

20+import qualified AST.Helpers as Help

21+import qualified Elm.Compiler.Version as Compiler

22+import qualified Elm.Package as Pkg

23+

24+

25+

26+-- PIPES

27+

28+

29+(|>) :: a -> (a -> b) -> b

30+(|>) x f =

31+ f x

32+

33+

34+infixl 0 |>

35+

36+

37+

38+-- DOC HELPERS

39+

40+

41+functionName :: String -> String

42+functionName opName =

43+ if Help.isOp opName then

44+ "(" ++ opName ++ ")"

45+

46+ else

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

48+

49+

50+hintLink :: String -> String

51+hintLink fileName =

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

53+ ++ Pkg.versionToString Compiler.version

54+ ++ "/hints/" ++ fileName ++ ".md>"

55+

56+

57+stack :: [Doc] -> Doc

58+stack list =

59+ case list of

60+ [] ->

61+ error "function `stack` requires a non-empty list of docs"

62+

63+ doc : docs ->

64+ List.foldl' (\a b -> a <> hardline <> hardline <> b) doc docs

65+

66+

67+reflowParagraph :: String -> Doc

68+reflowParagraph paragraph =

69+ fillSep (map text (words paragraph))

70+

71+

72+commaSep :: [String] -> String

73+commaSep tokens =

74+ case tokens of

75+ [token] ->

76+ " " ++ token

77+

78+ [token1,token2] ->

79+ " " ++ token1 ++ " and " ++ token2

80+

81+ _ ->

82+ " " ++ List.intercalate ", " (init tokens) ++ ", and " ++ last tokens

83+

84+

85+capitalize :: String -> String

86+capitalize string =

87+ case string of

88+ [] -> []

89+ c : cs ->

90+ Char.toUpper c : cs

91+

92+

93+ordinalize :: Int -> String

94+ordinalize number =

95+ let

96+ remainder10 =

97+ number `mod` 10

98+

99+ remainder100 =

100+ number `mod` 100

101+

102+ ending

103+ | remainder100 `elem` [11..13] = "th"

104+ | remainder10 == 1 = "st"

105+ | remainder10 == 2 = "nd"

106+ | remainder10 == 3 = "rd"

107+ | otherwise = "th"

108+ in

109+ show number ++ ending

110+

111+

112+

113+drawCycle :: [String] -> Doc

114+drawCycle strings =

115+ let

116+ topLine =

117+ text "┌─────┐"

118+

119+ line str =

120+ text "│ " <> dullyellow (text str)

121+

122+ midLine =

123+ text "│ ↓"

124+

125+ bottomLine =

126+ text "└─────┘"

127+ in

128+ vcat (topLine : List.intersperse midLine (map line strings) ++ [ bottomLine ])

129+

130+

131+

132+-- FIND TYPOS

133+

134+

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

136+findPotentialTypos leftOnly rightOnly =

137+ let

138+ veryNear leftName =

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

140+ in

141+ concatMap veryNear leftOnly

142+

143+

144+vetTypos :: [(String, String)] -> Maybe (Set.Set String, Set.Set String)

145+vetTypos potentialTypos =

146+ let

147+ tallyNames (ln, rn) (lc, rc) =

148+ ( Map.insertWith (+) ln 1 lc

149+ , Map.insertWith (+) rn 1 rc

150+ )

151+

152+ (leftCounts, rightCounts) =

153+ foldr tallyNames (Map.empty, Map.empty) potentialTypos

154+

155+ acceptable :: Map.Map String Int -> Bool

156+ acceptable counts =

157+ not (Map.null counts)

158+ &&

159+ Map.foldr (\n unique -> n < 2 && unique) True counts

160+ in

161+ if acceptable leftCounts && acceptable rightCounts then

162+ Just (Map.keysSet leftCounts, Map.keysSet rightCounts)

163+

164+ else

165+ Nothing

7166

8−import Elm.Utils ((|>))

9167

10168

11169-- NEARBY NAMES

12170

171+

13172nearbyNames :: (a -> String) -> a -> [a] -> [a]

14173nearbyNames format name names =

15174 let editDistance =

src/Reporting/Error/Pattern.hs+45−88

@@ -1,13 +1,15 @@

11{-# OPTIONS_GHC -Wall #-}

22module Reporting.Error.Pattern where

4−import qualified AST.Module.Name as ModuleName

5−import qualified AST.Variable as Var

4+import Text.PrettyPrint.ANSI.Leijen (text)

66import qualified Nitpick.Pattern as Pattern

7−import qualified Reporting.PrettyPrint as P

7+import qualified Reporting.Error.Helpers as Help

8+import qualified Reporting.Render.Type as RenderType

89import qualified Reporting.Report as Report

910

1011

12+

1113data Error

1214 = Incomplete Origin [Pattern.Pattern]

1315 | Redundant

@@ -19,113 +21,68 @@ data Origin

1921 | Case

2022

2123

24+

2225-- TO REPORT

2326

24−toReport :: P.Dealiaser -> Error -> Report.Report

25−toReport dealiaser err =

27+

28+toReport :: RenderType.Localizer -> Error -> Report.Report

29+toReport _localizer err =

2630 case err of

2731 Incomplete Arg unhandled ->

28− Report.simple

32+ Report.report

2933 "PARTIAL PATTERN"

30− "This argument does not cover all possible inputs."

31− ( "Any of these patterns can cause a crash:\n"

32− ++ viewPatternList unhandled

33− ++ "\n\n"

34− ++ partialExplanation unhandled

35− )

34+ Nothing

35+ "This pattern does not cover all possible inputs."

36+ (text (unhandledError unhandled toCaseMessage))

3637

3738 Incomplete LetBound unhandled ->

38− Report.simple

39+ Report.report

3940 "PARTIAL PATTERN"

41+ Nothing

4042 "The pattern used here does not cover all possible values."

41− ( "Any of these patterns can cause a crash:\n"

42− ++ viewPatternList unhandled

43− ++ "\n\n"

44− ++ partialExplanation unhandled

45− )

43+ (text (unhandledError unhandled toCaseMessage))

4644

4745 Incomplete Case unhandled ->

48− Report.simple

49− "INCOMPLETE PATTERN MATCH"

46+ Report.report

47+ "MISSING PATTERNS"

48+ Nothing

5049 "This `case` does not have branches for all possibilities."

51− ( "Any of these patterns can cause a crash:\n"

52− ++ viewPatternList unhandled

53− ++ "\n\n"

54− ++ incompleteExplanation

55− )

50+ (text (unhandledError unhandled newTagsMessage))

5651

5752 Redundant ->

58− Report.simple

53+ Report.report

5954 "REDUNDANT PATTERN"

60− "The following pattern is redundant."

61− "Any value with this shape will be handled by a previous pattern."

55+ Nothing

56+ "The following pattern is redundant. Remove it."

57+ (text "Any value with this shape will be handled by a previous pattern.")

6258

6359

64−viewPatternList :: [Pattern.Pattern] -> String

65−viewPatternList unhandledPatterns =

60+unhandledError :: [Pattern.Pattern] -> String -> String

61+unhandledError unhandledPatterns relevantMessage =

6662 let

67− (showPatterns, rest) =

63+ (visiblePatterns, rest) =

6864 splitAt 4 unhandledPatterns

69− in

70− concatMap ((++) "\n ") $

71− map (Pattern.toString False) showPatterns

72− ++ if null rest then [] else ["..."]

73−

74−

75−partialExplanation :: [Pattern.Pattern] -> String

76−partialExplanation unhandledPatterns =

77−

78− "You probably want to switch to a `case` expression to handle all possible\n"

79− ++ "patterns in a simple way. If you think some cases are impossible, you can use\n"

80− ++ "`Debug.crash` to make that thinking explicit in your code.\n"

81− ++ "<http://package.elm-lang.org/packages/elm-lang/core/latest/Debug#crash>"

82− ++

83−

84− if isNothing unhandledPatterns then

85−

86− "\n\nSometimes you *know* a value will never be Nothing, though such cases are very\n"

87− ++ "rare. If you are certain you are in that case and that there is no better way\n"

88− ++ "to do things, I'd recommend creating a function `unsafe` that makes the danger\n"

89− ++ "explicit in the code. <https://github.com/elm-lang/core/issues/215>"

90−

91− else if isEmptyList unhandledPatterns then

92−

93− "\n\nSometimes you *know* a list cannot be empty, though such cases are relatively\n"

94− ++ "rare. If you are certain you are in that case and that there is no better\n"

95− ++ "way to do things, I'd recommend creating a function like `unsafe` that makes\n"

96− ++ "the danger explicit in the code. <https://github.com/elm-lang/core/issues/215>"

97−

98− else

99−

100− ""

101−

102−

103−isNothing :: [Pattern.Pattern] -> Bool

104−isNothing unhandledPatterns =

105− case unhandledPatterns of

106− [Pattern.Data (Var.Canonical (Var.Module moduleName) "Nothing") []] ->

107− moduleName == ModuleName.inCore ["Maybe"]

108−

109− _ ->

110− False

11165

66+ patternList =

67+ map (Pattern.toString False) visiblePatterns

68+ ++ if null rest then [] else ["..."]

69+ in

70+ "You need to account for the following values:\n"

71+ ++ concatMap ("\n " ++) patternList ++ "\n"

72+ ++ "\n"

73+ ++ relevantMessage ++ "\n"

74+ ++ "\n"

75+ ++ "If you are seeing this error for the first time, check out these hints:\n"

76+ ++ Help.hintLink "missing-patterns" ++ "\n"

77+ ++ "The recommendations about `Debug.crash` and wildcard patterns are important!"

11278

113−isEmptyList :: [Pattern.Pattern] -> Bool

114−isEmptyList unhandledPatterns =

115− case unhandledPatterns of

116− [Pattern.Data (Var.Canonical Var.BuiltIn "[]") []] ->

117− True

11879

119− _ ->

120− False

80+toCaseMessage :: String

81+toCaseMessage =

82+ "Switch to a `case` expression to handle all possible patterns."

12183

12284

123−incompleteExplanation :: String

124−incompleteExplanation =

125− "Did you add a new tag to a union type? Add how it should be handled here and\n"

126− ++ "you will be all set!\n"

127− ++ "\n"

128− ++ "If you want to go quick and implement this later, you may want to look into\n"

129− ++ "using `Debug.crash` which has some cool error reporting abilities.\n"

130− ++ "<http://package.elm-lang.org/packages/elm-lang/core/latest/Debug#crash>"

85+newTagsMessage :: String

86+newTagsMessage =

87+ "Did you add a new tag to a union type? Add a branch for it here!"

13188

src/Reporting/Error/Syntax.hs+130−107

@@ -4,12 +4,10 @@ module Reporting.Error.Syntax where

44import qualified Data.List as List

55import qualified Data.Set as Set

66import qualified Text.Parsec.Error as Parsec

7−import qualified Text.PrettyPrint as P

8−import Text.PrettyPrint ((<+>))

7+import Text.PrettyPrint.ANSI.Leijen (dullyellow, hsep, text)

10−import qualified AST.Helpers as Help

11−import qualified AST.Type as Type

12−import qualified Reporting.PrettyPrint as P

9+import qualified Reporting.Error.Helpers as Help

10+import qualified Reporting.Render.Type as RenderType

1311import qualified Reporting.Report as Report

1412

1513

@@ -25,177 +23,189 @@ data Error

2523 | DuplicateValueDeclaration String

2624 | DuplicateTypeDeclaration String

2725 | DuplicateDefinition String

28− | UnboundTypeVarsInAlias String [String] String [String] Type.Raw

29− | UnboundTypeVarsInUnion String [String] String [String] [(String, [Type.Raw])]

26+ | UnboundTypeVarsInAlias String [String] String [String]

27+ | UnboundTypeVarsInUnion String [String] String [String]

3028

3129

3230-- TO REPORT

3331

34−toReport :: P.Dealiaser -> Error -> Report.Report

35−toReport dealiaser err =

32+toReport :: RenderType.Localizer -> Error -> Report.Report

33+toReport _localizer err =

3634 case err of

3735 Parse messages ->

3836 parseErrorReport messages

3937

4038 BadFunctionName arity ->

41− Report.simple

39+ Report.report

4240 "BAD FUNCTION DEFINITION"

41+ Nothing

4342 "Complex patterns cannot be used as function names."

44− ( "This function definition has " ++ show arity ++ " arguments, but instead of a normal name like\n"

45− ++ "`add` or `reverse` it has a pattern. There is no way to \"deconstruct\" a\n"

46− ++ "function with pattern matching, so this needs to be changed to a normal name."

43+ ( Help.reflowParagraph $

44+ "This function definition has " ++ show arity ++ " arguments, but instead\

45+ \ of a normal name like `add` or `reverse` it has a pattern. There is no\

46+ \ way to \"deconstruct\" a function with pattern matching, so this needs to\

47+ \ be changed to a normal name."

4748 )

4849

4950 BadPattern name ->

50− Report.simple

51+ Report.report

5152 "BAD PATTERN"

53+ Nothing

5254 ("The free variable `" ++ name ++ "` appears more than once in this pattern.")

53− ( "Rename the variables so there are no duplicates.\n\n"

54− ++ "In Elm, pattern matching works by binding these free variables to subsections\n"

55− ++ "of the matching value. It does not make sense to have the same name for two\n"

56− ++ "different subsections though! When you say `" ++ name ++ "` in some code, there\n"

57− ++ "is no way for me to know which subsection you mean!"

55+ ( Help.stack

56+ [ text "Rename the variables so there are no duplicates."

57+ , Help.reflowParagraph $

58+ "In Elm, pattern matching works by binding these free variables to subsections\

59+ \ of the matching value. It does not make sense to have the same name for two\

60+ \ different subsections though! When you say `" ++ name ++ "` in some code, there\

61+ \ is no way for me to know which subsection you mean!"

62+ ]

5863 )

5964

6065 InfixDuplicate opName ->

61− Report.simple

66+ Report.report

6267 "INFIX OVERLAP"

63− ("The infix declarations for " ++ operator ++ " must be removed.")

64− ("The precedence and associativity can only be set in one place, and\n"

65− ++ "this information has already been set somewhere else."

68+ Nothing

69+ ("The infix declarations for " ++ Help.functionName opName ++ " must be removed.")

70+ ( Help.reflowParagraph $

71+ "The precedence and associativity of a particular operator can only be set in\

72+ \ one place in a code base, and " ++ Help.functionName opName

73+ ++ " has already been set somewhere else."

6674 )

67− where

68− operator =

69− if Help.isOp opName

70− then "(" ++ opName ++ ")"

71− else "`" ++ opName ++ "`"

7275

7376 TypeWithoutDefinition valueName ->

74− Report.simple

77+ Report.report

7578 "MISSING DEFINITION"

79+ Nothing

7680 ("There is a type annotation for `" ++ valueName ++ "` but there"

7781 ++ " is no corresponding definition!"

7882 )

79− ("Directly below the type annotation, put a definition like:\n\n"

80− ++ " " ++ valueName ++ " = 42"

83+ ( text $

84+ "Directly below the type annotation, put a definition like:\n\n"

85+ ++ " " ++ valueName ++ " = 42"

8186 )

8287

8388 PortWithoutAnnotation portName ->

84− Report.simple

89+ Report.report

8590 "PORT ERROR"

91+ Nothing

8692 ("Port `" ++ portName ++ "` does not have a type annotation!")

87− ("Directly above the port definition, I need something like this:\n\n"

88− ++ " port " ++ portName ++ " : Signal Int"

93+ ( text $

94+ "Directly above the port definition, I need something like this:\n\n"

95+ ++ " port " ++ portName ++ " : Signal Int"

8996 )

9097

9198

9299 UnexpectedPort ->

93− Report.simple

100+ Report.report

94101 "PORT ERROR"

102+ Nothing

95103 "This module has ports, but ports can only appear in the main module."

96− ( "Ports in library code would create hidden dependencies where importing a\n"

97− ++ "module could bring in constraints not captured in the public API. Furthermore,\n"

98− ++ "if the module is imported twice, do we send values out the port twice?"

104+ ( Help.reflowParagraph $

105+ "Ports in library code would create hidden dependencies where importing a\

106+ \ module could bring in constraints not captured in the public API. Furthermore,\

107+ \ if the module is imported twice, do we send values out the port twice?"

99108 )

100109

101110 DuplicateFieldName name ->

102− Report.simple

111+ Report.report

103112 "DUPLICATE FIELD"

113+ Nothing

104114 ("This record has more than one field named `" ++ name ++ "`.")

105− "There can only be one. Do some renaming to make sure the names are distinct!"

115+ (text "There can only be one. Do some renaming to make sure the names are distinct!")

106116

107117 DuplicateValueDeclaration name ->

108− Report.simple

118+ Report.report

109119 "DUPLICATE DEFINITION"

110− ("Naming multiple top-level values `" ++ name ++ "` makes things\n"

120+ Nothing

121+ ( "Naming multiple top-level values `" ++ name ++ "` makes things\n"

111122 ++ "ambiguous. When you say `" ++ name ++ "` which one do you want?"

112123 )

113− ("Find all the top-level values named `" ++ name ++ "` and\n"

114− ++ "do some renaming. Make sure the names are distinct!"

124+ ( Help.reflowParagraph $

125+ "Find all the top-level values named " ++ Help.functionName name

126+ ++ " and do some renaming. Make sure the names are distinct!"

115127 )

116128

117129 DuplicateTypeDeclaration name ->

118− Report.simple

130+ Report.report

119131 "DUPLICATE DEFINITION"

120− ("Naming multiple types `" ++ name ++ "` makes things ambiguous\n"

121− ++ "When you say `" ++ name ++ "` which one do you want?"

132+ Nothing

133+ ( "There are multiple types named `" ++ name ++ "` in this module."

122134 )

123− ("Find all the types named `" ++ name ++ "` and\n"

124− ++ "do some renaming. Make sure the names are distinct!"

135+ ( Help.reflowParagraph $

136+ "Search through this module, find all the types named `" ++ name

137+ ++ "`, and give each of them a unique name."

125138 )

126139

127140 DuplicateDefinition name ->

128− Report.simple

141+ Report.report

129142 "DUPLICATE DEFINITION"

130− ("Naming multiple values `" ++ name ++ "` in a single let-expression makes\n"

131− ++ "things ambiguous. When you say `" ++ name ++ "` which one do you want?"

143+ Nothing

144+ ("There are multiple values named `" ++ name ++ "` in this let-expression."

132145 )

133− ("Find all the values named `" ++ name ++ "` in this let-expression and\n"

134− ++ "do some renaming. Make sure the names are distinct!"

146+ ( Help.reflowParagraph $

147+ "Search through this let-expression, find all the values named `" ++ name

148+ ++ "`, and give each of them a unique name."

135149 )

136150

137− UnboundTypeVarsInAlias typeName givenVars tvar tvars tipe ->

138− unboundTypeVars typeName tvar tvars $ P.render $

139− P.hang

140− (P.text "type alias" <+> P.text typeName <+> P.hsep vars <+> P.equals)

141− 4

142− (P.pretty dealiaser False tipe)

143− where

144− vars = map P.text (givenVars ++ tvar : tvars)

145−

146−

147− UnboundTypeVarsInUnion typeName givenVars tvar tvars ctors ->

148− unboundTypeVars typeName tvar tvars $ P.render $

149− P.vcat

150− [ P.text "type" <+> P.text typeName <+> P.hsep vars

151− , map toDoc ctors

152− |> zipWith (<+>) (P.text "=" : repeat (P.text "|"))

153− |> P.vcat

154− |> P.nest 4

155− ]

156− where

157− (|>) = flip ($)

158− vars = map P.text (givenVars ++ tvar : tvars)

159− toDoc (ctor, args) =

160− P.text ctor <+> P.hsep (map (P.pretty dealiaser True) args)

161−

162−

163−unboundTypeVars :: String -> String -> [String] -> String -> Report.Report

164−unboundTypeVars typeName tvar tvars revisedDeclaration =

165− Report.simple

166− "UNBOUND TYPE VARS"

167− ( "Not all type variables in `" ++ typeName ++ "` are listed, making sneaky\n"

168− ++ "type errors possible. Unbound type variables include: "

169− ++ List.intercalate ", " (tvar:tvars)

151+ UnboundTypeVarsInAlias typeName givenVars tvar tvars ->

152+ unboundTypeVars "type alias" typeName givenVars tvar tvars

153+

154+ UnboundTypeVarsInUnion typeName givenVars tvar tvars ->

155+ unboundTypeVars "type" typeName givenVars tvar tvars

156+

157+

158+

159+unboundTypeVars :: String -> String -> [String] -> String -> [String] -> Report.Report

160+unboundTypeVars declKind typeName givenVars tvar tvars =

161+ Report.report

162+ "UNBOUND TYPE VARIABLES"

163+ Nothing

164+ ( Help.capitalize declKind ++ " `" ++ typeName ++ "` must declare its use of type variable"

165+ ++ Help.commaSep (tvar:tvars)

170166 )

171− ( "You probably want this definition instead:\n"

172− ++ concatMap ("\n "++) (lines revisedDeclaration) ++ "\n\n"

173− ++ "Here's why. Imagine one `" ++ typeName ++ "` where `" ++ tvar ++ "` is an Int and\n"

174− ++ "another where it is a Bool. When we explicitly list the type variables, type\n"

175− ++ "checker can see that they are actually different types."

167+ ( Help.stack

168+ [ text "You probably need to change the declaration like this:"

169+ , hsep $

170+ map text (declKind : typeName : givenVars)

171+ ++ map (dullyellow . text) (tvar : tvars)

172+ ++ map text ["=", "…"]

173+ , Help.reflowParagraph $

174+ "Here's why. Imagine one `" ++ typeName ++ "` where `" ++ tvar ++ "` is an Int and\

175+ \ another where it is a Bool. When we explicitly list the type variables, type\

176+ \ checker can see that they are actually different types."

177+ ]

176178 )

177179

178180

181+

179182-- TAGGING PARSE ERRORS

180183

184+

181185newline :: String

182186newline = "NEWLINE"

183187

188+

184189freshLine :: String

185190freshLine = "FRESH_LINE"

186191

192+

187193whitespace :: String

188194whitespace = "WHITESPACE"

189195

196+

190197keyword :: String -> String

191198keyword kwd =

192199 "KEYWORD=" ++ kwd

193200

201+

194202unkeyword :: String -> Maybe String

195203unkeyword message =

196− if List.isPrefixOf "KEYWORD=" message

197− then Just (drop (length "KEYWORD=") message)

198− else Nothing

204+ if List.isPrefixOf "KEYWORD=" message then

205+ Just (drop (length "KEYWORD=") message)

206+

207+ else

208+ Nothing

199209

200210

201211-- REPORTING PARSE ERRORS

@@ -214,9 +224,10 @@ parseErrorReport messages =

214224 Parsec.Expect msg ->

215225 let

216226 msg' =

217− if msg `elem` [whitespace, newline, freshLine]

218− then "whitespace"

219− else msg

227+ if msg `elem` [whitespace, newline, freshLine] then

228+ "whitespace"

229+ else

230+ msg

220231 in

221232 hint { _expected = Set.insert msg' (_expected hint) }

222233

@@ -226,26 +237,38 @@ parseErrorReport messages =

226237 (ParseHint msgs expects) =

227238 foldr addMsg emptyHint messages

228239

229− preHint =

240+ (preHint, maybePost) =

230241 case msgs of

231242 [msg] ->

232243 case unkeyword msg of

233244 Just kwd ->

234− "It looks like the keyword `" ++ kwd ++ "` is being used as a variable.\n"

235− ++ "Try renaming it to something else."

245+ ( "It looks like the keyword `" ++ kwd ++ "` is being used as a variable."

246+ , Just "Rename it to something else."

247+ )

248+

236249 Nothing ->

237− msg

250+ ( msg

251+ , Nothing

252+ )

238253

239− _ -> "I ran into something unexpected when parsing your code!"

254+ _ ->

255+ ( "I ran into something unexpected when parsing your code!"

256+ , Nothing

257+ )

240258

241259 postHint =

242− if Set.null expects

243− then ""

244− else

260+ if Set.null expects then

261+ "Maybe <http://elm-lang.org/docs/syntax> can help you figure it out."

262+

263+ else

245264 "I am looking for one of the following things:\n"

246265 ++ concatMap ("\n "++) (Set.toList expects)

247266 in

248− Report.simple "SYNTAX PROBLEM" preHint postHint

267+ Report.report

268+ "SYNTAX PROBLEM"

269+ Nothing

270+ preHint

271+ (text (maybe postHint id maybePost))

249272

250273

251274data ParseHint = ParseHint

src/Reporting/Error/Type.hs+503−176

@@ -1,37 +1,55 @@

11{-# OPTIONS_GHC -Wall #-}

22module Reporting.Error.Type where

4−import qualified Data.Char as Char

5−import Text.PrettyPrint ((<+>))

6−import qualified Text.PrettyPrint as P

4+import qualified Data.Maybe as Maybe

5+import Text.PrettyPrint.ANSI.Leijen

6+ ( Doc, (<>), (<+>), colon, dullyellow, equals

7+ , fillSep, hang, indent, text, underline, vcat

8+ )

8−import qualified AST.Helpers as Help

910import qualified AST.Type as Type

1011import qualified AST.Variable as Var

11−import qualified Reporting.PrettyPrint as P

12+import qualified Reporting.Error.Helpers as Help

1213import qualified Reporting.Region as Region

14+import qualified Reporting.Render.Type as RenderType

1315import qualified Reporting.Report as Report

1416

1517

18+

19+-- ERRORS

20+

21+

1622data Error

1723 = Mismatch Mismatch

18− | InfiniteType InfiniteType

1924 | BadMain Type.Canonical

25+ | InfiniteType

26+ { _name :: String

27+ , _overallType :: Type.Canonical

28+ , _infiniteType :: Type.Canonical

29+ }

2030

2131

2232data Mismatch = MismatchInfo

2333 { _hint :: Hint

2434 , _leftType :: Type.Canonical

2535 , _rightType :: Type.Canonical

26− , _note :: Maybe String

36+ , _reason :: Maybe Reason

2737 }

2838

2939

30−data InfiniteType = InfiniteTypeInfo

31− { _name :: String

32− , _var :: Type.Canonical

33− , _type :: Type.Canonical

34− }

40+data Reason

41+ = MessyFields [String] [String]

42+ | IntFloat

43+ | TooLongComparableTuple Int

44+ | BadVar (Maybe VarType) (Maybe VarType)

45+

46+

47+data VarType

48+ = Number

49+ | Comparable

50+ | Appendable

51+ | CompAppend

52+ | Rigid (Maybe String)

3553

3654

3755data Hint

@@ -47,7 +65,7 @@ data Hint

4765 | BinopRight Var.Canonical Region.Region

4866 | Binop Var.Canonical

4967 | Function (Maybe Var.Canonical)

50− | UnexpectedArg (Maybe Var.Canonical) Int Region.Region

68+ | UnexpectedArg (Maybe Var.Canonical) Int Int Region.Region

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

5270 | BadTypeAnnotation String

5371 | Instance String

@@ -66,166 +84,269 @@ data Pattern

6684 | PRecord

6785

6886

87+

6988-- TO REPORT

7089

71−toReport :: P.Dealiaser -> Error -> Report.Report

72−toReport dealiaser err =

90+

91+toReport :: RenderType.Localizer -> Error -> Report.Report

92+toReport localizer err =

7393 case err of

74− Mismatch (MismatchInfo hint leftType rightType note) ->

75− let

76− (subRegion, preHint, maybePostHint) = hintToString hint

77−

78− postHint =

79− maybe "" (++"\n\n") note

80− ++ maybe "" (++"\n\n") maybePostHint

81− ++ "As I infer the types of values flowing through your program, I see a conflict\n"

82− ++ "between these two types:\n\n"

83− ++ P.render (P.nest 4 (P.pretty dealiaser False leftType))

84− ++ "\n\n"

85− ++ P.render (P.nest 4 (P.pretty dealiaser False rightType))

86− in

87− Report.Report "TYPE MISMATCH" subRegion preHint postHint

94+ Mismatch info ->

95+ mismatchToReport localizer info

8896

89− InfiniteType (InfiniteTypeInfo name var tipe) ->

90− let

91− prettyVar =

92− P.pretty dealiaser False var

97+ InfiniteType name overallType infiniteType ->

98+ infiniteTypeToReport localizer name overallType infiniteType

9399

94− prettyType =

95− P.pretty dealiaser False tipe

96− in

97− Report.simple "INFINITE TYPE"

98− ( "I am inferring weird self-referential type for `" ++ name ++ "`"

99− )

100− ( "The bit of the type that is self-referential looks like this:\n\n"

101− ++ P.render (P.nest 4 (prettyVar <+> P.equals <+> prettyType))

102− ++ "\n\nThe cause is often that the usage of `" ++ name ++ "` is flipped around.\n\n"

103− ++ "Maybe you are inserting a data structure into an element? Maybe you are giving\n"

104− ++ "a function to an argument? Either way, something is probably backwards!\n\n"

105− ++ "Try breaking the code related to `" ++ name ++ "` into smaller pieces.\n"

106− ++ "Give each piece a name and try to write down its type."

100+ BadMain tipe ->

101+ Report.report

102+ "BAD MAIN TYPE"

103+ Nothing

104+ "The 'main' value has an unsupported type."

105+ ( Help.stack

106+ [ Help.reflowParagraph $

107+ "I need an Element, Html, (Signal Element), or (Signal Html) so I can render it\

108+ \ on screen, but you gave me:"

109+ , indent 4 (RenderType.toDoc localizer tipe)

110+ ]

107111 )

108112

109− BadMain tipe ->

110− Report.simple "BAD MAIN TYPE" "The 'main' value has an unsupported type." $

111− "I need an Element, Html, (Signal Element), or (Signal Html) so I can render it\n"

112− ++ "on screen, but you gave me:\n\n"

113− ++ P.render (P.nest 4 (P.pretty dealiaser False tipe))

114113

115114

116−hintToString :: Hint -> (Maybe Region.Region, String, Maybe String)

117−hintToString hint =

115+-- TYPE MISMATCHES

116+

117+

118+mismatchToReport :: RenderType.Localizer -> Mismatch -> Report.Report

119+mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =

120+ let

121+ report =

122+ Report.report "TYPE MISMATCH"

123+

124+ cmpHint leftWords rightWords extraHints =

125+ comparisonHint localizer leftType rightType leftWords rightWords

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

127+ ++ map toHint extraHints

128+ )

129+ in

118130 case hint of

119131 CaseBranch branchNumber region ->

120− ( Just region

121− , "The " ++ ordinalize branchNumber ++ " branch of this `case` results in an unexpected type of value."

122− , Just "All branches should match so that no matter which one we take, we always get\nback the same type of value."

123− )

132+ report

133+ (Just region)

134+ ( "The " ++ ordinalPair branchNumber

135+ ++ " branches of this `case` produce different types of values."

136+ )

137+ ( cmpHint

138+ ("The " ++ Help.ordinalize (branchNumber -1) ++ " branch has this type:")

139+ ("But the " ++ Help.ordinalize branchNumber ++ " is:")

140+ [ "All branches in a `case` must have the same type. So no matter\

141+ \ which one we take, we always get back the same type of value."

142+ ]

143+ )

124144

125145 Case ->

126− ( Nothing

127− , "All the branches of this case-expression are consistent, but the overall\n"

128− ++ "type does not match how it is used elsewhere."

129− , Nothing

130− )

146+ report

147+ Nothing

148+ ( "All the branches of this case-expression are consistent, but the overall\n"

149+ ++ "type does not match how it is used elsewhere."

150+ )

151+ ( cmpHint

152+ "The `case` evaluates to something of type:"

153+ "Which is fine, but the surrounding context wants it to be:"

154+ []

155+ )

131156

132157 IfCondition ->

133− ( Nothing

134− , "This condition does not evaluate to a boolean value, True or False."

135− , Just "Elm does not have \"truthiness\" such that ints and strings and lists are\nautomatically converted to booleans. Do that conversion explicitly."

136− )

158+ report

159+ Nothing

160+ "This condition does not evaluate to a boolean value, True or False."

161+ ( cmpHint

162+ "You have given me an condition with this type:"

163+ "But I need it to be:"

164+ [ "Elm does not have \"truthiness\" such that ints and strings and lists\

165+ \ are automatically converted to booleans. Do that conversion explicitly."

166+ ]

167+ )

137168

138169 IfBranches ->

139− ( Nothing

140− , "The branches of this `if` result in different types of values."

141− , Just "All branches should match so that no matter which one we take, we always get\nback the same type of value."

142− )

170+ report

171+ Nothing

172+ "The branches of this `if` produce different types of values."

173+ ( cmpHint

174+ "The `then` branch has type:"

175+ "But the `else` branch is:"

176+ [ "These need to match so that no matter which branch we take, we\

177+ \ always get back the same type of value."

178+ ]

179+ )

143180

144181 MultiIfBranch branchNumber region ->

145− ( Just region

146− , "The " ++ ordinalize branchNumber ++ " branch of this `if` results in an unexpected type of value."

147− , Just "All branches should match so that no matter which one we take, we always get\nback the same type of value."

148− )

182+ report

183+ (Just region)

184+ ( "The " ++ ordinalPair branchNumber

185+ ++ " branches of this `if` produce different types of values."

186+ )

187+ ( cmpHint

188+ ("The " ++ Help.ordinalize (branchNumber - 1) ++ " branch has this type:")

189+ ("But the "++ Help.ordinalize branchNumber ++ " is:")

190+ [ "All the branches of an `if` need to match so that no matter which\

191+ \ one we take, we get back the same type of value overall."

192+ ]

193+ )

149194

150195 If ->

151− ( Nothing

152− , "All the branches of this if-expression are consistent, but the overall\n"

153− ++ "type does not match how it is used elsewhere."

154− , Nothing

155− )

196+ report

197+ Nothing

198+ "All the branches of this `if` are consistent, but the overall\

199+ \ type does not match how it is used elsewhere."

200+ ( cmpHint

201+ "The `if` evaluates to something of type:"

202+ "Which is fine, but the surrounding context wants it to be:"

203+ []

204+ )

156205

157206 ListElement elementNumber region ->

158− ( Just region

159− , "The " ++ ordinalize elementNumber ++ " element of this list is an unexpected type of value."

160− , Just "All elements should be the same type of value so that we can iterate over the\nlist without running into unexpected values."

161− )

207+ report

208+ (Just region)

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

210+ ( cmpHint

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

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

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

214+ \ iterate through the list without running into unexpected values."

215+ ]

216+ )

162217

163218 List ->

164− ( Nothing

165− , "All the elements in this list are the same type, but the overall\n"

166− ++ "type does not match how it is used elsewhere."

167− , Nothing

168− )

219+ report

220+ Nothing

221+ ( "All the elements in this list are the same type, but the overall\n"

222+ ++ "type does not match how it is used elsewhere."

223+ )

224+ ( cmpHint

225+ "The list has type:"

226+ "Which is fine, but the surrounding context wants it to be:"

227+ []

228+ )

169229

170230 BinopLeft op region ->

171− ( Just region

172− , "The left argument of " ++ prettyOperator op ++ " is causing a type mismatch."

173− , Nothing

174− )

231+ report

232+ (Just region)

233+ ("The left argument of " ++ prettyName op ++ " is causing a type mismatch.")

234+ ( cmpHint

235+ (prettyName op ++ " is expecting the left argument to be a:")

236+ "But the left argument is:"

237+ []

238+ )

175239

176240 BinopRight op region ->

177− ( Just region

178− , "The right argument of " ++ prettyOperator op ++ " is causing a type mismatch."

179− , Nothing

180− )

241+ report

242+ (Just region)

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

244+ ( cmpHint

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

246+ "But the right argument is:"

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

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

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

250+ ]

251+ )

181252

182253 Binop op ->

183− ( Nothing

184− , "The two arguments to " ++ prettyOperator op ++ " are fine, but the overall type of this expression\n"

185− ++ "does not match how it is used elsewhere."

186− , Nothing

187− )

254+ report

255+ Nothing

256+ ( "The two arguments to " ++ prettyName op ++

257+ " are fine, but the overall type of this expression\

258+ \ does not match how it is used elsewhere."

259+ )

260+ ( cmpHint

261+ "The result of this binary operation is:"

262+ "Which is fine, but the surrounding context wants it to be:"

263+ []

264+ )

188265

189266 Function maybeName ->

190− ( Nothing

191− , "The return type of " ++ funcName maybeName ++ " is being used in unexpected ways."

192− , Nothing

193− )

267+ report

268+ Nothing

269+ ( "The return type of " ++ funcName maybeName ++ " is being used in unexpected ways."

270+ )

271+ ( cmpHint

272+ "The function results in this type of value:"

273+ "Which is fine, but the surrounding context wants it to be:"

274+ []

275+ )

194276

195− UnexpectedArg maybeName index region ->

196− ( Just region

197− , "The " ++ ordinalize index ++ " argument to " ++ funcName maybeName

198− ++ " has an unexpected type."

199− , Nothing

200− )

277+ UnexpectedArg maybeName 1 1 region ->

278+ report

279+ (Just region)

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

281+ ( cmpHint

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

283+ "But it is:"

284+ []

285+ )

286+

287+ UnexpectedArg maybeName index _totalArgs region ->

288+ report

289+ (Just region)

290+ ( "The " ++ Help.ordinalize index ++ " argument to " ++ funcName maybeName

291+ ++ " is causing a mismatch."

292+ )

293+ ( cmpHint

294+ ( Help.capitalize (funcName maybeName) ++ " is expecting the "

295+ ++ Help.ordinalize index ++ " argument to be:"

296+ )

297+ "But it is:"

298+ ( if index == 1 then

299+ []

300+ else

301+ [ "I always figure out the type of arguments from left to right. If an argument\

302+ \ is acceptable when I check it, I assume it is \"correct\" in subsequent checks.\

303+ \ So the problem may actually be in how previous arguments interact with the "

304+ ++ Help.ordinalize index ++ "."

305+ ]

306+ )

307+ )

201308

202309 FunctionArity maybeName expected actual region ->

203310 let

204311 s = if expected <= 1 then "" else "s"

205312 in

206− ( Just region

207− , capitalize (funcName maybeName) ++ " is expecting " ++ show expected

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

209− , Nothing

210− )

313+ report

314+ (Just region)

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

316+ ++ " argument" ++ s ++ ", but was given " ++ show actual ++ "."

317+ )

318+ (text "Maybe you forgot some parentheses somewhere?")

211319

212320 BadTypeAnnotation name ->

213− ( Nothing

214− , "The type annotation for `" ++ name ++ "` does not match its definition."

215− , Nothing

216− )

321+ report

322+ Nothing

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

324+ ( cmpHint

325+ "The type annotation is saying:"

326+ "But I am inferring that the definition has this type:"

327+ []

328+ )

217329

218330 Instance name ->

219− ( Nothing

220− , "Given how `" ++ name ++ "` is defined, this use will not work out."

221− , Nothing

222− )

331+ report

332+ Nothing

333+ (Help.functionName name ++ " is being used in an unexpected way.")

334+ ( cmpHint

335+ ("Based on its definition, " ++ Help.functionName name ++ " has this type:")

336+ "But you are trying to use it as:"

337+ []

338+ )

223339

224340 Literal name ->

225− ( Nothing

226− , "This " ++ name ++ " value is being used as if it is some other type of value."

227− , Nothing

228− )

341+ report

342+ Nothing

343+ ( "This " ++ name ++ " value is being used as if it is some other type of value."

344+ )

345+ ( cmpHint

346+ ("The " ++ name ++ " definitely has this type:")

347+ ("But it is being used as:")

348+ []

349+ )

229350

230351 Pattern patErr ->

231352 let

@@ -233,44 +354,95 @@ hintToString hint =

233354 case patErr of

234355 PVar name -> "variable `" ++ name ++ "`"

235356 PAlias name -> "alias `" ++ name ++ "`"

236− PData name -> "`" ++ name ++ "`"

357+ PData name -> "tag `" ++ name ++ "`"

237358 PRecord -> "a record"

238359 in

239− ( Nothing

240− , "Problem with " ++ thing ++ " in this pattern match."

241− , Nothing

242− )

360+ report

361+ Nothing

362+ ( Help.capitalize thing ++ " is causing problems in this pattern match."

363+ )

364+ ( cmpHint

365+ "This pattern matches things of type:"

366+ "But the values it will actually be trying to match are:"

367+ []

368+ )

243369

244370 Shader ->

245− ( Nothing

246− , "There is some problem with this GLSL shader."

247− , Nothing

248− )

371+ report

372+ Nothing

373+ "There is some problem with this GLSL shader."

374+ ( cmpHint

375+ "The shader block has this type:"

376+ "Which is fine, but the surrounding context wants it to be:"

377+ []

378+ )

249379

250380 Range ->

251− ( Nothing

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

253− , Nothing

254− )

381+ report

382+ Nothing

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

384+ ( cmpHint

385+ "The low end of the range has type:"

386+ "But the high end is:"

387+ []

388+ )

255389

256390 Lambda ->

257− ( Nothing

258− , "This anonymous function is being used in an unexpected way."

259− , Nothing

260− )

391+ report

392+ Nothing

393+ "This anonymous function is being used in an unexpected way."

394+ ( cmpHint

395+ "The anonymous function has type:"

396+ "But you are trying to use it as:"

397+ []

398+ )

261399

262400 Record ->

263− ( Nothing

264− , "This record is being used in an unexpected way."

265− , Nothing

266− )

401+ report

402+ Nothing

403+ "This record is being used in an unexpected way."

404+ ( cmpHint

405+ "The record has type:"

406+ "But you are trying to use it as:"

407+ []

408+ )

409+

410+

411+comparisonHint

412+ :: RenderType.Localizer

413+ -> Type.Canonical

414+ -> Type.Canonical

415+ -> String

416+ -> String

417+ -> [Doc]

418+ -> Doc

419+comparisonHint localizer leftType rightType leftWords rightWords finalHints =

420+ let

421+ (leftDoc, rightDoc) =

422+ RenderType.diffToDocs localizer leftType rightType

423+ in

424+ Help.stack $

425+ [ Help.reflowParagraph leftWords

426+ , indent 4 leftDoc

427+ , Help.reflowParagraph rightWords

428+ , indent 4 rightDoc

429+ ]

430+ ++

431+ finalHints

432+

433+

434+

435+-- MISMATCH HELPERS

267436

268437

269−prettyOperator :: Var.Canonical -> String

270−prettyOperator (Var.Canonical _ opName) =

271− if Help.isOp opName

272− then "(" ++ opName ++ ")"

273− else "`" ++ opName ++ "`"

438+ordinalPair :: Int -> String

439+ordinalPair number =

440+ Help.ordinalize (number -1 ) ++ " and " ++ Help.ordinalize number

441+

442+

443+prettyName :: Var.Canonical -> String

444+prettyName (Var.Canonical _ opName) =

445+ Help.functionName opName

274446

275447

276448funcName :: Maybe Var.Canonical -> String

@@ -280,31 +452,186 @@ funcName maybeVar =

280452 "this function"

281453

282454 Just var ->

283− "function " ++ prettyOperator var

455+ "function " ++ prettyName var

456+

457+

458+

459+-- MISMTACH REASONS

460+

284461

462+flipReason :: Reason -> Reason

463+flipReason reason =

464+ case reason of

465+ MessyFields leftOnly rightOnly ->

466+ MessyFields rightOnly leftOnly

285467

286−capitalize :: String -> String

287−capitalize string =

288− case string of

289− [] -> []

290− c : cs ->

291− Char.toUpper c : cs

468+ IntFloat ->

469+ IntFloat

292470

471+ TooLongComparableTuple len ->

472+ TooLongComparableTuple len

473+

474+ BadVar left right ->

475+ BadVar right left

476+

477+

478+reasonToString :: Reason -> Maybe Doc

479+reasonToString reason =

480+ let

481+ go msg =

482+ Just (toHint msg)

483+ in

484+ case reason of

485+ MessyFields leftOnly rightOnly ->

486+ do let typos = Help.findPotentialTypos leftOnly rightOnly

487+ _ <- Help.vetTypos typos

488+ misspellingMessage typos

293489

294−ordinalize :: Int -> String

295−ordinalize number =

490+ IntFloat ->

491+ go

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

493+ \ `toFloat` and `round` to do specific conversions.\

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

495+

496+ TooLongComparableTuple len ->

497+ go $

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

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

500+

501+ BadVar (Just Comparable) _ ->

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

503+

504+ BadVar (Just Appendable) _ ->

505+ go "Only strings, text, and lists are appendable."

506+

507+ BadVar (Just CompAppend) _ ->

508+ go "Only strings and lists are both comparable and appendable."

509+

510+ BadVar (Just (Rigid _)) (Just (Rigid _)) ->

511+ Just $ Help.stack $

512+ [ hintDoc <> text "This usually happens when a few factors come together."

513+ , indent 4 $ vcat $

514+ [ text "1. You have a generic function with a type annotation."

515+ , text "2. In its definition, there is a `let` with generic type annotations."

516+ ]

517+ , Help.reflowParagraph

518+ "The issue is that these type variables are not actually shared between\

519+ \ outer and inner type annotations right now. You can usually fix this by\

520+ \ commenting out the inner type annotations."

521+ ]

522+

523+ BadVar (Just (Rigid (Just name))) _ ->

524+ go $

525+ "Looks like the type annotation is too generic. Type variable\

526+ \ `" ++ name ++ "` is saying *many* kinds of value can be given, but the\

527+ \ actual definition needs a more specific type. I am not sure whether the\

528+ \ type annotation or the definition is \"right\" though, you may have to\

529+ \ make the annotation more specific or make the definition more generic."

530+

531+ BadVar (Just (Rigid _)) _ ->

532+ go genericRigidError

533+

534+ BadVar _ (Just (Rigid _)) ->

535+ go genericRigidError

536+

537+ BadVar _ _ ->

538+ Nothing

539+

540+

541+genericRigidError :: String

542+genericRigidError =

543+ "There is some problem with a rigid type variable. It is very likely that a\

544+ \ type annotation is too generic. One type is saying *many* kinds of value\

545+ \ can be given, but the other needs a more specific type."

546+

547+

548+hintDoc :: Doc

549+hintDoc =

550+ underline (text "Hint") <> colon

551+

552+

553+toHint :: String -> Doc

554+toHint str =

555+ fillSep (hintDoc : map text (words str))

556+

557+

558+misspellingMessage :: [(String,String)] -> Maybe Doc

559+misspellingMessage typos =

560+ if null typos then

561+ Nothing

562+

563+ else

564+ let

565+ maxLen =

566+ maximum (map (length . fst) typos)

567+ in

568+ Just $ hang 4 $ vcat $

569+ toHint "I compared the record fields and found some potential typos."

570+ : text ""

571+ : map (pad maxLen) typos

572+

573+

574+pad :: Int -> (String, String) -> Doc

575+pad maxLen (leftField, rightField) =

576+ text (replicate (maxLen - length leftField) ' ')

577+ <> dullyellow (text leftField)

578+ <+> text "<->"

579+ <+> dullyellow (text rightField)

580+

581+

582+

583+-- INFINITE TYPES

584+

585+

586+infiniteTypeToReport

587+ :: RenderType.Localizer

588+ -> String

589+ -> Type.Canonical

590+ -> Type.Canonical

591+ -> Report.Report

592+infiniteTypeToReport localizer name overallType infiniteType =

593+ Report.report

594+ "INFINITE TYPE"

595+ Nothing

596+ ( "I am inferring a weird self-referential type for " ++ Help.functionName name

597+ )

598+ ( Help.stack $

599+ explainInfiniteType localizer name overallType infiniteType

600+ ++

601+ [ text $

602+ "This can be very tricky to figure out, so definitely read the debugging hints:\n"

603+ ++ Help.hintLink "infinite-type"

604+ ]

605+ )

606+

607+

608+explainInfiniteType

609+ :: RenderType.Localizer

610+ -> String

611+ -> Type.Canonical

612+ -> Type.Canonical

613+ -> [Doc]

614+explainInfiniteType localizer name overallType infiniteType =

296615 let

297− remainder10 =

298− number `mod` 10

299−

300− remainder100 =

301− number `mod` 100

302−

303− ending

304− | remainder100 `elem` [11..13] = "th"

305− | remainder10 == 1 = "st"

306− | remainder10 == 2 = "nd"

307− | remainder10 == 3 = "rd"

308− | otherwise = "th"

616+ selfReference =

617+ text "?" <+> equals <+> RenderType.toDoc localizer infiniteType

309618 in

310− show number ++ ending

619+ case overallType of

620+ Type.Var "?" ->

621+ [ Help.reflowParagraph $

622+ "I cannot write down the actual type of " ++ Help.functionName name ++

623+ " because it is infinitely large (that's the problem!) so here it\

624+ \ is as an equation where `?` represents the type:"

625+ , indent 4 selfReference

626+ ]

627+

628+ _ ->

629+ [ Help.reflowParagraph $

630+ "I am inferring that " ++ Help.functionName name ++ " has this type:"

631+ , indent 4 (RenderType.toDoc localizer overallType)

632+ , Help.reflowParagraph $

633+ "The problem is in the `?` which seems to contain itself. I cannot show\

634+ \ you that type directly (because it is infinitely large!) so here it is\

635+ \ as an equation:"

636+ , indent 4 selfReference

637+ ]

src/Reporting/PrettyPrint.hsdeleted−46

@@ -1,46 +0,0 @@

1−{-# LANGUAGE FlexibleInstances #-}

2−module Reporting.PrettyPrint where

3−

4−import qualified Data.Map as Map

5−import Text.PrettyPrint as P

6−

7−import qualified AST.Helpers as Help

8−

9−

10−-- PRETTY

11−

12−class Pretty a where

13− pretty :: Dealiaser -> Bool -> a -> Doc

14−

15−

16−type Dealiaser =

17− Map.Map String String

18−

19−

20−-- INSTANCES

21−

22−instance Pretty String where

23− pretty _ _ str =

24− P.text str

25−

26−

27−-- HELPERS

28−

29−commaCat :: [Doc] -> Doc

30−commaCat docs =

31− cat (punctuate comma docs)

32−

33−

34−commaSep :: [Doc] -> Doc

35−commaSep docs =

36− sep (punctuate comma docs)

37−

38−

39−parensIf :: Bool -> Doc -> Doc

40−parensIf bool doc =

41− if bool then parens doc else doc

42−

43−

44−variable :: String -> Doc

45−variable x =

46− if Help.isOp x then parens (text x) else text x

src/Reporting/Render/Code.hsnew file+113

@@ -0,0 +1,113 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Reporting.Render.Code

3+ ( render

4+ )

5+ where

7+import Control.Applicative ((<|>))

8+import Text.PrettyPrint.ANSI.Leijen (Doc, (<>), hardline, dullred, empty, text)

10+import qualified Reporting.Region as R

11+

12+

13+(|>) :: a -> (a -> b) -> b

14+(|>) a f =

15+ f a

16+

17+

18+(<==>) :: Doc -> Doc -> Doc

19+(<==>) a b =

20+ a <> hardline <> b

21+

22+

23+render :: Maybe R.Region -> R.Region -> String -> Doc

24+render maybeSubRegion region@(R.Region start end) source =

25+ let

26+ (R.Position startLine startColumn) = start

27+ (R.Position endLine endColumn) = end

28+

29+ relevantLines =

30+ lines source

31+ |> drop (startLine - 1)

32+ |> take (endLine - startLine + 1)

33+ in

34+ case relevantLines of

35+ [] ->

36+ empty

37+

38+ [sourceLine] ->

39+ singleLineRegion startLine sourceLine $

40+ case maybeSubRegion of

41+ Nothing ->

42+ (0, startColumn, endColumn, length sourceLine)

43+

44+ Just (R.Region s e) ->

45+ (startColumn, R.column s, R.column e, endColumn)

46+

47+ firstLine : rest ->

48+ let

49+ filteredFirstLine =

50+ replicate (startColumn - 1) ' '

51+ ++ drop (startColumn - 1) firstLine

52+

53+ filteredLastLine =

54+ take (endColumn) (last rest)

55+

56+ focusedRelevantLines =

57+ filteredFirstLine : init rest ++ [filteredLastLine]

58+

59+ lineNumbersWidth =

60+ length (show endLine)

61+

62+ subregion =

63+ maybeSubRegion <|> Just region

64+

65+ numberedLines =

66+ zipWith

67+ (addLineNumber subregion lineNumbersWidth)

68+ [startLine .. endLine]

69+ focusedRelevantLines

70+ in

71+ foldr (<==>) empty numberedLines

72+

73+

74+addLineNumber :: Maybe R.Region -> Int -> Int -> String -> Doc

75+addLineNumber maybeSubRegion width n line =

76+ let

77+ number =

78+ if n < 0 then " " else show n

79+

80+ lineNumber =

81+ replicate (width - length number) ' ' ++ number ++ "│"

82+

83+ spacer (R.Region start end) =

84+ if R.line start <= n && n <= R.line end then

85+ dullred (text ">")

86+ else

87+ text " "

88+ in

89+ text lineNumber

90+ <> maybe (text " ") spacer maybeSubRegion

91+ <> text line

92+

93+

94+singleLineRegion :: Int -> String -> (Int, Int, Int, Int) -> Doc

95+singleLineRegion lineNum sourceLine (start, innerStart, innerEnd, end) =

96+ let

97+ width =

98+ length (show lineNum)

99+

100+ underline =

101+ text (replicate (innerStart + width + 1) ' ')

102+ <>

103+ dullred (text (replicate (max 1 (innerEnd - innerStart)) '^'))

104+

105+ trimmedSourceLine =

106+ sourceLine

107+ |> drop (start - 1)

108+ |> take (end - start + 1)

109+ |> (++) (replicate (start - 1) ' ')

110+ in

111+ addLineNumber Nothing width lineNum trimmedSourceLine

112+ <==>

113+ underline

src/Reporting/Render/Type.hsnew file+494

@@ -0,0 +1,494 @@

1+module Reporting.Render.Type

2+ ( Localizer

3+ , decl

4+ , annotation

5+ , toDoc

6+ , diffToDocs

7+ , Style(..)

8+ )

9+ where

10+

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

12+import qualified Data.Map as Map

13+import qualified Data.Set as Set

14+import Text.PrettyPrint.ANSI.Leijen

15+ ( Doc, (<+>), cat, colon, comma, dullyellow, equals, hang, hsep

16+ , lbrace, lparen, parens, rbrace, rparen, sep, text, vcat

17+ )

18+

19+import qualified AST.Helpers as Help

20+import qualified AST.Type as Type

21+import qualified AST.Variable as Var

22+import qualified Reporting.Error.Helpers as Help

23+

24+

25+

26+-- PUBLIC API FOR CREATING DOCS

27+

28+

29+toDoc :: Localizer -> Type.Canonical -> Doc

30+toDoc localizer tipe =

31+ docType localizer None tipe

32+

33+

34+diffToDocs :: Localizer -> Type.Canonical -> Type.Canonical -> (Doc,Doc)

35+diffToDocs localizer leftType rightType =

36+ case diff localizer None leftType rightType of

37+ Same doc ->

38+ (doc, doc)

39+

40+ Diff leftDoc rightDoc ->

41+ (leftDoc, rightDoc)

42+

43+

44+decl :: Localizer -> String -> [String] -> [(String, [Type.Canonical])] -> Doc

45+decl localizer name vars tags =

46+ let

47+ docTag (tag, args) =

48+ hang 2 (sep (text tag : map (docType localizer App) args))

49+ in

50+ hang 4 $ vcat $

51+ (hsep (map text ("type" : name : vars)))

52+ :

53+ zipWith (<+>)

54+ (equals : repeat (text "|"))

55+ (map docTag tags)

56+

57+

58+annotation :: Localizer -> String -> Type.Canonical -> Doc

59+annotation localizer name tipe =

60+ let

61+ docName =

62+ if Help.isOp name then parens (text name) else text name

63+ in

64+ case Type.collectLambdas tipe of

65+ parts@(_ : _ : _) ->

66+ hang 4 $ sep $

67+ docName

68+ : zipWith (<+>)

69+ (colon : repeat (text "->"))

70+ (map (docType localizer Func) parts)

71+

72+ _ ->

73+ hang 4 $ sep $

74+ [ docName <+> colon

75+ , docType localizer None tipe

76+ ]

77+

78+

79+

80+-- LOCALIZE TYPES

81+

82+

83+type Localizer =

84+ Map.Map String String

85+

86+

87+varToDoc :: Localizer -> Var.Canonical -> Doc

88+varToDoc localizer var =

89+ let

90+ name = Var.toString var

91+ in

92+ if name == "_Tuple0" then

93+ text "()"

94+

95+ else

96+ text (maybe name id (Map.lookup name localizer))

97+

98+

99+

100+-- DIFF BUILDER

101+

102+

103+data Diff a

104+ = Diff a a

105+ | Same a

106+

107+

108+instance Functor Diff where

109+ fmap func d =

110+ case d of

111+ Diff left right ->

112+ Diff (func left) (func right)

113+

114+ Same both ->

115+ Same (func both)

116+

117+

118+instance Applicative Diff where

119+ pure a =

120+ Same a

121+

122+ (<*>) func arg =

123+ case (func, arg) of

124+ (Diff leftFunc rightFunc, Diff leftArg rightArg) ->

125+ Diff (leftFunc leftArg) (rightFunc rightArg)

126+

127+ (Diff leftFunc rightFunc, Same arg) ->

128+ Diff (leftFunc arg) (rightFunc arg)

129+

130+ (Same func, Diff leftArg rightArg) ->

131+ Diff (func leftArg) (func rightArg)

132+

133+ (Same func, Same arg) ->

134+ Same (func arg)

135+

136+

137+partitionDiffs :: Map.Map k (Diff a) -> ( [(k, (a,a))], [(k, a)] )

138+partitionDiffs dict =

139+ let

140+ collect key value (diffKeys, sameKeys) =

141+ case value of

142+ Diff left right ->

143+ ( (key, (left, right)) : diffKeys

144+ , sameKeys

145+ )

146+

147+ Same both ->

148+ ( diffKeys

149+ , (key, both) : sameKeys

150+ )

151+ in

152+ Map.foldrWithKey collect ([],[]) dict

153+

154+

155+

156+-- DOC DIFF

157+

158+

159+data Context

160+ = None

161+ | Func

162+ | App

163+

164+

165+diff :: Localizer -> Context -> Type.Canonical -> Type.Canonical -> Diff Doc

166+diff localizer context leftType rightType =

167+ let

168+ go = diff localizer

169+ in

170+ case (leftType, rightType) of

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

172+ let

173+ leftParts = Type.collectLambdas leftType

174+ rightParts = Type.collectLambdas rightType

175+ in

176+

177+ if length leftParts /= length rightParts then

178+ difference

179+ (docLambda context (map (docType localizer Func) leftParts))

180+ (docLambda context (map (docType localizer Func) rightParts))

181+

182+ else

183+ docLambda context <$> sequenceA (zipWith (go Func) leftParts rightParts)

184+

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

186+ pure (text x)

187+

188+ (Type.Type leftName, Type.Type rightName) | leftName == rightName ->

189+ pure (varToDoc localizer leftName)

190+

191+ (Type.App (Type.Type leftName) leftArgs, Type.App (Type.Type rightName) rightArgs) ->

192+ if leftName /= rightName || length leftArgs /= length rightArgs then

193+ difference

194+ (docApp localizer context leftName (map (docType localizer App) leftArgs))

195+ (docApp localizer context rightName (map (docType localizer App) rightArgs))

196+

197+ else

198+ let

199+ subContext =

200+ if Var.isTuple leftName then None else App

201+ in

202+ docApp localizer context leftName

203+ <$> sequenceA (zipWith (go subContext) leftArgs rightArgs)

204+

205+ (Type.App _ _, Type.App _ _) ->

206+ error "Type applications without concrete names should not get here."

207+

208+ (Type.Record outerLeftFields outerLeftExt, Type.Record outerRightFields outerRightExt) ->

209+ let

210+ (leftFields, leftExt) =

211+ flattenRecord outerLeftFields outerLeftExt

212+

213+ (rightFields, rightExt) =

214+ flattenRecord outerRightFields outerRightExt

215+ in

216+ diffRecord localizer leftFields leftExt rightFields rightExt

217+

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

219+ docApp localizer context leftName

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

221+

222+ (Type.Aliased _ args real, _) ->

223+ go context (Type.dealias args real) rightType

224+

225+ (_, Type.Aliased _ args real) ->

226+ go context leftType (Type.dealias args real)

227+

228+ (_, _) ->

229+ difference

230+ (docType localizer context leftType)

231+ (docType localizer context rightType)

232+

233+

234+difference :: Doc -> Doc -> Diff Doc

235+difference leftDoc rightDoc =

236+ Diff (dullyellow leftDoc) (dullyellow rightDoc)

237+

238+

239+

240+-- RECORD DIFFS

241+

242+

243+diffRecord :: Localizer -> Fields -> Maybe String -> Fields -> Maybe String -> Diff Doc

244+diffRecord localizer leftFields leftExt rightFields rightExt =

245+ let

246+ (leftOnly, both, rightOnly) =

247+ vennDiagram leftFields rightFields

248+ in

249+ if Map.null leftOnly && Map.null rightOnly then

250+ let

251+ fieldDiffs =

252+ Map.map (uncurry (diff localizer None)) both

253+ in

254+ case partitionDiffs fieldDiffs of

255+ ([], sames) ->

256+ let

257+ mkRecord =

258+ docRecord Full (map (first text) sames)

259+ in

260+ if leftExt == rightExt then

261+ Same (mkRecord (fmap text leftExt))

262+

263+ else

264+ Diff

265+ (mkRecord (fmap (dullyellow . text) leftExt))

266+ (mkRecord (fmap (dullyellow . text) rightExt))

267+

268+ (diffs, sames) ->

269+ let

270+ (lefts, rights) = unzipDiffs diffs

271+ style = if null sames then Full else Elide

272+ in

273+ Diff

274+ (docRecord style lefts (fmap text leftExt))

275+ (docRecord style rights (fmap text rightExt))

276+

277+ else

278+ let

279+ (lefts, rights) =

280+ analyzeFields (Map.keys leftOnly) (Map.keys rightOnly)

281+

282+ style =

283+ if Map.null both then Full else Elide

284+ in

285+ Diff

286+ (docRecord style lefts (fmap text leftExt))

287+ (docRecord style rights (fmap text rightExt))

288+

289+

290+unzipDiffs :: [(String, (Doc, Doc))] -> ( [(Doc, Doc)], [(Doc, Doc)] )

291+unzipDiffs diffPairs =

292+ let

293+ unzipHelp (name, (left, right)) =

294+ (,) (text name, left) (text name, right)

295+ in

296+ unzip (map unzipHelp diffPairs)

297+

298+

299+

300+-- RECORD DIFFS HELPERS

301+

302+

303+analyzeFields :: [String] -> [String] -> ( [(Doc, Doc)], [(Doc, Doc)] )

304+analyzeFields leftOnly rightOnly =

305+ let

306+ potentialTypos =

307+ Help.findPotentialTypos leftOnly rightOnly

308+

309+ mkField func name =

310+ ( func (text name), text "…" )

311+

312+ mkFieldWith counts name =

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

314+ in

315+ case Help.vetTypos potentialTypos of

316+ Just (leftTypos, rightTypos) ->

317+ ( map (mkFieldWith leftTypos) leftOnly

318+ , map (mkFieldWith rightTypos) rightOnly

319+ )

320+

321+ Nothing ->

322+ ( map (mkField dullyellow) leftOnly

323+ , map (mkField dullyellow) rightOnly

324+ )

325+

326+

327+type Fields =

328+ Map.Map String Type.Canonical

329+

330+

331+type DoubleFields =

332+ Map.Map String (Type.Canonical,Type.Canonical)

333+

334+

335+vennDiagram :: Fields -> Fields -> (Fields, DoubleFields, Fields)

336+vennDiagram leftFields rightFields =

337+ ( Map.difference leftFields rightFields

338+ , Map.intersectionWith (,) leftFields rightFields

339+ , Map.difference rightFields leftFields

340+ )

341+

342+

343+flattenRecord

344+ :: [(String, Type.Canonical)]

345+ -> Maybe Type.Canonical

346+ -> (Fields, Maybe String)

347+flattenRecord fields ext =

348+ first Map.fromList (flattenRecordHelp fields ext)

349+

350+

351+flattenRecordHelp

352+ :: [(String, Type.Canonical)]

353+ -> Maybe Type.Canonical

354+ -> ([(String, Type.Canonical)], Maybe String)

355+flattenRecordHelp fields ext =

356+ case ext of

357+ Nothing ->

358+ (fields, Nothing)

359+

360+ Just (Type.Var x) ->

361+ (fields, Just x)

362+

363+ Just (Type.Record subFields subExt) ->

364+ flattenRecordHelp (fields ++ subFields) subExt

365+

366+ Just (Type.Aliased _ args tipe) ->

367+ flattenRecordHelp fields (Just (Type.dealias args tipe))

368+

369+ _ ->

370+ error "Trying to flatten ill-formed record."

371+

372+

373+

374+-- TYPES TO DOCS

375+

376+

377+docType :: Localizer -> Context -> Type.Canonical -> Doc

378+docType localizer context tipe =

379+ case tipe of

380+ Type.Lambda _ _ ->

381+ docLambda context (map (docType localizer Func) (Type.collectLambdas tipe))

382+

383+ Type.Var x ->

384+ text x

385+

386+ Type.Type name ->

387+ varToDoc localizer name

388+

389+ Type.App (Type.Type name) args ->

390+ docApp localizer context name (map (docType localizer App) args)

391+

392+ Type.App _ _ ->

393+ error "type applications should start with a type atom"

394+

395+ Type.Record outerFields outerExt ->

396+ let

397+ (fields, ext) =

398+ flattenRecordHelp outerFields outerExt

399+ in

400+ docRecord Full

401+ (map (text *** docType localizer None) fields)

402+ (fmap text ext)

403+

404+ Type.Aliased name args _ ->

405+ docApp localizer context name (map (docType localizer App . snd) args)

406+

407+

408+

409+docLambda :: Context -> [Doc] -> Doc

410+docLambda context docs =

411+ case docs of

412+ [] ->

413+ error "cannot call docLambda with an empty list"

414+

415+ arg:rest ->

416+ case context of

417+ None ->

418+ sep (arg : map (text "->" <+>) rest)

419+

420+ _ ->

421+ cat

422+ [ lparen

423+ , sep (arg : map (text "->" <+>) rest)

424+ , rparen

425+ ]

426+

427+

428+

429+docApp :: Localizer -> Context -> Var.Canonical -> [Doc] -> Doc

430+docApp localizer context name args =

431+ if Var.isTuple name then

432+ sep

433+ [ cat (zipWith (<+>) (lparen : repeat comma) args)

434+ , rparen

435+ ]

436+

437+ else if null args then

438+ varToDoc localizer name

439+

440+ else

441+ case context of

442+ App ->

443+ cat

444+ [ lparen

445+ , hang 4 (sep (varToDoc localizer name : args))

446+ , rparen

447+ ]

448+

449+ _ ->

450+ hang 4 (sep (varToDoc localizer name : args))

451+

452+

453+

454+data Style

455+ = Elide

456+ | Full

457+

458+

459+docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc

460+docRecord style fields maybeExt =

461+ let

462+ docField (name, tipe) =

463+ hang 4 (sep [ name <+> colon, tipe ])

464+

465+ elision =

466+ case style of

467+ Full ->

468+ []

469+

470+ Elide ->

471+ [ text "…" ]

472+

473+ fieldDocs =

474+ elision ++ map docField fields

475+ in

476+ case (fieldDocs, maybeExt) of

477+ ([], Nothing) ->

478+ text "{}"

479+

480+ (_, Nothing) ->

481+ sep

482+ [ cat (zipWith (<+>) (lbrace : repeat comma) fieldDocs)

483+ , rbrace

484+ ]

485+

486+ (_, Just ext) ->

487+ sep

488+ [ hang 4 $ sep $

489+ [ lbrace <+> ext

490+ , cat (zipWith (<+>) (text "|" : repeat comma) fieldDocs)

491+ ]

492+ , rbrace

493+ ]

494+

src/Reporting/Report.hs+50−195

@@ -1,64 +1,44 @@

11{-# OPTIONS_GHC -Wall #-}

22{-# LANGUAGE OverloadedStrings #-}

33module Reporting.Report

4− ( Report(Report)

5− , simple

4+ ( Report

5+ , report

66 , toString

77 , toJson

8− , printError, printWarning

9− ) where

8+ , toHandle

9+ )

10+ where

1011

11−import Control.Applicative ((<|>))

12−import Control.Monad.Writer (Writer, execWriter, tell)

1312import Data.Aeson ((.=))

1413import qualified Data.Aeson.Types as Json

15−import System.Console.ANSI

16−import System.IO (hPutStr, stderr)

14+import System.IO (Handle)

15+import Text.PrettyPrint.ANSI.Leijen

16+ ( Doc, (<>), displayS, displayIO, dullcyan, fillSep, hardline, renderPretty, text

17+ )

1718

1819import qualified Reporting.Region as R

20+import qualified Reporting.Render.Code as Code

21+

22+

23+

24+-- BUILD REPORTS

1925

2026

2127data Report = Report

2228 { _title :: String

2329 , _highlight :: Maybe R.Region

24− , _preHint :: String

25− , _postHint :: String

30+ , _preHint :: Doc

31+ , _postHint :: Doc

2632 }

2733

2834

29−simple :: String -> String -> String -> Report

30−simple title pre post =

31− Report title Nothing pre post

32−

33−

34−toString :: String -> R.Region -> Report -> String -> String

35−toString location region report source =

36− execWriter (render plain location region report source)

37−

35+report :: String -> Maybe R.Region -> String -> Doc -> Report

36+report title highlight pre post =

37+ Report title highlight (fillSep (map text (words pre))) post

3838

39−printError :: String -> R.Region -> Report -> String -> IO ()

40−printError location region report source =

41− render (ansi Error) location region report source

4239

4340

44−printWarning :: String -> R.Region -> Report -> String -> IO ()

45−printWarning location region report source =

46− render (ansi Warning) location region report source

47−

48−

49−render

50− :: (Monad m)

51− => Renderer m

52− -> String

53− -> R.Region

54− -> Report

55− -> String

56− -> m ()

57−render renderer location region (Report title highlight pre post) source =

58− do messageBar renderer title location

59− normal renderer (pre ++ "\n\n")

60− grabRegion renderer highlight region source

61− normal renderer ("\n" ++ if null post then "\n" else post ++ "\n\n\n")

41+-- REPORT TO JSON

6242

6343

6444toJson :: [Json.Pair] -> Report -> (Maybe R.Region, [Json.Pair])

@@ -66,177 +46,52 @@ toJson extraFields (Report title subregion pre post) =

6646 let

6747 fields =

6848 [ "tag" .= title

69− , "overview" .= pre

70− , "details" .= post

49+ , "overview" .= displayS (renderPretty 1 80 pre) ""

50+ , "details" .= displayS (renderPretty 1 80 post) ""

7151 ]

7252 in

7353 (subregion, fields ++ extraFields)

7454

7555

76−-- RENDERING

77−

78−data Renderer m = Renderer

79− { normal :: String -> m ()

80− , header :: String -> m ()

81− , accent :: String -> m ()

82− }

83−

84−

85−plain :: Renderer (Writer String)

86−plain =

87− Renderer tell tell tell

8856

57+-- REPORT TO DOC

8958

90−data Type = Error | Warning

91−

92−

93−ansi :: Type -> Renderer IO

94−ansi tipe =

95− let

96− put =

97− hPutStr stderr

98−

99− put' intensity color string =

100− do hSetSGR stderr [SetColor Foreground intensity color]

101− put string

102− hSetSGR stderr [Reset]

103−

104− accentColor =

105− case tipe of

106− Error -> Red

107− Warning -> Yellow

108− in

109− Renderer

110− put

111− (put' Dull Cyan)

112− (put' Dull accentColor)

11359

60+toDoc :: String -> R.Region -> Report -> String -> Doc

61+toDoc location region (Report title highlight preHint postHint) source =

62+ messageBar title location

63+ <> hardline <> hardline <>

64+ preHint

65+ <> hardline <> hardline <>

66+ Code.render highlight region source

67+ <> hardline <>

68+ postHint

69+ <> hardline <> hardline

11470

11571

116−

117−-- REPORT HEADER

118−

119−messageBar :: Renderer m -> String -> String -> m ()

120−messageBar renderer tag location =

72+messageBar :: String -> String -> Doc

73+messageBar tag location =

12174 let

122− usedSpace = 4 + length tag + 1 + length location

75+ usedSpace =

76+ 4 + length tag + 1 + length location

12377 in

124− header renderer $

125− "-- " ++ tag ++ " "

126− ++ replicate (max 1 (80 - usedSpace)) '-'

127− ++ " " ++ location ++ "\n\n"

128−

129−

130−-- REGIONS

131−

132−grabRegion

133− :: (Monad m)

134− => Renderer m

135− -> Maybe R.Region

136− -> R.Region

137− -> String

138− -> m ()

139−grabRegion renderer maybeSubRegion region@(R.Region start end) source =

140− let

141− (R.Position startLine startColumn) = start

142− (R.Position endLine endColumn) = end

78+ dullcyan $ text $

79+ "-- " ++ tag ++ " " ++ replicate (max 1 (80 - usedSpace)) '-' ++ " " ++ location

14380

144− (|>) = flip ($)

14581

146− relevantLines =

147− lines source

148− |> drop (startLine - 1)

149− |> take (endLine - startLine + 1)

150− in

151− case relevantLines of

152− [] ->

153− normal renderer ""

154−

155− [sourceLine] ->

156− singleLineRegion renderer startLine sourceLine $

157− case maybeSubRegion of

158− Nothing ->

159− (0, startColumn, endColumn, length sourceLine)

160−

161− Just (R.Region s e) ->

162− (startColumn, R.column s, R.column e, endColumn)

163−

164− firstLine : rest ->

165− let

166− filteredFirstLine =

167− replicate (startColumn - 1) ' '

168− ++ drop (startColumn - 1) firstLine

169−

170− filteredLastLine =

171− take (endColumn) (last rest)

172−

173− focusedRelevantLines =

174− filteredFirstLine : init rest ++ [filteredLastLine]

175−

176− lineNumbersWidth =

177− length (show endLine)

178−

179− subregion =

180− maybeSubRegion <|> Just region

181−

182− numberedLines =

183− zipWith

184− (addLineNumber renderer subregion lineNumbersWidth)

185− [startLine .. endLine]

186− focusedRelevantLines

187− in

188− mapM_ (\line -> line >> normal renderer "\n") numberedLines

189−

190−

191−addLineNumber

192− :: (Monad m)

193− => Renderer m

194− -> Maybe R.Region

195− -> Int

196− -> Int

197− -> String

198− -> m ()

199−addLineNumber renderer maybeSubRegion width n line =

200− let

201− number =

202− if n < 0 then " " else show n

20382

204− lineNumber =

205− replicate (width - length number) ' ' ++ number ++ "│"

83+-- RENDER DOCS

20684

207− spacer (R.Region start end) =

208− if R.line start <= n && n <= R.line end

209− then accent renderer ">"

210− else normal renderer " "

211− in

212− do normal renderer lineNumber

213− maybe (normal renderer " ") spacer maybeSubRegion

214− normal renderer line

215−

216−

217−singleLineRegion

218− :: (Monad m)

219− => Renderer m

220− -> Int

221− -> String

222− -> (Int, Int, Int, Int)

223− -> m ()

224−singleLineRegion renderer lineNum sourceLine (start, innerStart, innerEnd, end) =

225− let

226− width =

227− length (show lineNum)

22885

229− underline =

230− replicate (innerStart + width + 1) ' '

231− ++ replicate (max 1 (innerEnd - innerStart)) '^'

86+toString :: String -> R.Region -> Report -> String -> String

87+toString location region rprt source =

88+ displayS

89+ (renderPretty 1 80 (toDoc location region rprt source))

90+ ""

23291

233− (|>) = flip ($)

23492

235− trimmedSourceLine =

236− sourceLine

237− |> drop (start - 1)

238− |> take (end - start + 1)

239− |> (++) (replicate (start - 1) ' ')

240− in

241− do addLineNumber renderer Nothing width lineNum trimmedSourceLine

242− accent renderer $ "\n" ++ underline

93+toHandle :: Handle -> String -> R.Region -> Report -> String -> IO ()

94+toHandle handle location region rprt source =

95+ displayIO

96+ handle

97+ (renderPretty 1 80 (toDoc location region rprt source))

src/Reporting/Result.hs+3−3

@@ -6,14 +6,14 @@ import Control.Monad.Except (Except, runExcept)

77import qualified Reporting.Annotation as A

88import qualified Reporting.Region as R

9−import qualified Reporting.PrettyPrint as P

9+import qualified Reporting.Render.Type as RenderType

1010

1111

1212-- TASK

1313

1414data Result warning error result =

1515 Result

16− (Maybe P.Dealiaser, [A.Located warning])

16+ (Maybe RenderType.Localizer, [A.Located warning])

1717 (RawResult [A.Located error] result)

1818

1919

@@ -70,7 +70,7 @@ addWarnings newWarnings (Result (dealiaser, warnings) rawResult) =

7070 Result (dealiaser, newWarnings ++ warnings) rawResult

7171

7272

73−addDealiaser :: P.Dealiaser -> Result w e a -> Result w e a

73+addDealiaser :: RenderType.Localizer -> Result w e a -> Result w e a

7474addDealiaser dealiaser (Result (_, warnings) rawResult) =

7575 Result (Just dealiaser, warnings) rawResult

7676

src/Reporting/Warning.hs+22−35

@@ -4,73 +4,60 @@ module Reporting.Warning where

55import Data.Aeson ((.=))

66import qualified Data.Aeson as Json

7−import qualified Text.PrettyPrint as P

8−import Text.PrettyPrint ((<+>))

7+import Text.PrettyPrint.ANSI.Leijen (text)

10−import qualified AST.Helpers as Help

119import qualified AST.Module.Name as ModuleName

1210import qualified AST.Type as Type

1311import qualified Reporting.Annotation as A

14−import qualified Reporting.PrettyPrint as P

12+import qualified Reporting.Error.Helpers as Help

1513import qualified Reporting.Report as Report

14+import qualified Reporting.Render.Type as RenderType

15+

1616

1717

1818-- ALL POSSIBLE WARNINGS

1919

20+

2021data Warning

2122 = UnusedImport ModuleName.Raw

2223 | MissingTypeAnnotation String Type.Canonical

2324

2425

25−-- TO STRING

26−

27−toString :: P.Dealiaser -> String -> String -> A.Located Warning -> String

28−toString dealiaser location source (A.A region warning) =

29− Report.toString location region (toReport dealiaser warning) source

3026

27+-- TO REPORT

3128

32−print :: P.Dealiaser -> String -> String -> A.Located Warning -> IO ()

33−print dealiaser location source (A.A region warning) =

34− Report.printWarning location region (toReport dealiaser warning) source

3529

36−

37−toReport :: P.Dealiaser -> Warning -> Report.Report

38−toReport dealiaser warning =

30+toReport :: RenderType.Localizer -> Warning -> Report.Report

31+toReport localizer warning =

3932 case warning of

4033 UnusedImport moduleName ->

41− Report.simple

34+ Report.report

4235 "unused import"

36+ Nothing

4337 ("Module `" ++ ModuleName.toString moduleName ++ "` is unused.")

44− ""

38+ (text "Best to remove it. Don't save code quality for later!")

4539

4640 MissingTypeAnnotation name inferredType ->

47− Report.simple

41+ Report.report

4842 "missing type annotation"

49− ("Top-level value `" ++ name ++ "` does not have a type annotation.")

50− ( "The type annotation you want looks something like this:\n\n"

51− ++ P.render (P.nest 4 typeDoc)

43+ Nothing

44+ ("Top-level value " ++ Help.functionName name ++ " does not have a type annotation.")

45+ ( Help.stack

46+ [ text "I inferred the type annotation so you can copy it into your code:"

47+ , RenderType.annotation localizer name inferredType

48+ ]

5249 )

53− where

54− nameDoc =

55− if Help.isOp name then

56− P.parens (P.text name)

57− else

58− P.text name

5950

60− typeDoc =

61− P.hang

62− (nameDoc <+> P.colon)

63− 4

64− (P.pretty dealiaser False inferredType)

6551

6652

6753-- TO JSON

6854

69−toJson :: P.Dealiaser -> FilePath -> A.Located Warning -> Json.Value

70−toJson dealiaser filePath (A.A region warning) =

55+

56+toJson :: RenderType.Localizer -> FilePath -> A.Located Warning -> Json.Value

57+toJson localizer filePath (A.A region warning) =

7158 let

7259 (maybeRegion, additionalFields) =

73− Report.toJson [] (toReport dealiaser warning)

60+ Report.toJson [] (toReport localizer warning)

7461 in

7562 Json.object $

7663 [ "file" .= filePath

src/Type/Constrain/Expression.hs+82−85

@@ -3,7 +3,6 @@ module Type.Constrain.Expression where

44import Control.Arrow (second)

55import qualified Control.Monad as Monad

6−import qualified Data.List as List

76import qualified Data.Map as Map

98import qualified AST.Expression.General as E

@@ -28,7 +27,7 @@ constrain

2827 -> Type

2928 -> IO TypeConstraint

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

31− let list t = Env.get env Env.types "List" <| t

30+ let list t = Env.getType env "List" <| t

3231 (<?) = CInstance region

3332 in

3433 case expression of

@@ -40,23 +39,24 @@ constrain env annotatedExpr@(A.A region expression) tipe =

4039 exists $ \unif ->

4140 let

4241 shaderTipe a u v =

43− Env.get env Env.types "WebGL.Shader" <| a <| u <| v

42+ Env.getType env "WebGL.Shader" <| a <| u <| v

4443

45− glTipe =

46− Env.get env Env.types . Lit.glTipeName

44+ glToType glTipe =

45+ Env.getType env (Lit.glTipeName glTipe)

4746

4847 makeRec accessor baseRec =

4948 let decls = accessor gltipe

5049 in

51− if Map.size decls == 0

52− then baseRec

53− else record (Map.map (\t -> [glTipe t]) decls) baseRec

50+ if Map.size decls == 0 then

51+ baseRec

52+ else

53+ record (Map.map glToType decls) baseRec

5454

5555 attribute = makeRec Lit.attribute attr

5656 uniform = makeRec Lit.uniform unif

57− varying = makeRec Lit.varying (termN EmptyRecord1)

57+ varying = makeRec Lit.varying (TermN EmptyRecord1)

5858 in

59− return (CEqual Error.Shader region tipe (shaderTipe attribute uniform varying))

59+ return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)

6060

6161 E.Var var ->

6262 let name = V.toString var

@@ -104,8 +104,8 @@ constrain env annotatedExpr@(A.A region expression) tipe =

104104 constrainCase env region expr branches tipe

105105

106106 E.Data name exprs ->

107− do vars <- Monad.forM exprs $ \_ -> variable Flexible

108− let pairs = zip exprs (map varN vars)

107+ do vars <- Monad.forM exprs $ \_ -> mkVar Nothing

108+ let pairs = zip exprs (map VarN vars)

109109 (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)

110110 return $ ex vars (cs /\ name <? ctipe)

111111 where

@@ -115,31 +115,31 @@ constrain env annotatedExpr@(A.A region expression) tipe =

115115

116116 E.Access expr label ->

117117 exists $ \t ->

118− constrain env expr (record (Map.singleton label [tipe]) t)

118+ constrain env expr (record (Map.singleton label tipe) t)

119119

120120 E.Update expr fields ->

121121 exists $ \t ->

122− do oldVars <- Monad.forM fields $ \_ -> variable Flexible

123− let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))

122+ do oldVars <- mapM (\_ -> mkVar Nothing) fields

123+ let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))

124124 cOld <- ex oldVars <$> constrain env expr (record oldFields t)

125125

126− newVars <- Monad.forM fields $ \_ -> variable Flexible

127− let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))

126+ newVars <- mapM (\_ -> mkVar Nothing) fields

127+ let newFields = Map.fromList (zip (map fst fields) (map VarN newVars))

128128 let cNew = CEqual Error.Record region tipe (record newFields t)

129129

130− cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN newVars)

130+ cs <- Monad.zipWithM (constrain env) (map snd fields) (map VarN newVars)

131131

132132 return $ cOld /\ ex newVars (CAnd (cNew : cs))

133133

134134 E.Record fields ->

135− do vars <- Monad.forM fields (\_ -> variable Flexible)

135+ do vars <- Monad.forM fields (\_ -> mkVar Nothing)

136136 fieldCons <-

137137 Monad.zipWithM

138138 (constrain env)

139139 (map snd fields)

140− (map varN vars)

141− let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

142− let recordType = record fields' (termN EmptyRecord1)

140+ (map VarN vars)

141+ let fields' = Map.fromList (zip (map fst fields) (map VarN vars))

142+ let recordType = record fields' (TermN EmptyRecord1)

143143 return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region tipe recordType])))

144144

145145 E.Let defs body ->

@@ -178,14 +178,14 @@ constrainApp

178178 -> Type

179179 -> IO TypeConstraint

180180constrainApp env region f args tipe =

181− do funcVar <- variable Flexible

182− funcCon <- constrain env f (varN funcVar)

181+ do funcVar <- mkVar Nothing

182+ funcCon <- constrain env f (VarN funcVar)

183183

184184 (vars, argCons, numberOfArgsCons, argMatchCons, _, returnVar) <-

185185 argConstraints env maybeName region (length args) funcVar 1 args

186186

187187 let returnCon =

188− CEqual (Error.Function maybeName) region (varN returnVar) tipe

188+ CEqual (Error.Function maybeName) region (VarN returnVar) tipe

189189

190190 return $ ex (funcVar : vars) $

191191 CAnd (funcCon : argCons ++ numberOfArgsCons ++ argMatchCons ++ [returnCon])

@@ -214,10 +214,10 @@ argConstraints env name region totalArgs overallVar index args =

214214 return ([], [], [], [], Nothing, overallVar)

215215

216216 expr@(A.A subregion _) : rest ->

217− do argVar <- variable Flexible

218− argCon <- constrain env expr (varN argVar)

219− argIndexVar <- variable Flexible

220− localReturnVar <- variable Flexible

217+ do argVar <- mkVar Nothing

218+ argCon <- constrain env expr (VarN argVar)

219+ argIndexVar <- mkVar Nothing

220+ localReturnVar <- mkVar Nothing

221221

222222 (vars, argConRest, numberOfArgsRest, argMatchRest, restRegion, returnVar) <-

223223 argConstraints env name region totalArgs localReturnVar (index + 1) rest

@@ -229,15 +229,15 @@ argConstraints env name region totalArgs overallVar index args =

229229 CEqual

230230 (Error.FunctionArity name (index - 1) totalArgs arityRegion)

231231 region

232− (varN argIndexVar ==> varN localReturnVar)

233− (varN overallVar)

232+ (VarN argIndexVar ==> VarN localReturnVar)

233+ (VarN overallVar)

234234

235235 let argMatchCon =

236236 CEqual

237− (Error.UnexpectedArg name index subregion)

237+ (Error.UnexpectedArg name index totalArgs subregion)

238238 region

239− (varN argIndexVar)

240− (varN argVar)

239+ (VarN argIndexVar)

240+ (VarN argVar)

241241

242242 return

243243 ( argVar : argIndexVar : localReturnVar : vars

@@ -262,26 +262,26 @@ constrainBinop

262262 -> Type

263263 -> IO TypeConstraint

264264constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightRegion _) tipe =

265− do leftVar <- variable Flexible

266− rightVar <- variable Flexible

265+ do leftVar <- mkVar Nothing

266+ rightVar <- mkVar Nothing

267267

268− leftCon <- constrain env leftExpr (varN leftVar)

269− rightCon <- constrain env rightExpr (varN rightVar)

268+ leftCon <- constrain env leftExpr (VarN leftVar)

269+ rightCon <- constrain env rightExpr (VarN rightVar)

270270

271− leftVar' <- variable Flexible

272− rightVar' <- variable Flexible

273− answerVar <- variable Flexible

271+ leftVar' <- mkVar Nothing

272+ rightVar' <- mkVar Nothing

273+ answerVar <- mkVar Nothing

274274

275− let opType = varN leftVar' ==> varN rightVar' ==> varN answerVar

275+ let opType = VarN leftVar' ==> VarN rightVar' ==> VarN answerVar

276276

277277 return $

278278 ex [leftVar,rightVar,leftVar',rightVar',answerVar] $ CAnd $

279279 [ leftCon

280280 , rightCon

281281 , CInstance region (V.toString op) opType

282− , CEqual (Error.BinopLeft op leftRegion) region (varN leftVar') (varN leftVar)

283− , CEqual (Error.BinopRight op rightRegion) region (varN rightVar') (varN rightVar)

284− , CEqual (Error.Binop op) region tipe (varN answerVar)

282+ , CEqual (Error.BinopLeft op leftRegion) region (VarN leftVar') (VarN leftVar)

283+ , CEqual (Error.BinopRight op rightRegion) region (VarN rightVar') (VarN rightVar)

284+ , CEqual (Error.Binop op) region tipe (VarN answerVar)

285285 ]

286286

287287

@@ -302,12 +302,12 @@ constrainList env region exprs tipe =

302302 return $ ex vars (CAnd (exprCons ++ cons))

303303 where

304304 elementConstraint expr@(A.A region' _) =

305− do var <- variable Flexible

306− con <- constrain env expr (varN var)

305+ do var <- mkVar Nothing

306+ con <- constrain env expr (VarN var)

307307 return ( (var, region'), con )

308308

309309 varToCon var =

310− CEqual Error.List region tipe (Env.get env Env.types "List" <| varN var)

310+ CEqual Error.List region tipe (Env.getType env "List" <| VarN var)

311311

312312

313313-- CONSTRAIN IF EXPRESSIONS

@@ -334,17 +334,17 @@ constrainIf env region branches finally tipe =

334334 return $ ex (condVars ++ vars) (CAnd (condCons ++ branchExprCons ++ cons))

335335 where

336336 bool =

337− Env.get env Env.types "Bool"

337+ Env.getType env "Bool"

338338

339339 constrainCondition condition@(A.A condRegion _) =

340− do condVar <- variable Flexible

341− condCon <- constrain env condition (varN condVar)

342− let boolCon = CEqual Error.IfCondition condRegion (varN condVar) bool

340+ do condVar <- mkVar Nothing

341+ condCon <- constrain env condition (VarN condVar)

342+ let boolCon = CEqual Error.IfCondition condRegion (VarN condVar) bool

343343 return (condVar, CAnd [ condCon, boolCon ])

344344

345345 constrainBranch expr@(A.A branchRegion _) =

346− do branchVar <- variable Flexible

347− exprCon <- constrain env expr (varN branchVar)

346+ do branchVar <- mkVar Nothing

347+ exprCon <- constrain env expr (VarN branchVar)

348348 return

349349 ( (branchVar, branchRegion)

350350 , exprCon

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

355355 [(thenVar, _), (elseVar, _)] ->

356356 return

357357 ( [thenVar,elseVar]

358− , [ CEqual Error.IfBranches region (varN thenVar) (varN elseVar)

358+ , [ CEqual Error.IfBranches region (VarN thenVar) (VarN elseVar)

359359 , varToCon thenVar

360360 ]

361361 )

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

364364 pairCons region Error.MultiIfBranch varToCon branchInfo

365365

366366 varToCon var =

367− CEqual Error.If region (varN var) tipe

367+ CEqual Error.If region (VarN var) tipe

368368

369369

370370-- CONSTRAIN CASE EXPRESSIONS

@@ -377,27 +377,27 @@ constrainCase

377377 -> Type

378378 -> IO TypeConstraint

379379constrainCase env region expr branches tipe =

380− do exprVar <- variable Flexible

381− exprCon <- constrain env expr (varN exprVar)

380+ do exprVar <- mkVar Nothing

381+ exprCon <- constrain env expr (VarN exprVar)

382382

383383 (branchInfo, branchExprCons) <-

384− unzip <$> mapM (branch (varN exprVar)) branches

384+ unzip <$> mapM (branch (VarN exprVar)) branches

385385

386386 (vars, cons) <- pairCons region Error.CaseBranch varToCon branchInfo

387387

388388 return $ ex (exprVar : vars) (CAnd (exprCon : branchExprCons ++ cons))

389389 where

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

391− do branchVar <- variable Flexible

391+ do branchVar <- mkVar Nothing

392392 fragment <- Pattern.constrain env pattern patternType

393− branchCon <- constrain env branchExpr (varN branchVar)

393+ branchCon <- constrain env branchExpr (VarN branchVar)

394394 return

395395 ( (branchVar, branchRegion)

396396 , CLet [Fragment.toScheme fragment] branchCon

397397 )

398398

399399 varToCon var =

400− CEqual Error.Case region tipe (varN var)

400+ CEqual Error.Case region tipe (VarN var)

401401

402402

403403-- COLLECT PAIRS

@@ -419,11 +419,11 @@ pairCons

419419pairCons region pairHint varToCon items =

420420 let

421421 pairToCon (Pair index var1 var2 subregion) =

422− CEqual (pairHint index subregion) region (varN var1) (varN var2)

422+ CEqual (pairHint index subregion) region (VarN var1) (VarN var2)

423423 in

424424 case collectPairs 2 items of

425425 Nothing ->

426− do var <- variable Flexible

426+ do var <- mkVar Nothing

427427 return ([var], [varToCon var])

428428

429429 Just (pairs, var) ->

@@ -499,7 +499,8 @@ constrainDef env info (Canonical.Definition _ (A.A patternRegion pattern) expr m

499499 (P.Var name, Nothing) ->

500500 constrainUnannotatedDef env info qs patternRegion name expr

501501

502− _ -> error ("problem in constrainDef with " ++ show pattern)

502+ _ ->

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

503504

504505

505506constrainAnnotatedDef

@@ -514,28 +515,26 @@ constrainAnnotatedDef

514515 -> IO Info

515516constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe =

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

517− rigidVars <- Monad.forM qs (\_ -> variable Rigid)

518−

519− flexiVars <- Monad.forM qs (\_ -> variable Flexible)

518+ rigidVars <- mapM mkRigid qs

520519

521− let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars

520+ flexiVars <- mapM mkNamedVar qs

522521

523− let env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

522+ let env' = Env.addValues env (zip qs flexiVars)

524523

525524 (vars, typ) <- Env.instantiateType env tipe Map.empty

526525

527526 let scheme =

528527 Scheme

529− { rigidQuantifiers = []

530− , flexibleQuantifiers = flexiVars ++ vars

531− , constraint = CTrue

532− , header = Map.singleton name (A.A patternRegion typ)

533− }

534−

535− var <- variable Flexible

536− defCon <- constrain env' expr (varN var)

528+ { _rigidQuantifiers = []

529+ , _flexibleQuantifiers = flexiVars ++ vars

530+ , _constraint = CTrue

531+ , _header = Map.singleton name (A.A patternRegion typ)

532+ }

533+

534+ var <- mkVar Nothing

535+ defCon <- constrain env' expr (VarN var)

537536 let annCon =

538− CEqual (Error.BadTypeAnnotation name) typeRegion typ (varN var)

537+ CEqual (Error.BadTypeAnnotation name) typeRegion typ (VarN var)

539538

540539 return $ info

541540 { iSchemes = scheme : iSchemes info

@@ -553,15 +552,13 @@ constrainUnannotatedDef

553552 -> IO Info

554553constrainUnannotatedDef env info qs patternRegion name expr =

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

556− rigidVars <- Monad.forM qs (\_ -> variable Rigid)

557−

558− v <- variable Flexible

555+ rigidVars <- mapM mkRigid qs

559556

560− let tipe = varN v

557+ v <- mkVar Nothing

561558

562− let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars

559+ let tipe = VarN v

563560

564− let env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

561+ let env' = Env.addValues env (zip qs rigidVars)

565562

566563 con <- constrain env' expr tipe

567564

src/Type/Constrain/Literal.hs+27−16

@@ -14,24 +14,35 @@ constrain

1414 -> T.Type

1515 -> IO T.TypeConstraint

1616constrain env region literal tipe =

17− do tipe' <- litType

18− return (T.CEqual (Error.Literal name) region tipe tipe')

17+ do definiteType <- litType

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

1919 where

2020 prim name =

21− return (Env.get env Env.types name)

21+ return (Env.getType env name)

2222

23− litType =

23+ (name, litType) =

2424 case literal of

25− L.IntNum _ -> T.varN `fmap` T.variable (T.Is T.Number)

26− L.FloatNum _ -> prim "Float"

27− L.Chr _ -> prim "Char"

28− L.Str _ -> prim "String"

29− L.Boolean _ -> prim "Bool"

25+ L.IntNum _ ->

26+ ( "number"

27+ , T.VarN <$> T.mkVar (Just T.Number)

28+ )

3029

31− name =

32− case literal of

33− L.IntNum _ -> "number"

34− L.FloatNum _ -> "float"

35− L.Chr _ -> "character"

36− L.Str _ -> "string"

37− L.Boolean _ -> "boolean"

30+ L.FloatNum _ ->

31+ ( "float"

32+ , prim "Float"

33+ )

34+

35+ L.Chr _ ->

36+ ( "character"

37+ , prim "Char"

38+ )

39+

40+ L.Str _ ->

41+ ( "string"

42+ , prim "String"

43+ )

44+

45+ L.Boolean _ ->

46+ ( "boolean"

47+ , prim "Bool"

48+ )

src/Type/Constrain/Pattern.hs+11−12

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

1−{-# LANGUAGE FlexibleInstances #-}

21module Type.Constrain.Pattern where

43import Control.Arrow (second)

@@ -26,7 +25,7 @@ constrain env (A.A region pattern) tipe =

2625 CEqual (Error.Pattern patternError) region leftType rightType

2726

2827 rvar v =

29− A.A region (varN v)

28+ A.A region (VarN v)

3029 in

3130 case pattern of

3231 P.Anything ->

@@ -37,22 +36,22 @@ constrain env (A.A region pattern) tipe =

3736 return $ emptyFragment { typeConstraint = c }

3837

3938 P.Var name ->

40− do v <- variable Flexible

39+ do variable <- mkVar Nothing

4140 return $ Fragment

42− { typeEnv = Map.singleton name (rvar v)

43− , vars = [v]

41+ { typeEnv = Map.singleton name (rvar variable)

42+ , vars = [variable]

4443 , typeConstraint =

45− equal (Error.PVar name) (varN v) tipe

44+ equal (Error.PVar name) (VarN variable) tipe

4645 }

4746

4847 P.Alias name p ->

49− do v <- variable Flexible

48+ do variable <- mkVar Nothing

5049 fragment <- constrain env p tipe

5150 return $ fragment

52− { typeEnv = Map.insert name (rvar v) (typeEnv fragment)

53− , vars = v : vars fragment

51+ { typeEnv = Map.insert name (rvar variable) (typeEnv fragment)

52+ , vars = variable : vars fragment

5453 , typeConstraint =

55− equal (Error.PAlias name) (varN v) tipe

54+ equal (Error.PAlias name) (VarN variable) tipe

5655 /\ typeConstraint fragment

5756 }

5857

@@ -73,13 +72,13 @@ constrain env (A.A region pattern) tipe =

7372

7473 P.Record fields ->

7574 do pairs <-

76− mapM (\name -> (,) name <$> variable Flexible) fields

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

7776

7877 let tenv =

7978 Map.fromList (map (second rvar) pairs)

8079

8180 let unannotatedTenv =

82− Map.map (\v -> [A.drop v]) tenv

81+ Map.map A.drop tenv

8382

8483 con <- exists $ \t ->

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

src/Type/Environment.hs+104−93

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

1−module Type.Environment where

1+{-# OPTIONS_GHC -Wall #-}

2+module Type.Environment

3+ ( Environment

4+ , initialize

5+ , getType, freshDataScheme, ctorNames

6+ , addValues

7+ , instantiateType

8+ )

9+ where

210

3−import Control.Monad (forM)

411import qualified Control.Monad.State as State

5−import qualified Data.Traversable as Traverse

12+import qualified Data.List as List

13+import Data.Map ((!))

614import qualified Data.Map as Map

715import qualified Data.Set as Set

8−import Data.List (isPrefixOf)

916

1017import qualified AST.Type as T

1118import qualified AST.Variable as V

@@ -18,22 +25,22 @@ type VarDict = Map.Map String Variable

1825

1926

2027data Environment = Environment

21− { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))

22− , types :: TypeDict

23− , value :: TypeDict

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

29+ , _types :: TypeDict

30+ , _value :: TypeDict

2431 }

2532

2633

27−initialEnvironment :: [Module.CanonicalAdt] -> IO Environment

28−initialEnvironment datatypes =

34+initialize :: [Module.CanonicalAdt] -> IO Environment

35+initialize datatypes =

2936 do types <- makeTypes datatypes

3037 let env =

3138 Environment

32− { constructor = Map.empty

33− , value = Map.empty

34− , types = types

39+ { _constructor = Map.empty

40+ , _value = Map.empty

41+ , _types = types

3542 }

36− return $ env { constructor = makeConstructors env datatypes }

43+ return $ env { _constructor = makeConstructors env datatypes }

3744

3845

3946makeTypes :: [Module.CanonicalAdt] -> IO TypeDict

@@ -43,14 +50,14 @@ makeTypes datatypes =

4350 return (Map.fromList (adts ++ bs))

4451 where

4552 makeImported :: (V.Canonical, Module.AdtInfo V.Canonical) -> IO (String, Type)

46− makeImported (var, _) =

47− do tvar <- namedVar Constant var

48− return (V.toString var, varN tvar)

53+ makeImported (name, _) =

54+ do tvar <- mkAtom name

55+ return (V.toString name, VarN tvar)

4956

5057 makeBuiltin :: (String, Int) -> IO (String, Type)

5158 makeBuiltin (name, _) =

52− do name' <- namedVar Constant (V.builtin name)

53− return (name, varN name')

59+ do name' <- mkAtom (V.builtin name)

60+ return (name, VarN name')

5461

5562 builtins :: [(String, Int)]

5663 builtins =

@@ -72,17 +79,17 @@ makeConstructors env datatypes =

7279 Map.fromList builtins

7380 where

7481 list t =

75− (types env Map.! "List") <| t

82+ (_types env ! "List") <| t

7683

7784 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

7885 inst numTVars tipe =

79− do vars <- forM [1..numTVars] $ \_ -> variable Flexible

80− let (args, result) = tipe (map (varN) vars)

86+ do vars <- mapM (\_ -> mkVar Nothing) [1..numTVars]

87+ let (args, result) = tipe (map (VarN) vars)

8188 return (length args, vars, args, result)

8289

8390 tupleCtor n =

8491 let name = "_Tuple" ++ show n

85− in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))

92+ in (name, inst n $ \vs -> (vs, foldl (<|) (_types env ! name) vs))

8693

8794 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]

8895 builtins =

@@ -112,44 +119,62 @@ ctorToType env (name, (tvars, ctors)) =

112119 return (types, returnType)

113120

114121

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

116−get env subDict key =

122+

123+-- ACCESS TYPES

124+

125+

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

127+get subDict env key =

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

118129 where

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

120131

121132

122−freshDataScheme

123− :: Environment

124− -> String

125− -> IO (Int, [Variable], [Type], Type)

126−freshDataScheme env name =

127− get env constructor name

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

134+getType =

135+ get _types

128136

129137

130−instantiateType

131− :: Environment

132− -> T.Canonical

133− -> VarDict

134− -> IO ([Variable], Type)

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

139+freshDataScheme =

140+ get _constructor

141+

142+

143+ctorNames :: Environment -> [String]

144+ctorNames env =

145+ Map.keys (_constructor env)

146+

147+

148+-- UPDATE ENVIRONMENT

149+

150+

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

160+

161+

162+

163+-- INSTANTIATE TYPES

164+

165+

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

135167instantiateType env sourceType dict =

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

137169 return (Map.elems dict', tipe)

138170

139171

140−instantiator

141− :: Environment

142− -> T.Canonical

143− -> State.StateT VarDict IO Type

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

144173instantiator env sourceType =

145174 instantiatorHelp env Set.empty sourceType

146175

147176

148−instantiatorHelp

149− :: Environment

150− -> Set.Set String

151− -> T.Canonical

152− -> State.StateT VarDict IO Type

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

153178instantiatorHelp env aliasVars sourceType =

154179 let go = instantiatorHelp env aliasVars

155180 in

@@ -157,70 +182,56 @@ instantiatorHelp env aliasVars sourceType =

157182 T.Lambda t1 t2 ->

158183 (==>) <$> go t1 <*> go t2

159184

160− T.Var x ->

161− do dict <- State.get

162− case Set.member x aliasVars of

163− True ->

164− return (PlaceHolder x)

165− False ->

166− case Map.lookup x dict of

167− Just v ->

168− return (varN v)

169−

170− Nothing ->

171− do v <- State.liftIO $ namedVar flex (V.local x)

172− State.put (Map.insert x v dict)

173− return (varN v)

174− where

175− flex | "number" `isPrefixOf` x = Is Number

176− | "comparable" `isPrefixOf` x = Is Comparable

177− | "appendable" `isPrefixOf` x = Is Appendable

178− | otherwise = Flexible

185+ T.Var name ->

186+ if Set.member name aliasVars then

187+ return (PlaceHolder name)

188+

189+ else

190+ do dict <- State.get

191+ case Map.lookup name dict of

192+ Just variable ->

193+ return (VarN variable)

194+

195+ Nothing ->

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

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

198+ return (VarN variable)

179199

180200 T.Aliased name args aliasType ->

181− do args' <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args

182− aliasedType' <-

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

202+ realType <-

183203 case aliasType of

184204 T.Filled tipe ->

185205 instantiatorHelp env Set.empty tipe

206+

186207 T.Holey tipe ->

187208 instantiatorHelp env (Set.fromList (map fst args)) tipe

188209

189− case aliasedType' of

190− PlaceHolder _ ->

191− error "problem instantiating type"

192−

193− VarN maybeSubAlias v ->

194− case maybeSubAlias of

195− Nothing ->

196− return (VarN (Just (name,args')) v)

197− Just _subAlias ->

198− return (TermN (Just (name,args')) (Var1 aliasedType'))

199−

200− TermN maybeSubAlias t ->

201− case maybeSubAlias of

202− Nothing ->

203− return (TermN (Just (name, args')) t)

204− Just _subAlias ->

205− return (TermN (Just (name,args')) (Var1 aliasedType'))

210+ return (AliasN name targs realType)

206211

207212 T.Type name ->

208− case Map.lookup (V.toString name) (types env) of

209− Just t -> return t

213+ case Map.lookup (V.toString name) (_types env) of

214+ Just tipe ->

215+ return tipe

216+

210217 Nothing ->

211218 error $

212219 "Could not find type constructor `" ++

213220 V.toString name ++ "` while checking types."

214221

215− T.App t ts ->

216− do t' <- go t

217− ts' <- mapM go ts

218− return $ foldl (<|) t' ts'

222+ T.App func args ->

223+ do tfunc <- go func

224+ targs <- mapM go args

225+ return $ foldl (<|) tfunc targs

219226

220227 T.Record fields ext ->

221− do fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)

222− ext' <-

228+ do tfields <- traverse go (Map.fromList fields)

229+ text <-

223230 case ext of

224− Nothing -> return $ termN EmptyRecord1

225− Just x -> go x

226− return $ termN (Record1 fields' ext')

231+ Nothing ->

232+ return $ TermN EmptyRecord1

233+

234+ Just extType ->

235+ go extType

236+

237+ return $ TermN (Record1 tfields text)

src/Type/Inference.hs+5−6

@@ -42,13 +42,12 @@ infer interfaces modul =

4242genConstraints

4343 :: Module.Interfaces

4444 -> Module.CanonicalModule

45− -> IO (Env.TypeDict, T.TypeConstraint)

45+ -> IO (Map.Map String T.Type, T.TypeConstraint)

4646genConstraints interfaces modul =

47− do env <-

48− Env.initialEnvironment (canonicalizeAdts interfaces modul)

47+ do env <- Env.initialize (canonicalizeAdts interfaces modul)

4948

5049 ctors <-

51− forM (Map.keys (Env.constructor env)) $ \name ->

50+ forM (Env.ctorNames env) $ \name ->

5251 do (_, vars, args, result) <- Env.freshDataScheme env name

5352 return (name, (vars, foldr (T.==>) result args))

5453

@@ -60,10 +59,10 @@ genConstraints interfaces modul =

6059 let header = Map.map snd (Map.fromList allTypes)

6160 let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]

6261

63− fvar <- T.variable T.Flexible

62+ fvar <- T.mkVar Nothing

6463

6564 constraint <-

66− TcExpr.constrain env (program (body modul)) (T.varN fvar)

65+ TcExpr.constrain env (program (body modul)) (T.VarN fvar)

6766

6867 return (header, environ constraint)

6968

src/Type/PrettyPrint.hsdeleted−20

@@ -1,20 +0,0 @@

1−module Type.PrettyPrint where

2−

3−import Text.PrettyPrint

4−

5−

6−data ParensWhen = Fn | App | Never

7−

8−

9−class PrettyType a where

10− pretty :: ParensWhen -> a -> Doc

11−

12−

13−commaSep :: [Doc] -> Doc

14−commaSep docs =

15− sep (punctuate comma docs)

16−

17−

18−parensIf :: Bool -> Doc -> Doc

19−parensIf bool doc =

20− if bool then parens doc else doc

src/Type/Solve.hs+152−98

@@ -2,7 +2,7 @@ module Type.Solve (solve) where

33import Control.Applicative ((<|>))

44import Control.Monad

5−import Control.Monad.State (StateT, execStateT, liftIO)

5+import Control.Monad.State (execStateT, liftIO)

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

77import qualified Data.Foldable as F

88import qualified Data.List as List

@@ -14,21 +14,22 @@ import qualified AST.Type as Type

1414import qualified Reporting.Annotation as A

1515import qualified Reporting.Error.Type as Error

1616import qualified Type.State as TS

17−import Type.Type

17+import Type.Type as Type

1818import Type.Unify

1919

2020

21+

2122{-| Every variable has rank less than or equal to the maxRank of the pool.

2223This sorts variables into the young and old pools accordingly.

2324-}

24−generalize :: TS.Pool -> StateT TS.SolverState IO ()

25+generalize :: TS.Pool -> TS.Solver ()

2526generalize youngPool =

2627 do youngMark <- TS.uniqueMark

2728 let youngRank = TS.maxRank youngPool

2829 let insert dict var =

2930 do descriptor <- liftIO $ UF.descriptor var

30− liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })

31− return $ Map.insertWith (++) (rank descriptor) [var] dict

31+ liftIO $ UF.modifyDescriptor var (\desc -> desc { _mark = youngMark })

32+ return $ Map.insertWith (++) (_rank descriptor) [var] dict

3233

3334 -- Sort the youngPool variables by rank.

3435 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)

@@ -58,63 +59,98 @@ generalize youngPool =

5859 True -> return ()

5960 False -> do

6061 desc <- liftIO $ UF.descriptor var

61− case rank desc < youngRank of

62− True -> TS.register var >> return ()

63− False -> do

64− let flex' = case flex desc of { Flexible -> Rigid ; other -> other }

65− liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })

62+ case _rank desc < youngRank of

63+ True ->

64+ TS.register var >> return ()

65+ False ->

66+ liftIO $ UF.setDescriptor var $ desc

67+ { _rank = noRank

68+ , _content = rigidify (_content desc)

69+ }

6670

6771 mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)

6872

6973

74+rigidify :: Content -> Content

75+rigidify content =

76+ case content of

77+ Var Flex maybeSuper _ ->

78+ Var Rigid maybeSuper Nothing

79+

80+ _ ->

81+ content

82+

83+

7084-- adjust the ranks of variables such that ranks never increase as you

7185-- move deeper into a variable.

72−adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int

86+adjustRank :: Int -> Int -> Int -> Variable -> TS.Solver Int

7387adjustRank youngMark visitedMark groupRank var =

7488 do descriptor <- liftIO $ UF.descriptor var

75− case () of

76− () | mark descriptor == youngMark ->

77− do -- Set the variable as marked first because it may be cyclic.

78− liftIO $ UF.modifyDescriptor var $ \desc ->

79− desc { mark = visitedMark }

80− rank' <- maybe (return groupRank) adjustTerm (structure descriptor)

81− liftIO $ UF.modifyDescriptor var $ \desc ->

82− desc { rank = rank' }

83− return rank'

84−

85− | mark descriptor /= visitedMark ->

86− do let rank' = min groupRank (rank descriptor)

87− liftIO $ UF.setDescriptor var (descriptor { mark = visitedMark, rank = rank' })

88− return rank'

89−

90− | otherwise ->

91− return (rank descriptor)

92− where

93− adjust =

94− adjustRank youngMark visitedMark groupRank

95−

96− adjustTerm term =

97− case term of

98− App1 a b ->

99− max `liftM` adjust a `ap` adjust b

100−

101− Fun1 a b ->

102− max `liftM` adjust a `ap` adjust b

103−

104− Var1 x ->

105− adjust x

106−

107− EmptyRecord1 ->

108− return outermostRank

109−

110− Record1 fields extension ->

111− do ranks <- mapM adjust (concat (Map.elems fields))

112− rnk <- adjust extension

113− return . maximum $ rnk : ranks

89+ adjustRankHelp youngMark visitedMark groupRank var descriptor

90+

91+

92+adjustRankHelp :: Int -> Int -> Int -> Variable -> Descriptor -> TS.Solver Int

93+adjustRankHelp youngMark visitedMark groupRank var descriptor =

94+ if _mark descriptor == youngMark then

95+

96+ do -- Set the variable as marked first because it may be cyclic.

97+ liftIO $ UF.modifyDescriptor var $ \desc ->

98+ desc { _mark = visitedMark }

99+

100+ maxRank <-

101+ adjustRankContent youngMark visitedMark groupRank (_content descriptor)

102+

103+ liftIO $ UF.modifyDescriptor var $ \desc ->

104+ desc { _rank = maxRank }

105+

106+ return maxRank

107+

108+ else if _mark descriptor /= visitedMark then

109+

110+ do let minRank = min groupRank (_rank descriptor)

111+ liftIO $ UF.setDescriptor var (descriptor { _mark = visitedMark, _rank = minRank })

112+ return minRank

113+

114+ else

115+

116+ return (_rank descriptor)

117+

118+

119+adjustRankContent :: Int -> Int -> Int -> Content -> TS.Solver Int

120+adjustRankContent youngMark visitedMark groupRank content =

121+ let

122+ go = adjustRank youngMark visitedMark groupRank

123+ in

124+ case content of

125+ Error ->

126+ return groupRank

127+

128+ Atom _ ->

129+ return groupRank

130+

131+ Var _ _ _ ->

132+ return groupRank

133+

134+ Alias _ args realVar ->

135+ maximum <$> mapM go (realVar : map snd args)

136+

137+ Structure (App1 func arg) ->

138+ max <$> go func <*> go arg

139+

140+ Structure (Fun1 arg result) ->

141+ max <$> go arg <*> go result

142+

143+ Structure EmptyRecord1 ->

144+ return outermostRank

145+

146+ Structure (Record1 fields extension) ->

147+ maximum <$> mapM go (extension : Map.elems fields)

148+

114149

115150

116151-- SOLVER

117152

153+

118154solve :: TypeConstraint -> ExceptT [A.Located Error.Error] IO TS.SolverState

119155solve constraint =

120156 do state <-

@@ -126,7 +162,7 @@ solve constraint =

126162 throwError errors

127163

128164

129−actuallySolve :: TypeConstraint -> StateT TS.SolverState IO ()

165+actuallySolve :: TypeConstraint -> TS.Solver ()

130166actuallySolve constraint =

131167 case constraint of

132168 CTrue ->

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

151187

152188 CLet schemes constraint' ->

153189 do oldEnv <- TS.getEnv

154− headers <- Map.unions `fmap` mapM solveScheme schemes

190+ headers <- Map.unions <$> mapM solveScheme schemes

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

156192 actuallySolve constraint'

157193 mapM occurs $ Map.toList headers

@@ -165,17 +201,17 @@ actuallySolve constraint =

165201 TS.makeInstance tipe

166202

167203 Nothing ->

168− if List.isPrefixOf "Native." name

169− then liftIO (variable Flexible)

170− else error ("Could not find `" ++ name ++ "` when solving type constraints.")

204+ if List.isPrefixOf "Native." name then

205+ liftIO (mkVar Nothing)

206+

207+ else

208+ error ("Could not find `" ++ name ++ "` when solving type constraints.")

171209

172210 t <- TS.flatten term

173211 unify (Error.Instance name) region freshCopy t

174212

175213

176−solveScheme

177− :: TypeScheme

178− -> StateT TS.SolverState IO (Map.Map String (A.Located Variable))

214+solveScheme :: TypeScheme -> TS.Solver (Map.Map String (A.Located Variable))

179215solveScheme scheme =

180216 let

181217 flatten (A.A region term) =

@@ -210,26 +246,37 @@ solveScheme scheme =

210246-- Checks that all of the given variables belong to distinct equivalence classes.

211247-- Also checks that their structure is Nothing, so they represent a variable, not

212248-- a more complex term.

213−allDistinct :: [Variable] -> StateT TS.SolverState IO ()

249+allDistinct :: [Variable] -> TS.Solver ()

214250allDistinct vars =

215− do seen <- TS.uniqueMark

251+ do seenMark <- TS.uniqueMark

216252 forM_ vars $ \var ->

217253 do desc <- liftIO $ UF.descriptor var

218− case structure desc of

219− Just _ ->

220− crash "Cannot generalize something that is not a type variable."

254+ case _content desc of

255+ Structure _ ->

256+ crash "Can only generalize type variables, not structures."

257+

258+ Atom _ ->

259+ crash "Can only generalize type variables, not structures."

260+

261+ Alias _ _ _ ->

262+ crash "Can only generalize type variables, not aliases."

263+

264+ Error ->

265+ crash "Can only generalize type variables, not error types."

266+

267+ Var _ _ _ ->

268+ if _mark desc == seenMark then

269+ crash "Duplicate variable during generalization."

221270

222− Nothing ->

223− if mark desc == seen

224− then crash "Duplicate variable during generalization."

225− else liftIO (UF.setDescriptor var (desc { mark = seen }))

271+ else

272+ liftIO (UF.setDescriptor var (desc { _mark = seenMark }))

226273

227274

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

229−isGeneric :: Variable -> StateT TS.SolverState IO ()

276+isGeneric :: Variable -> TS.Solver ()

230277isGeneric var =

231278 do desc <- liftIO $ UF.descriptor var

232− if rank desc == noRank

279+ if _rank desc == noRank

233280 then return ()

234281 else crash "Unable to generalize a type variable. It is not unranked."

235282

@@ -237,59 +284,66 @@ isGeneric var =

237284crash :: String -> a

238285crash msg =

239286 error $

240− "It looks like something went wrong with the type inference algorithm.\n"

241− ++ msg ++ "\n"

287+ "It looks like something went wrong with the type inference algorithm.\n\n"

288+ ++ msg ++ "\n\n"

242289 ++ "Please create a minimal example that triggers this problem and report it to\n"

243290 ++ "<https://github.com/elm-lang/elm-compiler/issues>"

244291

245292

246−occurs :: (String, A.Located Variable) -> StateT TS.SolverState IO ()

293+

294+-- OCCURS CHECK

295+

296+

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

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

248− do maybePair <- liftIO $ occursHelp [] variable

249− case maybePair of

299+ do maybeInfinite <- liftIO $ occursHelp [] variable

300+ case maybeInfinite of

250301 Nothing ->

251302 return ()

252303

253− Just (t1, t2) ->

254− let

255− info = Error.InfiniteTypeInfo name t1 t2

256− in

257− TS.addError region (Error.InfiniteType info)

304+ Just infiniteType ->

305+ do overallType <- liftIO (Type.toSrcType variable)

306+ TS.addError region (Error.InfiniteType name overallType infiniteType)

258307

259308

260−occursHelp

261− :: [Variable]

262− -> Variable

263− -> IO (Maybe (Type.Canonical, Type.Canonical))

309+occursHelp :: [Variable] -> Variable -> IO (Maybe Type.Canonical)

264310occursHelp seen var =

265311 if elem var seen then

266− do desc <- UF.descriptor var

267− UF.setDescriptor var (desc { structure = Nothing })

268− var' <- UF.fresh desc

269− srcVar <- toSrcType var

270− srcVar' <- toSrcType var'

271− return (Just (srcVar, srcVar'))

312+ do infiniteDescriptor <- UF.descriptor var

313+ structureVar <- UF.fresh infiniteDescriptor

314+ UF.setDescriptor var (infiniteDescriptor { _content = Error })

315+ srcVar <- Type.toSrcType structureVar

316+ return (Just srcVar)

317+

272318 else

273319 do desc <- UF.descriptor var

274− case structure desc of

275− Nothing ->

320+ case _content desc of

321+ Atom _ ->

276322 return Nothing

277323

278− Just struct ->

279− let go = occursHelp (var:seen)

324+ Var _ _ _ ->

325+ return Nothing

326+

327+ Error ->

328+ return Nothing

329+

330+ Alias _ args _ ->

331+ -- TODO is it okay to only check args?

332+ F.asum <$> mapM (occursHelp (var:seen) . snd) args

333+

334+ Structure term ->

335+ let

336+ go = occursHelp (var:seen)

280337 in

281− case struct of

338+ case term of

282339 App1 a b ->

283340 (<|>) <$> go a <*> go b

284341

285342 Fun1 a b ->

286343 (<|>) <$> go a <*> go b

287344

288− Var1 a ->

289− go a

290−

291345 EmptyRecord1 ->

292346 return Nothing

293347

294348 Record1 fields ext ->

295− F.asum <$> mapM go (ext : concat (Map.elems fields))

349+ F.asum <$> mapM go (ext : Map.elems fields)

src/Type/State.hs+197−136

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

1−{-# LANGUAGE FlexibleContexts #-}

2−{-# LANGUAGE MultiParamTypeClasses #-}

1+{-# OPTIONS_GHC -Wall #-}

32module Type.State where

5−import Control.Applicative ((<|>))

6−import Control.Monad.State

4+import qualified Control.Monad.State as State

75import Data.Map ((!))

86import qualified Data.Map as Map

9−import qualified Data.Traversable as Traversable

107import qualified Data.UnionFind.IO as UF

118

129import qualified Reporting.Annotation as A

@@ -37,6 +34,9 @@ emptyPool =

3734type Env = Map.Map String (A.Located Variable)

3835

3936

37+type Solver = State.StateT SolverState IO

38+

39+

4040-- Keeps track of the environment, type variable pool, and a list of errors

4141data SolverState = SS

4242 { sEnv :: Env

@@ -58,191 +58,257 @@ initialState =

5858 }

5959

6060

61−modifyEnv :: (MonadState SolverState m) => (Env -> Env) -> m ()

61+modifyEnv :: (Env -> Env) -> Solver ()

6262modifyEnv f =

63− modify $ \state -> state { sEnv = f (sEnv state) }

63+ State.modify $ \state -> state { sEnv = f (sEnv state) }

6464

6565

66−modifyPool :: (MonadState SolverState m) => (Pool -> Pool) -> m ()

66+modifyPool :: (Pool -> Pool) -> Solver ()

6767modifyPool f =

68− modify $ \state -> state { sPool = f (sPool state) }

68+ State.modify $ \state -> state { sPool = f (sPool state) }

6969

7070

71−addError :: R.Region -> Error.Error -> StateT SolverState IO ()

71+addError :: R.Region -> Error.Error -> Solver ()

7272addError region err =

73− modify $ \state -> state { sError = A.A region err : sError state }

73+ State.modify $ \state -> state { sError = A.A region err : sError state }

7474

7575

76−switchToPool :: (MonadState SolverState m) => Pool -> m ()

76+switchToPool :: Pool -> Solver ()

7777switchToPool pool =

7878 modifyPool (\_ -> pool)

7979

8080

81−getPool :: StateT SolverState IO Pool

81+getPool :: Solver Pool

8282getPool =

83− gets sPool

83+ State.gets sPool

8484

8585

86−getEnv :: StateT SolverState IO Env

86+getEnv :: Solver Env

8787getEnv =

88− gets sEnv

88+ State.gets sEnv

8989

9090

91−saveLocalEnv :: StateT SolverState IO ()

91+saveLocalEnv :: Solver ()

9292saveLocalEnv =

9393 do currentEnv <- getEnv

94− modify $ \state -> state { sSavedEnv = currentEnv }

94+ State.modify $ \state -> state { sSavedEnv = currentEnv }

9595

9696

97−uniqueMark :: StateT SolverState IO Int

97+uniqueMark :: Solver Int

9898uniqueMark =

99− do state <- get

99+ do state <- State.get

100100 let mark = sMark state

101− put $ state { sMark = mark + 1 }

101+ State.put $ state { sMark = mark + 1 }

102102 return mark

103103

104104

105−nextRankPool :: StateT SolverState IO Pool

105+nextRankPool :: Solver Pool

106106nextRankPool =

107107 do pool <- getPool

108108 return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }

109109

110110

111−register :: Variable -> StateT SolverState IO Variable

111+register :: Variable -> Solver Variable

112112register variable =

113113 do modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }

114114 return variable

115115

116116

117−introduce :: Variable -> StateT SolverState IO Variable

117+introduce :: Variable -> Solver Variable

118118introduce variable =

119119 do pool <- getPool

120− liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })

120+ State.liftIO $ UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank pool })

121121 register variable

122122

123123

124−flatten :: Type -> StateT SolverState IO Variable

124+flatten :: Type -> Solver Variable

125125flatten term =

126126 flattenHelp Map.empty term

127127

128128

129−flattenHelp :: Map.Map String Variable -> Type -> StateT SolverState IO Variable

130−flattenHelp aliasDict term =

131− case term of

129+flattenHelp :: Map.Map String Variable -> Type -> Solver Variable

130+flattenHelp aliasDict termN =

131+ case termN of

132132 PlaceHolder name ->

133− return (aliasDict ! name)

134−

135− VarN maybeAlias v ->

136− do maybeAlias' <- Traversable.traverse flattenAlias maybeAlias

137− liftIO $ UF.modifyDescriptor v $ \desc ->

138− desc { alias = maybeAlias' <|> alias desc }

139− return v

140−

141− TermN maybeAlias subTerm ->

142− do maybeAlias' <- Traversable.traverse flattenAlias maybeAlias

143− let localDict = maybe aliasDict (Map.fromList . snd) maybeAlias'

144− flatStructure <- traverseTerm (flattenHelp localDict) subTerm

145− pool <- getPool

146− var <-

147− liftIO . UF.fresh $ Descriptor

148− { structure = Just flatStructure

149− , rank = maxRank pool

150− , flex = Flexible

151− , name = Nothing

152− , copy = Nothing

153− , mark = noMark

154− , alias = maybeAlias'

133+ return (aliasDict ! name)

134+

135+ AliasN name args realType ->

136+ do flatArgs <- mapM (traverse (flattenHelp aliasDict)) args

137+ flatVar <- flattenHelp (Map.fromList flatArgs) realType

138+ pool <- getPool

139+ variable <-

140+ State.liftIO . UF.fresh $ Descriptor

141+ { _content = Alias name flatArgs flatVar

142+ , _rank = maxRank pool

143+ , _mark = noMark

144+ , _copy = Nothing

145+ }

146+ register variable

147+

148+ VarN v ->

149+ return v

150+

151+ TermN term1 ->

152+ do variableTerm <- traverseTerm (flattenHelp aliasDict) term1

153+ pool <- getPool

154+ variable <-

155+ State.liftIO . UF.fresh $ Descriptor

156+ { _content = Structure variableTerm

157+ , _rank = maxRank pool

158+ , _mark = noMark

159+ , _copy = Nothing

160+ }

161+ register variable

162+

163+

164+makeInstance :: Variable -> Solver Variable

165+makeInstance var =

166+ do alreadyCopiedMark <- uniqueMark

167+ freshVar <- makeCopy alreadyCopiedMark var

168+ _ <- restore alreadyCopiedMark var

169+ return freshVar

170+

171+

172+makeCopy :: Int -> Variable -> Solver Variable

173+makeCopy alreadyCopiedMark variable =

174+ do desc <- State.liftIO $ UF.descriptor variable

175+ makeCopyHelp desc alreadyCopiedMark variable

176+

177+

178+makeCopyHelp :: Descriptor -> Int -> Variable -> Solver Variable

179+makeCopyHelp descriptor alreadyCopiedMark variable =

180+ if _mark descriptor == alreadyCopiedMark then

181+ case _copy descriptor of

182+ Just copiedVariable ->

183+ return copiedVariable

184+

185+ Nothing ->

186+ error $

187+ "Error copying type variable. This should be impossible." ++

188+ " Please report an error to the github repo!"

189+

190+ else if _rank descriptor /= noRank || not (needsCopy (_content descriptor)) then

191+ return variable

192+

193+ else

194+ do pool <- getPool

195+ newVar <-

196+ State.liftIO $ UF.fresh $ Descriptor

197+ { _content = error "will be filled in soon!"

198+ , _rank = maxRank pool

199+ , _mark = noMark

200+ , _copy = Nothing

155201 }

156− register var

157− where

158− flattenAlias (name, args) =

159− let flattenPair (arg, subTerm) =

160− (,) arg <$> flattenHelp aliasDict subTerm

161− in

162− (,) name <$> mapM flattenPair args

202+ _ <- register newVar

163203

204+ -- Link the original variable to the new variable. This lets us

205+ -- avoid making multiple copies of the variable we are instantiating.

206+ --

207+ -- Need to do this before recursively copying the content of

208+ -- the variable to avoid looping on cyclic terms.

209+ State.liftIO $ UF.modifyDescriptor variable $ \desc ->

210+ desc { _mark = alreadyCopiedMark, _copy = Just newVar }

164211

212+ -- Now we recursively copy the content of the variable.

213+ -- We have already marked the variable as copied, so we

214+ -- will not repeat this work or crawl this variable again.

215+ let oldContent = _content descriptor

216+ newContent <-

217+ case oldContent of

218+ Structure term ->

219+ Structure <$> traverseTerm (makeCopy alreadyCopiedMark) term

165220

221+ Atom _ ->

222+ return oldContent

166223

167−makeInstance :: Variable -> StateT SolverState IO Variable

168−makeInstance var =

169− do alreadyCopied <- uniqueMark

170− freshVar <- makeCopy alreadyCopied var

171− restore alreadyCopied var

172− return freshVar

224+ Var Rigid maybeSuper _ ->

225+ return (Var Flex maybeSuper Nothing)

226+

227+ Var Flex _ _ ->

228+ return oldContent

229+

230+ Alias name args realType ->

231+ Alias name

232+ <$> mapM (traverse (makeCopy alreadyCopiedMark)) args

233+ <*> makeCopy alreadyCopiedMark realType

234+

235+ Error ->

236+ return oldContent

237+

238+ State.liftIO $ UF.modifyDescriptor newVar $ \desc ->

239+ desc { _content = newContent }

173240

241+ return newVar

174242

175−makeCopy :: Int -> Variable -> StateT SolverState IO Variable

176−makeCopy alreadyCopied variable = do

177− desc <- liftIO $ UF.descriptor variable

178− case () of

179− () | mark desc == alreadyCopied ->

180− case copy desc of

181− Just v ->

182− return v

183− Nothing ->

184− error $

185− "Error copying type variable. This should be impossible." ++

186− " Please report an error to the github repo!"

187−

188− | rank desc /= noRank || flex desc == Constant ->

243+

244+needsCopy :: Content -> Bool

245+needsCopy content =

246+ case content of

247+ Structure _ ->

248+ True

249+

250+ Atom _ ->

251+ False

252+

253+ Var _ _ _ ->

254+ True

255+

256+ Alias _ _ _ ->

257+ True

258+

259+ Error ->

260+ False

261+

262+

263+

264+restore :: Int -> Variable -> Solver Variable

265+restore alreadyCopiedMark variable =

266+ do desc <- State.liftIO $ UF.descriptor variable

267+ if _mark desc /= alreadyCopiedMark

268+ then

189269 return variable

190270

191− | otherwise ->

192− do pool <- getPool

193− newVar <-

194− liftIO $ UF.fresh $ Descriptor

195− { structure = Nothing

196− , rank = maxRank pool

197− , mark = noMark

198− , flex =

199− case flex desc of

200− Is s -> Is s

201− _ -> Flexible

202− , copy = Nothing

203− , name =

204− case flex desc of

205− Rigid -> Nothing

206− _ -> name desc

207− , alias = Nothing

208− }

209− register newVar

210−

211− -- Link the original variable to the new variable. This lets us

212− -- avoid making multiple copies of the variable we are instantiating.

213− --

214− -- Need to do this before recursively copying the structure of

215− -- the variable to avoid looping on cyclic terms.

216− liftIO $ UF.modifyDescriptor variable $ \desc ->

217− desc { mark = alreadyCopied, copy = Just newVar }

218−

219− -- Now we recursively copy the structure of the variable.

220− -- We have already marked the variable as copied, so we

221− -- will not repeat this work or crawl this variable again.

222− case structure desc of

223− Nothing ->

224− return newVar

225−

226− Just term ->

227− do newTerm <- traverseTerm (makeCopy alreadyCopied) term

228− liftIO $ UF.modifyDescriptor newVar $ \desc ->

229− desc { structure = Just newTerm }

230− return newVar

231−

232−

233−restore :: Int -> Variable -> StateT SolverState IO Variable

234−restore alreadyCopied variable =

235− do desc <- liftIO $ UF.descriptor variable

236− case mark desc /= alreadyCopied of

237− True -> return variable

238− False ->

239− do restoredStructure <-

240− Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)

241− liftIO $ UF.modifyDescriptor variable $ \desc ->

242− desc { mark = noMark, rank = noRank, structure = restoredStructure }

271+ else

272+ do restoredContent <-

273+ restoreContent alreadyCopiedMark (_content desc)

274+ State.liftIO $ UF.setDescriptor variable $ Descriptor

275+ { _content = restoredContent

276+ , _rank = noRank

277+ , _mark = noMark

278+ , _copy = Nothing

279+ }

243280 return variable

244281

245282

283+

284+restoreContent :: Int -> Content -> Solver Content

285+restoreContent alreadyCopiedMark content =

286+ let

287+ go = restore alreadyCopiedMark

288+ in

289+ case content of

290+ Structure term ->

291+ Structure <$> traverseTerm go term

292+

293+ Atom _ ->

294+ return content

295+

296+ Var _ _ _ ->

297+ return content

298+

299+ Alias name args var ->

300+ Alias name

301+ <$> mapM (traverse go) args

302+ <*> go var

303+

304+ Error ->

305+ return content

306+

307+

308+

309+-- TERM TRAVERSAL

310+

311+

246312traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)

247313traverseTerm f term =

248314 case term of

@@ -252,13 +318,8 @@ traverseTerm f term =

252318 Fun1 a b ->

253319 Fun1 <$> f a <*> f b

254320

255− Var1 x ->

256− Var1 <$> f x

257−

258321 EmptyRecord1 ->

259322 return EmptyRecord1

260323

261324 Record1 fields ext ->

262− Record1

263− <$> Traversable.traverse (mapM f) fields

264− <*> f ext

325+ Record1 <$> traverse f fields <*> f ext

src/Type/Type.hs+219−444

@@ -1,108 +1,117 @@

1+{-# OPTIONS_GHC -Wall #-}

12module Type.Type where

34import Control.Monad.State (StateT)

45import qualified Control.Monad.State as State

5−import qualified Data.Char as Char

6+import qualified Data.List as List

67import qualified Data.Map as Map

78import qualified Data.Set as Set

89import qualified Data.Traversable as Traverse (traverse)

910import qualified Data.UnionFind.IO as UF

10−import Text.PrettyPrint as P

11−import System.IO.Unsafe

1211

1312import qualified AST.Type as T

1413import qualified AST.Variable as Var

1514import qualified Reporting.Annotation as A

1615import qualified Reporting.Error.Type as Error

1716import qualified Reporting.Region as R

18−import Type.PrettyPrint

17+

1918

2019

2120-- CONCRETE TYPES

2221

23−type Type = TermN Variable

2422

25−type Variable = UF.Point Descriptor

23+type Type =

24+ TermN Variable

25+

26+

27+type Variable =

28+ UF.Point Descriptor

29+

2630

27−type TypeConstraint = Constraint Type Variable

31+type TypeConstraint =

32+ Constraint Type Variable

2833

29−type TypeScheme = Scheme Type Variable

3034

31−type Alias a = Maybe (Var.Canonical, [(String,a)])

35+type TypeScheme =

36+ Scheme Type Variable

37+

3238

3339

3440-- TYPE PRIMITIVES

3541

42+

3643data Term1 a

3744 = App1 a a

3845 | Fun1 a a

39− | Var1 a

4046 | EmptyRecord1

41− | Record1 (Map.Map String [a]) a

47+ | Record1 (Map.Map String a) a

4248

4349

4450data TermN a

4551 = PlaceHolder String

46− | VarN (Alias (TermN a)) a

47− | TermN (Alias (TermN a)) (Term1 (TermN a))

48−

52+ | AliasN Var.Canonical [(String, TermN a)] (TermN a)

53+ | VarN a

54+ | TermN (Term1 (TermN a))

4955

50−varN :: a -> TermN a

51−varN =

52− VarN Nothing

5356

54−

55−termN :: (Term1 (TermN a)) -> TermN a

56−termN =

57− TermN Nothing

58−

59−

60−record :: Map.Map String [TermN a] -> TermN a -> TermN a

57+record :: Map.Map String (TermN a) -> TermN a -> TermN a

6158record fs rec =

62− termN (Record1 fs rec)

59+ TermN (Record1 fs rec)

60+

6361

6462

6563-- DESCRIPTORS

6664

65+

6766data Descriptor = Descriptor

68− { structure :: Maybe (Term1 Variable)

69− , rank :: Int

70− , flex :: Flex

71− , name :: Maybe TypeName

72− , copy :: Maybe Variable

73− , mark :: Int

74− , alias :: Alias Variable

67+ { _content :: Content

68+ , _rank :: Int

69+ , _mark :: Int

70+ , _copy :: Maybe Variable

7571 }

7672

73+

74+data Content

75+ = Structure (Term1 Variable)

76+ | Atom Var.Canonical

77+ | Var Flex (Maybe Super) (Maybe String)

78+ | Alias Var.Canonical [(String,Variable)] Variable

79+ | Error

80+

81+

82+data Flex

83+ = Rigid

84+ | Flex

85+

86+

87+data Super

88+ = Number

89+ | Comparable

90+ | Appendable

91+ | CompAppend

92+ deriving (Eq)

93+

94+

7795noRank :: Int

7896noRank = -1

7997

98+

8099outermostRank :: Int

81100outermostRank = 0

82101

102+

83103noMark :: Int

84104noMark = 0

85105

106+

86107initialMark :: Int

87108initialMark = 1

88109

89−data Flex

90− = Rigid

91− | Flexible

92− | Constant

93− | Is SuperType

94− | Error

95− deriving (Eq)

96−

97−data SuperType

98− = Number

99− | Comparable

100− | Appendable

101− deriving (Eq)

102110

103111

104112-- CONSTRAINTS

105113

114+

106115data Constraint a b

107116 = CTrue

108117 | CSaveEnv

@@ -111,66 +120,88 @@ data Constraint a b

111120 | CLet [Scheme a b] (Constraint a b)

112121 | CInstance R.Region SchemeName a

113122

123+

114124type SchemeName = String

115125

116−type TypeName = Var.Canonical

117126

118127data Scheme a b = Scheme

119− { rigidQuantifiers :: [b]

120− , flexibleQuantifiers :: [b]

121− , constraint :: Constraint a b

122− , header :: Map.Map String (A.Located a)

128+ { _rigidQuantifiers :: [b]

129+ , _flexibleQuantifiers :: [b]

130+ , _constraint :: Constraint a b

131+ , _header :: Map.Map String (A.Located a)

123132 }

124133

125134

135+

126136-- TYPE HELPERS

127137

138+

128139infixr 9 ==>

129140

141+

130142(==>) :: Type -> Type -> Type

131143(==>) a b =

132− termN (Fun1 a b)

144+ TermN (Fun1 a b)

133145

134146

135147(<|) :: TermN a -> TermN a -> TermN a

136148(<|) f a =

137− termN (App1 f a)

138−

149+ TermN (App1 f a)

139150

140−-- VARIABLE HELPERS

141151

142−namedVar :: Flex -> Var.Canonical -> IO Variable

143−namedVar flex name = UF.fresh $ Descriptor

144− { structure = Nothing

145− , rank = noRank

146− , flex = flex

147− , name = Just name

148− , copy = Nothing

149− , mark = noMark

150− , alias = Nothing

151− }

152152

153+-- VARIABLE CREATION

153154

154−variable :: Flex -> IO Variable

155−variable flex =

156− UF.fresh (descriptor flex)

157155

158−

159−descriptor :: Flex -> Descriptor

160−descriptor flex =

156+mkDescriptor :: Content -> Descriptor

157+mkDescriptor content =

161158 Descriptor

162− { structure = Nothing

163− , rank = noRank

164− , flex = flex

165− , name = Nothing

166− , copy = Nothing

167− , mark = noMark

168− , alias = Nothing

159+ { _content = content

160+ , _rank = noRank

161+ , _mark = noMark

162+ , _copy = Nothing

169163 }

170164

171165

166+mkAtom :: Var.Canonical -> IO Variable

167+mkAtom name =

168+ UF.fresh $ mkDescriptor (Atom name)

169+

170+

171+mkVar :: Maybe Super -> IO Variable

172+mkVar maybeSuper =

173+ UF.fresh $ mkDescriptor (Var Flex maybeSuper Nothing)

174+

175+

176+mkNamedVar :: String -> IO Variable

177+mkNamedVar name =

178+ UF.fresh $ mkDescriptor (Var Flex (toSuper name) Nothing)

179+

180+

181+mkRigid :: String -> IO Variable

182+mkRigid name =

183+ UF.fresh $ mkDescriptor (Var Rigid (toSuper name) (Just name))

184+

185+

186+toSuper :: String -> Maybe Super

187+toSuper name =

188+ if List.isPrefixOf "number" name then

189+ Just Number

190+

191+ else if List.isPrefixOf "comparable" name then

192+ Just Comparable

193+

194+ else if List.isPrefixOf "appendable" name then

195+ Just Appendable

196+

197+ else

198+ Nothing

199+

200+

201+

172202-- CONSTRAINT HELPERS

173203

204+

174205monoscheme :: Map.Map String (A.Located a) -> Scheme a b

175206monoscheme headers =

176207 Scheme [] [] CTrue headers

@@ -200,401 +231,178 @@ fl rqs constraint =

200231

201232exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint

202233exists f =

203− do v <- variable Flexible

204− ex [v] <$> f (varN v)

234+ do v <- mkVar Nothing

235+ ex [v] <$> f (VarN v)

205236

206237

207238existsNumber :: (Type -> IO TypeConstraint) -> IO TypeConstraint

208239existsNumber f =

209− do v <- variable (Is Number)

210− ex [v] <$> f (varN v)

211−

212−

213−-- TYPES TO PRETTY STRINGS

214−

215−instance PrettyType a => PrettyType (UF.Point a) where

216− pretty when point =

217− unsafePerformIO $ fmap (pretty when) (UF.descriptor point)

218−

219−

220−instance PrettyType a => PrettyType (Term1 a) where

221− pretty when term =

222− let prty = pretty Never in

223− case term of

224− App1 f x ->

225− parensIf needed (px <+> pretty App x)

226− where

227− px = prty f

228− needed =

229− case when of

230− App -> True

231− _ -> False

232−

233− Fun1 arg body ->

234− parensIf needed (pretty Fn arg <+> P.text "->" <+> prty body)

235− where

236− needed =

237− case when of

238− Never -> False

239− _ -> True

240−

241− Var1 x ->

242− prty x

243−

244− EmptyRecord1 ->

245− P.braces P.empty

246−

247− Record1 fields ext ->

248− P.braces (extend <+> commaSep prettyFields)

249− where

250− prettyExt = prty ext

251−

252− extend

253− | P.render prettyExt == "{}" =

254− P.empty

255− | otherwise =

256− prettyExt <+> P.text "|"

257−

258− mkPretty f t =

259− P.text f <+> P.text ":" <+> prty t

260−

261− prettyFields =

262− concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)

263−

264−

265−instance PrettyType a => PrettyType (TermN a) where

266− pretty when term =

267− case term of

268− PlaceHolder _ ->

269− error "problem prettifying type, probably indicates a bigger problem"

270−

271− VarN alias x ->

272− either alias (pretty when x)

273−

274− TermN alias t1 ->

275− either alias (pretty when t1)

276− where

277− either maybeAlias doc =

278− case maybeAlias of

279− Nothing -> doc

280− Just (name, args) ->

281− P.hang

282− (P.text (Var.toString name))

283− 2

284− (P.sep (map (pretty App . snd) args))

285−

286−

287−instance PrettyType Descriptor where

288− pretty when desc =

289− case (alias desc, structure desc, name desc) of

290− (Just (name, args), _, _) ->

291− P.hang

292− (P.text (Var.toString name))

293− 4

294− (P.sep (map (pretty App . snd) args))

295−

296− (_, Just term, _) ->

297− pretty when term

298−

299− (_, _, Just name)

300− | Var.isTuple name ->

301− P.parens . P.text $ replicate (read (drop 6 (Var.toString name)) - 1) ','

302− | otherwise ->

303− P.text (Var.toString name)

304−

305− _ -> P.text "?"

306−

307−

308−instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where

309− pretty _ constraint =

310− let prty = pretty Never in

311− case constraint of

312− CTrue ->

313− P.text "True"

314−

315− CSaveEnv ->

316− P.text "SaveTheEnvironment!!!"

317−

318− CEqual _ _ a b ->

319− prty a <+> P.text "=" <+> prty b

320−

321− CAnd [] ->

322− P.text "True"

323−

324− CAnd cs ->

325− P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)

326−

327− CLet [Scheme [] fqs constraint header] CTrue | Map.null header ->

328− P.sep [ binder, pretty Never c ]

329− where

330− mergeExists vs c =

331− case c of

332− CLet [Scheme [] fqs' c' _] CTrue -> mergeExists (vs ++ fqs') c'

333− _ -> (vs, c)

334−

335− (fqs', c) = mergeExists fqs constraint

336−

337− binder =

338− if null fqs'

339− then P.empty

340− else

341− P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."

342−

343− CLet schemes constraint ->

344− P.fsep

345− [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)

346− , P.text "in", pretty Never constraint

347− ]

240+ do v <- mkVar (Just Number)

241+ ex [v] <$> f (VarN v)

348242

349− CInstance _region name tipe ->

350− P.text name <+> P.text "<" <+> prty tipe

351243

352244

353−instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where

354− pretty _ (Scheme rqs fqs constraint headers) =

355− P.sep [ forall, cs, headers' ]

356− where

357− prty = pretty Never

358−

359− forall =

360− if null rqs && null fqs

361− then P.empty

362− else P.text "\x2200" <+> frees <+> rigids

363−

364− frees = P.hsep (map prty fqs)

365−

366− rigids =

367− if null rqs

368− then P.empty

369− else P.braces . P.hsep $ map prty rqs

245+-- CONVERT TO SOURCE TYPES

370246

371− cs =

372− case constraint of

373− CTrue -> P.empty

374− CAnd [] -> P.empty

375− _ -> P.brackets (pretty Never constraint)

376247

377− headers' =

378− if Map.size headers > 0 then dict else P.empty

248+-- TODO: Attach resulting type to the descriptor so that you

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

250+toSrcType :: Variable -> IO T.Canonical

251+toSrcType variable =

252+ do usedNames <- getVarNames variable

253+ State.evalStateT (variableToSrcType variable) (makeNameState usedNames)

379254

380− dict =

381− P.parens . commaSep . map prettyPair $ Map.toList headers

382255

383− prettyPair (fieldName, A.A _ tipe) =

384− P.text fieldName <+> P.text ":" <+> pretty Never tipe

256+variableToSrcType :: Variable -> StateT NameState IO T.Canonical

257+variableToSrcType variable =

258+ do descriptor <- State.liftIO (UF.descriptor variable)

259+ case _content descriptor of

260+ Structure term ->

261+ termToSrcType term

385262

263+ Atom name ->

264+ return (T.Type name)

386265

387−-- CONVERT TO SOURCE TYPES

266+ Var _ _ (Just name) ->

267+ return (T.Var name)

388268

389−-- TODO: Attach resulting type to the descriptor so that you

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

391−toSrcType :: Variable -> IO T.Canonical

392−toSrcType variable =

393− do addNames variable

394− variableToSrcType variable variable

269+ Var flex maybeSuper Nothing ->

270+ do freshName <- getFreshName maybeSuper

271+ State.liftIO $ UF.modifyDescriptor variable $ \desc ->

272+ desc { _content = Var flex maybeSuper (Just freshName) }

273+ return (T.Var freshName)

395274

275+ Alias name args realVariable ->

276+ do srcArgs <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType tvar) args

277+ srcType <- variableToSrcType realVariable

278+ return (T.Aliased name srcArgs (T.Filled srcType))

396279

397−variableToSrcType :: Variable -> Variable -> IO T.Canonical

398−variableToSrcType rootVariable variable =

399− do desc <- UF.descriptor variable

400− srcType <- maybe (backupSrcType desc) (termToSrcType rootVariable) (structure desc)

401− case alias desc of

402− Nothing ->

403− return srcType

280+ Error ->

281+ return (T.Var "?")

404282

405− Just (name, args) ->

406− case srcType of

407− T.Type (Var.Canonical Var.BuiltIn _) ->

408− return srcType

409283

410− _ ->

411− do args' <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType rootVariable tvar) args

412− return (T.Aliased name args' (T.Filled srcType))

413− where

414− backupSrcType :: Descriptor -> IO T.Canonical

415− backupSrcType desc =

416− case name desc of

417− Just v@(Var.Canonical _ x@(c:_))

418− | Char.isLower c ->

419− return (T.Var x)

420− | otherwise ->

421− return $ T.Type v

422−

423− _ ->

424− error $

425− concat

426− [ "Problem converting the following type "

427− , "from a type-checker type to a source-syntax type:"

428− , P.render (pretty Never rootVariable)

429− ]

430−

431−

432−termToSrcType :: Variable -> Term1 Variable -> IO T.Canonical

433−termToSrcType rootVariable term =

434− let go = variableToSrcType rootVariable in

284+termToSrcType :: Term1 Variable -> StateT NameState IO T.Canonical

285+termToSrcType term =

435286 case term of

436− App1 a b ->

437− do a' <- go a

438− b' <- go b

439− case a' of

287+ App1 func arg ->

288+ do srcFunc <- variableToSrcType func

289+ srcArg <- variableToSrcType arg

290+ case srcFunc of

440291 T.App f args ->

441− return $ T.App f (args ++ [b'])

292+ return (T.App f (args ++ [srcArg]))

293+

442294 _ ->

443− return $ T.App a' [b']

295+ return (T.App srcFunc [srcArg])

444296

445297 Fun1 a b ->

446− T.Lambda <$> go a <*> go b

447−

448− Var1 a ->

449− go a

298+ T.Lambda

299+ <$> variableToSrcType a

300+ <*> variableToSrcType b

450301

451302 EmptyRecord1 ->

452303 return $ T.Record [] Nothing

453304

454− Record1 tfields extension ->

455− do fields' <- Traverse.traverse (mapM go) tfields

456− let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

457− ext' <- dealias <$> go extension

305+ Record1 fields extension ->

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

307+ srcExt <- T.iteratedDealias <$> variableToSrcType extension

458308 return $

459− case ext' of

460− T.Record fs ext -> T.Record (fs ++ fields) ext

461− T.Var _ -> T.Record fields (Just ext')

462− _ -> error "Used toSrcType on a type that is not well-formed"

463− where

464− dealias :: T.Canonical -> T.Canonical

465− dealias tipe =

466− case tipe of

467− T.Aliased _ args tipe' ->

468− T.dealias args tipe'

469− _ ->

470− tipe

309+ case srcExt of

310+ T.Record subFields subExt ->

311+ T.Record (subFields ++ srcFields) subExt

471312

313+ T.Var _ ->

314+ T.Record srcFields (Just srcExt)

472315

473−-- ADD NAMES TO TYPES

316+ _ ->

317+ error "Used toSrcType on a type that is not well-formed"

474318

475−addNames :: Variable -> IO ()

476−addNames variable =

477− do usedNames <- getVarNames variable

478− let freeNames = makeFreeNames usedNames

479− State.runStateT (varAddNames variable) (NameState freeNames 0 0 0)

480− return ()

481319

482320

483−makeFreeNames :: Set.Set String -> [String]

484−makeFreeNames usedNames =

485− let makeName suffix =

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

487−

488− allNames =

489− concatMap makeName ("" : "'" : "_" : map show [ (0 :: Int) .. ])

490− in

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

321+-- MANAGE FRESH VARIABLE NAMES

492322

493323

494324data NameState = NameState

495− { freeNames :: [String]

496− , numberPrimes :: Int

497− , comparablePrimes :: Int

498− , appendablePrimes :: Int

325+ { _freeNames :: [String]

326+ , _numberPrimes :: Int

327+ , _comparablePrimes :: Int

328+ , _appendablePrimes :: Int

329+ , _compAppendPrimes :: Int

499330 }

500331

501332

502−varAddNames :: Variable -> StateT NameState IO ()

503−varAddNames var =

504− do desc <- State.liftIO (UF.descriptor var)

505− case alias desc of

506− Nothing ->

507− return ()

508−

509− Just (_name, args) ->

510− mapM_ (\(v,t) -> (,) v <$> varAddNames t) args

511−

512− case structure desc of

513− Just term ->

514− termAddNames term

515−

516− Nothing ->

517− case name desc of

518− Just _ -> return ()

519− Nothing ->

520− do name' <- createName desc

521− State.liftIO $ UF.modifyDescriptor var $ \desc ->

522− desc { name = Just (Var.local name') }

523−

524−

525−termAddNames :: Term1 Variable -> StateT NameState IO ()

526−termAddNames term =

527− case term of

528− App1 a b ->

529− do varAddNames a

530− varAddNames b

333+makeNameState :: Set.Set String -> NameState

334+makeNameState usedNames =

335+ let

336+ makeName suffix =

337+ map (:suffix) ['a'..'z']

531338

532− Fun1 a b ->

533− do varAddNames a

534− varAddNames b

339+ allNames =

340+ concatMap makeName ("" : map show [ (1 :: Int) .. ])

535341

536− Var1 a ->

537− varAddNames a

342+ freeNames =

343+ filter (\name -> Set.notMember name usedNames) allNames

344+ in

345+ NameState freeNames 0 0 0 0

538346

539− EmptyRecord1 ->

540− return ()

541−

542− Record1 fields extension ->

543− do mapM_ varAddNames (concat (Map.elems fields))

544− varAddNames extension

545347

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

349+getFreshName maybeSuper =

350+ case maybeSuper of

351+ Nothing ->

352+ do names <- State.gets _freeNames

353+ State.modify (\state -> state { _freeNames = tail names })

354+ return (head names)

546355

547−createName :: (Monad m) => Descriptor -> StateT NameState m String

548−createName desc =

549− case flex desc of

550− Is Number ->

551− do primes <- State.gets numberPrimes

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

356+ Just Number ->

357+ do primes <- State.gets _numberPrimes

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

553359 return ("number" ++ replicate primes '\'')

554360

555− Is Comparable ->

556− do primes <- State.gets comparablePrimes

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

361+ Just Comparable ->

362+ do primes <- State.gets _comparablePrimes

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

558364 return ("comparable" ++ replicate primes '\'')

559365

560− Is Appendable ->

561− do primes <- State.gets appendablePrimes

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

366+ Just Appendable ->

367+ do primes <- State.gets _appendablePrimes

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

563369 return ("appendable" ++ replicate primes '\'')

564370

565− _ ->

566− do names <- State.gets freeNames

567− State.modify (\state -> state { freeNames = tail names })

568− return (head names)

371+ Just CompAppend ->

372+ do primes <- State.gets _compAppendPrimes

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

374+ return ("compappend" ++ replicate primes '\'')

375+

569376

570377

571378-- GET ALL VARIABLE NAMES

572379

380+

573381getVarNames :: Variable -> IO (Set.Set String)

574382getVarNames var =

575383 do desc <- UF.descriptor var

576384

577− let baseSet =

578− case name desc of

579− Just var -> Set.singleton (Var.toString var)

580− Nothing -> Set.empty

385+ case _content desc of

386+ Var _ _ (Just name) ->

387+ return (Set.singleton name)

388+

389+ Var _ _ Nothing ->

390+ return Set.empty

581391

582− structureSet <-

583− case structure desc of

584− Nothing -> return Set.empty

585− Just term -> getVarNamesTerm term

392+ Structure term ->

393+ getVarNamesTerm term

586394

587− aliasSet <-

588− case alias desc of

589− Nothing ->

590− return Set.empty

395+ Alias _name args realVar ->

396+ do let argSet = Set.fromList (map fst args)

397+ realSet <- getVarNames realVar

398+ sets <- mapM (getVarNames . snd) args

399+ return (Set.unions (realSet : argSet : sets))

591400

592− Just (_name, args) ->

593− do let set = Set.fromList (map fst args)

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

595− return (Set.unions (set : sets))

401+ Atom _ ->

402+ return Set.empty

596403

597− return (Set.unions [ baseSet, structureSet, aliasSet ])

404+ Error ->

405+ return Set.empty

598406

599407

600408getVarNamesTerm :: Term1 Variable -> IO (Set.Set String)

@@ -607,43 +415,10 @@ getVarNamesTerm term =

607415 Fun1 a b ->

608416 Set.union <$> go a <*> go b

609417

610− Var1 a ->

611− go a

612−

613418 EmptyRecord1 ->

614419 return Set.empty

615420

616421 Record1 fields extension ->

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

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

618423 Set.union fieldVars <$> go extension

619424

620−

621−-- COLLECT APPLICATIONS

622−

623−data AppStructure

624− = List Variable

625− | Tuple [Variable]

626− | Other

627−

628−

629−collectApps :: Variable -> IO AppStructure

630−collectApps var =

631− go [] var

632− where

633− go vars var = do

634− desc <- UF.descriptor var

635− case (structure desc, vars) of

636− (Nothing, [v]) ->

637− case name desc of

638− Just n | Var.isList n -> return (List v)

639− _ -> return Other

640−

641− (Nothing, vs) ->

642− case name desc of

643− Just n | Var.isTuple n -> return (Tuple vs)

644− _ -> return Other

645−

646− (Just term, _) ->

647− case term of

648− App1 a b -> go (vars ++ [b]) a

649− _ -> return Other

src/Type/Unify.hs+619−402

@@ -1,438 +1,655 @@

1+{-# OPTIONS_GHC -Wall #-}

12module Type.Unify (unify) where

3−import Control.Applicative ((<|>))

4−import Control.Monad.Except (ExceptT, throwError, runExceptT)

5−import Control.Monad.State as State

6−import qualified Data.List as List

4+import Control.Monad (zipWithM_)

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

76import qualified Data.Map as Map

87import qualified Data.UnionFind.IO as UF

9−import Text.PrettyPrint (render)

108

11−import qualified AST.Type as AstType

129import qualified AST.Variable as Var

1310import qualified Reporting.Region as R

1411import qualified Reporting.Error.Type as Error

1512import qualified Type.State as TS

1613import Type.Type as Type

17−import Type.PrettyPrint

18−import Elm.Utils ((|>))

19−

20−

21−unify

22− :: Error.Hint

23− -> R.Region

24− -> Variable

25− -> Variable

26− -> StateT TS.SolverState IO ()

27−unify hint region variable1 variable2 =

28− do result <- runExceptT (unifyHelp variable1 variable2)

14+

15+

16+

17+-- KICK OFF UNIFICATION

18+

19+

20+unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()

21+unify hint region expected actual =

22+ do result <- runExceptT (guardedUnify ExpectedActual expected actual)

2923 case result of

3024 Right state ->

3125 return state

3226

33− Left (RawMismatch (leftType, rightType, note)) ->

34− TS.addError region $ Error.Mismatch $

35− Error.MismatchInfo hint leftType rightType note

27+ Left (Mismatch subExpected subActual maybeReason) ->

28+ let

29+ mkError =

30+ do expectedSrcType <- Type.toSrcType expected

31+ actualSrcType <- Type.toSrcType actual

32+ mergeHelp expected actual Error

33+ let info = Error.MismatchInfo hint expectedSrcType actualSrcType maybeReason

34+ return (Error.Mismatch info)

35+ in

36+ TS.addError region =<< liftIO mkError

37+

3638

3739

38−-- ACTUALLY UNIFY STUFF

40+-- UNIFICATION HELPERS

41+

3942

4043type Unify =

41− ExceptT RawMismatch (StateT TS.SolverState IO)

44+ ExceptT Mismatch TS.Solver

45+

46+

47+data Context = Context

48+ { _orientation :: Orientation

49+ , _first :: Variable

50+ , _firstDesc :: Descriptor

51+ , _second :: Variable

52+ , _secondDesc :: Descriptor

53+ }

54+

55+

56+data Orientation = ExpectedActual | ActualExpected

57+

58+

59+reorient :: Context -> Context

60+reorient (Context orientation var1 desc1 var2 desc2) =

61+ let

62+ otherOrientation =

63+ case orientation of

64+ ExpectedActual -> ActualExpected

65+ ActualExpected -> ExpectedActual

66+ in

67+ Context otherOrientation var2 desc2 var1 desc1

68+

69+

70+

71+-- ERROR MESSAGES

72+

73+

74+data Mismatch

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

76+

77+

78+mismatch :: 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)

85+

86+ ActualExpected ->

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

88+ in

89+ throwError (Mismatch expected actual orientedReason)

4290

4391

44−newtype RawMismatch =

45− RawMismatch (AstType.Canonical, AstType.Canonical, Maybe String)

92+badRigid :: Maybe String -> Error.Reason

93+badRigid maybeName =

94+ Error.BadVar (Just (Error.Rigid maybeName)) Nothing

4695

4796

48−typeError

49− :: UF.Point Descriptor

50− -> UF.Point Descriptor

51− -> Maybe String

52− -> Unify a

53−typeError leftType rightType note =

54− do leftSrcType <- liftIO (Type.toSrcType leftType)

55− rightSrcType <- liftIO (Type.toSrcType rightType)

56− liftIO $ do

57− UF.setDescriptor leftType (Type.descriptor Error)

58− UF.setDescriptor rightType (Type.descriptor Error)

59− throwError (RawMismatch (leftSrcType, rightSrcType, note))

97+badSuper :: Super -> Error.Reason

98+badSuper super =

99+ Error.BadVar (Just (errorSuper super)) Nothing

60100

61101

62−unifyHelp :: Variable -> Variable -> Unify ()

63−unifyHelp variable1 variable2 =

64− do equivalent <- liftIO $ UF.equivalent variable1 variable2

102+doubleBad :: Error.VarType -> Error.VarType -> Error.Reason

103+doubleBad vt1 vt2 =

104+ Error.BadVar (Just vt1) (Just vt2)

105+

106+

107+errorSuper :: Super -> Error.VarType

108+errorSuper super =

109+ case super of

110+ Number ->

111+ Error.Number

112+

113+ Comparable ->

114+ Error.Comparable

115+

116+ Appendable ->

117+ Error.Appendable

118+

119+ CompAppend ->

120+ Error.CompAppend

121+

122+

123+

124+-- MERGE

125+

126+

127+merge :: Context -> Content -> Unify ()

128+merge (Context _ first _ second _) content =

129+ liftIO $ mergeHelp first second content

130+

131+

132+mergeHelp :: Variable -> Variable -> Content -> IO ()

133+mergeHelp first second content =

134+ UF.union' first second $ \desc1 desc2 ->

135+ return $

136+ Descriptor

137+ { _content = content

138+ , _rank = min (_rank desc1) (_rank desc2)

139+ , _mark = noMark

140+ , _copy = Nothing

141+ }

142+

143+

144+fresh :: Context -> Content -> Unify Variable

145+fresh (Context _ _ desc1 _ desc2) content =

146+ do freshVariable <-

147+ liftIO $ UF.fresh $

148+ Descriptor

149+ { _content = content

150+ , _rank = min (_rank desc1) (_rank desc2)

151+ , _mark = noMark

152+ , _copy = Nothing

153+ }

154+ lift (TS.register freshVariable)

155+

156+

157+

158+-- ACTUALLY UNIFY THINGS

159+

160+

161+guardedUnify :: Orientation -> Variable -> Variable -> Unify ()

162+guardedUnify orientation left right =

163+ do equivalent <- liftIO $ UF.equivalent left right

65164 if equivalent

66− then return ()

67− else actuallyUnify variable1 variable2

68−

69−

70−actuallyUnify :: Variable -> Variable -> Unify ()

71−actuallyUnify variable1 variable2 = do

72− desc1 <- liftIO $ UF.descriptor variable1

73− desc2 <- liftIO $ UF.descriptor variable2

74− let (name', flex', rank', alias') = combinedDescriptors desc1 desc2

75−

76− merge1 :: Unify ()

77− merge1 =

78− liftIO $ do

79− if rank desc1 < rank desc2

80− then UF.union variable2 variable1

81− else UF.union variable1 variable2

82− UF.modifyDescriptor variable1 $ \desc ->

83− desc { structure = structure desc1

84− , flex = flex'

85− , name = name'

86− , alias = alias'

87− }

88−

89− merge2 :: Unify ()

90− merge2 =

91− liftIO $ do

92− if rank desc1 < rank desc2

93− then UF.union variable2 variable1

94− else UF.union variable1 variable2

95− UF.modifyDescriptor variable2 $ \desc ->

96− desc { structure = structure desc2

97− , flex = flex'

98− , name = name'

99− , alias = alias'

100− }

101−

102− merge =

103− if rank desc1 < rank desc2 then merge1 else merge2

104−

105− fresh :: Maybe (Term1 Variable) -> Unify Variable

106− fresh structure =

107− do v <- liftIO . UF.fresh $ Descriptor

108− { structure = structure

109− , rank = rank'

110− , flex = flex'

111− , name = name'

112− , copy = Nothing

113− , mark = noMark

114− , alias = alias'

115− }

116− lift (TS.register v)

117−

118− flexAndUnify v =

119− do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }

120− unifyHelp variable1 variable2

121−

122− unifyNumber svar (Var.Canonical home name) =

123− case home of

124− Var.BuiltIn | name `elem` ["Int","Float"] ->

125− flexAndUnify svar

126−

127− Var.Local | List.isPrefixOf "number" name ->

128− flexAndUnify svar

129−

130− Var.TopLevel _ | List.isPrefixOf "number" name ->

131− flexAndUnify svar

132−

133− _ ->

134− typeError variable1 variable2 Nothing

135−

136− comparableError maybeHint =

137− typeError variable1 variable2 $ Just $

138− "Note: comparable types include Int, Float, Char, String, lists, and tuples."

139− ++ maybe "" ("\n"++) maybeHint

140−

141− appendableError =

142− typeError variable1 variable2 $ Just $

143− "Note: appendable types include only Strings, Lists, and Text."

144−

145− unifyComparable v (Var.Canonical home name) =

146− case home of

147− Var.BuiltIn | name `elem` ["Int","Float","Char","String"] ->

148− flexAndUnify v

149− Var.Local | List.isPrefixOf "comparable" name ->

150− flexAndUnify v

151− _ ->

152− comparableError Nothing

153−

154− unifyComparableStructure varSuper varFlex =

155− do struct <- liftIO $ collectApps varFlex

156− case struct of

157− Other ->

158− comparableError Nothing

159−

160− List v ->

161− do flexAndUnify varSuper

162− unifyHelp v =<< liftIO (variable $ Is Comparable)

163−

164− Tuple vs ->

165− if length vs > 6 then

166− comparableError $ Just $

167− "Furthermore, it cannot be a tuple with more than 6 elements."

168− else

169− do flexAndUnify varSuper

170− cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)

171− zipWithM_ unifyHelp vs cmpVars

172−

173− unifyAppendable v cvar@(Var.Canonical home name) =

174− let

175− canUnify =

176− Var.isPrim "String" cvar

177− || Var.isText cvar

178− || Var.isLocal (List.isPrefixOf "comparable") cvar

179− || Var.isLocal (List.isPrefixOf "appendable") cvar

180− in

181− if canUnify then

182− flexAndUnify v

183− else

184− appendableError

185−

186− unifyAppendableStructure varSuper varFlex =

187− do struct <- liftIO $ collectApps varFlex

188− case struct of

189− List _ -> flexAndUnify varSuper

190− _ -> appendableError

191−

192− rigidError var =

193− typeError variable1 variable2 $ Just $

194− rigidErrorMessage (render (pretty Never var))

195−

196− superUnify =

197− case (flex desc1, flex desc2, name desc1, name desc2) of

198− (Is super1, Is super2, _, _)

199− | super1 == super2 -> merge

200− (Is Number, Is Comparable, _, _) -> merge1

201− (Is Comparable, Is Number, _, _) -> merge2

202−

203− (Is Number, _, _, Just name) -> unifyNumber variable1 name

204− (_, Is Number, Just name, _) -> unifyNumber variable2 name

205−

206− (Is Appendable, _, _, Just name) -> unifyAppendable variable1 name

207− (_, Is Appendable, Just name, _) -> unifyAppendable variable2 name

208− (Is Appendable, _, _, _) -> unifyAppendableStructure variable1 variable2

209− (_, Is Appendable, _, _) -> unifyAppendableStructure variable2 variable1

210−

211− (Is Comparable, _, _, Just name) -> unifyComparable variable1 name

212− (_, Is Comparable, Just name, _) -> unifyComparable variable2 name

213− (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2

214− (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1

215−

216− (Rigid, _, _, _) -> rigidError variable1

217− (_, Rigid, _, _) -> rigidError variable2

218− _ -> typeError variable1 variable2 Nothing

219−

220− case (structure desc1, structure desc2) of

221− (Nothing, Nothing)

222− | flex desc1 == Flexible && flex desc1 == Flexible ->

223− merge

224−

225− (Nothing, _)

226− | flex desc1 == Flexible -> merge2

227− | flex desc1 == Error -> return ()

228−

229− (_, Nothing)

230− | flex desc2 == Flexible -> merge1

231− | flex desc2 == Error -> return ()

232−

233− (Just (Var1 v), _) ->

234− unifyHelp v variable2

235−

236− (_, Just (Var1 v)) ->

237− unifyHelp variable1 v

238−

239− (Nothing, _) ->

240− superUnify

241−

242− (_, Nothing) ->

243− superUnify

244−

245− (Just type1, Just type2) ->

246− case (type1,type2) of

247− (App1 term1 term2, App1 term1' term2') ->

248− do merge

249− unifyHelp term1 term1'

250− unifyHelp term2 term2'

251− (Fun1 term1 term2, Fun1 term1' term2') ->

252− do merge

253− unifyHelp term1 term1'

254− unifyHelp term2 term2'

165+ then return ()

166+ else

167+ do leftDesc <- liftIO $ UF.descriptor left

168+ rightDesc <- liftIO $ UF.descriptor right

169+ actuallyUnify (Context orientation left leftDesc right rightDesc)

255170

256− (EmptyRecord1, EmptyRecord1) ->

257− return ()

258−

259− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2

260− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext

261−

262− (Record1 _ _, Record1 _ _) ->

263− recordUnify fresh variable1 variable2

264−

265− _ -> typeError variable1 variable2 Nothing

266−

267−

268−-- RIGID ERROR

269−

270−rigidErrorMessage :: String -> String

271−rigidErrorMessage var =

272− "Could not unify user provided type variable `" ++ var ++ "`. The most likely cases are:\n\n"

273− ++ " 1. The type you wrote down is too general. It says any type can go through\n"

274− ++ " but in fact only a certain type can.\n"

275− ++ " 2. A type variable is probably being shared between two type annotations.\n"

276− ++ " They are treated as different things in the current implementation, so\n"

277− ++ " Try commenting out some type annotations and see what happens."

278−

279−

280−-- RECORD UNIFICATION

281−

282−recordUnify

283− :: (Maybe (Term1 Variable) -> Unify Variable)

284− -> Variable

285− -> Variable

286− -> Unify ()

287−recordUnify fresh variable1 variable2 =

288− do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)

289− (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)

290−

291− unifyOverlappingFields fields1 fields2

292−

293− let freshRecord fields ext =

294− fresh (Just (Record1 fields ext))

295−

296− let uniqueFields1 = diffFields fields1 fields2

297− let uniqueFields2 = diffFields fields2 fields1

298−

299− let addFieldMismatchError missingFields =

300− typeError variable1 variable2 $ Just $

301− fieldMismatchError missingFields

302−

303− case (ext1, ext2) of

304− (Empty _, Empty _) ->

305− case Map.null uniqueFields1 && Map.null uniqueFields2 of

306− True -> return ()

307− False -> typeError variable1 variable2 Nothing

308−

309− (Empty var1, Extension var2) ->

310− case (Map.null uniqueFields1, Map.null uniqueFields2) of

311− (_, False) -> addFieldMismatchError uniqueFields2

312− (True, True) -> unifyHelp var1 var2

313− (False, True) ->

314− do subRecord <- freshRecord uniqueFields1 var1

315− unifyHelp subRecord var2

316−

317− (Extension var1, Empty var2) ->

318− case (Map.null uniqueFields1, Map.null uniqueFields2) of

319− (False, _) -> addFieldMismatchError uniqueFields1

320− (True, True) -> unifyHelp var1 var2

321− (True, False) ->

322− do subRecord <- freshRecord uniqueFields2 var2

323− unifyHelp var1 subRecord

324−

325− (Extension var1, Extension var2) ->

326− case (Map.null uniqueFields1, Map.null uniqueFields2) of

327− (True, True) ->

328− unifyHelp var1 var2

329−

330− (True, False) ->

331− do subRecord <- freshRecord uniqueFields2 var2

332− unifyHelp var1 subRecord

333−

334− (False, True) ->

335− do subRecord <- freshRecord uniqueFields1 var1

336− unifyHelp subRecord var2

337−

338− (False, False) ->

339− do record1' <- freshRecord uniqueFields1 =<< fresh Nothing

340− record2' <- freshRecord uniqueFields2 =<< fresh Nothing

341− unifyHelp record1' var2

342− unifyHelp var1 record2'

343−

344−

345−unifyOverlappingFields

346− :: Map.Map String [Variable]

347− -> Map.Map String [Variable]

348− -> Unify ()

349−unifyOverlappingFields fields1 fields2 =

350− Map.intersectionWith (zipWith unifyHelp) fields1 fields2

351− |> Map.elems

352− |> concat

353− |> sequence_

354−

355−

356−diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]

357−diffFields fields1 fields2 =

358− let eat (_:xs) (_:ys) = eat xs ys

359− eat xs _ = xs

171+

172+subUnify :: Context -> Variable -> Variable -> Unify ()

173+subUnify context var1 var2 =

174+ guardedUnify (_orientation context) var1 var2

175+

176+

177+actuallyUnify :: Context -> Unify ()

178+actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =

179+ let

180+ secondContent = _content secondDesc

360181 in

361− Map.union (Map.intersectionWith eat fields1 fields2) fields1

362− |> Map.filter (not . null)

182+ case _content firstDesc of

183+ Error ->

184+ -- If there was an error, just pretend it is okay. This lets us avoid

185+ -- "cascading" errors where one problem manifests as multiple message.

186+ return ()

187+

188+ Var Flex Nothing _ ->

189+ unifyFlex context secondContent

190+

191+ Var Flex (Just super) _ ->

192+ unifySuper context super secondContent

193+

194+ Var Rigid maybeSuper maybeName ->

195+ unifyRigid context maybeSuper maybeName secondContent

196+

197+ Atom name ->

198+ unifyAtom context name secondContent

199+

200+ Alias name args realVar ->

201+ unifyAlias context name args realVar secondContent

202+

203+ Structure term ->

204+ unifyStructure context term secondContent

205+

206+

207+

208+-- UNIFY FLEXIBLE VARIABLES

209+

210+

211+unifyFlex :: Context -> Content -> Unify ()

212+unifyFlex context otherContent =

213+ case otherContent of

214+ Error ->

215+ return ()

216+

217+ Var Flex _ _ ->

218+ merge context otherContent

219+

220+ Var Rigid _ _ ->

221+ merge context otherContent

222+

223+ Atom _ ->

224+ merge context otherContent

225+

226+ Alias _ _ _ ->

227+ merge context otherContent

228+

229+ Structure _ ->

230+ merge context otherContent

231+

232+

233+

234+-- UNIFY RIGID VARIABLES

235+

236+

237+unifyRigid :: Context -> Maybe Super -> Maybe String -> Content -> Unify ()

238+unifyRigid context maybeSuper maybeName otherContent =

239+ case otherContent of

240+ Error ->

241+ return ()

242+

243+ Var Flex otherMaybeSuper _ ->

244+ if maybeSuper == otherMaybeSuper then

245+ merge context (Var Rigid maybeSuper maybeName)

246+ else

247+ mismatch context (Just (badRigid maybeName))

248+

249+ Var Rigid _ otherMaybeName ->

250+ mismatch context $ Just $

251+ doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)

252+

253+ Atom _ ->

254+ mismatch context (Just (badRigid maybeName))

255+

256+ Alias _ _ _ ->

257+ mismatch context (Just (badRigid maybeName))

258+

259+ Structure _ ->

260+ mismatch context (Just (badRigid maybeName))

261+

262+

263+-- UNIFY SUPER VARIABLES

264+

265+

266+unifySuper :: Context -> Super -> Content -> Unify ()

267+unifySuper context super otherContent =

268+ case otherContent of

269+ Structure term ->

270+ unifySuperStructure context super term

271+

272+ Atom name ->

273+ if atomMatchesSuper super name then

274+ merge context otherContent

275+ else

276+ mismatch context (Just (badSuper super))

277+

278+ Var Rigid Nothing maybeName ->

279+ mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))

280+

281+ Var Rigid (Just otherSuper) maybeName ->

282+ if super == otherSuper then

283+ merge context otherContent

284+ else

285+ mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))

286+

287+ Var Flex Nothing _ ->

288+ merge context (Var Flex (Just super) Nothing)

289+

290+ Var Flex (Just otherSuper) _ ->

291+ case combineSupers super otherSuper of

292+ Left reason ->

293+ mismatch context (Just reason)

294+

295+ Right newSuper ->

296+ merge context (Var Flex (Just newSuper) Nothing)

297+

298+ Alias _ _ realVar ->

299+ subUnify context (_first context) realVar

300+

301+ Error ->

302+ return ()

303+

304+

305+combineSupers :: Super -> Super -> Either Error.Reason Super

306+combineSupers firstSuper secondSuper =

307+ case (firstSuper, secondSuper) of

308+ (Number , Number ) -> Right Number

309+ (Comparable, Number ) -> Right Number

310+ (Number , Comparable) -> Right Number

311+

312+ (Comparable, Comparable) -> Right Comparable

313+ (Appendable, Appendable) -> Right Appendable

314+

315+ (Appendable, Comparable) -> Right CompAppend

316+ (Comparable, Appendable) -> Right CompAppend

317+

318+ (CompAppend, CompAppend) -> Right CompAppend

319+ (CompAppend, Comparable) -> Right CompAppend

320+ (Comparable, CompAppend) -> Right CompAppend

321+ (CompAppend, Appendable) -> Right CompAppend

322+ (Appendable, CompAppend) -> Right CompAppend

323+

324+ (_ , _ ) ->

325+ Left $ doubleBad (errorSuper firstSuper) (errorSuper secondSuper)

326+

327+

328+isPrimitiveFrom :: [String] -> Var.Canonical -> Bool

329+isPrimitiveFrom prims var =

330+ any (\p -> Var.isPrim p var) prims

363331

364332

365−data ExpandedRecord = ExpandedRecord

366− { _fields :: Map.Map String [Variable]

367− , _extension :: Extension

333+atomMatchesSuper :: Super -> Var.Canonical -> Bool

334+atomMatchesSuper super name =

335+ case super of

336+ Number ->

337+ isPrimitiveFrom ["Int", "Float"] name

338+

339+ Comparable ->

340+ isPrimitiveFrom ["Int", "Float", "Char", "String"] name

341+

342+ Appendable ->

343+ Var.isPrim "String" name || Var.isText name

344+

345+ CompAppend ->

346+ Var.isPrim "String" name

347+

348+

349+unifySuperStructure :: Context -> Super -> Term1 Variable -> Unify ()

350+unifySuperStructure context super term =

351+ do appStructure <- liftIO (collectApps (Structure term))

352+ case appStructure of

353+ Other ->

354+ mismatch context (Just (badSuper super))

355+

356+ List variable ->

357+ case super of

358+ Number ->

359+ mismatch context (Just (badSuper super))

360+

361+ Appendable ->

362+ merge context (Structure term)

363+

364+ Comparable ->

365+ do merge context (Structure term)

366+ unifyComparableRecursive (_orientation context) variable

367+

368+ CompAppend ->

369+ do merge context (Structure term)

370+ unifyComparableRecursive (_orientation context) variable

371+

372+ Tuple entries ->

373+ case super of

374+ Number ->

375+ mismatch context (Just (badSuper super))

376+

377+ Appendable ->

378+ mismatch context (Just (badSuper super))

379+

380+ Comparable ->

381+ if length entries > 6 then

382+ mismatch context (Just (Error.TooLongComparableTuple (length entries)))

383+

384+ else

385+ do merge context (Structure term)

386+ mapM_ (unifyComparableRecursive (_orientation context)) entries

387+

388+ CompAppend ->

389+ mismatch context (Just (badSuper super))

390+

391+

392+unifyComparableRecursive :: Orientation -> Variable -> Unify ()

393+unifyComparableRecursive orientation var =

394+ do compVar <-

395+ liftIO $

396+ do desc <- UF.descriptor var

397+ UF.fresh $

398+ Descriptor

399+ { _content = Var Flex (Just Comparable) Nothing

400+ , _rank = _rank desc

401+ , _mark = noMark

402+ , _copy = Nothing

403+ }

404+

405+ guardedUnify orientation compVar var

406+

407+

408+data AppStructure

409+ = List Variable

410+ | Tuple [Variable]

411+ | Other

412+

413+

414+collectApps :: Content -> IO AppStructure

415+collectApps content =

416+ collectAppsHelp [] content

417+

418+

419+collectAppsHelp :: [Variable] -> Content -> IO AppStructure

420+collectAppsHelp args content =

421+ case (content, args) of

422+ (Structure (App1 func arg), _) ->

423+ collectAppsHelp (args ++ [arg]) =<< getContent func

424+

425+ (Atom name, [arg]) | Var.isList name ->

426+ return (List arg)

427+

428+ (Atom name, _) | Var.isTuple name ->

429+ return (Tuple args)

430+

431+ _ ->

432+ return Other

433+

434+

435+getContent :: Variable -> IO Content

436+getContent variable =

437+ _content <$> UF.descriptor variable

438+

439+

440+

441+-- UNIFY ATOMS

442+

443+

444+unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()

445+unifyAtom context name otherContent =

446+ case otherContent of

447+ Error ->

448+ return ()

449+

450+ Var Flex Nothing _ ->

451+ merge context (Atom name)

452+

453+ Var Flex (Just super) _ ->

454+ if atomMatchesSuper super name then

455+ merge context (Atom name)

456+

457+ else

458+ mismatch context (Just ((Error.flipReason (badSuper super))))

459+

460+ Var Rigid _ maybeName ->

461+ mismatch context (Just (Error.flipReason (badRigid maybeName)))

462+

463+ Atom otherName ->

464+ if name == otherName then

465+ merge context otherContent

466+

467+ else

468+ mismatch context $

469+ if isIntFloat name otherName || isIntFloat otherName name then

470+ Just Error.IntFloat

471+ else

472+ Nothing

473+

474+ Alias _ _ realVar ->

475+ subUnify context (_first context) realVar

476+

477+ Structure _ ->

478+ mismatch context Nothing

479+

480+

481+isIntFloat :: Var.Canonical -> Var.Canonical -> Bool

482+isIntFloat name otherName =

483+ Var.isPrim "Int" name && Var.isPrim "Float" otherName

484+

485+

486+-- UNIFY ALIASES

487+

488+

489+unifyAlias :: Context -> Var.Canonical -> [(String, Variable)] -> Variable -> Content -> Unify ()

490+unifyAlias context name args realVar otherContent =

491+ case otherContent of

492+ Error ->

493+ return ()

494+

495+ Var Flex Nothing _ ->

496+ merge context (Alias name args realVar)

497+

498+ Var _ _ _ ->

499+ subUnify context realVar (_second context)

500+

501+ Atom _ ->

502+ subUnify context realVar (_second context)

503+

504+

505+ Alias otherName otherArgs otherRealVar ->

506+ if name == otherName then

507+ do merge context otherContent

508+ zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)

509+

510+ else

511+ subUnify context realVar otherRealVar

512+

513+ Structure _ ->

514+ subUnify context realVar (_second context)

515+

516+

517+

518+-- UNIFY STRUCTURES

519+

520+

521+unifyStructure :: Context -> Term1 Variable -> Content -> Unify ()

522+unifyStructure context term otherContent =

523+ case otherContent of

524+ Error ->

525+ return ()

526+

527+ Var Flex Nothing _ ->

528+ merge context (Structure term)

529+

530+ Var Flex (Just super) _ ->

531+ unifySuper (reorient context) super (Structure term)

532+

533+ Var Rigid _ maybeName ->

534+ mismatch context (Just (Error.flipReason (badRigid maybeName)))

535+

536+ Atom _ ->

537+ mismatch context Nothing

538+

539+ Alias _ _ realVar ->

540+ subUnify context (_first context) realVar

541+

542+ Structure otherTerm ->

543+ case (term, otherTerm) of

544+ (App1 func arg, App1 otherFunc otherArg) ->

545+ do subUnify context func otherFunc

546+ subUnify context arg otherArg

547+ merge context otherContent

548+

549+ (Fun1 arg result, Fun1 otherArg otherResult) ->

550+ do subUnify context arg otherArg

551+ subUnify context result otherResult

552+ merge context otherContent

553+

554+ (EmptyRecord1, EmptyRecord1) ->

555+ merge context otherContent

556+

557+ (Record1 fields ext, EmptyRecord1) | Map.null fields ->

558+ subUnify context ext (_second context)

559+

560+ (EmptyRecord1, Record1 fields ext) | Map.null fields ->

561+ subUnify context (_first context) ext

562+

563+ (Record1 fields extension, Record1 otherFields otherExtension) ->

564+ do firstStructure <- gatherFields context fields extension

565+ secondStructure <- gatherFields context otherFields otherExtension

566+ unifyRecord context firstStructure secondStructure

567+

568+ _ ->

569+ mismatch context Nothing

570+

571+

572+

573+-- UNIFY RECORDS

574+

575+

576+unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()

577+unifyRecord context firstStructure secondStructure =

578+ do let (RecordStructure expFields expVar expStruct) = firstStructure

579+ let (RecordStructure actFields actVar actStruct) = secondStructure

580+

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

582+ -- looking into whether the particular field types match.

583+ let unifySharedFields otherFields ext =

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

585+ _ <- traverse (uncurry (subUnify context)) sharedFields

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

587+ merge context (Structure (Record1 allFields ext))

588+

589+ let uniqueExpFields = Map.difference expFields actFields

590+ let uniqueActFields = Map.difference actFields expFields

591+

592+ case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of

593+ (_, True, _, True) ->

594+ do subUnify context expVar actVar

595+ unifySharedFields Map.empty expVar

596+

597+ (Empty, _, _, False) ->

598+ mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))

599+

600+ (_, False, Empty, _) ->

601+ mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))

602+

603+ (_, False, _, True) ->

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

605+ subUnify context subRecord actVar

606+ unifySharedFields Map.empty subRecord

607+

608+ (_, True, _, False) ->

609+ do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))

610+ subUnify context expVar subRecord

611+ unifySharedFields Map.empty subRecord

612+

613+ (Extension, False, Extension, False) ->

614+ do let subFields = Map.union uniqueExpFields uniqueActFields

615+ subExt <- fresh context (Var Flex Nothing Nothing)

616+ expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))

617+ actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))

618+ subUnify context expVar expRecord

619+ subUnify context actRecord actVar

620+ unifySharedFields subFields subExt

621+

622+

623+

624+-- GATHER RECORD STRUCTURE

625+

626+

627+data RecordStructure = RecordStructure

628+ { _fields :: Map.Map String Variable

629+ , _extVar :: Variable

630+ , _extStruct :: ExtensionStructure

368631 }

369632

370−data Extension = Empty Variable | Extension Variable

633+

634+data ExtensionStructure

635+ = Empty

636+ | Extension

371637

372638

373−gatherFields :: Variable -> IO ExpandedRecord

374−gatherFields var =

375− do desc <- UF.descriptor var

376− case structure desc of

377− (Just (Record1 fields ext)) ->

378− do (ExpandedRecord deeperFields rootExt) <- gatherFields ext

379− return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)

639+gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure

640+gatherFields context fields variable =

641+ do desc <- liftIO (UF.descriptor variable)

642+ case _content desc of

643+ Structure (Record1 subFields subExt) ->

644+ gatherFields context (Map.union fields subFields) subExt

380645

381− (Just EmptyRecord1) ->

382− return (ExpandedRecord Map.empty (Empty var))

646+ Structure EmptyRecord1 ->

647+ return (RecordStructure fields variable Empty)

648+

649+ Alias _ _ var ->

650+ -- TODO may be dropping useful alias info here

651+ gatherFields context fields var

383652

384653 _ ->

385− return (ExpandedRecord Map.empty (Extension var))

386−

387−

388−-- assumes that one of the dicts has stuff in it

389−fieldMismatchError :: Map.Map String a -> String

390−fieldMismatchError missingFields =

391− case Map.keys missingFields of

392− [] -> ""

393− [key] ->

394− "Looks like a record is missing the field `" ++ key ++ "`"

395− keys ->

396− "Looks like a record is missing fields "

397− ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys

398−

399−

400−combinedDescriptors

401− :: Descriptor

402− -> Descriptor

403− -> (Maybe Var.Canonical, Flex, Int, Alias Variable)

404−combinedDescriptors desc1 desc2 =

405− (name', flex', rank', alias')

406− where

407− rank' :: Int

408− rank' =

409− min (rank desc1) (rank desc2)

410−

411− alias' :: Alias Variable

412− alias' =

413− alias desc1 <|> alias desc2

414−

415− name' :: Maybe Var.Canonical

416− name' =

417− case (name desc1, name desc2) of

418− (Just name1, Just name2) ->

419− case (flex desc1, flex desc2) of

420− (_, Flexible) -> Just name1

421− (Flexible, _) -> Just name2

422− (Is Number, Is _) -> Just name1

423− (Is _, Is Number) -> Just name2

424− (Is _, Is _) -> Just name1

425− (_, _) -> Nothing

426− (Just name1, _) -> Just name1

427− (_, Just name2) -> Just name2

428− _ -> Nothing

429−

430− flex' :: Flex

431− flex' =

432− case (flex desc1, flex desc2) of

433− (f, Flexible) -> f

434− (Flexible, f) -> f

435− (Is Number, Is _) -> Is Number

436− (Is _, Is Number) -> Is Number

437− (Is super, Is _) -> Is super

438− (_, _) -> Flexible

654+ return (RecordStructure fields variable Extension)

655+

src/Validate.hs+2−2

@@ -403,7 +403,7 @@ checkDecl isRoot (A.A (region,_) decl) =

403403 (v:vs) = Set.toList (Set.fromList unbound)

404404 in

405405 Result.throw region

406− (Error.UnboundTypeVarsInUnion name boundVars v vs ctors)

406+ (Error.UnboundTypeVarsInUnion name boundVars v vs)

407407

408408 D.TypeAlias name boundVars tipe ->

409409 case findUnbound boundVars (freeVars tipe) of

@@ -415,7 +415,7 @@ checkDecl isRoot (A.A (region,_) decl) =

415415 (v:vs) = Set.toList (Set.fromList unbound)

416416 in

417417 Result.throw region

418− (Error.UnboundTypeVarsInAlias name boundVars v vs tipe)

418+ (Error.UnboundTypeVarsInAlias name boundVars v vs)

419419

420420 D.Port _ ->

421421 if isRoot

tests/Test/Compiler.hs+11−1

@@ -19,6 +19,8 @@ import Test.HUnit (Assertion, assertFailure, assertBool, assertEqual)

1919import qualified Elm.Compiler as Compiler

2020import qualified Elm.Package as Package

2121

22+

23+

2224writeExpectedJsEnvVarName :: String

2325writeExpectedJsEnvVarName =

2426 "ELM_WRITE_NEW_EXPECTED"

@@ -38,8 +40,10 @@ compilerTests =

3840 ]

3941

4042

43+

4144-- GATHER FILES

4245

46+

4347getElms :: FilePath -> IO [FilePath]

4448getElms filePath =

4549 find

@@ -54,14 +58,16 @@ testsDir =

5458

5559convertToExpectedJsFilePath :: String -> FilePath -> FilePath

5660convertToExpectedJsFilePath expectedJsDir filePath =

57− testsDir

61+ testsDir

5862 </> expectedJsDir

5963 </> joinPath (drop 3 (splitDirectories filePath))

6064 <.> ".js"

6165

6266

67+

6368-- TEST HELPERS

6469

70+

6571compileString :: FilePath -> String -> Either String Compiler.Result

6672compileString filePath source =

6773 let context =

@@ -85,8 +91,10 @@ readFileOrErrorStr filePath =

8591 return (show e)

8692

8793

94+

8895-- RUN TESTS

8996

97+

9098testIf

9199 :: (Either String Compiler.Result -> Assertion)

92100 -> [FilePath]

@@ -143,8 +151,10 @@ testMatchesExpected elmDir expectedJsDir =

143151 traverse (doMatchesExpectedTest expectedJsDir) elmFiles

144152

145153

154+

146155-- CHECK RESULTS

147156

157+

148158isSuccess :: Either String a -> Assertion

149159isSuccess result =

150160 case result of

tests/test-files/good-expected-js/Declarations/Ports.elm.js+1−1

@@ -38,7 +38,7 @@ Elm.Main.make = function (_elm) {

3838 })) : _U.badPort("an array",v);

3939 });

4040 var tuple = Elm.Native.Port.make(_elm).inbound("tuple",

41− "(Float, Bool)",

41+ "( Float, Bool )",

4242 function (v) {

4343 return typeof v === "object" && v instanceof Array ? {ctor: "_Tuple2"

4444 ,_0: typeof v[0] === "number" ? v[0] : _U.badPort("a number",