8bc9edd · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

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

8bc9eddEvan Czaplicki11 years ago

elm-compiler.cabal+4−3

compare with master

unifiedsplit

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

108 Reporting.Error.Pattern,

109 Reporting.Error.Syntax,

110 Reporting.Error.Type,

111− Reporting.PrettyPrint,

112 Reporting.Region,

111 Reporting.Region,

112+ Reporting.Render.Code,

113+ Reporting.Render.Type,

113 Reporting.Report,

114 Reporting.Report,

114 Reporting.Result,

115 Reporting.Result,

115 Reporting.Warning,

116 Reporting.Warning,

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

119 Type.Environment,

120 Type.Environment,

120 Type.Fragment,

121 Type.Fragment,

121 Type.Inference,

122 Type.Inference,

122− Type.PrettyPrint,

123 Type.Solve,

124 Type.State,

125 Type.Type,

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

131 aeson >= 0.7 && < 0.9,

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

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

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

134 base >=4.2 && <5,

135 base >=4.2 && <5,

135 binary >= 0.7.0.0 && < 0.8,

136 binary >= 0.7.0.0 && < 0.8,

136 bytestring >= 0.9 && < 0.11,

137 bytestring >= 0.9 && < 0.11,

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

190 Test.Property.Arbitrary

191 Test.Property.Arbitrary

191 AST.Helpers

192 AST.Helpers

192 AST.Literal

193 AST.Literal

193− Reporting.PrettyPrint

194

195 build-depends:

196 test-framework > 0.8 && < 0.9,

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

201 aeson >= 0.7 && < 0.9,

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

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

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

204 base >=4.2 && <5,

205 base >=4.2 && <5,

205 binary >= 0.7.0.0 && < 0.8,

206 binary >= 0.7.0.0 && < 0.8,

206 bytestring >= 0.9 && < 0.11,

207 bytestring >= 0.9 && < 0.11,

src/AST/Expression/Canonical.hs−24

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

1{-# OPTIONS_GHC -Wall #-}

2module AST.Expression.Canonical where

4−import Text.PrettyPrint as P

5−

6import qualified AST.Expression.General as General

4import qualified AST.Expression.General as General

7import qualified AST.Pattern as Pattern

5import qualified AST.Pattern as Pattern

8import qualified AST.Type as Type

6import qualified AST.Type as Type

9import qualified AST.Variable as Var

7import qualified AST.Variable as Var

10import qualified Reporting.Annotation as A

8import qualified Reporting.Annotation as A

11−import qualified Reporting.PrettyPrint as P

12import qualified Reporting.Region as R

9import qualified Reporting.Region as R

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

26data Def

23data Def

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

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

28− deriving (Show)

31data Facts = Facts

27data Facts = Facts

32 { dependencies :: [Var.TopLevel]

28 { dependencies :: [Var.TopLevel]

33 }

29 }

34− deriving (Eq, Ord, Show)

37dummyFacts :: Facts

32dummyFacts :: Facts

38dummyFacts =

33dummyFacts =

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

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

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.

8-}

9module AST.Expression.General where

11−import Text.PrettyPrint as P

12−

13−import qualified AST.Helpers as Help

14import qualified AST.Literal as Literal

11import qualified AST.Literal as Literal

15import qualified AST.Pattern as Pattern

12import qualified AST.Pattern as Pattern

16import qualified AST.Type as Type

13import qualified AST.Type as Type

17import qualified AST.Variable as Var

14import qualified AST.Variable as Var

18import qualified Reporting.Annotation as A

15import qualified Reporting.Annotation as A

19−import qualified Reporting.PrettyPrint as P

22---- GENERAL AST ----

18---- GENERAL AST ----

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

58 -- for type checking and code gen only

54 -- for type checking and code gen only

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

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

60 | GLShader String String Literal.GLShaderTipe

56 | GLShader String String Literal.GLShaderTipe

61− deriving (Show)

64-- PORTS

59-- PORTS

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

67 = In String (Type.Port tipe)

62 = In String (Type.Port tipe)

68 | Out String expr (Type.Port tipe)

63 | Out String expr (Type.Port tipe)

69 | Task String expr (Type.Port tipe)

64 | Task String expr (Type.Port tipe)

70− deriving (Eq, Show)

65+ deriving (Eq)

73portName :: PortImpl expr tipe -> String

68portName :: PortImpl expr tipe -> String

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

100 "_save_the_environment!!!"

95 "_save_the_environment!!!"

101

102

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

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

104dummyLet defs =

99dummyLet defs =

105 let body =

100 let body =

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

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

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

108 A.A undefined (Let defs body)

103 A.A undefined (Let defs body)

109

104

110

105

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−

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

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

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

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

258 case expr of

108 case expr of

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

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

28data Def'

29 = Definition Pattern.RawPattern Expr

30 | TypeAnnotation String Type.Raw

31− deriving (Show)

31+

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

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

23data Def

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

4import qualified Data.Char as Char

6splitDots :: String -> [String]

8splitDots :: String -> [String]

7splitDots variable =

9splitDots variable =

8 go [] variable

10 go [] variable

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

17isTuple :: String -> Bool

19isTuple :: String -> Bool

18isTuple name =

20isTuple name =

21+ take 6 name == "_Tuple"

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

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

22isOp :: String -> Bool

25isOp :: String -> Bool

src/AST/Literal.hs+3−11

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

2module AST.Literal where

4import qualified Data.Map as Map

5−import qualified Text.PrettyPrint as P

6−

7−import qualified Reporting.PrettyPrint as P

10data Literal

7data Literal

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

13 | Chr Char

10 | Chr Char

14 | Str String

11 | Str String

15 | Boolean Bool

12 | Boolean Bool

16− deriving (Eq, Ord, Show)

13+ deriving (Eq, Ord)

17−

18−

19−instance P.Pretty Literal where

20− pretty _ _ literal =

21− P.text (toString literal)

24toString :: Literal -> String

16toString :: Literal -> String

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

39 | V4

31 | V4

40 | M4

32 | M4

41 | Texture

33 | Texture

42− deriving (Eq, Show)

34+ deriving (Eq)

45glTipeName :: GLTipe -> String

37glTipeName :: GLTipe -> String

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

59 , uniform :: Map.Map String GLTipe

51 , uniform :: Map.Map String GLTipe

60 , varying :: Map.Map String GLTipe

52 , varying :: Map.Map String GLTipe

61 }

53 }

62− deriving (Eq, Show)

54+ deriving (Eq)

src/AST/Pattern.hs+2−46

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

2module AST.Pattern where

4import qualified Data.Set as Set

5−import Text.PrettyPrint as P

7−import qualified AST.Helpers as Help

8import qualified AST.Literal as L

6import qualified AST.Literal as L

9import qualified AST.Variable as Var

7import qualified AST.Variable as Var

10import qualified Reporting.Annotation as A

8import qualified Reporting.Annotation as A

11−import qualified Reporting.PrettyPrint as P

12import qualified Reporting.Region as R

9import qualified Reporting.Region as R

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

23 | Var String

20 | Var String

24 | Anything

21 | Anything

25 | Literal L.Literal

22 | Literal L.Literal

26− deriving (Show)

29type RawPattern =

25type RawPattern =

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

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

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

60+

64-- FIND VARIABLES

61-- FIND VARIABLES

63+

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

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

67boundVars (A.A ann pattern) =

65boundVars (A.A ann pattern) =

68 case pattern of

66 case pattern of

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

99boundVarList pattern =

97boundVarList pattern =

100 Set.toList (boundVarSet pattern)

98 Set.toList (boundVarSet pattern)

101

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

2 ( Raw, Raw'(..)

3 , Canonical(..), Aliased(..)

4 , Port(..), getPortType

5− , deepDealias, dealias

5+ , deepDealias, iteratedDealias, dealias

6 , collectLambdas

7− , fieldMap

8 , tuple

7 , tuple

9 ) where

8 ) where

11import Control.Arrow (second)

10import Control.Arrow (second)

12import Data.Binary

11import Data.Binary

13import qualified Data.Map as Map

12import qualified Data.Map as Map

14−import qualified Data.Maybe as Maybe

15−import Text.PrettyPrint as P

17import qualified AST.Variable as Var

14import qualified AST.Variable as Var

18−import qualified AST.Helpers as Help

19import qualified Reporting.Annotation as A

15import qualified Reporting.Annotation as A

20−import qualified Reporting.PrettyPrint as P

21import qualified Reporting.Region as R

16import qualified Reporting.Region as R

19+

24-- DEFINITION

20-- DEFINITION

22+

26type Raw =

23type Raw =

27 A.Located Raw'

24 A.Located Raw'

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

33 | RType Var.Raw

30 | RType Var.Raw

34 | RApp Raw [Raw]

31 | RApp Raw [Raw]

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

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

36− deriving (Show)

39data Canonical

35data Canonical

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

43 | App Canonical [Canonical]

39 | App Canonical [Canonical]

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

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

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

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

46− deriving (Eq, Ord, Show)

42+ deriving (Eq, Ord)

49data Aliased t

45data Aliased t

50 = Holey t

46 = Holey t

51 | Filled t

47 | Filled t

52− deriving (Eq, Ord, Show)

48+ deriving (Eq, Ord)

55data Port t

51data Port t

56 = Normal t

52 = Normal t

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

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

58− deriving (Eq, Show)

54+ deriving (Eq)

61getPortType :: Port tipe -> tipe

57getPortType :: Port tipe -> tipe

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

65 Signal tipe _ -> tipe

61 Signal tipe _ -> tipe

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−

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

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

87tuple region types =

65tuple region types =

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

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

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

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

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

71+

93-- DEALIASING

72-- DEALIASING

74+

95deepDealias :: Canonical -> Canonical

75deepDealias :: Canonical -> Canonical

96deepDealias tipe =

76deepDealias tipe =

97− let go = deepDealias in

98 case tipe of

77 case tipe of

99 Lambda a b ->

78 Lambda a b ->

100− Lambda (go a) (go b)

79+ Lambda (deepDealias a) (deepDealias b)

101

102 Var _ ->

81 Var _ ->

103 tipe

82 tipe

104

105 Record fields ext ->

84 Record fields ext ->

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

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

107

108 Aliased _name args tipe' ->

87 Aliased _name args tipe' ->

109 deepDealias (dealias args tipe')

88 deepDealias (dealias args tipe')

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

112 tipe

91 tipe

113

114 App f args ->

93 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

116

105

117

106

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

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

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

148 App (go f) (map go args)

137 App (go f) (map go args)

149

138

150

139

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−

210

140

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

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

264

142

265

143

266collectLambdas :: Canonical -> [Canonical]

144collectLambdas :: Canonical -> [Canonical]

267collectLambdas tipe =

145collectLambdas tipe =

268− gatherLambda getCanLambda tipe

146+ case tipe of

269−

147+ Lambda arg result ->

270−

148+ arg : collectLambdas result

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'

336

149

337 _ ->

150 _ ->

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

151+ [tipe]

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

358

152

359− _ ->

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

361

153

362

154

363-- BINARY

155-- BINARY

364

156

157+

365instance Binary Canonical where

158instance Binary Canonical where

366 put tipe =

159 put tipe =

367 case tipe of

160 case tipe of

src/AST/Variable.hs+18−45

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

1module AST.Variable where

3import Data.Binary

4−import qualified Data.Map as Map

5import qualified Data.Maybe as Maybe

4import qualified Data.Maybe as Maybe

6−import Text.PrettyPrint as P

8import qualified AST.Helpers as Help

6import qualified AST.Helpers as Help

9import qualified AST.Module.Name as ModuleName

7import qualified AST.Module.Name as ModuleName

10−import qualified Reporting.PrettyPrint as P

13-- RAW NAMES

11-- RAW NAMES

13+

15newtype Raw = Raw String

14newtype Raw = Raw String

16− deriving (Eq, Ord, Show)

15+ deriving (Eq, Ord)

16+

19-- TOP LEVEL NAMES

21+

21data TopLevel = TopLevelVar

22data TopLevel = TopLevelVar

22 { topHome :: ModuleName.Canonical

23 { topHome :: ModuleName.Canonical

23 , topName :: String

24 , topName :: String

24 }

25 }

25− deriving (Eq, Ord, Show)

26+ deriving (Eq, Ord)

29-- CANONICAL NAMES

30-- CANONICAL NAMES

32+

31data Home

33data Home

32 = BuiltIn

34 = BuiltIn

33 | Module ModuleName.Canonical

35 | Module ModuleName.Canonical

34 | TopLevel ModuleName.Canonical

36 | TopLevel ModuleName.Canonical

35 | Local

37 | Local

36− deriving (Eq, Ord, Show)

38+ deriving (Eq, Ord)

39data Canonical = Canonical

41data Canonical = Canonical

40 { home :: !Home

42 { home :: !Home

41 , name :: !String

43 , name :: !String

42 }

44 }

43− deriving (Eq, Ord, Show)

45+ deriving (Eq, Ord)

46local :: String -> Canonical

48local :: String -> Canonical

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

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

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

73+

71-- VARIABLE RECOGNIZERS

74-- VARIABLE RECOGNIZERS

76+

73isLocalHome :: Home -> Bool

77isLocalHome :: Home -> Bool

74isLocalHome home =

78isLocalHome home =

75 case home of

79 case home of

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

190 name

194 name

191

195

192

196

197+

193-- LISTINGS

198-- LISTINGS

194

199

200+

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

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

196data Listing a = Listing

202data Listing a = Listing

197 { _explicits :: [a]

203 { _explicits :: [a]

198 , _open :: Bool

204 , _open :: Bool

199 }

205 }

200− deriving (Eq, Ord, Show)

206+ deriving (Eq, Ord)

201

207

202

208

203openListing :: Listing a

209openListing :: Listing a

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

220 = Value !String

226 = Value !String

221 | Alias !String

227 | Alias !String

222 | Union !String !(Listing String)

228 | Union !String !(Listing String)

223− deriving (Eq, Ord, Show)

229+ deriving (Eq, Ord)

230+

224

231

225

232

226-- CATEGORIZING VALUES

233-- CATEGORIZING VALUES

227

234

235+

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

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

229getValues values =

237getValues values =

230 Maybe.mapMaybe getValue values

238 Maybe.mapMaybe getValue values

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

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

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

265

273

266

274

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−

303

275

304-- BINARY SERIALIZATION

276-- BINARY SERIALIZATION

305

277

278+

306instance Binary Canonical where

279instance Binary Canonical where

307 put (Canonical home name) =

280 put (Canonical home name) =

308 case home of

281 case home of

src/Elm/Compiler.hs+32−29

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

3 ( version

4 , parseDependencies

5 , compile, Context(..), Result(..)

6− , Dealiaser, dummyDealiaser

6+ , Localizer, dummyLocalizer

7 , Error, errorToString, errorToJson, printError

8 , Warning, warningToString, warningToJson, printWarning

9+ )

9− ) where

10+ where

11import qualified Data.Aeson as Json

12import qualified Data.Aeson as Json

12import qualified Data.Map as Map

13import qualified Data.Map as Map

14+import System.IO (Handle)

14import qualified AST.Module as Module

16import qualified AST.Module as Module

15import qualified AST.Module.Name as ModuleName

17import qualified AST.Module.Name as ModuleName

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

24import qualified Parse.Parse as Parse

26import qualified Parse.Parse as Parse

25import qualified Reporting.Annotation as A

27import qualified Reporting.Annotation as A

26import qualified Reporting.Error as Error

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

28import qualified Reporting.Result as Result

31import qualified Reporting.Result as Result

29import qualified Reporting.Warning as Warning

32import qualified Reporting.Warning as Warning

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

64 :: Context

67 :: Context

65 -> String

68 -> String

66 -> PublicModule.Interfaces

69 -> PublicModule.Interfaces

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

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

69compile context source interfaces =

72compile context source interfaces =

70 let

73 let

71 (Context packageName isRoot isExposed dependencies) =

74 (Context packageName isRoot isExposed dependencies) =

72 context

75 context

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

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

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

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

76 docs <- docsGen isExposed modul

79 docs <- docsGen isExposed modul

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

81 return (Result docs interface javascript)

84 return (Result docs interface javascript)

82 in

85 in

83− ( maybe dummyDealiaser Dealiaser dealiaser

86+ ( maybe dummyLocalizer Localizer localizer

84 , map Warning warnings

87 , map Warning warnings

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

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

86 )

89 )

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

124

127

125-- DEALIASER

128-- DEALIASER

126

129

127−newtype Dealiaser =

130+newtype Localizer =

128− Dealiaser P.Dealiaser

131+ Localizer RenderType.Localizer

129

132

130

133

131−dummyDealiaser :: Dealiaser

134+dummyLocalizer :: Localizer

132−dummyDealiaser =

135+dummyLocalizer =

133− Dealiaser Map.empty

136+ Localizer Map.empty

134

137

135

138

136-- ERRORS

139-- ERRORS

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

139 Error (A.Located Error.Error)

142 Error (A.Located Error.Error)

140

143

141

144

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

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

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

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

144− Error.toString dealiaser location source err

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

145

148

146

149

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

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

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

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

149− Error.print dealiaser location source err

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

150

153

151

154

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

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

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

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

154− Error.toJson dealiaser location err

157+ Error.toJson localizer location err

155

158

156

159

157-- WARNINGS

160-- WARNINGS

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

160 Warning (A.Located Warning.Warning)

163 Warning (A.Located Warning.Warning)

161

164

162

165

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

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

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

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

165− Warning.toString dealiaser location source err

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

166

169

167

170

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

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

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

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

170− Warning.print dealiaser location source err

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

171

174

172

175

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

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

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

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

175− Warning.toJson dealiaser location err

178+ Warning.toJson localizer location wrn

176

179

177

180

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

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

4import qualified Data.Version as Version

5import qualified Paths_elm_compiler as This

6−import Elm.Package

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

9rawVersion :: [Int]

10rawVersion =

11 Version.versionBranch This.version

13+

13version :: Version

14version :: Version

14version =

15version =

15 case rawVersion of

16 case rawVersion of

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

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

7import qualified AST.Type as T

8import qualified AST.Variable as Var

9import Generate.JavaScript.Helpers

10−import qualified Reporting.PrettyPrint as P

10+import qualified Reporting.Render.Type as RenderType

13-- TASK

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

97 T.Normal tipe ->

98 _Port "inbound" `call`

99 [ StringLit () name

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

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

101 , toTypeFunction tipe

102 ]

103

104 T.Signal _root arg ->

105 _Port "inboundSignal" `call`

106 [ StringLit () name

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

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

108 , toTypeFunction arg

109 ]

110

src/Nitpick/Pattern.hs+15−2

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

17 | Anything

18 | Literal L.Literal

19 | AnythingBut (Set.Set L.Literal)

20− deriving (Show, Eq)

20+ deriving (Eq)

23fromCanonicalPattern :: P.CanonicalPattern -> Pattern

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

83 L.toString literal

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

100

101

89addParensIf :: Bool -> String -> String

102addParensIf :: Bool -> String -> String

src/Parse/Expression.hs+28−36

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

91parensTerm :: IParser Source.Expr

92parensTerm =

93− choice

93+ let

94− [ try (parens opFn)

94+ mkFunc args realBody start end =

95− , parens (tupleFn <|> parened)

95+ foldr

96− ]

97− where

98− lambda start end x body =

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

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

100−

101− var start end x =

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

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

98+ args

103

104− opFn =

100+ mkBinop op =

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

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

111

102

112 tupleFn =

103 tupleFn =

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

104+ do commas <- many1 comma

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

115−

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

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

117−

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

118− return $

107+

119− foldr

108+ parenedExpr =

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)

109+ do expressions <- padded (commaSep expr)

126− return $

110+ return $ \start end ->

127− case expressions of

111+ case expressions of

128− [expression] ->

112+ [expression] ->

129− expression

113+ expression

130− _ ->

114+ _ ->

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

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+

132

124

133

125

134recordTerm :: IParser Source.Expr

126recordTerm :: IParser Source.Expr

src/Reporting/Annotation.hs−8

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

1module Reporting.Annotation where

3import Prelude hiding (map)

4−import qualified Reporting.PrettyPrint as P

5import qualified Reporting.Region as R

4import qualified Reporting.Region as R

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

10data Annotated annotation a

9data Annotated annotation a

11 = A annotation a

10 = A annotation a

12− deriving (Show)

15type Located a =

13type Located a =

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

48drop (A _ value) =

46drop (A _ value) =

49 value

47 value

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

5import Data.Aeson ((.=))

6import qualified Data.Aeson as Json

7−import Prelude hiding (print)

9import qualified Reporting.Annotation as A

8import qualified Reporting.Annotation as A

10import qualified Reporting.Error.Canonicalize as Canonicalize

9import qualified Reporting.Error.Canonicalize as Canonicalize

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

12import qualified Reporting.Error.Pattern as Pattern

11import qualified Reporting.Error.Pattern as Pattern

13import qualified Reporting.Error.Syntax as Syntax

12import qualified Reporting.Error.Syntax as Syntax

14import qualified Reporting.Error.Type as Type

13import qualified Reporting.Error.Type as Type

15−import qualified Reporting.PrettyPrint as P

14+import qualified Reporting.Render.Type as RenderType

16import qualified Reporting.Report as Report

15import qualified Reporting.Report as Report

18+

19-- ALL POSSIBLE ERRORS

21+

21data Error

22data Error

22 = Syntax Syntax.Error

23 = Syntax Syntax.Error

23 | Canonicalize Canonicalize.Error

24 | Canonicalize Canonicalize.Error

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

26 | Docs Docs.Error

27 | Docs Docs.Error

30+

29-- TO REPORT

31-- TO REPORT

33+

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

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

32−toReport dealiaser err =

35+toReport localizer err =

33 case err of

36 case err of

34 Syntax syntaxError ->

37 Syntax syntaxError ->

35− Syntax.toReport dealiaser syntaxError

38+ Syntax.toReport localizer syntaxError

37 Canonicalize canonicalizeError ->

40 Canonicalize canonicalizeError ->

38− Canonicalize.toReport dealiaser canonicalizeError

41+ Canonicalize.toReport localizer canonicalizeError

40 Type typeError ->

43 Type typeError ->

41− Type.toReport dealiaser typeError

44+ Type.toReport localizer typeError

43 Pattern patternError ->

46 Pattern patternError ->

44− Pattern.toReport dealiaser patternError

47+ Pattern.toReport localizer patternError

46 Docs docsError ->

49 Docs docsError ->

47 Docs.toReport docsError

50 Docs.toReport docsError

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−

62-- TO JSON

54-- TO JSON

56+

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

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

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

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

66 let

59 let

67 (maybeRegion, additionalFields) =

60 (maybeRegion, additionalFields) =

68 case err of

61 case err of

69 Syntax syntaxError ->

62 Syntax syntaxError ->

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

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

72 Canonicalize canonicalizeError ->

65 Canonicalize canonicalizeError ->

73 let

66 let

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

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

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

77 (Canonicalize.extractSuggestions canonicalizeError)

70 (Canonicalize.extractSuggestions canonicalizeError)

78 in

71 in

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

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

81 Type typeError ->

74 Type typeError ->

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

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

84 Pattern patternError ->

77 Pattern patternError ->

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

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

87 Docs docsError ->

80 Docs docsError ->

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

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

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

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

1{-# OPTIONS_GHC -Wall #-}

2module Reporting.Error.Canonicalize where

4+import Control.Arrow (second)

4−import qualified Text.PrettyPrint as P

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

6import qualified AST.Module.Name as ModuleName

7import qualified AST.Module.Name as ModuleName

7import qualified AST.Type as Type

8import qualified AST.Type as Type

8import qualified AST.Variable as Var

9import qualified AST.Variable as Var

10+import qualified Reporting.Annotation as A

9import qualified Reporting.Error.Helpers as Help

11import qualified Reporting.Error.Helpers as Help

10−import qualified Reporting.PrettyPrint as P

11import qualified Reporting.Region as Region

12import qualified Reporting.Region as Region

13+import qualified Reporting.Render.Type as RenderType

12import qualified Reporting.Report as Report

14import qualified Reporting.Report as Report

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

22 | Port PortError

24 | Port PortError

27+

25-- VARIABLES

28-- VARIABLES

30+

27data VarError = VarError

31data VarError = VarError

28 { varKind :: String

32 { varKind :: String

29 , varName :: String

33 , varName :: String

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

44 Var (VarError kind name problem suggestions)

48 Var (VarError kind name problem suggestions)

51+

47-- PATTERN

52-- PATTERN

54+

49data PatternError

55data PatternError

50 = PatternArgMismatch Var.Canonical Int Int

56 = PatternArgMismatch Var.Canonical Int Int

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

55 Pattern (PatternArgMismatch name expected actual)

61 Pattern (PatternArgMismatch name expected actual)

64+

58-- IMPORTS

65-- IMPORTS

67+

60data ImportError

68data ImportError

61 = ModuleNotFound [ModuleName.Raw]

69 = ModuleNotFound [ModuleName.Raw]

62 | ValueNotFound String [String]

70 | ValueNotFound String [String]

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

72 Import name (ValueNotFound value possibilities)

80 Import name (ValueNotFound value possibilities)

83+

75-- ALIASES

84-- ALIASES

86+

77data AliasError

87data AliasError

78 = ArgMismatch Var.Canonical Int Int

88 = ArgMismatch Var.Canonical Int Int

79 | SelfRecursive String [String] Type.Raw

89 | SelfRecursive String [String] Type.Raw

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

85 Alias (ArgMismatch name expected actual)

95 Alias (ArgMismatch name expected actual)

98+

88-- PORTS

99-- PORTS

100

101+

90data PortError = PortError

102data PortError = PortError

91 { portName :: String

103 { portName :: String

92 , portIsInbound :: Bool

104 , portIsInbound :: Bool

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

107 Port (PortError name isInbound rootType localType maybeMessage)

119 Port (PortError name isInbound rootType localType maybeMessage)

108

120

109

121

122+

110-- TO REPORT

123-- TO REPORT

111

124

125+

112namingError :: String -> String -> Report.Report

126namingError :: String -> String -> Report.Report

113namingError pre post =

127namingError pre post =

114− Report.simple "NAMING ERROR" pre post

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

115

129

116

130

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

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

118−toReport dealiaser err =

132+toReport localizer err =

119 case err of

133 case err of

120 Var (VarError kind name problem suggestions) ->

134 Var (VarError kind name problem suggestions) ->

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

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

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

156 argMismatchReport "Type" var expected actual

170 argMismatchReport "Type" var expected actual

157

171

158 SelfRecursive name tvars tipe ->

172 SelfRecursive name tvars tipe ->

173+ Report.report

174+ "ALIAS PROBLEM"

175+ Nothing

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

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

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

177+ (

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

178+ Help.stack

179+ [ Help.reflowParagraph $

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

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

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

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

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

182+ , indent 4 $

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

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

184+ , text $

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

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

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

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

187+ ]

188+ )

168

189

169 MutuallyRecursive aliases ->

190 MutuallyRecursive aliases ->

191+ Report.report

192+ "ALIAS PROBLEM"

193+ Nothing

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

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

195+ ( Help.stack

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

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

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

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

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

198+ , Help.reflowParagraph $

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

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

175− where

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

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

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

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

202+ ]

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

203+ )

179

204

180 Import name importError ->

205 Import name importError ->

181 let moduleName = ModuleName.toString name

206 let moduleName = ModuleName.toString name

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

205 let

230 let

206 boundPort =

231 boundPort =

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

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

219 in

233 in

234+ Report.report

220− Report.simple "PORT ERROR" preHint postHint

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

221

249

222

250

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

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

224argMismatchReport kind var expected actual =

252argMismatchReport kind var expected actual =

225− let

253+ Report.report

226− preHint =

254+ "ARGUMENT"

255+ Nothing

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

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

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

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

229 ++ " arguments."

258 ++ " arguments."

230−

259+ )

231− postHint =

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

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

233− in

234− Report.simple "ARGUMENT" preHint postHint

235

261

236

262

237extractSuggestions :: Error -> Maybe [String]

263extractSuggestions :: Error -> Maybe [String]

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

262

288

263 Port _ ->

289 Port _ ->

264 Nothing

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

1{-# OPTIONS_GHC -Wall #-}

2module Reporting.Error.Docs where

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

4import qualified Reporting.Error.Helpers as Help

6import qualified Reporting.Error.Helpers as Help

5import qualified Reporting.Report as Report

7import qualified Reporting.Report as Report

10+

8data Error

11data Error

9 = NoDocs

12 = NoDocs

10 | OnlyInDocs String [String]

13 | OnlyInDocs String [String]

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

13 | NoType String

16 | NoType String

19+

16-- TO REPORT

20-- TO REPORT

22+

18toReport :: Error -> Report.Report

23toReport :: Error -> Report.Report

19toReport err =

24toReport err =

20 case err of

25 case err of

21 NoDocs ->

26 NoDocs ->

27+ Report.report

22− Report.simple "DOCUMENTATION ERROR"

28+ "DOCUMENTATION ERROR"

29+ Nothing

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

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

24 ++ "imports."

31 ++ "imports."

25 )

32 )

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

28 OnlyInDocs name suggestions ->

36 OnlyInDocs name suggestions ->

37+ Report.report

29− Report.simple "DOCUMENTATION ERROR"

38+ "DOCUMENTATION ERROR"

39+ Nothing

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

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

41+ ( text $

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

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

43+ ++ Help.maybeYouWant suggestions

44+ )

33 OnlyInExports names ->

46 OnlyInExports names ->

34− Report.simple

47+ Report.report

35 "DOCUMENTATION ERROR"

48 "DOCUMENTATION ERROR"

49+ Nothing

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

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

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

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

38 )

52 )

53+ ( text $

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

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

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

41 )

56 )

43 NoComment name ->

58 NoComment name ->

59+ Report.report

44− Report.simple "DOCUMENTATION ERROR"

60+ "DOCUMENTATION ERROR"

61+ Nothing

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

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

54 )

64 )

56 NoType name ->

66 NoType name ->

67+ Report.report

57− Report.simple "MISSING ANNOTATION"

68+ "MISSING ANNOTATION"

69+ Nothing

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

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

71+ ( text $

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

72+ "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!"

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

61 )

74 )

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

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

1{-# 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

4import Data.Function (on)

11import Data.Function (on)

12+import qualified Data.Char as Char

5import qualified Data.List as List

13import qualified Data.List as List

14+import qualified Data.Map as Map

15+import qualified Data.Set as Set

6import qualified Text.EditDistance as Dist

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

166

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

167

168

11-- NEARBY NAMES

169-- NEARBY NAMES

170

171+

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

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

14nearbyNames format name names =

173nearbyNames format name names =

15 let editDistance =

174 let editDistance =

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

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

1{-# OPTIONS_GHC -Wall #-}

2module Reporting.Error.Pattern where

4−import qualified AST.Module.Name as ModuleName

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

5−import qualified AST.Variable as Var

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

8import qualified Reporting.Report as Report

9import qualified Reporting.Report as Report

12+

11data Error

13data Error

12 = Incomplete Origin [Pattern.Pattern]

14 = Incomplete Origin [Pattern.Pattern]

13 | Redundant

15 | Redundant

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

19 | Case

21 | Case

24+

22-- TO REPORT

25-- TO REPORT

27+

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

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

25−toReport dealiaser err =

29+toReport _localizer err =

26 case err of

30 case err of

27 Incomplete Arg unhandled ->

31 Incomplete Arg unhandled ->

28− Report.simple

32+ Report.report

29 "PARTIAL PATTERN"

33 "PARTIAL PATTERN"

34+ Nothing

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

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

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

36+ (text (unhandledError unhandled toCaseMessage))

32− ++ viewPatternList unhandled

33− ++ "\n\n"

34− ++ partialExplanation unhandled

35− )

37 Incomplete LetBound unhandled ->

38 Incomplete LetBound unhandled ->

38− Report.simple

39+ Report.report

39 "PARTIAL PATTERN"

40 "PARTIAL PATTERN"

41+ Nothing

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

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

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

43+ (text (unhandledError unhandled toCaseMessage))

42− ++ viewPatternList unhandled

43− ++ "\n\n"

44− ++ partialExplanation unhandled

45− )

47 Incomplete Case unhandled ->

45 Incomplete Case unhandled ->

48− Report.simple

46+ Report.report

49− "INCOMPLETE PATTERN MATCH"

47+ "MISSING PATTERNS"

48+ Nothing

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

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

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

50+ (text (unhandledError unhandled newTagsMessage))

52− ++ viewPatternList unhandled

53− ++ "\n\n"

54− ++ incompleteExplanation

55− )

57 Redundant ->

52 Redundant ->

58− Report.simple

53+ Report.report

59 "REDUNDANT PATTERN"

54 "REDUNDANT PATTERN"

55+ Nothing

60− "The following pattern is redundant."

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

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

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

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

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

65−viewPatternList unhandledPatterns =

61+unhandledError unhandledPatterns relevantMessage =

66 let

62 let

67− (showPatterns, rest) =

63+ (visiblePatterns, rest) =

68 splitAt 4 unhandledPatterns

64 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

111

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

112

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

114−isEmptyList unhandledPatterns =

115− case unhandledPatterns of

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

117− True

118

119− _ ->

80+toCaseMessage :: String

120− False

81+toCaseMessage =

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

121

122

123−incompleteExplanation :: String

85+newTagsMessage :: String

124−incompleteExplanation =

86+newTagsMessage =

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

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

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

131

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

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

4import qualified Data.List as List

5import qualified Data.Set as Set

6import qualified Text.Parsec.Error as Parsec

7−import qualified Text.PrettyPrint as P

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

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

10−import qualified AST.Helpers as Help

9+import qualified Reporting.Error.Helpers as Help

11−import qualified AST.Type as Type

10+import qualified Reporting.Render.Type as RenderType

12−import qualified Reporting.PrettyPrint as P

13import qualified Reporting.Report as Report

11import qualified Reporting.Report as Report

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

25 | DuplicateValueDeclaration String

23 | DuplicateValueDeclaration String

26 | DuplicateTypeDeclaration String

24 | DuplicateTypeDeclaration String

27 | DuplicateDefinition String

25 | DuplicateDefinition String

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

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

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

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

32-- TO REPORT

30-- TO REPORT

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

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

35−toReport dealiaser err =

33+toReport _localizer err =

36 case err of

34 case err of

37 Parse messages ->

35 Parse messages ->

38 parseErrorReport messages

36 parseErrorReport messages

40 BadFunctionName arity ->

38 BadFunctionName arity ->

41− Report.simple

39+ Report.report

42 "BAD FUNCTION DEFINITION"

40 "BAD FUNCTION DEFINITION"

41+ Nothing

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

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

43+ ( Help.reflowParagraph $

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

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

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

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

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

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

47+ \ be changed to a normal name."

47 )

48 )

49 BadPattern name ->

50 BadPattern name ->

50− Report.simple

51+ Report.report

51 "BAD PATTERN"

52 "BAD PATTERN"

53+ Nothing

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

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

55+ ( Help.stack

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

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

57+ , Help.reflowParagraph $

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

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

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

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

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

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

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

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

62+ ]

58 )

63 )

60 InfixDuplicate opName ->

65 InfixDuplicate opName ->

61− Report.simple

66+ Report.report

62 "INFIX OVERLAP"

67 "INFIX OVERLAP"

68+ Nothing

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

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

70+ ( Help.reflowParagraph $

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

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

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

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

66 )

74 )

67− where

68− operator =

69− if Help.isOp opName

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

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

73 TypeWithoutDefinition valueName ->

76 TypeWithoutDefinition valueName ->

74− Report.simple

77+ Report.report

75 "MISSING DEFINITION"

78 "MISSING DEFINITION"

79+ Nothing

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

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

77 ++ " is no corresponding definition!"

81 ++ " is no corresponding definition!"

78 )

82 )

83+ ( text $

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

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

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

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

81 )

86 )

83 PortWithoutAnnotation portName ->

88 PortWithoutAnnotation portName ->

84− Report.simple

89+ Report.report

85 "PORT ERROR"

90 "PORT ERROR"

91+ Nothing

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

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

93+ ( text $

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

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

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

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

89 )

96 )

92 UnexpectedPort ->

99 UnexpectedPort ->

93− Report.simple

100+ Report.report

94 "PORT ERROR"

101 "PORT ERROR"

102+ Nothing

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

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

104+ ( Help.reflowParagraph $

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

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

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

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

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

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

99 )

108 )

100

109

101 DuplicateFieldName name ->

110 DuplicateFieldName name ->

102− Report.simple

111+ Report.report

103 "DUPLICATE FIELD"

112 "DUPLICATE FIELD"

113+ Nothing

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

114 ("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!")

106

116

107 DuplicateValueDeclaration name ->

117 DuplicateValueDeclaration name ->

108− Report.simple

118+ Report.report

109 "DUPLICATE DEFINITION"

119 "DUPLICATE DEFINITION"

120+ Nothing

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

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

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

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

112 )

123 )

124+ ( Help.reflowParagraph $

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

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

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

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

115 )

127 )

116

128

117 DuplicateTypeDeclaration name ->

129 DuplicateTypeDeclaration name ->

118− Report.simple

130+ Report.report

119 "DUPLICATE DEFINITION"

131 "DUPLICATE DEFINITION"

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

132+ Nothing

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

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

122 )

134 )

135+ ( Help.reflowParagraph $

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

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

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

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

125 )

138 )

126

139

127 DuplicateDefinition name ->

140 DuplicateDefinition name ->

128− Report.simple

141+ Report.report

129 "DUPLICATE DEFINITION"

142 "DUPLICATE DEFINITION"

143+ Nothing

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

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

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

132 )

145 )

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

146+ ( Help.reflowParagraph $

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

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

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

135 )

149 )

136

150

137− UnboundTypeVarsInAlias typeName givenVars tvar tvars tipe ->

151+ UnboundTypeVarsInAlias typeName givenVars tvar tvars ->

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)

152+ unboundTypeVars "type alias" typeName givenVars tvar tvars

145−

153+

146−

147− UnboundTypeVarsInUnion typeName givenVars tvar tvars ctors ->

154+ UnboundTypeVarsInUnion typeName givenVars tvar tvars ->

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)

155+ unboundTypeVars "type" typeName givenVars tvar tvars

159− toDoc (ctor, args) =

156+

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

157+

161−

158+

162−

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

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

164−unboundTypeVars typeName tvar tvars revisedDeclaration =

160+unboundTypeVars declKind typeName givenVars tvar tvars =

165− Report.simple

161+ Report.report

166− "UNBOUND TYPE VARS"

162+ "UNBOUND TYPE VARIABLES"

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

163+ Nothing

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

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

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

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

170 )

166 )

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

167+ ( Help.stack

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

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 $

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

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

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

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

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

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

177+ ]

176 )

178 )

177

179

178

180

181+

179-- TAGGING PARSE ERRORS

182-- TAGGING PARSE ERRORS

180

183

184+

181newline :: String

185newline :: String

182newline = "NEWLINE"

186newline = "NEWLINE"

183

187

188+

184freshLine :: String

189freshLine :: String

185freshLine = "FRESH_LINE"

190freshLine = "FRESH_LINE"

186

191

192+

187whitespace :: String

193whitespace :: String

188whitespace = "WHITESPACE"

194whitespace = "WHITESPACE"

189

195

196+

190keyword :: String -> String

197keyword :: String -> String

191keyword kwd =

198keyword kwd =

192 "KEYWORD=" ++ kwd

199 "KEYWORD=" ++ kwd

193

200

201+

194unkeyword :: String -> Maybe String

202unkeyword :: String -> Maybe String

195unkeyword message =

203unkeyword message =

196− if List.isPrefixOf "KEYWORD=" message

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

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

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

206+

207+ else

198− else Nothing

208+ Nothing

199

209

200

210

201-- REPORTING PARSE ERRORS

211-- REPORTING PARSE ERRORS

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

214 Parsec.Expect msg ->

224 Parsec.Expect msg ->

215 let

225 let

216 msg' =

226 msg' =

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

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

218− then "whitespace"

228+ "whitespace"

219− else msg

229+ else

230+ msg

220 in

231 in

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

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

222

233

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

226 (ParseHint msgs expects) =

237 (ParseHint msgs expects) =

227 foldr addMsg emptyHint messages

238 foldr addMsg emptyHint messages

228

239

229− preHint =

240+ (preHint, maybePost) =

230 case msgs of

241 case msgs of

231 [msg] ->

242 [msg] ->

232 case unkeyword msg of

243 case unkeyword msg of

233 Just kwd ->

244 Just kwd ->

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

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

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

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

247+ )

248+

236 Nothing ->

249 Nothing ->

237− msg

250+ ( msg

251+ , Nothing

252+ )

238

253

254+ _ ->

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

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

256+ , Nothing

257+ )

240

258

241 postHint =

259 postHint =

242− if Set.null expects

260+ if Set.null expects then

243− then ""

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

262+

244− else

263+ else

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

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

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

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

247 in

266 in

267+ Report.report

248− Report.simple "SYNTAX PROBLEM" preHint postHint

268+ "SYNTAX PROBLEM"

269+ Nothing

270+ preHint

271+ (text (maybe postHint id maybePost))

249

272

250

273

251data ParseHint = ParseHint

274data ParseHint = ParseHint

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

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

1{-# OPTIONS_GHC -Wall #-}

2module Reporting.Error.Type where

4−import qualified Data.Char as Char

4+import qualified Data.Maybe as Maybe

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

5+import Text.PrettyPrint.ANSI.Leijen

6−import qualified Text.PrettyPrint as P

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

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

8+ )

8−import qualified AST.Helpers as Help

9import qualified AST.Type as Type

10import qualified AST.Type as Type

10import qualified AST.Variable as Var

11import qualified AST.Variable as Var

11−import qualified Reporting.PrettyPrint as P

12+import qualified Reporting.Error.Helpers as Help

12import qualified Reporting.Region as Region

13import qualified Reporting.Region as Region

14+import qualified Reporting.Render.Type as RenderType

13import qualified Reporting.Report as Report

15import qualified Reporting.Report as Report

18+

19+-- ERRORS

20+

21+

16data Error

22data Error

17 = Mismatch Mismatch

23 = Mismatch Mismatch

18− | InfiniteType InfiniteType

19 | BadMain Type.Canonical

24 | BadMain Type.Canonical

25+ | InfiniteType

26+ { _name :: String

27+ , _overallType :: Type.Canonical

28+ , _infiniteType :: Type.Canonical

29+ }

22data Mismatch = MismatchInfo

32data Mismatch = MismatchInfo

23 { _hint :: Hint

33 { _hint :: Hint

24 , _leftType :: Type.Canonical

34 , _leftType :: Type.Canonical

25 , _rightType :: Type.Canonical

35 , _rightType :: Type.Canonical

26− , _note :: Maybe String

36+ , _reason :: Maybe Reason

27 }

37 }

30−data InfiniteType = InfiniteTypeInfo

40+data Reason

31− { _name :: String

41+ = MessyFields [String] [String]

32− , _var :: Type.Canonical

42+ | IntFloat

33− , _type :: Type.Canonical

43+ | TooLongComparableTuple Int

34− }

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

45+

46+

47+data VarType

48+ = Number

49+ | Comparable

50+ | Appendable

51+ | CompAppend

52+ | Rigid (Maybe String)

37data Hint

55data Hint

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

47 | BinopRight Var.Canonical Region.Region

65 | BinopRight Var.Canonical Region.Region

48 | Binop Var.Canonical

66 | Binop Var.Canonical

49 | Function (Maybe Var.Canonical)

67 | Function (Maybe Var.Canonical)

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

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

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

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

52 | BadTypeAnnotation String

70 | BadTypeAnnotation String

53 | Instance String

71 | Instance String

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

66 | PRecord

84 | PRecord

87+

69-- TO REPORT

88-- TO REPORT

90+

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

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

72−toReport dealiaser err =

92+toReport localizer err =

73 case err of

93 case err of

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

94+ Mismatch info ->

75− let

95+ mismatchToReport localizer info

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

89− InfiniteType (InfiniteTypeInfo name var tipe) ->

97+ InfiniteType name overallType infiniteType ->

90− let

98+ infiniteTypeToReport localizer name overallType infiniteType

91− prettyVar =

92− P.pretty dealiaser False var

94− prettyType =

100+ BadMain tipe ->

95− P.pretty dealiaser False tipe

101+ Report.report

96− in

102+ "BAD MAIN TYPE"

97− Report.simple "INFINITE TYPE"

103+ Nothing

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

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

99− )

105+ ( Help.stack

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

106+ [ Help.reflowParagraph $

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

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

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

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

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

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

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

110+ ]

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

107 )

111 )

108

112

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

114

113

115

114

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

115+-- TYPE MISMATCHES

117−hintToString hint =

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

118 case hint of

130 case hint of

119 CaseBranch branchNumber region ->

131 CaseBranch branchNumber region ->

132+ report

120− ( Just region

133+ (Just region)

134+ ( "The " ++ ordinalPair branchNumber

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

136+ )

137+ ( cmpHint

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

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\

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

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

142+ ]

123− )

143+ )

124

144

125 Case ->

145 Case ->

146+ report

126− ( Nothing

147+ Nothing

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

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

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

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

129− , Nothing

150+ )

151+ ( cmpHint

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

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

154+ []

130− )

155+ )

131

156

132 IfCondition ->

157 IfCondition ->

158+ report

133− ( Nothing

159+ Nothing

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

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

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

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

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

166+ ]

136− )

167+ )

137

168

138 IfBranches ->

169 IfBranches ->

170+ report

139− ( Nothing

171+ Nothing

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

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

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

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

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

178+ ]

142− )

179+ )

143

180

144 MultiIfBranch branchNumber region ->

181 MultiIfBranch branchNumber region ->

182+ report

145− ( Just region

183+ (Just region)

184+ ( "The " ++ ordinalPair branchNumber

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

186+ )

187+ ( cmpHint

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

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\

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

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

192+ ]

148− )

193+ )

149

194

150 If ->

195 If ->

196+ report

151− ( Nothing

197+ Nothing

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

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

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

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

154− , Nothing

200+ ( cmpHint

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

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

203+ []

155− )

204+ )

156

205

157 ListElement elementNumber region ->

206 ListElement elementNumber region ->

207+ report

158− ( Just region

208+ (Just region)

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

210+ ( cmpHint

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

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

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

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

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

161− )

216+ )

162

217

163 List ->

218 List ->

219+ report

164− ( Nothing

220+ Nothing

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

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

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

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

167− , Nothing

223+ )

224+ ( cmpHint

225+ "The list has type:"

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

227+ []

168− )

228+ )

169

229

170 BinopLeft op region ->

230 BinopLeft op region ->

231+ report

171− ( Just region

232+ (Just region)

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

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

173− , Nothing

234+ ( cmpHint

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

236+ "But the left argument is:"

237+ []

174− )

238+ )

175

239

176 BinopRight op region ->

240 BinopRight op region ->

241+ report

177− ( Just region

242+ (Just region)

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

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

179− , Nothing

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

180− )

251+ )

181

252

182 Binop op ->

253 Binop op ->

254+ report

183− ( Nothing

255+ Nothing

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

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

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

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

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

186− , Nothing

259+ )

260+ ( cmpHint

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

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

263+ []

187− )

264+ )

188

265

189 Function maybeName ->

266 Function maybeName ->

267+ report

190− ( Nothing

268+ Nothing

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

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

192− , Nothing

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

193− )

275+ )

194

276

195− UnexpectedArg maybeName index region ->

277+ UnexpectedArg maybeName 1 1 region ->

278+ report

196− ( Just region

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)

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

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

198− ++ " has an unexpected type."

291+ ++ " is causing a mismatch."

199− , Nothing

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

200− )

307+ )

201

308

202 FunctionArity maybeName expected actual region ->

309 FunctionArity maybeName expected actual region ->

203 let

310 let

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

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

205 in

312 in

313+ report

206− ( Just region

314+ (Just region)

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

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

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

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

209− , Nothing

317+ )

210− )

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

211

319

212 BadTypeAnnotation name ->

320 BadTypeAnnotation name ->

321+ report

213− ( Nothing

322+ Nothing

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

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

215− , Nothing

324+ ( cmpHint

325+ "The type annotation is saying:"

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

327+ []

216− )

328+ )

217

329

218 Instance name ->

330 Instance name ->

331+ report

219− ( Nothing

332+ Nothing

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

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

221− , Nothing

334+ ( cmpHint

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

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

337+ []

222− )

338+ )

223

339

224 Literal name ->

340 Literal name ->

341+ report

225− ( Nothing

342+ Nothing

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

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

227− , Nothing

344+ )

345+ ( cmpHint

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

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

348+ []

228− )

349+ )

229

350

230 Pattern patErr ->

351 Pattern patErr ->

231 let

352 let

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

233 case patErr of

354 case patErr of

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

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

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

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

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

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

237 PRecord -> "a record"

358 PRecord -> "a record"

238 in

359 in

360+ report

239− ( Nothing

361+ Nothing

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

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

241− , Nothing

363+ )

364+ ( cmpHint

365+ "This pattern matches things of type:"

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

367+ []

242− )

368+ )

243

369

244 Shader ->

370 Shader ->

371+ report

245− ( Nothing

372+ Nothing

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

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

247− , Nothing

374+ ( cmpHint

375+ "The shader block has this type:"

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

377+ []

248− )

378+ )

249

379

250 Range ->

380 Range ->

381+ report

251− ( Nothing

382+ Nothing

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

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

253− , Nothing

384+ ( cmpHint

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

386+ "But the high end is:"

387+ []

254− )

388+ )

255

389

256 Lambda ->

390 Lambda ->

391+ report

257− ( Nothing

392+ Nothing

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

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

259− , Nothing

394+ ( cmpHint

395+ "The anonymous function has type:"

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

397+ []

260− )

398+ )

261

399

262 Record ->

400 Record ->

401+ report

263− ( Nothing

402+ Nothing

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

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

265− , Nothing

404+ ( cmpHint

405+ "The record has type:"

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

407+ []

266− )

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

267

436

268

437

438+ordinalPair :: Int -> String

439+ordinalPair number =

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

441+

442+

269−prettyOperator :: Var.Canonical -> String

443+prettyName :: Var.Canonical -> String

270−prettyOperator (Var.Canonical _ opName) =

444+prettyName (Var.Canonical _ opName) =

271− if Help.isOp opName

445+ Help.functionName opName

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

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

274

446

275

447

276funcName :: Maybe Var.Canonical -> String

448funcName :: Maybe Var.Canonical -> String

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

280 "this function"

452 "this function"

281

453

282 Just var ->

454 Just var ->

283− "function " ++ prettyOperator var

455+ "function " ++ prettyName var

456+

457+

458+

459+-- MISMTACH REASONS

460+

284

461

462+flipReason :: Reason -> Reason

463+flipReason reason =

464+ case reason of

465+ MessyFields leftOnly rightOnly ->

466+ MessyFields rightOnly leftOnly

285

467

286−capitalize :: String -> String

468+ IntFloat ->

287−capitalize string =

469+ IntFloat

288− case string of

289− [] -> []

290− c : cs ->

291− Char.toUpper c : cs

292

470

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

293

489

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+

294−ordinalize :: Int -> String

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

295−ordinalize number =

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 =

296 let

615 let

297− remainder10 =

616+ selfReference =

298− number `mod` 10

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

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"

309 in

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

1{-# OPTIONS_GHC -Wall #-}

2{-# LANGUAGE OverloadedStrings #-}

3module Reporting.Report

4− ( Report(Report)

4+ ( Report

5− , simple

5+ , report

6 , toString

7 , toJson

8− , printError, printWarning

8+ , toHandle

9+ )

9− ) where

10+ where

11−import Control.Applicative ((<|>))

12−import Control.Monad.Writer (Writer, execWriter, tell)

13import Data.Aeson ((.=))

12import Data.Aeson ((.=))

14import qualified Data.Aeson.Types as Json

13import qualified Data.Aeson.Types as Json

15−import System.Console.ANSI

14+import System.IO (Handle)

16−import System.IO (hPutStr, stderr)

15+import Text.PrettyPrint.ANSI.Leijen

16+ ( Doc, (<>), displayS, displayIO, dullcyan, fillSep, hardline, renderPretty, text

17+ )

18import qualified Reporting.Region as R

19import qualified Reporting.Region as R

20+import qualified Reporting.Render.Code as Code

21+

22+

23+

24+-- BUILD REPORTS

21data Report = Report

27data Report = Report

22 { _title :: String

28 { _title :: String

23 , _highlight :: Maybe R.Region

29 , _highlight :: Maybe R.Region

24− , _preHint :: String

30+ , _preHint :: Doc

25− , _postHint :: String

31+ , _postHint :: Doc

26 }

32 }

29−simple :: String -> String -> String -> Report

35+report :: String -> Maybe R.Region -> String -> Doc -> Report

30−simple title pre post =

36+report title highlight pre post =

31− Report title Nothing pre post

37+ Report title highlight (fillSep (map text (words 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−

39−printError :: String -> R.Region -> Report -> String -> IO ()

40−printError location region report source =

41− render (ansi Error) location region report source

44−printWarning :: String -> R.Region -> Report -> String -> IO ()

41+-- REPORT TO JSON

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

64toJson :: [Json.Pair] -> Report -> (Maybe R.Region, [Json.Pair])

44toJson :: [Json.Pair] -> Report -> (Maybe R.Region, [Json.Pair])

@@ -66,177 +46,52 @@ toJson extraFields (Report title subregion pre post) =

66 let

46 let

67 fields =

47 fields =

68 [ "tag" .= title

48 [ "tag" .= title

69− , "overview" .= pre

49+ , "overview" .= displayS (renderPretty 1 80 pre) ""

70− , "details" .= post

50+ , "details" .= displayS (renderPretty 1 80 post) ""

71 ]

51 ]

72 in

52 in

73 (subregion, fields ++ extraFields)

53 (subregion, fields ++ extraFields)

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

57+-- REPORT TO DOC

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)

113

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

114

115

116−

117−-- REPORT HEADER

118−

119−messageBar :: Renderer m -> String -> String -> m ()

72+messageBar :: String -> String -> Doc

120−messageBar renderer tag location =

73+messageBar tag location =

121 let

74 let

75+ usedSpace =

122− usedSpace = 4 + length tag + 1 + length location

76+ 4 + length tag + 1 + length location

123 in

77 in

124− header renderer $

78+ dullcyan $ text $

125− "-- " ++ tag ++ " "

126− ++ replicate (max 1 (80 - usedSpace)) '-'

79+ "-- " ++ tag ++ " " ++ replicate (max 1 (80 - usedSpace)) '-' ++ " " ++ location

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

143

144− (|>) = flip ($)

145

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

203

204− lineNumber =

83+-- RENDER DOCS

205− replicate (width - length number) ' ' ++ number ++ "│"

206

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)

228

229− underline =

86+toString :: String -> R.Region -> Report -> String -> String

230− replicate (innerStart + width + 1) ' '

87+toString location region rprt source =

231− ++ replicate (max 1 (innerEnd - innerStart)) '^'

88+ displayS

89+ (renderPretty 1 80 (toDoc location region rprt source))

90+ ""

232

233− (|>) = flip ($)

234

235− trimmedSourceLine =

93+toHandle :: Handle -> String -> R.Region -> Report -> String -> IO ()

236− sourceLine

94+toHandle handle location region rprt source =

237− |> drop (start - 1)

95+ displayIO

238− |> take (end - start + 1)

96+ handle

239− |> (++) (replicate (start - 1) ' ')

97+ (renderPretty 1 80 (toDoc location region rprt source))

240− in

241− do addLineNumber renderer Nothing width lineNum trimmedSourceLine

242− accent renderer $ "\n" ++ underline

src/Reporting/Result.hs+3−3

@@ -6,14 +6,14 @@ import Control.Monad.Except (Except, runExcept)

7import qualified Reporting.Annotation as A

8import qualified Reporting.Region as R

9−import qualified Reporting.PrettyPrint as P

9+import qualified Reporting.Render.Type as RenderType

12-- TASK

14data Result warning error result =

15 Result

16− (Maybe P.Dealiaser, [A.Located warning])

16+ (Maybe RenderType.Localizer, [A.Located warning])

17 (RawResult [A.Located error] result)

@@ -70,7 +70,7 @@ addWarnings newWarnings (Result (dealiaser, warnings) rawResult) =

70 Result (dealiaser, newWarnings ++ warnings) rawResult

73−addDealiaser :: P.Dealiaser -> Result w e a -> Result w e a

73+addDealiaser :: RenderType.Localizer -> Result w e a -> Result w e a

74addDealiaser dealiaser (Result (_, warnings) rawResult) =

75 Result (Just dealiaser, warnings) rawResult

src/Reporting/Warning.hs+22−35

@@ -4,73 +4,60 @@ module Reporting.Warning where

5import Data.Aeson ((.=))

6import qualified Data.Aeson as Json

7−import qualified Text.PrettyPrint as P

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

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

10−import qualified AST.Helpers as Help

11import qualified AST.Module.Name as ModuleName

9import qualified AST.Module.Name as ModuleName

12import qualified AST.Type as Type

10import qualified AST.Type as Type

13import qualified Reporting.Annotation as A

11import qualified Reporting.Annotation as A

14−import qualified Reporting.PrettyPrint as P

12+import qualified Reporting.Error.Helpers as Help

15import qualified Reporting.Report as Report

13import qualified Reporting.Report as Report

14+import qualified Reporting.Render.Type as RenderType

15+

18-- ALL POSSIBLE WARNINGS

20+

20data Warning

21data Warning

21 = UnusedImport ModuleName.Raw

22 = UnusedImport ModuleName.Raw

22 | MissingTypeAnnotation String Type.Canonical

23 | MissingTypeAnnotation String Type.Canonical

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

27+-- TO REPORT

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

36−

37−toReport :: P.Dealiaser -> Warning -> Report.Report

30+toReport :: RenderType.Localizer -> Warning -> Report.Report

38−toReport dealiaser warning =

31+toReport localizer warning =

39 case warning of

32 case warning of

40 UnusedImport moduleName ->

33 UnusedImport moduleName ->

41− Report.simple

34+ Report.report

42 "unused import"

35 "unused import"

36+ Nothing

43 ("Module `" ++ ModuleName.toString moduleName ++ "` is unused.")

37 ("Module `" ++ ModuleName.toString moduleName ++ "` is unused.")

44− ""

38+ (text "Best to remove it. Don't save code quality for later!")

46 MissingTypeAnnotation name inferredType ->

40 MissingTypeAnnotation name inferredType ->

47− Report.simple

41+ Report.report

48 "missing type annotation"

42 "missing type annotation"

43+ Nothing

49− ("Top-level value `" ++ name ++ "` does not have a type annotation.")

44+ ("Top-level value " ++ Help.functionName name ++ " does not have a type annotation.")

50− ( "The type annotation you want looks something like this:\n\n"

45+ ( Help.stack

51− ++ P.render (P.nest 4 typeDoc)

46+ [ text "I inferred the type annotation so you can copy it into your code:"

47+ , RenderType.annotation localizer name inferredType

48+ ]

52 )

49 )

53− where

54− nameDoc =

55− if Help.isOp name then

56− P.parens (P.text name)

57− else

58− P.text name

60− typeDoc =

61− P.hang

62− (nameDoc <+> P.colon)

63− 4

64− (P.pretty dealiaser False inferredType)

67-- TO JSON

53-- TO JSON

55+

69−toJson :: P.Dealiaser -> FilePath -> A.Located Warning -> Json.Value

56+toJson :: RenderType.Localizer -> FilePath -> A.Located Warning -> Json.Value

70−toJson dealiaser filePath (A.A region warning) =

57+toJson localizer filePath (A.A region warning) =

71 let

58 let

72 (maybeRegion, additionalFields) =

59 (maybeRegion, additionalFields) =

73− Report.toJson [] (toReport dealiaser warning)

60+ Report.toJson [] (toReport localizer warning)

74 in

61 in

75 Json.object $

62 Json.object $

76 [ "file" .= filePath

63 [ "file" .= filePath

src/Type/Constrain/Expression.hs+82−85

@@ -3,7 +3,6 @@ module Type.Constrain.Expression where

4import Control.Arrow (second)

5import qualified Control.Monad as Monad

6−import qualified Data.List as List

7import qualified Data.Map as Map

6import qualified Data.Map as Map

9import qualified AST.Expression.General as E

8import qualified AST.Expression.General as E

@@ -28,7 +27,7 @@ constrain

28 -> Type

27 -> Type

29 -> IO TypeConstraint

28 -> IO TypeConstraint

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

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

32 (<?) = CInstance region

31 (<?) = CInstance region

33 in

32 in

34 case expression of

33 case expression of

@@ -40,23 +39,24 @@ constrain env annotatedExpr@(A.A region expression) tipe =

40 exists $ \unif ->

39 exists $ \unif ->

41 let

40 let

42 shaderTipe a u v =

41 shaderTipe a u v =

43− Env.get env Env.types "WebGL.Shader" <| a <| u <| v

42+ Env.getType env "WebGL.Shader" <| a <| u <| v

45− glTipe =

44+ glToType glTipe =

46− Env.get env Env.types . Lit.glTipeName

45+ Env.getType env (Lit.glTipeName glTipe)

48 makeRec accessor baseRec =

47 makeRec accessor baseRec =

49 let decls = accessor gltipe

48 let decls = accessor gltipe

50 in

49 in

51− if Map.size decls == 0

50+ if Map.size decls == 0 then

52− then baseRec

51+ baseRec

52+ else

53− else record (Map.map (\t -> [glTipe t]) decls) baseRec

53+ record (Map.map glToType decls) baseRec

55 attribute = makeRec Lit.attribute attr

56 uniform = makeRec Lit.uniform unif

57− varying = makeRec Lit.varying (termN EmptyRecord1)

57+ varying = makeRec Lit.varying (TermN EmptyRecord1)

58 in

59− return (CEqual Error.Shader region tipe (shaderTipe attribute uniform varying))

59+ return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)

61 E.Var var ->

62 let name = V.toString var

@@ -104,8 +104,8 @@ constrain env annotatedExpr@(A.A region expression) tipe =

104 constrainCase env region expr branches tipe

105

106 E.Data name exprs ->

107− do vars <- Monad.forM exprs $ \_ -> variable Flexible

107+ do vars <- Monad.forM exprs $ \_ -> mkVar Nothing

108− let pairs = zip exprs (map varN vars)

108+ let pairs = zip exprs (map VarN vars)

109 (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)

110 return $ ex vars (cs /\ name <? ctipe)

111 where

@@ -115,31 +115,31 @@ constrain env annotatedExpr@(A.A region expression) tipe =

115

116 E.Access expr label ->

117 exists $ \t ->

118− constrain env expr (record (Map.singleton label [tipe]) t)

118+ constrain env expr (record (Map.singleton label tipe) t)

119

120 E.Update expr fields ->

121 exists $ \t ->

122− do oldVars <- Monad.forM fields $ \_ -> variable Flexible

122+ do oldVars <- mapM (\_ -> mkVar Nothing) fields

123− let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))

123+ let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))

124 cOld <- ex oldVars <$> constrain env expr (record oldFields t)

125

126− newVars <- Monad.forM fields $ \_ -> variable Flexible

126+ newVars <- mapM (\_ -> mkVar Nothing) fields

127− let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))

127+ let newFields = Map.fromList (zip (map fst fields) (map VarN newVars))

128 let cNew = CEqual Error.Record region tipe (record newFields t)

129

130− cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN newVars)

130+ cs <- Monad.zipWithM (constrain env) (map snd fields) (map VarN newVars)

131

132 return $ cOld /\ ex newVars (CAnd (cNew : cs))

133

134 E.Record fields ->

135− do vars <- Monad.forM fields (\_ -> variable Flexible)

135+ do vars <- Monad.forM fields (\_ -> mkVar Nothing)

136 fieldCons <-

137 Monad.zipWithM

138 (constrain env)

139 (map snd fields)

140− (map varN vars)

140+ (map VarN vars)

141− let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

141+ let fields' = Map.fromList (zip (map fst fields) (map VarN vars))

142− let recordType = record fields' (termN EmptyRecord1)

142+ let recordType = record fields' (TermN EmptyRecord1)

143 return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region tipe recordType])))

144

145 E.Let defs body ->

@@ -178,14 +178,14 @@ constrainApp

178 -> Type

179 -> IO TypeConstraint

180constrainApp env region f args tipe =

181− do funcVar <- variable Flexible

181+ do funcVar <- mkVar Nothing

182− funcCon <- constrain env f (varN funcVar)

182+ funcCon <- constrain env f (VarN funcVar)

183

184 (vars, argCons, numberOfArgsCons, argMatchCons, _, returnVar) <-

185 argConstraints env maybeName region (length args) funcVar 1 args

186

187 let returnCon =

188− CEqual (Error.Function maybeName) region (varN returnVar) tipe

188+ CEqual (Error.Function maybeName) region (VarN returnVar) tipe

189

190 return $ ex (funcVar : vars) $

191 CAnd (funcCon : argCons ++ numberOfArgsCons ++ argMatchCons ++ [returnCon])

@@ -214,10 +214,10 @@ argConstraints env name region totalArgs overallVar index args =

214 return ([], [], [], [], Nothing, overallVar)

215

216 expr@(A.A subregion _) : rest ->

217− do argVar <- variable Flexible

217+ do argVar <- mkVar Nothing

218− argCon <- constrain env expr (varN argVar)

218+ argCon <- constrain env expr (VarN argVar)

219− argIndexVar <- variable Flexible

219+ argIndexVar <- mkVar Nothing

220− localReturnVar <- variable Flexible

220+ localReturnVar <- mkVar Nothing

221

222 (vars, argConRest, numberOfArgsRest, argMatchRest, restRegion, returnVar) <-

223 argConstraints env name region totalArgs localReturnVar (index + 1) rest

@@ -229,15 +229,15 @@ argConstraints env name region totalArgs overallVar index args =

229 CEqual

230 (Error.FunctionArity name (index - 1) totalArgs arityRegion)

231 region

232− (varN argIndexVar ==> varN localReturnVar)

232+ (VarN argIndexVar ==> VarN localReturnVar)

233− (varN overallVar)

233+ (VarN overallVar)

234

235 let argMatchCon =

236 CEqual

237− (Error.UnexpectedArg name index subregion)

237+ (Error.UnexpectedArg name index totalArgs subregion)

238 region

239− (varN argIndexVar)

239+ (VarN argIndexVar)

240− (varN argVar)

240+ (VarN argVar)

241

242 return

243 ( argVar : argIndexVar : localReturnVar : vars

@@ -262,26 +262,26 @@ constrainBinop

262 -> Type

263 -> IO TypeConstraint

264constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightRegion _) tipe =

265− do leftVar <- variable Flexible

265+ do leftVar <- mkVar Nothing

266− rightVar <- variable Flexible

266+ rightVar <- mkVar Nothing

267

268− leftCon <- constrain env leftExpr (varN leftVar)

268+ leftCon <- constrain env leftExpr (VarN leftVar)

269− rightCon <- constrain env rightExpr (varN rightVar)

269+ rightCon <- constrain env rightExpr (VarN rightVar)

270

271− leftVar' <- variable Flexible

271+ leftVar' <- mkVar Nothing

272− rightVar' <- variable Flexible

272+ rightVar' <- mkVar Nothing

273− answerVar <- variable Flexible

273+ answerVar <- mkVar Nothing

274

275− let opType = varN leftVar' ==> varN rightVar' ==> varN answerVar

275+ let opType = VarN leftVar' ==> VarN rightVar' ==> VarN answerVar

276

277 return $

278 ex [leftVar,rightVar,leftVar',rightVar',answerVar] $ CAnd $

279 [ leftCon

280 , rightCon

281 , CInstance region (V.toString op) opType

282− , CEqual (Error.BinopLeft op leftRegion) region (varN leftVar') (varN leftVar)

282+ , CEqual (Error.BinopLeft op leftRegion) region (VarN leftVar') (VarN leftVar)

283− , CEqual (Error.BinopRight op rightRegion) region (varN rightVar') (varN rightVar)

283+ , CEqual (Error.BinopRight op rightRegion) region (VarN rightVar') (VarN rightVar)

284− , CEqual (Error.Binop op) region tipe (varN answerVar)

284+ , CEqual (Error.Binop op) region tipe (VarN answerVar)

285 ]

286

287

@@ -302,12 +302,12 @@ constrainList env region exprs tipe =

302 return $ ex vars (CAnd (exprCons ++ cons))

303 where

304 elementConstraint expr@(A.A region' _) =

305− do var <- variable Flexible

305+ do var <- mkVar Nothing

306− con <- constrain env expr (varN var)

306+ con <- constrain env expr (VarN var)

307 return ( (var, region'), con )

308

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

311

312

313-- CONSTRAIN IF EXPRESSIONS

@@ -334,17 +334,17 @@ constrainIf env region branches finally tipe =

334 return $ ex (condVars ++ vars) (CAnd (condCons ++ branchExprCons ++ cons))

335 where

336 bool =

337− Env.get env Env.types "Bool"

337+ Env.getType env "Bool"

338

339 constrainCondition condition@(A.A condRegion _) =

340− do condVar <- variable Flexible

340+ do condVar <- mkVar Nothing

341− condCon <- constrain env condition (varN condVar)

341+ condCon <- constrain env condition (VarN condVar)

342− let boolCon = CEqual Error.IfCondition condRegion (varN condVar) bool

342+ let boolCon = CEqual Error.IfCondition condRegion (VarN condVar) bool

343 return (condVar, CAnd [ condCon, boolCon ])

344

345 constrainBranch expr@(A.A branchRegion _) =

346− do branchVar <- variable Flexible

346+ do branchVar <- mkVar Nothing

347− exprCon <- constrain env expr (varN branchVar)

347+ exprCon <- constrain env expr (VarN branchVar)

348 return

349 ( (branchVar, branchRegion)

350 , exprCon

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

355 [(thenVar, _), (elseVar, _)] ->

356 return

357 ( [thenVar,elseVar]

358− , [ CEqual Error.IfBranches region (varN thenVar) (varN elseVar)

358+ , [ CEqual Error.IfBranches region (VarN thenVar) (VarN elseVar)

359 , varToCon thenVar

360 ]

361 )

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

364 pairCons region Error.MultiIfBranch varToCon branchInfo

365

366 varToCon var =

367− CEqual Error.If region (varN var) tipe

367+ CEqual Error.If region (VarN var) tipe

368

369

370-- CONSTRAIN CASE EXPRESSIONS

@@ -377,27 +377,27 @@ constrainCase

377 -> Type

378 -> IO TypeConstraint

379constrainCase env region expr branches tipe =

380− do exprVar <- variable Flexible

380+ do exprVar <- mkVar Nothing

381− exprCon <- constrain env expr (varN exprVar)

381+ exprCon <- constrain env expr (VarN exprVar)

382

383 (branchInfo, branchExprCons) <-

384− unzip <$> mapM (branch (varN exprVar)) branches

384+ unzip <$> mapM (branch (VarN exprVar)) branches

385

386 (vars, cons) <- pairCons region Error.CaseBranch varToCon branchInfo

387

388 return $ ex (exprVar : vars) (CAnd (exprCon : branchExprCons ++ cons))

389 where

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

391− do branchVar <- variable Flexible

391+ do branchVar <- mkVar Nothing

392 fragment <- Pattern.constrain env pattern patternType

393− branchCon <- constrain env branchExpr (varN branchVar)

393+ branchCon <- constrain env branchExpr (VarN branchVar)

394 return

395 ( (branchVar, branchRegion)

396 , CLet [Fragment.toScheme fragment] branchCon

397 )

398

399 varToCon var =

400− CEqual Error.Case region tipe (varN var)

400+ CEqual Error.Case region tipe (VarN var)

401

402

403-- COLLECT PAIRS

@@ -419,11 +419,11 @@ pairCons

419pairCons region pairHint varToCon items =

420 let

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

423 in

424 case collectPairs 2 items of

425 Nothing ->

426− do var <- variable Flexible

426+ do var <- mkVar Nothing

427 return ([var], [varToCon var])

428

429 Just (pairs, var) ->

@@ -499,7 +499,8 @@ constrainDef env info (Canonical.Definition _ (A.A patternRegion pattern) expr m

499 (P.Var name, Nothing) ->

500 constrainUnannotatedDef env info qs patternRegion name expr

501

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"

503

504

505

505constrainAnnotatedDef

506constrainAnnotatedDef

@@ -514,28 +515,26 @@ constrainAnnotatedDef

514 -> IO Info

515 -> IO Info

515constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe =

516constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe =

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

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

517− rigidVars <- Monad.forM qs (\_ -> variable Rigid)

518+ rigidVars <- mapM mkRigid qs

518−

519− flexiVars <- Monad.forM qs (\_ -> variable Flexible)

520

519

521− let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars

520+ flexiVars <- mapM mkNamedVar qs

522

521

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)

524

523

525 (vars, typ) <- Env.instantiateType env tipe Map.empty

524 (vars, typ) <- Env.instantiateType env tipe Map.empty

526

525

527 let scheme =

526 let scheme =

528 Scheme

527 Scheme

529− { rigidQuantifiers = []

528+ { _rigidQuantifiers = []

530− , flexibleQuantifiers = flexiVars ++ vars

529+ , _flexibleQuantifiers = flexiVars ++ vars

531− , constraint = CTrue

530+ , _constraint = CTrue

532− , header = Map.singleton name (A.A patternRegion typ)

531+ , _header = Map.singleton name (A.A patternRegion typ)

533− }

532+ }

534−

533+

535− var <- variable Flexible

534+ var <- mkVar Nothing

536− defCon <- constrain env' expr (varN var)

535+ defCon <- constrain env' expr (VarN var)

537 let annCon =

536 let annCon =

538− CEqual (Error.BadTypeAnnotation name) typeRegion typ (varN var)

537+ CEqual (Error.BadTypeAnnotation name) typeRegion typ (VarN var)

539

538

540 return $ info

539 return $ info

541 { iSchemes = scheme : iSchemes info

540 { iSchemes = scheme : iSchemes info

@@ -553,15 +552,13 @@ constrainUnannotatedDef

553 -> IO Info

552 -> IO Info

554constrainUnannotatedDef env info qs patternRegion name expr =

553constrainUnannotatedDef env info qs patternRegion name expr =

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

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

556− rigidVars <- Monad.forM qs (\_ -> variable Rigid)

555+ rigidVars <- mapM mkRigid qs

557−

558− v <- variable Flexible

559

556

560− let tipe = varN v

557+ v <- mkVar Nothing

561

558

562− let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars

559+ let tipe = VarN v

563

560

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)

565

562

566 con <- constrain env' expr tipe

563 con <- constrain env' expr tipe

567

564

src/Type/Constrain/Literal.hs+27−16

@@ -14,24 +14,35 @@ constrain

14 -> T.Type

15 -> IO T.TypeConstraint

16constrain env region literal tipe =

17− do tipe' <- litType

17+ do definiteType <- litType

18− return (T.CEqual (Error.Literal name) region tipe tipe')

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

19 where

20 prim name =

21− return (Env.get env Env.types name)

21+ return (Env.getType env name)

23− litType =

23+ (name, litType) =

24 case literal of

25− L.IntNum _ -> T.varN `fmap` T.variable (T.Is T.Number)

25+ L.IntNum _ ->

26− L.FloatNum _ -> prim "Float"

26+ ( "number"

27− L.Chr _ -> prim "Char"

27+ , T.VarN <$> T.mkVar (Just T.Number)

28− L.Str _ -> prim "String"

28+ )

29− L.Boolean _ -> prim "Bool"

31− name =

32− case literal of

33− L.IntNum _ -> "number"

34− L.FloatNum _ -> "float"

30+ L.FloatNum _ ->

31+ ( "float"

32+ , prim "Float"

33+ )

34+

35+ L.Chr _ ->

35− L.Chr _ -> "character"

36+ ( "character"

37+ , prim "Char"

38+ )

39+

40+ L.Str _ ->

36− L.Str _ -> "string"

41+ ( "string"

42+ , prim "String"

43+ )

44+

37− L.Boolean _ -> "boolean"

45+ L.Boolean _ ->

46+ ( "boolean"

47+ , prim "Bool"

48+ )

src/Type/Constrain/Pattern.hs+11−12

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

1−{-# LANGUAGE FlexibleInstances #-}

2module Type.Constrain.Pattern where

1module Type.Constrain.Pattern where

4import Control.Arrow (second)

3import Control.Arrow (second)

@@ -26,7 +25,7 @@ constrain env (A.A region pattern) tipe =

26 CEqual (Error.Pattern patternError) region leftType rightType

25 CEqual (Error.Pattern patternError) region leftType rightType

28 rvar v =

27 rvar v =

29− A.A region (varN v)

28+ A.A region (VarN v)

30 in

29 in

31 case pattern of

30 case pattern of

32 P.Anything ->

31 P.Anything ->

@@ -37,22 +36,22 @@ constrain env (A.A region pattern) tipe =

37 return $ emptyFragment { typeConstraint = c }

36 return $ emptyFragment { typeConstraint = c }

39 P.Var name ->

38 P.Var name ->

40− do v <- variable Flexible

39+ do variable <- mkVar Nothing

41 return $ Fragment

40 return $ Fragment

42− { typeEnv = Map.singleton name (rvar v)

41+ { typeEnv = Map.singleton name (rvar variable)

43− , vars = [v]

42+ , vars = [variable]

44 , typeConstraint =

43 , typeConstraint =

45− equal (Error.PVar name) (varN v) tipe

44+ equal (Error.PVar name) (VarN variable) tipe

46 }

45 }

48 P.Alias name p ->

47 P.Alias name p ->

49− do v <- variable Flexible

48+ do variable <- mkVar Nothing

50 fragment <- constrain env p tipe

49 fragment <- constrain env p tipe

51 return $ fragment

50 return $ fragment

52− { typeEnv = Map.insert name (rvar v) (typeEnv fragment)

51+ { typeEnv = Map.insert name (rvar variable) (typeEnv fragment)

53− , vars = v : vars fragment

52+ , vars = variable : vars fragment

54 , typeConstraint =

53 , typeConstraint =

55− equal (Error.PAlias name) (varN v) tipe

54+ equal (Error.PAlias name) (VarN variable) tipe

56 /\ typeConstraint fragment

55 /\ typeConstraint fragment

57 }

56 }

@@ -73,13 +72,13 @@ constrain env (A.A region pattern) tipe =

74 P.Record fields ->

73 P.Record fields ->

75 do pairs <-

74 do pairs <-

76− mapM (\name -> (,) name <$> variable Flexible) fields

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

78 let tenv =

77 let tenv =

79 Map.fromList (map (second rvar) pairs)

78 Map.fromList (map (second rvar) pairs)

81 let unannotatedTenv =

80 let unannotatedTenv =

82− Map.map (\v -> [A.drop v]) tenv

81+ Map.map A.drop tenv

84 con <- exists $ \t ->

83 con <- exists $ \t ->

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

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

src/Type/Environment.hs+104−93

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

1+{-# OPTIONS_GHC -Wall #-}

1−module Type.Environment where

2+module Type.Environment

3+ ( Environment

4+ , initialize

5+ , getType, freshDataScheme, ctorNames

6+ , addValues

7+ , instantiateType

8+ )

9+ where

3−import Control.Monad (forM)

4import qualified Control.Monad.State as State

11import qualified Control.Monad.State as State

5−import qualified Data.Traversable as Traverse

12+import qualified Data.List as List

13+import Data.Map ((!))

6import qualified Data.Map as Map

14import qualified Data.Map as Map

7import qualified Data.Set as Set

15import qualified Data.Set as Set

8−import Data.List (isPrefixOf)

10import qualified AST.Type as T

17import qualified AST.Type as T

11import qualified AST.Variable as V

18import qualified AST.Variable as V

@@ -18,22 +25,22 @@ type VarDict = Map.Map String Variable

20data Environment = Environment

27data Environment = Environment

21− { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))

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

22− , types :: TypeDict

29+ , _types :: TypeDict

23− , value :: TypeDict

30+ , _value :: TypeDict

24 }

31 }

27−initialEnvironment :: [Module.CanonicalAdt] -> IO Environment

34+initialize :: [Module.CanonicalAdt] -> IO Environment

28−initialEnvironment datatypes =

35+initialize datatypes =

29 do types <- makeTypes datatypes

36 do types <- makeTypes datatypes

30 let env =

37 let env =

31 Environment

38 Environment

32− { constructor = Map.empty

39+ { _constructor = Map.empty

33− , value = Map.empty

40+ , _value = Map.empty

34− , types = types

41+ , _types = types

35 }

42 }

36− return $ env { constructor = makeConstructors env datatypes }

43+ return $ env { _constructor = makeConstructors env datatypes }

39makeTypes :: [Module.CanonicalAdt] -> IO TypeDict

46makeTypes :: [Module.CanonicalAdt] -> IO TypeDict

@@ -43,14 +50,14 @@ makeTypes datatypes =

43 return (Map.fromList (adts ++ bs))

50 return (Map.fromList (adts ++ bs))

44 where

51 where

45 makeImported :: (V.Canonical, Module.AdtInfo V.Canonical) -> IO (String, Type)

52 makeImported :: (V.Canonical, Module.AdtInfo V.Canonical) -> IO (String, Type)

46− makeImported (var, _) =

53+ makeImported (name, _) =

47− do tvar <- namedVar Constant var

54+ do tvar <- mkAtom name

48− return (V.toString var, varN tvar)

55+ return (V.toString name, VarN tvar)

50 makeBuiltin :: (String, Int) -> IO (String, Type)

57 makeBuiltin :: (String, Int) -> IO (String, Type)

51 makeBuiltin (name, _) =

58 makeBuiltin (name, _) =

52− do name' <- namedVar Constant (V.builtin name)

59+ do name' <- mkAtom (V.builtin name)

53− return (name, varN name')

60+ return (name, VarN name')

55 builtins :: [(String, Int)]

62 builtins :: [(String, Int)]

56 builtins =

63 builtins =

@@ -72,17 +79,17 @@ makeConstructors env datatypes =

72 Map.fromList builtins

79 Map.fromList builtins

73 where

80 where

74 list t =

81 list t =

75− (types env Map.! "List") <| t

82+ (_types env ! "List") <| t

77 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

84 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

78 inst numTVars tipe =

85 inst numTVars tipe =

79− do vars <- forM [1..numTVars] $ \_ -> variable Flexible

86+ do vars <- mapM (\_ -> mkVar Nothing) [1..numTVars]

80− let (args, result) = tipe (map (varN) vars)

87+ let (args, result) = tipe (map (VarN) vars)

81 return (length args, vars, args, result)

88 return (length args, vars, args, result)

83 tupleCtor n =

90 tupleCtor n =

84 let name = "_Tuple" ++ show n

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

87 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]

94 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]

88 builtins =

95 builtins =

@@ -112,44 +119,62 @@ ctorToType env (name, (tvars, ctors)) =

112 return (types, returnType)

119 return (types, returnType)

113

120

114

121

122+

123+-- ACCESS TYPES

124+

125+

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

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

116−get env subDict key =

127+get subDict env key =

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

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

118 where

129 where

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

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

120

131

121

132

122−freshDataScheme

123− :: Environment

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

124− -> String

134+getType =

125− -> IO (Int, [Variable], [Type], Type)

135+ get _types

126−freshDataScheme env name =

127− get env constructor name

128

136

129

137

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+

130−instantiateType

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

131− :: Environment

132− -> T.Canonical

133− -> VarDict

134− -> IO ([Variable], Type)

135instantiateType env sourceType dict =

167instantiateType env sourceType dict =

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

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

137 return (Map.elems dict', tipe)

169 return (Map.elems dict', tipe)

138

170

139

171

140−instantiator

141− :: Environment

142− -> T.Canonical

143− -> State.StateT VarDict IO Type

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

144instantiator env sourceType =

173instantiator env sourceType =

145 instantiatorHelp env Set.empty sourceType

174 instantiatorHelp env Set.empty sourceType

146

175

147

176

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

153instantiatorHelp env aliasVars sourceType =

178instantiatorHelp env aliasVars sourceType =

154 let go = instantiatorHelp env aliasVars

179 let go = instantiatorHelp env aliasVars

155 in

180 in

@@ -157,70 +182,56 @@ instantiatorHelp env aliasVars sourceType =

157 T.Lambda t1 t2 ->

182 T.Lambda t1 t2 ->

158 (==>) <$> go t1 <*> go t2

183 (==>) <$> go t1 <*> go t2

159

184

160− T.Var x ->

185+ T.Var name ->

161− do dict <- State.get

162− case Set.member x aliasVars of

186+ if Set.member name aliasVars then

163− True ->

164− return (PlaceHolder x)

187+ return (PlaceHolder name)

165− False ->

188+

189+ else

190+ do dict <- State.get

166− case Map.lookup x dict of

191+ case Map.lookup name dict of

167− Just v ->

192+ Just variable ->

168− return (varN v)

193+ return (VarN variable)

169−

194+

170− Nothing ->

195+ Nothing ->

171− do v <- State.liftIO $ namedVar flex (V.local x)

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

172− State.put (Map.insert x v dict)

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

173− return (varN v)

198+ return (VarN variable)

174− where

175− flex | "number" `isPrefixOf` x = Is Number

176− | "comparable" `isPrefixOf` x = Is Comparable

177− | "appendable" `isPrefixOf` x = Is Appendable

178− | otherwise = Flexible

179

199

180 T.Aliased name args aliasType ->

200 T.Aliased name args aliasType ->

181− do args' <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args

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

182− aliasedType' <-

202+ realType <-

183 case aliasType of

203 case aliasType of

184 T.Filled tipe ->

204 T.Filled tipe ->

185 instantiatorHelp env Set.empty tipe

205 instantiatorHelp env Set.empty tipe

206+

186 T.Holey tipe ->

207 T.Holey tipe ->

187 instantiatorHelp env (Set.fromList (map fst args)) tipe

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

188

209

189− case aliasedType' of

210+ return (AliasN name targs realType)

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

206

211

207 T.Type name ->

212 T.Type name ->

208− case Map.lookup (V.toString name) (types env) of

213+ case Map.lookup (V.toString name) (_types env) of

214+ Just tipe ->

209− Just t -> return t

215+ return tipe

216+

210 Nothing ->

217 Nothing ->

211 error $

218 error $

212 "Could not find type constructor `" ++

219 "Could not find type constructor `" ++

213 V.toString name ++ "` while checking types."

220 V.toString name ++ "` while checking types."

214

221

215− T.App t ts ->

222+ T.App func args ->

216− do t' <- go t

223+ do tfunc <- go func

217− ts' <- mapM go ts

224+ targs <- mapM go args

218− return $ foldl (<|) t' ts'

225+ return $ foldl (<|) tfunc targs

219

226

220 T.Record fields ext ->

227 T.Record fields ext ->

221− do fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)

228+ do tfields <- traverse go (Map.fromList fields)

222− ext' <-

229+ text <-

223 case ext of

230 case ext of

231+ Nothing ->

224− Nothing -> return $ termN EmptyRecord1

232+ return $ TermN EmptyRecord1

233+

225− Just x -> go x

234+ Just extType ->

235+ go extType

236+

226− return $ termN (Record1 fields' ext')

237+ return $ TermN (Record1 tfields text)

src/Type/Inference.hs+5−6

@@ -42,13 +42,12 @@ infer interfaces modul =

42genConstraints

43 :: Module.Interfaces

44 -> Module.CanonicalModule

45− -> IO (Env.TypeDict, T.TypeConstraint)

45+ -> IO (Map.Map String T.Type, T.TypeConstraint)

46genConstraints interfaces modul =

47− do env <-

48− Env.initialEnvironment (canonicalizeAdts interfaces modul)

47+ do env <- Env.initialize (canonicalizeAdts interfaces modul)

50 ctors <-

49 ctors <-

51− forM (Map.keys (Env.constructor env)) $ \name ->

50+ forM (Env.ctorNames env) $ \name ->

52 do (_, vars, args, result) <- Env.freshDataScheme env name

51 do (_, vars, args, result) <- Env.freshDataScheme env name

53 return (name, (vars, foldr (T.==>) result args))

52 return (name, (vars, foldr (T.==>) result args))

@@ -60,10 +59,10 @@ genConstraints interfaces modul =

60 let header = Map.map snd (Map.fromList allTypes)

59 let header = Map.map snd (Map.fromList allTypes)

61 let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]

60 let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]

63− fvar <- T.variable T.Flexible

62+ fvar <- T.mkVar Nothing

65 constraint <-

64 constraint <-

66− TcExpr.constrain env (program (body modul)) (T.varN fvar)

65+ TcExpr.constrain env (program (body modul)) (T.VarN fvar)

68 return (header, environ constraint)

67 return (header, environ constraint)

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

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

4import Control.Monad

5−import Control.Monad.State (StateT, execStateT, liftIO)

5+import Control.Monad.State (execStateT, liftIO)

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

7import qualified Data.Foldable as F

8import qualified Data.List as List

@@ -14,21 +14,22 @@ import qualified AST.Type as Type

14import qualified Reporting.Annotation as A

15import qualified Reporting.Error.Type as Error

16import qualified Type.State as TS

17−import Type.Type

17+import Type.Type as Type

18import Type.Unify

21+

21{-| Every variable has rank less than or equal to the maxRank of the pool.

22{-| Every variable has rank less than or equal to the maxRank of the pool.

22This sorts variables into the young and old pools accordingly.

23This sorts variables into the young and old pools accordingly.

23-}

24-}

24−generalize :: TS.Pool -> StateT TS.SolverState IO ()

25+generalize :: TS.Pool -> TS.Solver ()

25generalize youngPool =

26generalize youngPool =

26 do youngMark <- TS.uniqueMark

27 do youngMark <- TS.uniqueMark

27 let youngRank = TS.maxRank youngPool

28 let youngRank = TS.maxRank youngPool

28 let insert dict var =

29 let insert dict var =

29 do descriptor <- liftIO $ UF.descriptor var

30 do descriptor <- liftIO $ UF.descriptor var

30− liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })

31+ liftIO $ UF.modifyDescriptor var (\desc -> desc { _mark = youngMark })

31− return $ Map.insertWith (++) (rank descriptor) [var] dict

32+ return $ Map.insertWith (++) (_rank descriptor) [var] dict

33 -- Sort the youngPool variables by rank.

34 -- Sort the youngPool variables by rank.

34 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)

35 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)

@@ -58,63 +59,98 @@ generalize youngPool =

58 True -> return ()

59 True -> return ()

59 False -> do

60 False -> do

60 desc <- liftIO $ UF.descriptor var

61 desc <- liftIO $ UF.descriptor var

61− case rank desc < youngRank of

62+ case _rank desc < youngRank of

63+ True ->

62− True -> TS.register var >> return ()

64+ TS.register var >> return ()

63− False -> do

65+ False ->

64− let flex' = case flex desc of { Flexible -> Rigid ; other -> other }

65− liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })

66+ liftIO $ UF.setDescriptor var $ desc

67+ { _rank = noRank

68+ , _content = rigidify (_content desc)

69+ }

67 mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)

71 mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)

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+

70-- adjust the ranks of variables such that ranks never increase as you

84-- adjust the ranks of variables such that ranks never increase as you

71-- move deeper into a variable.

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

73adjustRank youngMark visitedMark groupRank var =

87adjustRank youngMark visitedMark groupRank var =

74 do descriptor <- liftIO $ UF.descriptor var

88 do descriptor <- liftIO $ UF.descriptor var

75− case () of

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 =

76− () | mark descriptor == youngMark ->

94+ if _mark descriptor == youngMark then

95+

77− do -- Set the variable as marked first because it may be cyclic.

96+ do -- Set the variable as marked first because it may be cyclic.

78− liftIO $ UF.modifyDescriptor var $ \desc ->

97+ liftIO $ UF.modifyDescriptor var $ \desc ->

79− desc { mark = visitedMark }

98+ desc { _mark = visitedMark }

80− rank' <- maybe (return groupRank) adjustTerm (structure descriptor)

99+

100+ maxRank <-

101+ adjustRankContent youngMark visitedMark groupRank (_content descriptor)

102+

81− liftIO $ UF.modifyDescriptor var $ \desc ->

103+ liftIO $ UF.modifyDescriptor var $ \desc ->

82− desc { rank = rank' }

104+ desc { _rank = maxRank }

105+

83− return rank'

106+ return maxRank

84−

107+

85− | mark descriptor /= visitedMark ->

108+ else if _mark descriptor /= visitedMark then

109+

86− do let rank' = min groupRank (rank descriptor)

110+ do let minRank = min groupRank (_rank descriptor)

87− liftIO $ UF.setDescriptor var (descriptor { mark = visitedMark, rank = rank' })

111+ liftIO $ UF.setDescriptor var (descriptor { _mark = visitedMark, _rank = minRank })

88− return rank'

112+ return minRank

89−

113+

90− | otherwise ->

114+ else

115+

91− return (rank descriptor)

116+ return (_rank descriptor)

92− where

117+

93− adjust =

118+

119+adjustRankContent :: Int -> Int -> Int -> Content -> TS.Solver Int

120+adjustRankContent youngMark visitedMark groupRank content =

121+ let

94− adjustRank youngMark visitedMark groupRank

122+ go = adjustRank youngMark visitedMark groupRank

95−

123+ in

96− adjustTerm term =

124+ case content of

97− case term of

125+ Error ->

98− App1 a b ->

126+ return groupRank

99− max `liftM` adjust a `ap` adjust b

127+

100−

128+ Atom _ ->

101− Fun1 a b ->

129+ return groupRank

102− max `liftM` adjust a `ap` adjust b

130+

103−

131+ Var _ _ _ ->

104− Var1 x ->

132+ return groupRank

105− adjust x

133+

106−

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+

107− EmptyRecord1 ->

143+ Structure EmptyRecord1 ->

108− return outermostRank

144+ return outermostRank

109−

145+

110− Record1 fields extension ->

146+ Structure (Record1 fields extension) ->

111− do ranks <- mapM adjust (concat (Map.elems fields))

147+ maximum <$> mapM go (extension : Map.elems fields)

112− rnk <- adjust extension

148+

113− return . maximum $ rnk : ranks

114

149

115

150

116-- SOLVER

151-- SOLVER

117

152

153+

118solve :: TypeConstraint -> ExceptT [A.Located Error.Error] IO TS.SolverState

154solve :: TypeConstraint -> ExceptT [A.Located Error.Error] IO TS.SolverState

119solve constraint =

155solve constraint =

120 do state <-

156 do state <-

@@ -126,7 +162,7 @@ solve constraint =

126 throwError errors

162 throwError errors

127

163

128

164

129−actuallySolve :: TypeConstraint -> StateT TS.SolverState IO ()

165+actuallySolve :: TypeConstraint -> TS.Solver ()

130actuallySolve constraint =

166actuallySolve constraint =

131 case constraint of

167 case constraint of

132 CTrue ->

168 CTrue ->

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

151

187

152 CLet schemes constraint' ->

188 CLet schemes constraint' ->

153 do oldEnv <- TS.getEnv

189 do oldEnv <- TS.getEnv

154− headers <- Map.unions `fmap` mapM solveScheme schemes

190+ headers <- Map.unions <$> mapM solveScheme schemes

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

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

156 actuallySolve constraint'

192 actuallySolve constraint'

157 mapM occurs $ Map.toList headers

193 mapM occurs $ Map.toList headers

@@ -165,17 +201,17 @@ actuallySolve constraint =

165 TS.makeInstance tipe

201 TS.makeInstance tipe

166

202

167 Nothing ->

203 Nothing ->

168− if List.isPrefixOf "Native." name

204+ if List.isPrefixOf "Native." name then

169− then liftIO (variable Flexible)

205+ liftIO (mkVar Nothing)

206+

207+ else

170− else error ("Could not find `" ++ name ++ "` when solving type constraints.")

208+ error ("Could not find `" ++ name ++ "` when solving type constraints.")

171

209

172 t <- TS.flatten term

210 t <- TS.flatten term

173 unify (Error.Instance name) region freshCopy t

211 unify (Error.Instance name) region freshCopy t

174

212

175

213

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

179solveScheme scheme =

215solveScheme scheme =

180 let

216 let

181 flatten (A.A region term) =

217 flatten (A.A region term) =

@@ -210,26 +246,37 @@ solveScheme scheme =

210-- Checks that all of the given variables belong to distinct equivalence classes.

246-- Checks that all of the given variables belong to distinct equivalence classes.

211-- Also checks that their structure is Nothing, so they represent a variable, not

247-- Also checks that their structure is Nothing, so they represent a variable, not

212-- a more complex term.

248-- a more complex term.

213−allDistinct :: [Variable] -> StateT TS.SolverState IO ()

249+allDistinct :: [Variable] -> TS.Solver ()

214allDistinct vars =

250allDistinct vars =

215− do seen <- TS.uniqueMark

251+ do seenMark <- TS.uniqueMark

216 forM_ vars $ \var ->

252 forM_ vars $ \var ->

217 do desc <- liftIO $ UF.descriptor var

253 do desc <- liftIO $ UF.descriptor var

218− case structure desc of

254+ case _content desc of

219− Just _ ->

255+ Structure _ ->

220− crash "Cannot generalize something that is not a type variable."

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

221

270

222− Nothing ->

271+ else

223− if mark desc == seen

224− then crash "Duplicate variable during generalization."

225− else liftIO (UF.setDescriptor var (desc { mark = seen }))

272+ liftIO (UF.setDescriptor var (desc { _mark = seenMark }))

226

273

227

274

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

275-- 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 ()

230isGeneric var =

277isGeneric var =

231 do desc <- liftIO $ UF.descriptor var

278 do desc <- liftIO $ UF.descriptor var

232− if rank desc == noRank

279+ if _rank desc == noRank

233 then return ()

280 then return ()

234 else crash "Unable to generalize a type variable. It is not unranked."

281 else crash "Unable to generalize a type variable. It is not unranked."

235

282

@@ -237,59 +284,66 @@ isGeneric var =

237crash :: String -> a

284crash :: String -> a

238crash msg =

285crash msg =

239 error $

286 error $

240− "It looks like something went wrong with the type inference algorithm.\n"

287+ "It looks like something went wrong with the type inference algorithm.\n\n"

241− ++ msg ++ "\n"

288+ ++ msg ++ "\n\n"

242 ++ "Please create a minimal example that triggers this problem and report it to\n"

289 ++ "Please create a minimal example that triggers this problem and report it to\n"

243 ++ "<https://github.com/elm-lang/elm-compiler/issues>"

290 ++ "<https://github.com/elm-lang/elm-compiler/issues>"

244

291

245

292

293+

294+-- OCCURS CHECK

295+

296+

246−occurs :: (String, A.Located Variable) -> StateT TS.SolverState IO ()

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

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

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

248− do maybePair <- liftIO $ occursHelp [] variable

299+ do maybeInfinite <- liftIO $ occursHelp [] variable

249− case maybePair of

300+ case maybeInfinite of

250 Nothing ->

301 Nothing ->

251 return ()

302 return ()

252

303

253− Just (t1, t2) ->

304+ Just infiniteType ->

254− let

305+ do overallType <- liftIO (Type.toSrcType variable)

255− info = Error.InfiniteTypeInfo name t1 t2

256− in

257− TS.addError region (Error.InfiniteType info)

306+ TS.addError region (Error.InfiniteType name overallType infiniteType)

258

307

259

308

260−occursHelp

261− :: [Variable]

262− -> Variable

263− -> IO (Maybe (Type.Canonical, Type.Canonical))

309+occursHelp :: [Variable] -> Variable -> IO (Maybe Type.Canonical)

264occursHelp seen var =

310occursHelp seen var =

265 if elem var seen then

311 if elem var seen then

266− do desc <- UF.descriptor var

312+ do infiniteDescriptor <- UF.descriptor var

313+ structureVar <- UF.fresh infiniteDescriptor

267− UF.setDescriptor var (desc { structure = Nothing })

314+ UF.setDescriptor var (infiniteDescriptor { _content = Error })

268− var' <- UF.fresh desc

269− srcVar <- toSrcType var

315+ srcVar <- Type.toSrcType structureVar

270− srcVar' <- toSrcType var'

271− return (Just (srcVar, srcVar'))

316+ return (Just srcVar)

317+

272 else

318 else

273 do desc <- UF.descriptor var

319 do desc <- UF.descriptor var

274− case structure desc of

320+ case _content desc of

275− Nothing ->

321+ Atom _ ->

276 return Nothing

322 return Nothing

277

323

278− Just struct ->

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

279− let go = occursHelp (var:seen)

336+ go = occursHelp (var:seen)

280 in

337 in

281− case struct of

338+ case term of

282 App1 a b ->

339 App1 a b ->

283 (<|>) <$> go a <*> go b

340 (<|>) <$> go a <*> go b

284

341

285 Fun1 a b ->

342 Fun1 a b ->

286 (<|>) <$> go a <*> go b

343 (<|>) <$> go a <*> go b

287

344

288− Var1 a ->

289− go a

290−

291 EmptyRecord1 ->

345 EmptyRecord1 ->

292 return Nothing

346 return Nothing

293

347

294 Record1 fields ext ->

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

1+{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE MultiParamTypeClasses #-}

3module Type.State where

2module Type.State where

5−import Control.Applicative ((<|>))

6−import Control.Monad.State

4+import qualified Control.Monad.State as State

7import Data.Map ((!))

5import Data.Map ((!))

8import qualified Data.Map as Map

6import qualified Data.Map as Map

9−import qualified Data.Traversable as Traversable

10import qualified Data.UnionFind.IO as UF

7import qualified Data.UnionFind.IO as UF

12import qualified Reporting.Annotation as A

9import qualified Reporting.Annotation as A

@@ -37,6 +34,9 @@ emptyPool =

37type Env = Map.Map String (A.Located Variable)

34type Env = Map.Map String (A.Located Variable)

37+type Solver = State.StateT SolverState IO

38+

39+

40-- Keeps track of the environment, type variable pool, and a list of errors

41data SolverState = SS

42 { sEnv :: Env

@@ -58,191 +58,257 @@ initialState =

58 }

61−modifyEnv :: (MonadState SolverState m) => (Env -> Env) -> m ()

61+modifyEnv :: (Env -> Env) -> Solver ()

62modifyEnv f =

63− modify $ \state -> state { sEnv = f (sEnv state) }

63+ State.modify $ \state -> state { sEnv = f (sEnv state) }

66−modifyPool :: (MonadState SolverState m) => (Pool -> Pool) -> m ()

66+modifyPool :: (Pool -> Pool) -> Solver ()

67modifyPool f =

68− modify $ \state -> state { sPool = f (sPool state) }

68+ State.modify $ \state -> state { sPool = f (sPool state) }

71−addError :: R.Region -> Error.Error -> StateT SolverState IO ()

71+addError :: R.Region -> Error.Error -> Solver ()

72addError 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 }

76−switchToPool :: (MonadState SolverState m) => Pool -> m ()

76+switchToPool :: Pool -> Solver ()

77switchToPool pool =

78 modifyPool (\_ -> pool)

81−getPool :: StateT SolverState IO Pool

81+getPool :: Solver Pool

82getPool =

83− gets sPool

83+ State.gets sPool

86−getEnv :: StateT SolverState IO Env

86+getEnv :: Solver Env

87getEnv =

88− gets sEnv

88+ State.gets sEnv

91−saveLocalEnv :: StateT SolverState IO ()

91+saveLocalEnv :: Solver ()

92saveLocalEnv =

93 do currentEnv <- getEnv

94− modify $ \state -> state { sSavedEnv = currentEnv }

94+ State.modify $ \state -> state { sSavedEnv = currentEnv }

97−uniqueMark :: StateT SolverState IO Int

97+uniqueMark :: Solver Int

98uniqueMark =

99− do state <- get

99+ do state <- State.get

100 let mark = sMark state

101− put $ state { sMark = mark + 1 }

101+ State.put $ state { sMark = mark + 1 }

102 return mark

103

104

105−nextRankPool :: StateT SolverState IO Pool

105+nextRankPool :: Solver Pool

106nextRankPool =

107 do pool <- getPool

108 return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }

109

110

111−register :: Variable -> StateT SolverState IO Variable

111+register :: Variable -> Solver Variable

112register variable =

113 do modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }

114 return variable

115

116

117−introduce :: Variable -> StateT SolverState IO Variable

117+introduce :: Variable -> Solver Variable

118introduce variable =

119 do pool <- getPool

120− liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })

120+ State.liftIO $ UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank pool })

121 register variable

122

123

124−flatten :: Type -> StateT SolverState IO Variable

124+flatten :: Type -> Solver Variable

125flatten term =

126 flattenHelp Map.empty term

127

128

129−flattenHelp :: Map.Map String Variable -> Type -> StateT SolverState IO Variable

129+flattenHelp :: Map.Map String Variable -> Type -> Solver Variable

130−flattenHelp aliasDict term =

130+flattenHelp aliasDict termN =

131− case term of

131+ case termN of

132 PlaceHolder name ->

133− return (aliasDict ! name)

133+ return (aliasDict ! name)

134−

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+

135− VarN maybeAlias v ->

148+ VarN v ->

136− do maybeAlias' <- Traversable.traverse flattenAlias maybeAlias

137− liftIO $ UF.modifyDescriptor v $ \desc ->

138− desc { alias = maybeAlias' <|> alias desc }

139− return v

149+ return v

140−

150+

141− TermN maybeAlias subTerm ->

151+ TermN term1 ->

142− do maybeAlias' <- Traversable.traverse flattenAlias maybeAlias

143− let localDict = maybe aliasDict (Map.fromList . snd) maybeAlias'

144− flatStructure <- traverseTerm (flattenHelp localDict) subTerm

152+ do variableTerm <- traverseTerm (flattenHelp aliasDict) term1

145− pool <- getPool

153+ pool <- getPool

146− var <-

154+ variable <-

147− liftIO . UF.fresh $ Descriptor

155+ State.liftIO . UF.fresh $ Descriptor

148− { structure = Just flatStructure

156+ { _content = Structure variableTerm

149− , rank = maxRank pool

157+ , _rank = maxRank pool

150− , flex = Flexible

158+ , _mark = noMark

151− , name = Nothing

159+ , _copy = Nothing

152− , 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

153− , mark = noMark

199+ , _mark = noMark

154− , alias = maybeAlias'

200+ , _copy = Nothing

155 }

201 }

156− register var

202+ _ <- register newVar

157− where

158− flattenAlias (name, args) =

159− let flattenPair (arg, subTerm) =

160− (,) arg <$> flattenHelp aliasDict subTerm

161− in

162− (,) name <$> mapM flattenPair args

163

203

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 }

164

211

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

165

220

221+ Atom _ ->

222+ return oldContent

166

223

167−makeInstance :: Variable -> StateT SolverState IO Variable

224+ Var Rigid maybeSuper _ ->

168−makeInstance var =

225+ return (Var Flex maybeSuper Nothing)

169− do alreadyCopied <- uniqueMark

226+

170− freshVar <- makeCopy alreadyCopied var

227+ Var Flex _ _ ->

171− restore alreadyCopied var

228+ return oldContent

172− return freshVar

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 }

173

240

241+ return newVar

174

242

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+

175−makeCopy :: Int -> Variable -> StateT SolverState IO Variable

264+restore :: Int -> Variable -> Solver Variable

176−makeCopy alreadyCopied variable = do

265+restore alreadyCopiedMark variable =

177− desc <- liftIO $ UF.descriptor variable

266+ do desc <- State.liftIO $ UF.descriptor variable

178− case () of

267+ if _mark desc /= alreadyCopiedMark

179− () | mark desc == alreadyCopied ->

268+ then

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

189 return variable

269 return variable

190

270

191− | otherwise ->

271+ else

192− do pool <- getPool

272+ do restoredContent <-

193− newVar <-

273+ restoreContent alreadyCopiedMark (_content desc)

194− liftIO $ UF.fresh $ Descriptor

274+ State.liftIO $ UF.setDescriptor variable $ Descriptor

195− { structure = Nothing

275+ { _content = restoredContent

196− , rank = maxRank pool

276+ , _rank = noRank

197− , mark = noMark

277+ , _mark = noMark

198− , flex =

278+ , _copy = Nothing

199− case flex desc of

279+ }

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 }

243 return variable

280 return variable

244

281

245

282

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+

246traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)

312traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)

247traverseTerm f term =

313traverseTerm f term =

248 case term of

314 case term of

@@ -252,13 +318,8 @@ traverseTerm f term =

252 Fun1 a b ->

318 Fun1 a b ->

253 Fun1 <$> f a <*> f b

319 Fun1 <$> f a <*> f b

254

320

255− Var1 x ->

256− Var1 <$> f x

257−

258 EmptyRecord1 ->

321 EmptyRecord1 ->

259 return EmptyRecord1

322 return EmptyRecord1

260

323

261 Record1 fields ext ->

324 Record1 fields ext ->

262− Record1

263− <$> Traversable.traverse (mapM f) fields

325+ Record1 <$> traverse f fields <*> f ext

264− <*> f ext

src/Type/Type.hs+219−444

@@ -1,108 +1,117 @@

1+{-# OPTIONS_GHC -Wall #-}

1module Type.Type where

2module Type.Type where

3import Control.Monad.State (StateT)

4import Control.Monad.State (StateT)

4import qualified Control.Monad.State as State

5import qualified Control.Monad.State as State

5−import qualified Data.Char as Char

6+import qualified Data.List as List

6import qualified Data.Map as Map

7import qualified Data.Map as Map

7import qualified Data.Set as Set

8import qualified Data.Set as Set

8import qualified Data.Traversable as Traverse (traverse)

9import qualified Data.Traversable as Traverse (traverse)

9import qualified Data.UnionFind.IO as UF

10import qualified Data.UnionFind.IO as UF

10−import Text.PrettyPrint as P

11−import System.IO.Unsafe

13import qualified AST.Type as T

12import qualified AST.Type as T

14import qualified AST.Variable as Var

13import qualified AST.Variable as Var

15import qualified Reporting.Annotation as A

14import qualified Reporting.Annotation as A

16import qualified Reporting.Error.Type as Error

15import qualified Reporting.Error.Type as Error

17import qualified Reporting.Region as R

16import qualified Reporting.Region as R

18−import Type.PrettyPrint

17+

21-- CONCRETE TYPES

20-- CONCRETE TYPES

23−type Type = TermN Variable

23+type Type =

24+ TermN Variable

25+

26+

27+type Variable =

25−type Variable = UF.Point Descriptor

28+ UF.Point Descriptor

29+

31+type TypeConstraint =

27−type TypeConstraint = Constraint Type Variable

32+ Constraint Type Variable

29−type TypeScheme = Scheme Type Variable

31−type Alias a = Maybe (Var.Canonical, [(String,a)])

35+type TypeScheme =

36+ Scheme Type Variable

37+

34-- TYPE PRIMITIVES

40-- TYPE PRIMITIVES

42+

36data Term1 a

43data Term1 a

37 = App1 a a

44 = App1 a a

38 | Fun1 a a

45 | Fun1 a a

39− | Var1 a

40 | EmptyRecord1

46 | EmptyRecord1

41− | Record1 (Map.Map String [a]) a

47+ | Record1 (Map.Map String a) a

44data TermN a

50data TermN a

45 = PlaceHolder String

51 = PlaceHolder String

52+ | AliasN Var.Canonical [(String, TermN a)] (TermN a)

46− | VarN (Alias (TermN a)) a

53+ | VarN a

47− | TermN (Alias (TermN a)) (Term1 (TermN a))

54+ | TermN (Term1 (TermN a))

48−

50−varN :: a -> TermN a

51−varN =

52− VarN Nothing

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

61record fs rec =

58record fs rec =

62− termN (Record1 fs rec)

59+ TermN (Record1 fs rec)

60+

65-- DESCRIPTORS

63-- DESCRIPTORS

65+

67data Descriptor = Descriptor

66data Descriptor = Descriptor

68− { structure :: Maybe (Term1 Variable)

67+ { _content :: Content

69− , rank :: Int

68+ , _rank :: Int

70− , flex :: Flex

71− , name :: Maybe TypeName

72− , copy :: Maybe Variable

73− , mark :: Int

69+ , _mark :: Int

74− , alias :: Alias Variable

70+ , _copy :: Maybe Variable

75 }

71 }

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+

77noRank :: Int

95noRank :: Int

78noRank = -1

96noRank = -1

98+

80outermostRank :: Int

99outermostRank :: Int

81outermostRank = 0

100outermostRank = 0

101

102+

83noMark :: Int

103noMark :: Int

84noMark = 0

104noMark = 0

105

106+

86initialMark :: Int

107initialMark :: Int

87initialMark = 1

108initialMark = 1

109

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)

102

110

103

111

104-- CONSTRAINTS

112-- CONSTRAINTS

105

113

114+

106data Constraint a b

115data Constraint a b

107 = CTrue

116 = CTrue

108 | CSaveEnv

117 | CSaveEnv

@@ -111,66 +120,88 @@ data Constraint a b

111 | CLet [Scheme a b] (Constraint a b)

120 | CLet [Scheme a b] (Constraint a b)

112 | CInstance R.Region SchemeName a

121 | CInstance R.Region SchemeName a

113

122

123+

114type SchemeName = String

124type SchemeName = String

115

125

116−type TypeName = Var.Canonical

117

126

118data Scheme a b = Scheme

127data Scheme a b = Scheme

119− { rigidQuantifiers :: [b]

128+ { _rigidQuantifiers :: [b]

120− , flexibleQuantifiers :: [b]

129+ , _flexibleQuantifiers :: [b]

121− , constraint :: Constraint a b

130+ , _constraint :: Constraint a b

122− , header :: Map.Map String (A.Located a)

131+ , _header :: Map.Map String (A.Located a)

123 }

132 }

124

133

125

134

135+

126-- TYPE HELPERS

136-- TYPE HELPERS

127

137

138+

128infixr 9 ==>

139infixr 9 ==>

129

140

141+

130(==>) :: Type -> Type -> Type

142(==>) :: Type -> Type -> Type

131(==>) a b =

143(==>) a b =

132− termN (Fun1 a b)

144+ TermN (Fun1 a b)

133

145

134

146

135(<|) :: TermN a -> TermN a -> TermN a

147(<|) :: TermN a -> TermN a -> TermN a

136(<|) f a =

148(<|) f a =

137− termN (App1 f a)

149+ TermN (App1 f a)

138−

139

150

140−-- VARIABLE HELPERS

141

151

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

152

153+-- VARIABLE CREATION

153

154

154−variable :: Flex -> IO Variable

155−variable flex =

156− UF.fresh (descriptor flex)

157

155

158−

156+mkDescriptor :: Content -> Descriptor

159−descriptor :: Flex -> Descriptor

157+mkDescriptor content =

160−descriptor flex =

161 Descriptor

158 Descriptor

162− { structure = Nothing

159+ { _content = content

163− , rank = noRank

160+ , _rank = noRank

164− , flex = flex

165− , name = Nothing

166− , copy = Nothing

167− , mark = noMark

161+ , _mark = noMark

168− , alias = Nothing

162+ , _copy = Nothing

169 }

163 }

170

164

171

165

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+

172-- CONSTRAINT HELPERS

202-- CONSTRAINT HELPERS

173

203

204+

174monoscheme :: Map.Map String (A.Located a) -> Scheme a b

205monoscheme :: Map.Map String (A.Located a) -> Scheme a b

175monoscheme headers =

206monoscheme headers =

176 Scheme [] [] CTrue headers

207 Scheme [] [] CTrue headers

@@ -200,401 +231,178 @@ fl rqs constraint =

200

231

201exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint

232exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint

202exists f =

233exists f =

203− do v <- variable Flexible

234+ do v <- mkVar Nothing

204− ex [v] <$> f (varN v)

235+ ex [v] <$> f (VarN v)

205

236

206

237

207existsNumber :: (Type -> IO TypeConstraint) -> IO TypeConstraint

238existsNumber :: (Type -> IO TypeConstraint) -> IO TypeConstraint

208existsNumber f =

239existsNumber f =

209− do v <- variable (Is Number)

240+ do v <- mkVar (Just Number)

210− ex [v] <$> f (varN v)

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

348

242

349− CInstance _region name tipe ->

350− P.text name <+> P.text "<" <+> prty tipe

351

243

352

244

353−instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where

245+-- CONVERT TO SOURCE TYPES

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

370

246

371− cs =

372− case constraint of

373− CTrue -> P.empty

374− CAnd [] -> P.empty

375− _ -> P.brackets (pretty Never constraint)

376

247

377− headers' =

248+-- TODO: Attach resulting type to the descriptor so that you

378− if Map.size headers > 0 then dict else P.empty

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)

379

254

380− dict =

381− P.parens . commaSep . map prettyPair $ Map.toList headers

382

255

383− prettyPair (fieldName, A.A _ tipe) =

256+variableToSrcType :: Variable -> StateT NameState IO T.Canonical

384− P.text fieldName <+> P.text ":" <+> pretty Never tipe

257+variableToSrcType variable =

258+ do descriptor <- State.liftIO (UF.descriptor variable)

259+ case _content descriptor of

260+ Structure term ->

261+ termToSrcType term

385

262

263+ Atom name ->

264+ return (T.Type name)

386

265

387−-- CONVERT TO SOURCE TYPES

266+ Var _ _ (Just name) ->

267+ return (T.Var name)

388

268

389−-- TODO: Attach resulting type to the descriptor so that you

269+ Var flex maybeSuper Nothing ->

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

270+ do freshName <- getFreshName maybeSuper

391−toSrcType :: Variable -> IO T.Canonical

271+ State.liftIO $ UF.modifyDescriptor variable $ \desc ->

392−toSrcType variable =

272+ desc { _content = Var flex maybeSuper (Just freshName) }

393− do addNames variable

273+ return (T.Var freshName)

394− variableToSrcType variable variable

395

274

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

396

279

397−variableToSrcType :: Variable -> Variable -> IO T.Canonical

280+ Error ->

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

281+ return (T.Var "?")

404

282

405− Just (name, args) ->

406− case srcType of

407− T.Type (Var.Canonical Var.BuiltIn _) ->

408− return srcType

409

283

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

284+termToSrcType :: Term1 Variable -> StateT NameState IO T.Canonical

433−termToSrcType rootVariable term =

285+termToSrcType term =

434− let go = variableToSrcType rootVariable in

435 case term of

286 case term of

436− App1 a b ->

287+ App1 func arg ->

437− do a' <- go a

288+ do srcFunc <- variableToSrcType func

438− b' <- go b

289+ srcArg <- variableToSrcType arg

439− case a' of

290+ case srcFunc of

440 T.App f args ->

291 T.App f args ->

441− return $ T.App f (args ++ [b'])

292+ return (T.App f (args ++ [srcArg]))

293+

442 _ ->

294 _ ->

443− return $ T.App a' [b']

295+ return (T.App srcFunc [srcArg])

444

296

445 Fun1 a b ->

297 Fun1 a b ->

446− T.Lambda <$> go a <*> go b

298+ T.Lambda

447−

299+ <$> variableToSrcType a

448− Var1 a ->

300+ <*> variableToSrcType b

449− go a

450

301

451 EmptyRecord1 ->

302 EmptyRecord1 ->

452 return $ T.Record [] Nothing

303 return $ T.Record [] Nothing

453

304

454− Record1 tfields extension ->

305+ Record1 fields extension ->

455− do fields' <- Traverse.traverse (mapM go) tfields

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

456− let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

307+ srcExt <- T.iteratedDealias <$> variableToSrcType extension

457− ext' <- dealias <$> go extension

458 return $

308 return $

459− case ext' of

309+ case srcExt of

460− T.Record fs ext -> T.Record (fs ++ fields) ext

310+ T.Record subFields subExt ->

461− T.Var _ -> T.Record fields (Just ext')

311+ T.Record (subFields ++ srcFields) subExt

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

471

312

313+ T.Var _ ->

314+ T.Record srcFields (Just srcExt)

472

315

473−-- ADD NAMES TO TYPES

316+ _ ->

317+ error "Used toSrcType on a type that is not well-formed"

474

318

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

481

319

482

320

483−makeFreeNames :: Set.Set String -> [String]

321+-- MANAGE FRESH VARIABLE NAMES

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

492

322

493

323

494data NameState = NameState

324data NameState = NameState

495− { freeNames :: [String]

325+ { _freeNames :: [String]

496− , numberPrimes :: Int

326+ , _numberPrimes :: Int

497− , comparablePrimes :: Int

327+ , _comparablePrimes :: Int

498− , appendablePrimes :: Int

328+ , _appendablePrimes :: Int

329+ , _compAppendPrimes :: Int

499 }

330 }

500

331

501

332

502−varAddNames :: Variable -> StateT NameState IO ()

333+makeNameState :: Set.Set String -> NameState

503−varAddNames var =

334+makeNameState usedNames =

504− do desc <- State.liftIO (UF.descriptor var)

335+ let

505− case alias desc of

336+ makeName suffix =

506− Nothing ->

337+ map (:suffix) ['a'..'z']

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

531

338

532− Fun1 a b ->

339+ allNames =

533− do varAddNames a

340+ concatMap makeName ("" : map show [ (1 :: Int) .. ])

534− varAddNames b

535

341

536− Var1 a ->

342+ freeNames =

537− varAddNames a

343+ filter (\name -> Set.notMember name usedNames) allNames

344+ in

345+ NameState freeNames 0 0 0 0

538

346

539− EmptyRecord1 ->

540− return ()

541−

542− Record1 fields extension ->

543− do mapM_ varAddNames (concat (Map.elems fields))

544− varAddNames extension

545

347

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)

546

355

547−createName :: (Monad m) => Descriptor -> StateT NameState m String

548−createName desc =

549− case flex desc of

550− Is Number ->

356+ Just Number ->

551− do primes <- State.gets numberPrimes

357+ do primes <- State.gets _numberPrimes

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

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

553 return ("number" ++ replicate primes '\'')

359 return ("number" ++ replicate primes '\'')

554

360

555− Is Comparable ->

361+ Just Comparable ->

556− do primes <- State.gets comparablePrimes

362+ do primes <- State.gets _comparablePrimes

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

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

558 return ("comparable" ++ replicate primes '\'')

364 return ("comparable" ++ replicate primes '\'')

559

365

560− Is Appendable ->

366+ Just Appendable ->

561− do primes <- State.gets appendablePrimes

367+ do primes <- State.gets _appendablePrimes

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

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

563 return ("appendable" ++ replicate primes '\'')

369 return ("appendable" ++ replicate primes '\'')

564

370

565− _ ->

371+ Just CompAppend ->

566− do names <- State.gets freeNames

372+ do primes <- State.gets _compAppendPrimes

567− State.modify (\state -> state { freeNames = tail names })

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

568− return (head names)

374+ return ("compappend" ++ replicate primes '\'')

375+

569

376

570

377

571-- GET ALL VARIABLE NAMES

378-- GET ALL VARIABLE NAMES

572

379

380+

573getVarNames :: Variable -> IO (Set.Set String)

381getVarNames :: Variable -> IO (Set.Set String)

574getVarNames var =

382getVarNames var =

575 do desc <- UF.descriptor var

383 do desc <- UF.descriptor var

576

384

577− let baseSet =

578− case name desc of

385+ case _content desc of

386+ Var _ _ (Just name) ->

579− Just var -> Set.singleton (Var.toString var)

387+ return (Set.singleton name)

388+

389+ Var _ _ Nothing ->

580− Nothing -> Set.empty

390+ return Set.empty

581

391

582− structureSet <-

392+ Structure term ->

583− case structure desc of

584− Nothing -> return Set.empty

585− Just term -> getVarNamesTerm term

393+ getVarNamesTerm term

586

394

587− aliasSet <-

395+ Alias _name args realVar ->

588− case alias desc of

396+ do let argSet = Set.fromList (map fst args)

589− Nothing ->

397+ realSet <- getVarNames realVar

590− return Set.empty

398+ sets <- mapM (getVarNames . snd) args

399+ return (Set.unions (realSet : argSet : sets))

591

400

592− Just (_name, args) ->

401+ Atom _ ->

593− do let set = Set.fromList (map fst args)

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

595− return (Set.unions (set : sets))

402+ return Set.empty

596

403

597− return (Set.unions [ baseSet, structureSet, aliasSet ])

404+ Error ->

405+ return Set.empty

598

406

599

407

600getVarNamesTerm :: Term1 Variable -> IO (Set.Set String)

408getVarNamesTerm :: Term1 Variable -> IO (Set.Set String)

@@ -607,43 +415,10 @@ getVarNamesTerm term =

607 Fun1 a b ->

415 Fun1 a b ->

608 Set.union <$> go a <*> go b

416 Set.union <$> go a <*> go b

609

417

610− Var1 a ->

611− go a

612−

613 EmptyRecord1 ->

418 EmptyRecord1 ->

614 return Set.empty

419 return Set.empty

615

420

616 Record1 fields extension ->

421 Record1 fields extension ->

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

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

618 Set.union fieldVars <$> go extension

423 Set.union fieldVars <$> go extension

619

424

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

1module Type.Unify (unify) where

2module Type.Unify (unify) where

3−import Control.Applicative ((<|>))

4+import Control.Monad (zipWithM_)

4−import Control.Monad.Except (ExceptT, throwError, runExceptT)

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

5−import Control.Monad.State as State

6−import qualified Data.List as List

7import qualified Data.Map as Map

6import qualified Data.Map as Map

8import qualified Data.UnionFind.IO as UF

7import qualified Data.UnionFind.IO as UF

9−import Text.PrettyPrint (render)

11−import qualified AST.Type as AstType

12import qualified AST.Variable as Var

9import qualified AST.Variable as Var

13import qualified Reporting.Region as R

10import qualified Reporting.Region as R

14import qualified Reporting.Error.Type as Error

11import qualified Reporting.Error.Type as Error

15import qualified Type.State as TS

12import qualified Type.State as TS

16import Type.Type as Type

13import Type.Type as Type

17−import Type.PrettyPrint

14+

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

15+

19−

16+

20−

17+-- KICK OFF UNIFICATION

21−unify

18+

22− :: Error.Hint

19+

23− -> R.Region

20+unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()

24− -> Variable

25− -> Variable

26− -> StateT TS.SolverState IO ()

27−unify hint region variable1 variable2 =

21+unify hint region expected actual =

28− do result <- runExceptT (unifyHelp variable1 variable2)

22+ do result <- runExceptT (guardedUnify ExpectedActual expected actual)

29 case result of

23 case result of

30 Right state ->

24 Right state ->

31 return state

25 return state

33− Left (RawMismatch (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

34− TS.addError region $ Error.Mismatch $

36+ TS.addError region =<< liftIO mkError

35− Error.MismatchInfo hint leftType rightType note

37+

38−-- ACTUALLY UNIFY STUFF

40+-- UNIFICATION HELPERS

41+

40type Unify =

43type 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)

44−newtype RawMismatch =

92+badRigid :: Maybe String -> Error.Reason

45− RawMismatch (AstType.Canonical, AstType.Canonical, Maybe String)

93+badRigid maybeName =

94+ Error.BadVar (Just (Error.Rigid maybeName)) Nothing

48−typeError

97+badSuper :: Super -> Error.Reason

49− :: UF.Point Descriptor

98+badSuper super =

50− -> UF.Point Descriptor

99+ Error.BadVar (Just (errorSuper super)) Nothing

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

100

101

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+

62−unifyHelp :: Variable -> Variable -> Unify ()

132+mergeHelp :: Variable -> Variable -> Content -> IO ()

63−unifyHelp variable1 variable2 =

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 =

64− do equivalent <- liftIO $ UF.equivalent variable1 variable2

163+ do equivalent <- liftIO $ UF.equivalent left right

65 if equivalent

164 if equivalent

66− then return ()

165+ then return ()

67− else actuallyUnify variable1 variable2

166+ else

68−

69−

70−actuallyUnify :: Variable -> Variable -> Unify ()

71−actuallyUnify variable1 variable2 = do

72− desc1 <- liftIO $ UF.descriptor variable1

167+ do leftDesc <- liftIO $ UF.descriptor left

73− desc2 <- liftIO $ UF.descriptor variable2

168+ rightDesc <- liftIO $ UF.descriptor right

74− let (name', flex', rank', alias') = combinedDescriptors desc1 desc2

169+ actuallyUnify (Context orientation left leftDesc right rightDesc)

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'

255

170

256− (EmptyRecord1, EmptyRecord1) ->

171+

257− return ()

172+subUnify :: Context -> Variable -> Variable -> Unify ()

258−

173+subUnify context var1 var2 =

259− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2

174+ guardedUnify (_orientation context) var1 var2

260− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext

175+

261−

176+

262− (Record1 _ _, Record1 _ _) ->

177+actuallyUnify :: Context -> Unify ()

263− recordUnify fresh variable1 variable2

178+actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =

264−

179+ let

265− _ -> typeError variable1 variable2 Nothing

180+ secondContent = _content secondDesc

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

360 in

181 in

361− Map.union (Map.intersectionWith eat fields1 fields2) fields1

182+ case _content firstDesc of

362− |> Map.filter (not . null)

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

363

331

364

332

365−data ExpandedRecord = ExpandedRecord

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

366− { _fields :: Map.Map String [Variable]

628+ { _fields :: Map.Map String Variable

367− , _extension :: Extension

629+ , _extVar :: Variable

630+ , _extStruct :: ExtensionStructure

368 }

631 }

369

632

370−data Extension = Empty Variable | Extension Variable

633+

634+data ExtensionStructure

635+ = Empty

636+ | Extension

371

637

372

638

373−gatherFields :: Variable -> IO ExpandedRecord

639+gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure

374−gatherFields var =

640+gatherFields context fields variable =

375− do desc <- UF.descriptor var

641+ do desc <- liftIO (UF.descriptor variable)

376− case structure desc of

642+ case _content desc of

377− (Just (Record1 fields ext)) ->

643+ Structure (Record1 subFields subExt) ->

378− do (ExpandedRecord deeperFields rootExt) <- gatherFields ext

644+ gatherFields context (Map.union fields subFields) subExt

379− return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)

380

645

381− (Just EmptyRecord1) ->

646+ Structure EmptyRecord1 ->

382− return (ExpandedRecord Map.empty (Empty var))

647+ return (RecordStructure fields variable Empty)

648+

649+ Alias _ _ var ->

650+ -- TODO may be dropping useful alias info here

651+ gatherFields context fields var

383

652

384 _ ->

653 _ ->

385− return (ExpandedRecord Map.empty (Extension var))

654+ return (RecordStructure fields variable Extension)

386−

655+

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

src/Validate.hs+2−2

@@ -403,7 +403,7 @@ checkDecl isRoot (A.A (region,_) decl) =

403 (v:vs) = Set.toList (Set.fromList unbound)

404 in

405 Result.throw region

406− (Error.UnboundTypeVarsInUnion name boundVars v vs ctors)

406+ (Error.UnboundTypeVarsInUnion name boundVars v vs)

407

408 D.TypeAlias name boundVars tipe ->

409 case findUnbound boundVars (freeVars tipe) of

@@ -415,7 +415,7 @@ checkDecl isRoot (A.A (region,_) decl) =

415 (v:vs) = Set.toList (Set.fromList unbound)

416 in

417 Result.throw region

418− (Error.UnboundTypeVarsInAlias name boundVars v vs tipe)

418+ (Error.UnboundTypeVarsInAlias name boundVars v vs)

419

420 D.Port _ ->

421 if isRoot

tests/Test/Compiler.hs+11−1

@@ -19,6 +19,8 @@ import Test.HUnit (Assertion, assertFailure, assertBool, assertEqual)

19import qualified Elm.Compiler as Compiler

20import qualified Elm.Package as Package

22+

23+

22writeExpectedJsEnvVarName :: String

24writeExpectedJsEnvVarName :: String

23writeExpectedJsEnvVarName =

25writeExpectedJsEnvVarName =

24 "ELM_WRITE_NEW_EXPECTED"

26 "ELM_WRITE_NEW_EXPECTED"

@@ -38,8 +40,10 @@ compilerTests =

38 ]

40 ]

43+

41-- GATHER FILES

44-- GATHER FILES

46+

43getElms :: FilePath -> IO [FilePath]

47getElms :: FilePath -> IO [FilePath]

44getElms filePath =

48getElms filePath =

45 find

49 find

@@ -54,14 +58,16 @@ testsDir =

55convertToExpectedJsFilePath :: String -> FilePath -> FilePath

59convertToExpectedJsFilePath :: String -> FilePath -> FilePath

56convertToExpectedJsFilePath expectedJsDir filePath =

60convertToExpectedJsFilePath expectedJsDir filePath =

57− testsDir

61+ testsDir

58 </> expectedJsDir

62 </> expectedJsDir

59 </> joinPath (drop 3 (splitDirectories filePath))

63 </> joinPath (drop 3 (splitDirectories filePath))

60 <.> ".js"

64 <.> ".js"

67+

63-- TEST HELPERS

68-- TEST HELPERS

70+

65compileString :: FilePath -> String -> Either String Compiler.Result

71compileString :: FilePath -> String -> Either String Compiler.Result

66compileString filePath source =

72compileString filePath source =

67 let context =

73 let context =

@@ -85,8 +91,10 @@ readFileOrErrorStr filePath =

85 return (show e)

91 return (show e)

94+

88-- RUN TESTS

95-- RUN TESTS

97+

90testIf

98testIf

91 :: (Either String Compiler.Result -> Assertion)

99 :: (Either String Compiler.Result -> Assertion)

92 -> [FilePath]

100 -> [FilePath]

@@ -143,8 +151,10 @@ testMatchesExpected elmDir expectedJsDir =

143 traverse (doMatchesExpectedTest expectedJsDir) elmFiles

151 traverse (doMatchesExpectedTest expectedJsDir) elmFiles

144

152

145

153

154+

146-- CHECK RESULTS

155-- CHECK RESULTS

147

156

157+

148isSuccess :: Either String a -> Assertion

158isSuccess :: Either String a -> Assertion

149isSuccess result =

159isSuccess result =

150 case result of

160 case result of

tests/test-files/good-expected-js/Declarations/Ports.elm.js+1−1

@@ -38,7 +38,7 @@ Elm.Main.make = function (_elm) {

38 })) : _U.badPort("an array",v);

39 });

40 var tuple = Elm.Native.Port.make(_elm).inbound("tuple",

41− "(Float, Bool)",

41+ "( Float, Bool )",

42 function (v) {

43 return typeof v === "object" && v instanceof Array ? {ctor: "_Tuple2"

44 ,_0: typeof v[0] === "number" ? v[0] : _U.badPort("a number",