e59f542 · elk · git.iko.soy

elm-compiler.cabal+1

compare with master

unifiedsplit

@@ -121,6 +121,7 @@ Library

121 Reporting.Error,

122 Reporting.Error.Canonicalize,

123 Reporting.Error.Docs,

124+ Reporting.Error.Json,

124 Reporting.Error.Main,

125 Reporting.Error.Main,

125 Reporting.Error.Pattern,

126 Reporting.Error.Pattern,

126 Reporting.Error.Syntax,

127 Reporting.Error.Syntax,

src/AST/Canonical.hs+2−3

@@ -240,10 +240,9 @@ data Ctor =

240

241

242data Docs

243− = NoDocs R.Position R.Position

243+ = NoDocs R.Region

244 | YesDocs

245− { _start :: R.Position

245+ { _region :: R.Region

246− , _end :: R.Position

247 , _overview :: B.ByteString

246 , _overview :: B.ByteString

248 , _comments :: Map.Map N.Name Text

247 , _comments :: Map.Map N.Name Text

249 }

248 }

src/AST/Source.hs+2−2

@@ -157,8 +157,8 @@ data Import =

157

158

159data Docs

160− = NoDocs R.Position R.Position

160+ = NoDocs R.Region

161− | YesDocs R.Position R.Position B.ByteString

161+ | YesDocs R.Region B.ByteString

162

163

164data Effects

src/AST/Valid.hs+2−7

@@ -112,9 +112,9 @@ defaultModule :: Map.Map N.Name Text -> [Src.Import] -> [A.Located Decl] -> [Uni

112defaultModule docs imports decls unions aliases binop =

113 Module

114 { _name = "Main"

115− , _overview = Src.NoDocs zero zero

115+ , _overview = Src.NoDocs R.one

116 , _docs = docs

117− , _exports = A.at zero zero Src.Open

117+ , _exports = A.At R.one Src.Open

118 , _imports = imports

119 , _decls = decls

120 , _unions = unions

@@ -122,8 +122,3 @@ defaultModule docs imports decls unions aliases binop =

122 , _binop = binop

123 , _effects = NoEffects

124 }

125−

126−

127−zero :: R.Position

128−zero =

129− R.Position 1 1

src/Canonicalize/Module.hs+4−4

@@ -71,11 +71,11 @@ canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports im

71toDocs :: Valid.Module -> Can.Docs

72toDocs (Valid.Module _ docs comments _ _ _ _ _ _ _) =

73 case docs of

74− Src.NoDocs start end ->

74+ Src.NoDocs region ->

75− Can.NoDocs start end

75+ Can.NoDocs region

76

77− Src.YesDocs start end overview ->

77+ Src.YesDocs region overview ->

78− Can.YesDocs start end overview comments

78+ Can.YesDocs region overview comments

79

80

81

src/Elm/Compiler/Imports.hs+4−9

@@ -47,12 +47,7 @@ defaults =

47

48import_ :: Module.Canonical -> Maybe N.Name -> Src.Exposing -> Src.Import

49import_ (Module.Canonical _ name) maybeAlias exposing =

50− Src.Import (A.At zero name) maybeAlias exposing

50+ Src.Import (A.At R.zero name) maybeAlias exposing

51−

52−

53−zero :: R.Region

54−zero =

55− R.Region (R.Position 0 0) (R.Position 0 0)

56

51

57

52

58

53

@@ -66,14 +61,14 @@ closed =

66

61

67typeOpen :: N.Name -> Src.Exposing

62typeOpen :: N.Name -> Src.Exposing

68typeOpen name =

63typeOpen name =

69− Src.Explicit [ A.At zero (Src.Upper name Src.Public) ]

64+ Src.Explicit [ A.At R.zero (Src.Upper name Src.Public) ]

70

65

71

66

72typeClosed :: N.Name -> Src.Exposing

67typeClosed :: N.Name -> Src.Exposing

73typeClosed name =

68typeClosed name =

74− Src.Explicit [ A.At zero (Src.Upper name Src.Private) ]

69+ Src.Explicit [ A.At R.zero (Src.Upper name Src.Private) ]

75

70

76

71

77operator :: N.Name -> Src.Exposing

72operator :: N.Name -> Src.Exposing

78operator op =

73operator op =

79− Src.Explicit [ A.At zero (Src.Operator op) ]

74+ Src.Explicit [ A.At R.zero (Src.Operator op) ]

src/Elm/Docs.hs+4−4

@@ -294,11 +294,11 @@ fromModule (Can.Module name docs exports decls unions aliases binops effects) =

294

295 Can.Export exportDict ->

296 case docs of

297− Can.NoDocs start end ->

297+ Can.NoDocs region ->

298− Result.throw $ Error.Docs $ E.NoDocs $ R.Region start end

298+ Result.throw $ Error.Docs $ E.NoDocs region

299

300− Can.YesDocs start end overview comments ->

300+ Can.YesDocs region overview comments ->

301− do names <- parseOverview (R.Region start end) overview

301+ do names <- parseOverview region overview

302 Result.mapError Error.Docs $

303 do checkNames exportDict names

304 let types = gatherTypes decls Map.empty

src/Json/Decode.hs+12−11

@@ -2,9 +2,8 @@

2{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-}

3module Json.Decode

4 ( parse

5− , Failure(..)

6 -- re-export from Json.Decode.Internals

5 -- re-export from Json.Decode.Internals

7− , Json.Decoder, Json.Error(..), Json.Type(..)

6+ , Json.Decoder

8 , Json.string, Json.text, Json.name, Json.bool, Json.int

7 , Json.string, Json.text, Json.name, Json.bool, Json.int

9 , Json.list, Json.dict, Json.pairs, Json.maybe

8 , Json.list, Json.dict, Json.pairs, Json.maybe

10 , Json.field, Json.at

9 , Json.field, Json.at

@@ -34,28 +33,30 @@ import qualified Parse.Primitives.Keyword as Keyword

34import qualified Parse.Primitives.Number as Number

33import qualified Parse.Primitives.Number as Number

35import qualified Parse.Primitives.Symbol as Symbol

34import qualified Parse.Primitives.Symbol as Symbol

36import qualified Reporting.Error.Syntax as E

35import qualified Reporting.Error.Syntax as E

36+import qualified Reporting.Error.Json as J

37+import qualified Reporting.Helpers as H

37import qualified Reporting.Region as R

38import qualified Reporting.Region as R

39+import qualified Reporting.Render.Code as Code

38

40

39

41

40

42

41-- PARSE

43-- PARSE

42

44

43

45

44−data Failure e

45− = BadJson E.Error

46− | BadContent (Json.Error e)

47−

48−

49−parse :: Json.Decoder e a -> B.ByteString -> Either (Failure e) a

46+parse :: FilePath -> String -> (e -> [H.Doc]) -> Json.Decoder e a -> B.ByteString -> Either H.Doc a

50−parse (Json.Decoder run) bytestring =

47+parse path rootName userErrorToDocs (Json.Decoder run) bytestring =

48+ let

49+ toDoc err =

50+ J.toDoc path rootName (Code.toSource (Text.decodeUtf8 bytestring)) userErrorToDocs err

51+ in

51 case P.run jsonFile bytestring of

52 case P.run jsonFile bytestring of

52 Left err ->

53 Left err ->

53− Left (BadJson err)

54+ Left (toDoc (J.BadJson err))

54

55

55 Right value ->

56 Right value ->

56 case run value of

57 case run value of

57 Left err ->

58 Left err ->

58− Left (BadContent err)

59+ Left (toDoc (J.BadContent err))

59

60

60 Right answer ->

61 Right answer ->

61 Right answer

62 Right answer

src/Json/Encode.hs+1−1

@@ -5,7 +5,7 @@ module Json.Encode

5 , encode

6 , writeUgly

7 , encodeUgly

8− , Value

8+ , Value(..)

9 , array

10 , object

11 , text

src/Parse/Module.hs+2−2

@@ -165,8 +165,8 @@ chompDocComment =

165 [ do doc <- W.docComment

166 docEnd <- P.getPosition

167 freshLine

168− return (Src.YesDocs nextStart docEnd doc)

168+ return (Src.YesDocs (R.Region nextStart docEnd) doc)

169− , return (Src.NoDocs endOfExposing nextStart)

169+ , return (Src.NoDocs (R.Region endOfExposing nextStart))

170 ]

171

172

src/Reporting/Error/Json.hsnew file+270

@@ -0,0 +1,270 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+module Reporting.Error.Json

5+ ( Error(..)

6+ , toDoc

7+ )

8+ where

9+

10+

11+import Prelude hiding (userError)

12+import qualified Data.Char as Char

13+import qualified Data.List as List

14+import qualified Data.Map as Map

15+import qualified Data.Text as Text

16+import Text.PrettyPrint.ANSI.Leijen ((<+>), (<>))

17+import qualified Text.PrettyPrint.ANSI.Leijen as P

18+

19+import qualified Json.Decode.Internals as Json

20+import qualified Json.Encode as E

21+import qualified Reporting.Error.Syntax as Syntax

22+import qualified Reporting.Helpers as H

23+import qualified Reporting.Region as R

24+import qualified Reporting.Render.Code as Code

25+import qualified Reporting.Report as Report

26+

27+

28+

29+-- ERROR

30+

31+

32+data Error e

33+ = BadJson Syntax.Error

34+ | BadContent (Json.Error e)

35+

36+

37+

38+-- TO DOC

39+

40+

41+toDoc :: FilePath -> String -> Code.Source -> (e -> [H.Doc]) -> Error e -> H.Doc

42+toDoc path rootName source userErrorToDocs err =

43+ Report.toDoc path $

44+ case err of

45+ BadJson syntaxError ->

46+ Syntax.toReport source syntaxError

47+

48+ BadContent jsonError ->

49+ Report.Report "BAD JSON" R.zero [] $

50+ case flatten jsonError of

51+ [] ->

52+ H.reflow

53+ "I am not sure what is wrong with this JSON. Please create an <http://sscce.org>\

54+ \ and share it at <https://github.com/elm-lang/elm-compiler/issues> so I can\

55+ \ provide a helpful hint here!"

56+

57+ [flatError] ->

58+ flatErrorToDoc rootName [] userErrorToDocs flatError

59+

60+ flatErrors ->

61+ let

62+ toNumberedDoc index flatErr =

63+ P.dullcyan ("(" <> P.int index <> ")") <+> flatErrorToDoc rootName [] userErrorToDocs flatErr

64+ in

65+ H.stack $

66+ [ H.reflow $

67+ "I have " ++ show (length flatErrors) ++ " theories on what is going wrong:"

68+ ]

69+ ++ zipWith toNumberedDoc [1..] flatErrors

70+

71+

72+

73+-- FLAT ERROR TO DOC

74+

75+

76+flatErrorToDoc :: String -> [H.Doc] -> (e -> [H.Doc]) -> FlatError e -> H.Doc

77+flatErrorToDoc rootName starter userErrorToDocs (FlatError accesses json theory theories) =

78+ case theories of

79+ [] ->

80+ let

81+ explanation =

82+ case theory of

83+ Failure userError ->

84+ userErrorToDocs userError

85+

86+ Expecting tipe ->

87+ ["I","was","expecting"] ++ anExpectedThing tipe

88+ in

89+ case accesses of

90+ [] ->

91+ H.fillSep (starter ++ explanation)

92+

93+ _ ->

94+ H.stack

95+ [ H.fillSep $ starter ++ ["The"] ++ actualThing json ++ ["at",accessToDoc rootName accesses,"is","causing","issues."]

96+ , H.fillSep explanation

97+ ]

98+

99+ _:_ ->

100+ let

101+ introduction =

102+ case accesses of

103+ [] ->

104+ ["I","am","having","trouble","with","the"]

105+ ++ actualThing json

106+ ++ ["here","because:"]

107+

108+ _ ->

109+ ["I","am","having","trouble","with","the"]

110+ ++ actualThing json

111+ ++ ["at",accessToDoc rootName accesses,"because:"]

112+ in

113+ H.stack

114+ [ H.fillSep (starter ++ introduction)

115+ , H.stack (toBullet [] userErrorToDocs theory : map (toBullet ["OR"] userErrorToDocs) theories)

116+ , H.reflow "I accept any of these things."

117+ ]

118+

119+

120+accessToDoc :: String -> [String] -> H.Doc

121+accessToDoc rootName accesses =

122+ P.dullyellow (P.text (rootName ++ concat accesses))

123+

124+

125+actualThing :: E.Value -> [H.Doc]

126+actualThing json =

127+ case json of

128+ E.Array _ -> [H.red "array"]

129+ E.Object _ -> [H.red "object"]

130+ E.String _ -> [H.red "string"]

131+ E.Boolean b -> [H.red (if b then "true" else "false"),"value"]

132+ E.Integer n -> ["number",H.red (H.text (show n))]

133+ E.Number _ -> [H.red "number"]

134+ E.Null -> [H.red "null","value"]

135+

136+

137+anExpectedThing :: Json.Type -> [H.Doc]

138+anExpectedThing tipe =

139+ case tipe of

140+ Json.TObject -> ["an", P.green "OBJECT" <> "."]

141+ Json.TArray -> ["an", P.green "ARRAY" <> "."]

142+ Json.TString -> ["a", P.green "STRING" <> "."]

143+ Json.TBool -> ["a", P.green "BOOLEAN" <> "."]

144+ Json.TInt -> ["an", P.green "INT" <> "."]

145+ Json.TObjectWith field -> ["an",P.green "OBJECT","with","a",P.green ("\"" <> P.text (Text.unpack field) <> "\""),"field."]

146+ Json.TArrayWith i len ->

147+ ["a",H.green "longer",P.green "ARRAY" <> "."

148+ ,"I","need","index",P.text (show i) <> ",","but","this","array"

149+ ,"only","has",P.text (show len),"elements."

150+ ]

151+

152+

153+toBullet :: [H.Doc] -> (e -> [H.Doc]) -> Theory e -> H.Doc

154+toBullet intro userErrorToDocs theory =

155+ H.indent 4 $ H.fillSep $ (++) intro $

156+ case theory of

157+ Failure userError ->

158+ userErrorToDocs userError

159+

160+ Expecting tipe ->

161+ ["I","was","expecting"] ++ anExpectedThing tipe

162+

163+

164+

165+-- TO FLAT ERRORS

166+

167+

168+data FlatError e =

169+ FlatError [String] E.Value (Theory e) [Theory e]

170+

171+

172+data Theory e

173+ = Failure e

174+ | Expecting Json.Type

175+

176+

177+flatten :: Json.Error e -> [FlatError e]

178+flatten jsonError =

179+ let

180+ depth (FlatError accesses _ _ _) =

181+ length accesses

182+ in

183+ List.sortOn depth $ flattenTree (toErrorTree jsonError)

184+

185+

186+flattenTree :: ErrorTree e -> [FlatError e]

187+flattenTree (ErrorTree theories subTrees) =

188+ let

189+ addAccess access (FlatError accesses json t ts) =

190+ FlatError (access:accesses) json t ts

191+

192+ toFlats (name, tree) =

193+ map (addAccess name) (flattenTree tree)

194+

195+ subErrors =

196+ concatMap toFlats (Map.toList subTrees)

197+ in

198+ case theories of

199+ [] ->

200+ subErrors

201+

202+ (json, theory) : rest ->

203+ FlatError [] json theory (map snd rest) : subErrors

204+

205+

206+

207+-- TO ERROR TREE

208+

209+

210+data ErrorTree e =

211+ ErrorTree

212+ { _theories :: [(E.Value, Theory e)]

213+ , _subErrors :: Map.Map String (ErrorTree e)

214+ }

215+

216+

217+toErrorTree :: Json.Error e -> ErrorTree e

218+toErrorTree jsonError =

219+ add jsonError empty

220+

221+

222+empty :: ErrorTree e

223+empty =

224+ ErrorTree [] Map.empty

225+

226+

227+add :: Json.Error e -> ErrorTree e -> ErrorTree e

228+add jsonError tree@(ErrorTree theories subErrors) =

229+ case jsonError of

230+ Json.Field field subErr ->

231+ ErrorTree theories (addName (fieldToName field) subErr subErrors)

232+

233+ Json.Index index subErr ->

234+ ErrorTree theories (addName (indexToName index) subErr subErrors)

235+

236+ Json.OneOf errors ->

237+ foldr add tree errors

238+

239+ Json.Expecting json tipe ->

240+ ErrorTree ((json, Expecting tipe) : theories) subErrors

241+

242+ Json.Failure json err ->

243+ ErrorTree ((json, Failure err) : theories) subErrors

244+

245+

246+addName :: String -> Json.Error e -> Map.Map String (ErrorTree e) -> Map.Map String (ErrorTree e)

247+addName name err subErrors =

248+ let

249+ subAdd maybeCrush =

250+ Just (add err (maybe empty id maybeCrush))

251+ in

252+ Map.alter subAdd name subErrors

253+

254+

255+fieldToName :: Text.Text -> String

256+fieldToName field =

257+ case Text.unpack field of

258+ [] ->

259+ "['']"

260+

261+ string@(char : rest) ->

262+ if Char.isAlpha char && all Char.isAlphaNum rest then

263+ '.' : string

264+ else

265+ "['" ++ string ++ "']"

266+

267+

268+indexToName :: Int -> String

269+indexToName index =

270+ "[" ++ show index ++ "]"

src/Reporting/Helpers.hs+1−1

@@ -12,7 +12,7 @@ module Reporting.Helpers

12 , nearbyNames, distance

13 -- re-exports

14 , Doc, (<+>), (<>), black, blue, cat, dullyellow, fillSep, green, hang

15− , hardline, hcat, hsep, indent, magenta, parens, sep, text, underline, vcat

15+ , hardline, hcat, hsep, indent, magenta, parens, red, sep, text, underline, vcat

16 )

17 where

18

src/Reporting/Region.hs+14

@@ -2,6 +2,8 @@

2module Reporting.Region

3 ( Region(..)

4 , Position(..)

5+ , zero

6+ , one

5 , merge

7 , merge

6 , encode

8 , encode

7 )

9 )

@@ -37,6 +39,18 @@ merge (Region start _) (Region _ end) =

37 Region start end

39 Region start end

38

40

39

41

42+{-# NOINLINE zero #-}

43+zero :: Region

44+zero =

45+ Region (Position 0 0) (Position 0 0)

46+

47+

48+{-# NOINLINE one #-}

49+one :: Region

50+one =

51+ Region (Position 1 1) (Position 1 1)

52+

53+

40

54

41-- JSON

55-- JSON

42

56

src/Type/Constrain/Module.hs+5−11

@@ -75,22 +75,16 @@ letPort name port_ makeConstraint =

75 Can.Incoming freeVars _ srcType ->

76 do vars <- traverse (\_ -> mkFlexVar) freeVars

77 tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType

78− let header = Map.singleton name (A.At zero tipe)

78+ let header = Map.singleton name (A.At R.zero tipe)

79 CLet (Map.elems vars) [] header CTrue <$> makeConstraint

80

81 Can.Outgoing freeVars _ srcType ->

82 do vars <- traverse (\_ -> mkFlexVar) freeVars

83 tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType

84− let header = Map.singleton name (A.At zero tipe)

84+ let header = Map.singleton name (A.At R.zero tipe)

85 CLet (Map.elems vars) [] header CTrue <$> makeConstraint

86

87

88−{-# NOINLINE zero #-}

89−zero :: R.Region

90−zero =

91− R.Region (R.Position 0 0) (R.Position 0 0)

92−

93−

94

88

95-- EFFECT MANAGER HELPERS

89-- EFFECT MANAGER HELPERS

96

90

@@ -100,7 +94,7 @@ letCmd home tipe constraint =

100 do msgVar <- mkFlexVar

94 do msgVar <- mkFlexVar

101 let msg = VarN msgVar

95 let msg = VarN msgVar

102 let cmdType = FunN (AppN home tipe [msg]) (AppN ModuleName.cmd N.cmd [msg])

96 let cmdType = FunN (AppN home tipe [msg]) (AppN ModuleName.cmd N.cmd [msg])

103− let header = Map.singleton "command" (A.At zero cmdType)

97+ let header = Map.singleton "command" (A.At R.zero cmdType)

104 return $ CLet [msgVar] [] header CTrue constraint

98 return $ CLet [msgVar] [] header CTrue constraint

105

99

106

100

@@ -109,7 +103,7 @@ letSub home tipe constraint =

109 do msgVar <- mkFlexVar

103 do msgVar <- mkFlexVar

110 let msg = VarN msgVar

104 let msg = VarN msgVar

111 let subType = FunN (AppN home tipe [msg]) (AppN ModuleName.sub N.sub [msg])

105 let subType = FunN (AppN home tipe [msg]) (AppN ModuleName.sub N.sub [msg])

112− let header = Map.singleton "subscription" (A.At zero subType)

106+ let header = Map.singleton "subscription" (A.At R.zero subType)

113 return $ CLet [msgVar] [] header CTrue constraint

107 return $ CLet [msgVar] [] header CTrue constraint

114

108

115

109

@@ -181,7 +175,7 @@ checkMap name home tipe constraint =

181 do a <- mkFlexVar

175 do a <- mkFlexVar

182 b <- mkFlexVar

176 b <- mkFlexVar

183 let mapType = toMapType home tipe (VarN a) (VarN b)

177 let mapType = toMapType home tipe (VarN a) (VarN b)

184− let mapCon = CLocal zero name (E.NoExpectation mapType)

178+ let mapCon = CLocal R.zero name (E.NoExpectation mapType)

185 return $ CLet [a,b] [] Map.empty mapCon constraint

179 return $ CLet [a,b] [] Map.empty mapCon constraint

186

180

187

181