74db13f · elk · git.iko.soy

elm-compiler.cabal+2−2

compare with master

unifiedsplit

@@ -108,7 +108,6 @@ Library

108 Reporting.Error.Pattern,

109 Reporting.Error.Syntax,

110 Reporting.Error.Type,

111− Reporting.PrettyPrint,

112 Reporting.Region,

111 Reporting.Region,

113 Reporting.Report,

112 Reporting.Report,

114 Reporting.Result,

113 Reporting.Result,

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

130 aeson >= 0.7 && < 0.9,

129 aeson >= 0.7 && < 0.9,

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

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

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

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

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

133 base >=4.2 && <5,

134 binary >= 0.7.0.0 && < 0.8,

135 bytestring >= 0.9 && < 0.11,

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

189 Test.Property.Arbitrary

190 AST.Helpers

191 AST.Literal

192− Reporting.PrettyPrint

193

192

194 build-depends:

193 build-depends:

195 test-framework > 0.8 && < 0.9,

194 test-framework > 0.8 && < 0.9,

@@ -200,6 +199,7 @@ Test-Suite compiler-tests

200 aeson >= 0.7 && < 0.9,

199 aeson >= 0.7 && < 0.9,

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

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

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

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

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

203 base >=4.2 && <5,

204 binary >= 0.7.0.0 && < 0.8,

205 bytestring >= 0.9 && < 0.11,

src/AST/Expression/Canonical.hs−24

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

1{-# OPTIONS_GHC -Wall #-}

2module AST.Expression.Canonical where

3

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

13

10

14

11

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

25

22

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)

29

25

30

26

31data Facts = Facts

27data Facts = Facts

32 { dependencies :: [Var.TopLevel]

28 { dependencies :: [Var.TopLevel]

33 }

29 }

34− deriving (Eq, Ord, Show)

35

30

36

31

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

40

35

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

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

8-}

9module AST.Expression.General where

10

11−import Text.PrettyPrint as P

12−

13import qualified AST.Helpers as Help

11import qualified AST.Helpers as Help

14import qualified AST.Literal as Literal

12import qualified AST.Literal as Literal

15import qualified AST.Pattern as Pattern

13import qualified AST.Pattern as Pattern

16import qualified AST.Type as Type

14import qualified AST.Type as Type

17import qualified AST.Variable as Var

15import qualified AST.Variable as Var

18import qualified Reporting.Annotation as A

16import qualified Reporting.Annotation as A

19−import qualified Reporting.PrettyPrint as P

20

17

21

18

22---- GENERAL AST ----

19---- GENERAL AST ----

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

58 -- for type checking and code gen only

55 -- for type checking and code gen only

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

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

60 | GLShader String String Literal.GLShaderTipe

57 | GLShader String String Literal.GLShaderTipe

61− deriving (Show)

62

58

63

59

64-- PORTS

60-- PORTS

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

67 = In String (Type.Port tipe)

63 = In String (Type.Port tipe)

68 | Out String expr (Type.Port tipe)

64 | Out String expr (Type.Port tipe)

69 | Task String expr (Type.Port tipe)

65 | Task String expr (Type.Port tipe)

70− deriving (Eq, Show)

66+ deriving (Eq)

71

67

72

68

73portName :: PortImpl expr tipe -> String

69portName :: PortImpl expr tipe -> String

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

100 "_save_the_environment!!!"

96 "_save_the_environment!!!"

101

97

102

98

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

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

104dummyLet defs =

100dummyLet defs =

105 let body =

101 let body =

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

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

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

108 A.A undefined (Let defs body)

104 A.A undefined (Let defs body)

109

105

110

106

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]

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

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

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

258 case expr of

109 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' =

22

23data Def

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

25− deriving (Show)

25+

src/AST/Literal.hs+3−11

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

2module AST.Literal where

3

4import qualified Data.Map as Map

5−import qualified Text.PrettyPrint as P

6−

7−import qualified Reporting.PrettyPrint as P

8

5

9

6

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)

22

14

23

15

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)

43

35

44

36

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

3

4import qualified Data.Set as Set

5−import Text.PrettyPrint as P

6

5

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

13

10

14

11

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

27

23

28

24

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

62

58

63

59

60+

64-- FIND VARIABLES

61-- FIND VARIABLES

65

62

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

99

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+19−197

@@ -10,18 +10,16 @@ module AST.Type

10import Control.Arrow (second)

11import Data.Binary

12import qualified Data.Map as Map

13−import qualified Data.Maybe as Maybe

14−import Text.PrettyPrint as P

15

13

16import qualified AST.Variable as Var

14import qualified AST.Variable as Var

17−import qualified AST.Helpers as Help

18import qualified Reporting.Annotation as A

15import qualified Reporting.Annotation as A

19−import qualified Reporting.PrettyPrint as P

20import qualified Reporting.Region as R

16import qualified Reporting.Region as R

21

17

22

18

19+

23-- DEFINITION

20-- DEFINITION

24

21

22+

25type Raw =

23type Raw =

26 A.Located Raw'

24 A.Located Raw'

27

25

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

32 | RType Var.Raw

30 | RType Var.Raw

33 | RApp Raw [Raw]

31 | RApp Raw [Raw]

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

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

35− deriving (Show)

36

33

37

34

38data Canonical

35data Canonical

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

42 | App Canonical [Canonical]

39 | App Canonical [Canonical]

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

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

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

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

45− deriving (Eq, Ord, Show)

42+ deriving (Eq, Ord)

46

43

47

44

48data Aliased t

45data Aliased t

49 = Holey t

46 = Holey t

50 | Filled t

47 | Filled t

51− deriving (Eq, Ord, Show)

48+ deriving (Eq, Ord)

52

49

53

50

54data Port t

51data Port t

55 = Normal t

52 = Normal t

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

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

57− deriving (Eq, Show)

54+ deriving (Eq)

58

55

59

56

60getPortType :: Port tipe -> tipe

57getPortType :: Port tipe -> tipe

@@ -71,8 +68,10 @@ tuple region types =

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

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

72

69

73

70

71+

74-- DEALIASING

72-- DEALIASING

75

73

74+

76deepDealias :: Canonical -> Canonical

75deepDealias :: Canonical -> Canonical

77deepDealias tipe =

76deepDealias tipe =

78 case tipe of

77 case tipe of

@@ -138,95 +137,23 @@ dealiasHelp typeTable tipe =

138 App (go f) (map go args)

137 App (go f) (map go args)

139

138

140

139

141−-- PRETTY PRINTING

142−

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

144− pretty dealiaser needsParens portType =

145− P.pretty dealiaser needsParens (getPortType portType)

146−

147−

148−instance P.Pretty Raw' where

149− pretty dealiaser needsParens tipe =

150− case tipe of

151− RLambda arg body ->

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

153−

154− RVar x ->

155− P.text x

156−

157− RType var ->

158− prettyType dealiaser var

159−

160− RApp func args ->

161− let

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

163− isTuple _ = False

164− in

165− prettyApp dealiaser needsParens isTuple func args

166−

167− RRecord fields ext ->

168− prettyRecord dealiaser (flattenRawRecord fields ext)

169−

170−

171−instance P.Pretty Canonical where

172− pretty dealiaser needsParens tipe =

173− case tipe of

174− Lambda arg body ->

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

176−

177− Var x ->

178− P.text x

179−

180− Type var ->

181− prettyType dealiaser var

182−

183− App func args ->

184− let

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

186− isTuple _ = False

187− in

188− prettyApp dealiaser needsParens isTuple func args

189−

190− Record fields ext ->

191− prettyRecord dealiaser (flattenCanRecord fields ext)

192

140

193− Aliased name args _ ->

141+-- COLLECT LAMBDAS

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

195− P.hang

196− (P.pretty dealiaser False name)

197− 2

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

199

142

200

143

201−-- PRETTY HELPERS

144+collectLambdas :: Canonical -> [Canonical]

202−

145+collectLambdas tipe =

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

146+ gatherLambda getCanLambda tipe

204−prettyType dealiaser var =

205− let

206− v = Var.toString var

207− in

208− P.text $

209− if v == "_Tuple0" then

210− "()"

211− else

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

213−

214

147

215−-- PRETTY LAMBDAS

216

148

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

149+gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]

218−prettyLambda dealiaser getLambda arg body =

150+gatherLambda get tipe =

219− let

151+ case get tipe of

220− rest =

152+ Just (arg, body) ->

221− gatherLambda getLambda body

153+ arg : gatherLambda get body

222

154

223− prettyArg t =

155+ Nothing ->

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

156+ [tipe]

225− in

226− P.sep

227− [ prettyArg arg

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

229− ]

230

157

231

158

232getRawLambda :: Raw -> Maybe (Raw, Raw)

159getRawLambda :: Raw -> Maybe (Raw, Raw)

@@ -243,115 +170,10 @@ getCanLambda tipe =

243 _ -> Nothing

170 _ -> Nothing

244

171

245

172

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

247−gatherLambda get tipe =

248− case get tipe of

249− Just (arg, body) ->

250− arg : gatherLambda get body

251−

252− Nothing ->

253− [tipe]

254−

255−

256−collectLambdas :: Canonical -> [Canonical]

257−collectLambdas tipe =

258− gatherLambda getCanLambda tipe

259−

260−

261−-- PRETTY APP

262−

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

264−prettyApp dealiaser needsParens isTuple func args

265− | isTuple func =

266− P.parens $ P.sep $

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

268−

269− | null args =

270− P.pretty dealiaser needsParens func

271−

272− | otherwise =

273− P.parensIf needsParens $

274− P.hang

275− (P.pretty dealiaser True func)

276− 2

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

278−

279−

280−-- PRETTY RECORD

281−

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

283−prettyRecord dealiaser recordInfo =

284− let

285− prettyField (field, tipe) =

286− P.hang

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

288− 4

289− (P.pretty dealiaser False tipe)

290− in

291− case recordInfo of

292− ([], Nothing) ->

293− P.text "{}"

294−

295− (fields, Nothing) ->

296− P.sep

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

298− , P.rbrace

299− ]

300−

301− (fields, Just x) ->

302− P.hang

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

304− 4

305− (P.sep

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

307− , P.rbrace

308− ]

309− )

310−

311−

312−flattenRawRecord

313− :: [(String, Raw)]

314− -> Maybe Raw

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

316−flattenRawRecord fields ext =

317− case ext of

318− Nothing ->

319− (fields, Nothing)

320−

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

322− (fields, Just x)

323−

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

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

326−

327− _ ->

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

329−

330−

331−flattenCanRecord

332− :: [(String, Canonical)]

333− -> Maybe Canonical

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

335−flattenCanRecord fields ext =

336− case ext of

337− Nothing ->

338− (fields, Nothing)

339−

340− Just (Var x) ->

341− (fields, Just x)

342−

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

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

345−

346− Just (Aliased _ args tipe) ->

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

348−

349− _ ->

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

351−

352

173

353-- BINARY

174-- BINARY

354

175

176+

355instance Binary Canonical where

177instance Binary Canonical where

356 put tipe =

178 put tipe =

357 case tipe of

179 case tipe of

src/AST/Variable.hs+18−44

@@ -3,44 +3,47 @@ module AST.Variable where

3import Data.Binary

4import qualified Data.Map as Map

5import qualified Data.Maybe as Maybe

6−import Text.PrettyPrint as P

7

6

8import qualified AST.Helpers as Help

7import qualified AST.Helpers as Help

9import qualified AST.Module.Name as ModuleName

8import qualified AST.Module.Name as ModuleName

10−import qualified Reporting.PrettyPrint as P

9+

11

10

12

11

13-- RAW NAMES

12-- RAW NAMES

14

13

14+

15newtype Raw = Raw String

16− deriving (Eq, Ord, Show)

16+ deriving (Eq, Ord)

17+

17

18

19

19-- TOP LEVEL NAMES

20-- TOP LEVEL NAMES

20

21

22+

21data TopLevel = TopLevelVar

23data TopLevel = TopLevelVar

22 { topHome :: ModuleName.Canonical

24 { topHome :: ModuleName.Canonical

23 , topName :: String

25 , topName :: String

24 }

26 }

25− deriving (Eq, Ord, Show)

27+ deriving (Eq, Ord)

26

28

27

29

28

30

29-- CANONICAL NAMES

31-- CANONICAL NAMES

30

32

33+

31data Home

34data Home

32 = BuiltIn

35 = BuiltIn

33 | Module ModuleName.Canonical

36 | Module ModuleName.Canonical

34 | TopLevel ModuleName.Canonical

37 | TopLevel ModuleName.Canonical

35 | Local

38 | Local

36− deriving (Eq, Ord, Show)

39+ deriving (Eq, Ord)

37

40

38

41

39data Canonical = Canonical

42data Canonical = Canonical

40 { home :: !Home

43 { home :: !Home

41 , name :: !String

44 , name :: !String

42 }

45 }

43− deriving (Eq, Ord, Show)

46+ deriving (Eq, Ord)

44

47

45

48

46local :: String -> Canonical

49local :: String -> Canonical

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

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

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

69

72

70

73

74+

71-- VARIABLE RECOGNIZERS

75-- VARIABLE RECOGNIZERS

72

76

77+

73isLocalHome :: Home -> Bool

78isLocalHome :: Home -> Bool

74isLocalHome home =

79isLocalHome home =

75 case home of

80 case home of

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

190 name

195 name

191

196

192

197

198+

193-- LISTINGS

199-- LISTINGS

194

200

201+

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

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

196data Listing a = Listing

203data Listing a = Listing

197 { _explicits :: [a]

204 { _explicits :: [a]

198 , _open :: Bool

205 , _open :: Bool

199 }

206 }

200− deriving (Eq, Ord, Show)

207+ deriving (Eq, Ord)

201

208

202

209

203openListing :: Listing a

210openListing :: Listing a

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

220 = Value !String

227 = Value !String

221 | Alias !String

228 | Alias !String

222 | Union !String !(Listing String)

229 | Union !String !(Listing String)

223− deriving (Eq, Ord, Show)

230+ deriving (Eq, Ord)

231+

224

232

225

233

226-- CATEGORIZING VALUES

234-- CATEGORIZING VALUES

227

235

236+

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

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

229getValues values =

238getValues values =

230 Maybe.mapMaybe getValue values

239 Maybe.mapMaybe getValue values

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

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

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

265

274

266

275

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

276

304-- BINARY SERIALIZATION

277-- BINARY SERIALIZATION

305

278

279+

306instance Binary Canonical where

280instance Binary Canonical where

307 put (Canonical home name) =

281 put (Canonical home name) =

308 case home of

282 case home of

src/Elm/Compiler.hs+18−17

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

6 , Dealiaser, dummyDealiaser

7 , Error, errorToString, errorToJson, printError

8 , Warning, warningToString, warningToJson, printWarning

9+ )

9− ) where

10+ where

10

11

11import qualified Data.Aeson as Json

12import qualified Data.Aeson as Json

12import qualified Data.Map as Map

13import qualified Data.Map as Map

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

24import qualified Parse.Parse as Parse

25import qualified Parse.Parse as Parse

25import qualified Reporting.Annotation as A

26import qualified Reporting.Annotation as A

26import qualified Reporting.Error as Error

27import qualified Reporting.Error as Error

27−import qualified Reporting.PrettyPrint as P

28+import qualified Reporting.Render.Type as RenderType

28import qualified Reporting.Result as Result

29import qualified Reporting.Result as Result

29import qualified Reporting.Warning as Warning

30import qualified Reporting.Warning as Warning

30

31

@@ -71,7 +72,7 @@ compile context source interfaces =

71 (Context packageName isRoot isExposed dependencies) =

72 (Context packageName isRoot isExposed dependencies) =

72 context

73 context

73

74

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

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

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

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

76 docs <- docsGen isExposed modul

77 docs <- docsGen isExposed modul

77

78

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

80

81

81 return (Result docs interface javascript)

82 return (Result docs interface javascript)

82 in

83 in

83− ( maybe dummyDealiaser Dealiaser dealiaser

84+ ( maybe dummyDealiaser Dealiaser localizer

84 , map Warning warnings

85 , map Warning warnings

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

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

86 )

87 )

@@ -125,7 +126,7 @@ docsGen isExposed modul =

125-- DEALIASER

126-- DEALIASER

126

127

127newtype Dealiaser =

128newtype Dealiaser =

128− Dealiaser P.Dealiaser

129+ Dealiaser RenderType.Localizer

129

130

131

131dummyDealiaser :: Dealiaser

132dummyDealiaser :: Dealiaser

@@ -140,18 +141,18 @@ newtype Error =

140

141

142

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

143errorToString :: Dealiaser -> String -> String -> Error -> String

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

144+errorToString (Dealiaser localizer) location source (Error err) =

144− Error.toString dealiaser location source err

145+ Error.toString localizer location source err

145

146

147

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

148printError :: Dealiaser -> String -> String -> Error -> IO ()

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

149+printError (Dealiaser localizer) location source (Error err) =

149− Error.print dealiaser location source err

150+ Error.print localizer location source err

150

151

152

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

153errorToJson :: Dealiaser -> String -> Error -> Json.Value

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

154+errorToJson (Dealiaser localizer) location (Error err) =

154− Error.toJson dealiaser location err

155+ Error.toJson localizer location err

155

156

157

157-- WARNINGS

158-- WARNINGS

@@ -161,17 +162,17 @@ newtype Warning =

161

162

163

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

164warningToString :: Dealiaser -> String -> String -> Warning -> String

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

165+warningToString (Dealiaser localizer) location source (Warning err) =

165− Warning.toString dealiaser location source err

166+ Warning.toString localizer location source err

166

167

168

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

169printWarning :: Dealiaser -> String -> String -> Warning -> IO ()

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

170+printWarning (Dealiaser localizer) location source (Warning err) =

170− Warning.print dealiaser location source err

171+ Warning.print localizer location source err

171

172

173

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

174warningToJson :: Dealiaser -> String -> Warning -> Json.Value

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

175+warningToJson (Dealiaser localizer) location (Warning err) =

175− Warning.toJson dealiaser location err

176+ Warning.toJson localizer location err

176

177

178

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

11

12

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 () (RenderType.tipe 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 () (RenderType.tipe Map.empty arg)

108 , toTypeFunction arg

109 ]

110

src/Reporting/Annotation.hs−8

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

1module Reporting.Annotation where

2

3import Prelude hiding (map)

4−import qualified Reporting.PrettyPrint as P

5import qualified Reporting.Region as R

4import qualified Reporting.Region as R

6

5

7

6

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

9

8

10data Annotated annotation a

9data Annotated annotation a

11 = A annotation a

10 = A annotation a

12− deriving (Show)

13

11

14

12

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

50

48

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+19−19

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

12import qualified Reporting.Error.Pattern as Pattern

13import qualified Reporting.Error.Syntax as Syntax

14import qualified Reporting.Error.Type as Type

15−import qualified Reporting.PrettyPrint as P

15+import qualified Reporting.Render.Type as RenderType

16import qualified Reporting.Report as Report

17

18

@@ -28,20 +28,20 @@ data Error

28

29-- TO REPORT

30

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

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

32−toReport dealiaser err =

32+toReport localizer err =

33 case err of

34 Syntax syntaxError ->

35− Syntax.toReport dealiaser syntaxError

35+ Syntax.toReport localizer syntaxError

36

37 Canonicalize canonicalizeError ->

38− Canonicalize.toReport dealiaser canonicalizeError

38+ Canonicalize.toReport localizer canonicalizeError

39

40 Type typeError ->

41− Type.toReport dealiaser typeError

41+ Type.toReport localizer typeError

42

43 Pattern patternError ->

44− Pattern.toReport dealiaser patternError

44+ Pattern.toReport localizer patternError

45

46 Docs docsError ->

47 Docs.toReport docsError

@@ -49,25 +49,25 @@ toReport dealiaser err =

49

50-- TO STRING

51

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

52+toString :: RenderType.Localizer -> String -> String -> A.Located Error -> String

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

53+toString localizer location source (A.A region err) =

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

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

55

56

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

57+print :: RenderType.Localizer -> String -> String -> A.Located Error -> IO ()

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

58+print localizer location source (A.A region err) =

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

59+ Report.printError location region (toReport localizer err) source

60

61

62-- TO JSON

63

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

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

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

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

66 let

67 (maybeRegion, additionalFields) =

68 case err of

69 Syntax syntaxError ->

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

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

71

72 Canonicalize canonicalizeError ->

73 let

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

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

77 (Canonicalize.extractSuggestions canonicalizeError)

78 in

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

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

80

81 Type typeError ->

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

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

83

84 Pattern patternError ->

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

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

86

87 Docs docsError ->

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

src/Reporting/Error/Canonicalize.hs+8−9

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

1{-# OPTIONS_GHC -Wall #-}

2module Reporting.Error.Canonicalize where

3

4−import qualified Text.PrettyPrint as P

5−

6import qualified AST.Module.Name as ModuleName

4import qualified AST.Module.Name as ModuleName

7import qualified AST.Type as Type

5import qualified AST.Type as Type

8import qualified AST.Variable as Var

6import qualified AST.Variable as Var

9import qualified Reporting.Error.Helpers as Help

7import qualified Reporting.Error.Helpers as Help

10−import qualified Reporting.PrettyPrint as P

11import qualified Reporting.Region as Region

8import qualified Reporting.Region as Region

9+import qualified Reporting.Render.Type as RenderType

12import qualified Reporting.Report as Report

10import qualified Reporting.Report as Report

13

11

14

12

@@ -114,8 +112,8 @@ namingError pre post =

114 Report.simple "NAMING ERROR" pre post

112 Report.simple "NAMING ERROR" pre post

115

113

116

114

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

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

118−toReport dealiaser err =

116+toReport localizer err =

119 case err of

117 case err of

120 Var (VarError kind name problem suggestions) ->

118 Var (VarError kind name problem suggestions) ->

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

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

@@ -161,8 +159,7 @@ toReport dealiaser err =

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

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

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

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

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

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

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

162+ ++ error "TODO RenderType.typeDecl localizer name tvars tipe"

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

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

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

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

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

168

165

@@ -211,8 +208,10 @@ toReport dealiaser err =

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

208 ++ " through " ++ boundPort ++ " `" ++ name ++ "`"

212

209

213 postHint =

210 postHint =

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

211+ "The specific unsupported type is:\n"

212+ ++ "\n"

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

213+ ++ error "TODO P.render (P.nest 4 (RenderType.doc localizer localType))" ++ "\n"

214+ ++ "\n"

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

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

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

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

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

217 ++ "Json.Values, and concrete records."

src/Reporting/Error/Pattern.hs+3−3

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

4import qualified AST.Module.Name as ModuleName

5import qualified AST.Variable as Var

6import qualified Nitpick.Pattern as Pattern

7−import qualified Reporting.PrettyPrint as P

7+import qualified Reporting.Render.Type as RenderType

8import qualified Reporting.Report as Report

9

10

@@ -21,8 +21,8 @@ data Origin

21

22-- TO REPORT

23

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

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

25−toReport dealiaser err =

25+toReport _localizer err =

26 case err of

27 Incomplete Arg unhandled ->

28 Report.simple

src/Reporting/Error/Syntax.hs+7−26

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

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

9

7

10import qualified AST.Helpers as Help

8import qualified AST.Helpers as Help

11import qualified AST.Type as Type

9import qualified AST.Type as Type

12−import qualified Reporting.PrettyPrint as P

10+import qualified Reporting.Render.Type as RenderType

13import qualified Reporting.Report as Report

11import qualified Reporting.Report as Report

14

12

15

13

@@ -31,8 +29,8 @@ data Error

31

29

32-- TO REPORT

30-- TO REPORT

33

31

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

@@ -135,29 +133,12 @@ toReport dealiaser err =

135 )

133 )

136

134

137 UnboundTypeVarsInAlias typeName givenVars tvar tvars tipe ->

135 UnboundTypeVarsInAlias typeName givenVars tvar tvars tipe ->

138− unboundTypeVars typeName tvar tvars $ P.render $

136+ unboundTypeVars typeName tvar tvars $

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)

137+ RenderType.aliasDecl localizer typeName (givenVars ++ tvar : tvars) tipe

145−

146

138

147 UnboundTypeVarsInUnion typeName givenVars tvar tvars ctors ->

139 UnboundTypeVarsInUnion typeName givenVars tvar tvars ctors ->

148− unboundTypeVars typeName tvar tvars $ P.render $

140+ unboundTypeVars typeName tvar tvars $

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)

141+ RenderType.typeDecl localizer typeName (givenVars ++ tvar : tvars) ctors

159− toDoc (ctor, args) =

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

161

142

162

143

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

144unboundTypeVars :: String -> String -> [String] -> String -> Report.Report

src/Reporting/Error/Type.hs+11−13

@@ -3,15 +3,13 @@ module Reporting.Error.Type where

3

4import qualified Data.Char as Char

5import qualified Data.List as List

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

7−import qualified Text.PrettyPrint as P

8

6

9import qualified AST.Helpers as AstHelp

7import qualified AST.Helpers as AstHelp

10import qualified AST.Type as Type

8import qualified AST.Type as Type

11import qualified AST.Variable as Var

9import qualified AST.Variable as Var

12import qualified Reporting.Error.Helpers as Help

10import qualified Reporting.Error.Helpers as Help

13−import qualified Reporting.PrettyPrint as P

14import qualified Reporting.Region as Region

11import qualified Reporting.Region as Region

12+import qualified Reporting.Render.Type as RenderType

15import qualified Reporting.Report as Report

13import qualified Reporting.Report as Report

16

14

17

15

@@ -81,26 +79,26 @@ data Pattern

81-- TO REPORT

79-- TO REPORT

82

80

83

81

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

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

85−toReport dealiaser err =

83+toReport localizer err =

86 case err of

84 case err of

87 Mismatch info ->

85 Mismatch info ->

88− mismatchToReport dealiaser info

86+ mismatchToReport localizer info

89

87

90 InfiniteType name var tipe ->

88 InfiniteType name var tipe ->

91 let

89 let

92 prettyVar =

90 prettyVar =

93− P.pretty dealiaser False var

91+ error "TODO P.pretty localizer False var"

94

92

95 prettyType =

93 prettyType =

96− P.pretty dealiaser False tipe

94+ error "TODO P.pretty localizer False tipe"

97 in

95 in

98 Report.simple "INFINITE TYPE"

96 Report.simple "INFINITE TYPE"

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

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

100 )

98 )

101 ( "TODO - do a better job\n\n"

99 ( "TODO - do a better job\n\n"

102 ++ "The bit of the type that is self-referential looks like this:\n\n"

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

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

101+ ++ error "TODO P.render (P.nest 4 (prettyVar <+> P.equals <+> prettyType))"

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

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

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

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

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

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

@@ -112,18 +110,18 @@ toReport dealiaser err =

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

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

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

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

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

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

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

113+ ++ RenderType.tipe localizer tipe

116

114

117

115

118−mismatchToReport :: P.Dealiaser -> Mismatch -> Report.Report

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

119−mismatchToReport dealiaser (MismatchInfo hint leftType rightType maybeReason) =

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

120 let

118 let

121 report =

119 report =

122 Report.Report "TYPE MISMATCH"

120 Report.Report "TYPE MISMATCH"

123

121

124 pretty tipe =

122 pretty tipe =

125 "\n\n"

123 "\n\n"

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

124+ ++ RenderType.tipe localizer tipe

127 ++ "\n\n"

125 ++ "\n\n"

128 in

126 in

129 case hint of

127 case hint of

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/Type.hsnew file+270

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

1+module Reporting.Render.Type

2+ ( Localizer

3+ , typeDecl

4+ , aliasDecl

5+ , annotation

6+ , tipe

7+ )

8+ where

9+

10+import qualified Data.Map as Map

11+import Text.PrettyPrint.ANSI.Leijen

12+

13+import qualified AST.Helpers as Help

14+

15+

16+type Localizer =

17+ Map.Map String String

18+

19+

20+typeDecl =

21+ error "TODO"

22+

23+

24+aliasDecl =

25+ error "TODO"

26+

27+

28+annotation =

29+ error "TODO"

30+

31+

32+tipe =

33+ error "TODO"

34+

35+

36+

37+{-- HELPERS

38+

39+commaCat :: [Doc] -> Doc

40+commaCat docs =

41+ cat (punctuate comma docs)

42+

43+

44+commaSep :: [Doc] -> Doc

45+commaSep docs =

46+ sep (punctuate comma docs)

47+

48+

49+parensIf :: Bool -> Doc -> Doc

50+parensIf bool doc =

51+ if bool then parens doc else doc

52+

53+

54+variable :: String -> Doc

55+variable x =

56+ if Help.isOp x then parens (text x) else text x

57+

58+

59+

60+-- PRETTY PRINTING

61+

62+instance (P.Pretty t) => P.Pretty (Port t) where

63+ pretty dealiaser needsParens portType =

64+ P.pretty dealiaser needsParens (getPortType portType)

65+

66+

67+instance P.Pretty Raw' where

68+ pretty dealiaser needsParens tipe =

69+ case tipe of

70+ RLambda arg body ->

71+ P.parensIf needsParens (prettyLambda dealiaser getRawLambda arg body)

72+

73+ RVar x ->

74+ P.text x

75+

76+ RType var ->

77+ prettyType dealiaser var

78+

79+ RApp func args ->

80+ let

81+ isTuple (A.A _ (RType name)) = Help.isTuple (Var.toString name)

82+ isTuple _ = False

83+ in

84+ prettyApp dealiaser needsParens isTuple func args

85+

86+ RRecord fields ext ->

87+ prettyRecord dealiaser (flattenRawRecord fields ext)

88+

89+

90+instance P.Pretty Canonical where

91+ pretty dealiaser needsParens tipe =

92+ case tipe of

93+ Lambda arg body ->

94+ P.parensIf needsParens (prettyLambda dealiaser getCanLambda arg body)

95+

96+ Var x ->

97+ P.text x

98+

99+ Type var ->

100+ prettyType dealiaser var

101+

102+ App func args ->

103+ let

104+ isTuple (Type name) = Help.isTuple (Var.toString name)

105+ isTuple _ = False

106+ in

107+ prettyApp dealiaser needsParens isTuple func args

108+

109+ Record fields ext ->

110+ prettyRecord dealiaser (flattenCanRecord fields ext)

111+

112+ Aliased name args _ ->

113+ P.parensIf (needsParens && not (null args)) $

114+ P.hang

115+ (P.pretty dealiaser False name)

116+ 2

117+ (P.sep (map (P.pretty dealiaser True . snd) args))

118+

119+

120+-- PRETTY HELPERS

121+

122+prettyType :: (Var.ToString var) => P.Dealiaser -> var -> P.Doc

123+prettyType dealiaser var =

124+ let

125+ v = Var.toString var

126+ in

127+ P.text $

128+ if v == "_Tuple0" then

129+ "()"

130+ else

131+ maybe v id (Map.lookup v dealiaser)

132+

133+

134+-- PRETTY LAMBDAS

135+

136+prettyLambda :: (P.Pretty t) => P.Dealiaser -> (t -> Maybe (t,t)) -> t -> t -> P.Doc

137+prettyLambda dealiaser getLambda arg body =

138+ let

139+ rest =

140+ gatherLambda getLambda body

141+

142+ prettyArg t =

143+ P.pretty dealiaser (Maybe.isJust (getLambda t)) t

144+ in

145+ P.sep

146+ [ prettyArg arg

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

148+ ]

149+

150+

151+getRawLambda :: Raw -> Maybe (Raw, Raw)

152+getRawLambda (A.A _ tipe) =

153+ case tipe of

154+ RLambda arg body -> Just (arg, body)

155+ _ -> Nothing

156+

157+

158+getCanLambda :: Canonical -> Maybe (Canonical, Canonical)

159+getCanLambda tipe =

160+ case tipe of

161+ Lambda arg body -> Just (arg, body)

162+ _ -> Nothing

163+

164+

165+gatherLambda :: (t -> Maybe (t,t)) -> t -> [t]

166+gatherLambda get tipe =

167+ case get tipe of

168+ Just (arg, body) ->

169+ arg : gatherLambda get body

170+

171+ Nothing ->

172+ [tipe]

173+

174+

175+collectLambdas :: Canonical -> [Canonical]

176+collectLambdas tipe =

177+ gatherLambda getCanLambda tipe

178+

179+

180+-- PRETTY APP

181+

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

183+prettyApp dealiaser needsParens isTuple func args

184+ | isTuple func =

185+ P.parens $ P.sep $

186+ P.punctuate P.comma (map (P.pretty dealiaser False) args)

187+

188+ | null args =

189+ P.pretty dealiaser needsParens func

190+

191+ | otherwise =

192+ P.parensIf needsParens $

193+ P.hang

194+ (P.pretty dealiaser True func)

195+ 2

196+ (P.sep (map (P.pretty dealiaser True) args))

197+

198+

199+-- PRETTY RECORD

200+

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

202+prettyRecord dealiaser recordInfo =

203+ let

204+ prettyField (field, tipe) =

205+ P.hang

206+ (P.text field <+> P.text ":")

207+ 4

208+ (P.pretty dealiaser False tipe)

209+ in

210+ case recordInfo of

211+ ([], Nothing) ->

212+ P.text "{}"

213+

214+ (fields, Nothing) ->

215+ P.sep

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

217+ , P.rbrace

218+ ]

219+

220+ (fields, Just x) ->

221+ P.hang

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

223+ 4

224+ (P.sep

225+ [ P.sep (P.punctuate P.comma (map prettyField fields))

226+ , P.rbrace

227+ ]

228+ )

229+

230+

231+flattenRawRecord

232+ :: [(String, Raw)]

233+ -> Maybe Raw

234+ -> ( [(String, Raw)], Maybe String )

235+flattenRawRecord fields ext =

236+ case ext of

237+ Nothing ->

238+ (fields, Nothing)

239+

240+ Just (A.A _ (RVar x)) ->

241+ (fields, Just x)

242+

243+ Just (A.A _ (RRecord fields' ext')) ->

244+ flattenRawRecord (fields' ++ fields) ext'

245+

246+ _ ->

247+ error "Trying to flatten ill-formed record."

248+

249+

250+flattenCanRecord

251+ :: [(String, Canonical)]

252+ -> Maybe Canonical

253+ -> ( [(String, Canonical)], Maybe String )

254+flattenCanRecord fields ext =

255+ case ext of

256+ Nothing ->

257+ (fields, Nothing)

258+

259+ Just (Var x) ->

260+ (fields, Just x)

261+

262+ Just (Record fields' ext') ->

263+ flattenCanRecord (fields' ++ fields) ext'

264+

265+ Just (Aliased _ args tipe) ->

266+ flattenCanRecord fields (Just (dealias args tipe))

267+

268+ _ ->

269+ error "Trying to flatten ill-formed record."

270+--}

src/Reporting/Result.hs+3−3

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

6

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

10

11

12-- TASK

13

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)

18

19

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

70 Result (dealiaser, newWarnings ++ warnings) rawResult

71

72

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

76

src/Reporting/Warning.hs+13−27

@@ -4,15 +4,12 @@ module Reporting.Warning where

4

5import Data.Aeson ((.=))

6import qualified Data.Aeson as Json

7−import qualified Text.PrettyPrint as P

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

9

7

10−import qualified AST.Helpers as Help

11import qualified AST.Module.Name as ModuleName

8import qualified AST.Module.Name as ModuleName

12import qualified AST.Type as Type

9import qualified AST.Type as Type

13import qualified Reporting.Annotation as A

10import qualified Reporting.Annotation as A

14−import qualified Reporting.PrettyPrint as P

15import qualified Reporting.Report as Report

11import qualified Reporting.Report as Report

12+import qualified Reporting.Render.Type as RenderType

16

13

17

14

18-- ALL POSSIBLE WARNINGS

15-- ALL POSSIBLE WARNINGS

@@ -24,18 +21,18 @@ data Warning

24

21

25-- TO STRING

22-- TO STRING

26

23

27−toString :: P.Dealiaser -> String -> String -> A.Located Warning -> String

24+toString :: RenderType.Localizer -> String -> String -> A.Located Warning -> String

28−toString dealiaser location source (A.A region warning) =

25+toString localizer location source (A.A region warning) =

29− Report.toString location region (toReport dealiaser warning) source

26+ Report.toString location region (toReport localizer warning) source

30

27

31

28

32−print :: P.Dealiaser -> String -> String -> A.Located Warning -> IO ()

29+print :: RenderType.Localizer -> String -> String -> A.Located Warning -> IO ()

33−print dealiaser location source (A.A region warning) =

30+print localizer location source (A.A region warning) =

34− Report.printWarning location region (toReport dealiaser warning) source

31+ Report.printWarning location region (toReport localizer warning) source

35

32

36

33

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

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

38−toReport dealiaser warning =

35+toReport localizer warning =

39 case warning of

36 case warning of

40 UnusedImport moduleName ->

37 UnusedImport moduleName ->

41 Report.simple

38 Report.simple

@@ -48,29 +45,18 @@ toReport dealiaser warning =

48 "missing type annotation"

45 "missing type annotation"

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

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

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

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

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

48+ ++ RenderType.annotation name inferredType

52 )

49 )

53− where

54− nameDoc =

55− if Help.isOp name then

56− P.parens (P.text name)

57− else

58− P.text name

59

50

60− typeDoc =

61− P.hang

62− (nameDoc <+> P.colon)

63− 4

64− (P.pretty dealiaser False inferredType)

65

51

66

52

67-- TO JSON

53-- TO JSON

68

54

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

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

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

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

71 let

57 let

72 (maybeRegion, additionalFields) =

58 (maybeRegion, additionalFields) =

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

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

74 in

60 in

75 Json.object $

61 Json.object $

76 [ "file" .= filePath

62 [ "file" .= filePath

src/Type/Constrain/Expression.hs+2−1

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