74db13f · elk · git.iko.soy

elm-compiler.cabal+2−2

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

108108 Reporting.Error.Pattern,

109109 Reporting.Error.Syntax,

110110 Reporting.Error.Type,

111− Reporting.PrettyPrint,

112111 Reporting.Region,

113112 Reporting.Report,

114113 Reporting.Result,

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

130129 aeson >= 0.7 && < 0.9,

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

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

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

133133 base >=4.2 && <5,

134134 binary >= 0.7.0.0 && < 0.8,

135135 bytestring >= 0.9 && < 0.11,

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

189189 Test.Property.Arbitrary

190190 AST.Helpers

191191 AST.Literal

192− Reporting.PrettyPrint

193192

194193 build-depends:

195194 test-framework > 0.8 && < 0.9,

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

200199 aeson >= 0.7 && < 0.9,

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

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

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

203203 base >=4.2 && <5,

204204 binary >= 0.7.0.0 && < 0.8,

205205 bytestring >= 0.9 && < 0.11,

src/AST/Expression/Canonical.hs−24

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

11{-# OPTIONS_GHC -Wall #-}

22module AST.Expression.Canonical where

33

4−import Text.PrettyPrint as P

5−

64import qualified AST.Expression.General as General

75import qualified AST.Pattern as Pattern

86import qualified AST.Type as Type

97import qualified AST.Variable as Var

108import qualified Reporting.Annotation as A

11−import qualified Reporting.PrettyPrint as P

129import qualified Reporting.Region as R

1310

1411

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

2522

2623data Def

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

28− deriving (Show)

2925

3026

3127data Facts = Facts

3228 { dependencies :: [Var.TopLevel]

3329 }

34− deriving (Eq, Ord, Show)

3530

3631

3732dummyFacts :: Facts

3833dummyFacts =

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

4035

41−

42−instance P.Pretty Def where

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

44− P.vcat [ annotation, definition ]

45− where

46− definition =

47− P.pretty dealiaser True pattern

48− <+> P.equals

49− <+> P.pretty dealiaser False expr

50−

51− annotation =

52− case maybeTipe of

53− Nothing ->

54− P.empty

55−

56− Just tipe ->

57− P.pretty dealiaser True pattern

58− <+> P.colon

59− <+> P.pretty dealiaser False tipe

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

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

88-}

99module AST.Expression.General where

1010

11−import Text.PrettyPrint as P

12−

1311import qualified AST.Helpers as Help

1412import qualified AST.Literal as Literal

1513import qualified AST.Pattern as Pattern

1614import qualified AST.Type as Type

1715import qualified AST.Variable as Var

1816import qualified Reporting.Annotation as A

19−import qualified Reporting.PrettyPrint as P

2017

2118

2219---- GENERAL AST ----

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

5855 -- for type checking and code gen only

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

6057 | GLShader String String Literal.GLShaderTipe

61− deriving (Show)

6258

6359

6460-- PORTS

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

6763 = In String (Type.Port tipe)

6864 | Out String expr (Type.Port tipe)

6965 | Task String expr (Type.Port tipe)

70− deriving (Eq, Show)

66+ deriving (Eq)

7167

7268

7369portName :: PortImpl expr tipe -> String

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

10096 "_save_the_environment!!!"

10197

10298

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

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

104100dummyLet defs =

105101 let body =

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

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

108104 A.A undefined (Let defs body)

109105

110106

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−

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

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

258109 case expr of

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

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

2828data Def'

2929 = Definition Pattern.RawPattern Expr

3030 | TypeAnnotation String Type.Raw

31− deriving (Show)

31+

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

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

2222

2323data Def

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

25− deriving (Show)

25+

src/AST/Literal.hs+3−11

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

22module AST.Literal where

33

44import qualified Data.Map as Map

5−import qualified Text.PrettyPrint as P

6−

7−import qualified Reporting.PrettyPrint as P

85

96

107data Literal

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

1310 | Chr Char

1411 | Str String

1512 | Boolean Bool

16− deriving (Eq, Ord, Show)

17−

18−

19−instance P.Pretty Literal where

20− pretty _ _ literal =

21− P.text (toString literal)

13+ deriving (Eq, Ord)

2214

2315

2416toString :: Literal -> String

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

3931 | V4

4032 | M4

4133 | Texture

42− deriving (Eq, Show)

34+ deriving (Eq)

4335

4436

4537glTipeName :: GLTipe -> String

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

5951 , uniform :: Map.Map String GLTipe

6052 , varying :: Map.Map String GLTipe

6153 }

62− deriving (Eq, Show)

54+ deriving (Eq)

src/AST/Pattern.hs+2−46

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

22module AST.Pattern where

33

44import qualified Data.Set as Set

5−import Text.PrettyPrint as P

65

7−import qualified AST.Helpers as Help

86import qualified AST.Literal as L

97import qualified AST.Variable as Var

108import qualified Reporting.Annotation as A

11−import qualified Reporting.PrettyPrint as P

129import qualified Reporting.Region as R

1310

1411

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

2320 | Var String

2421 | Anything

2522 | Literal L.Literal

26− deriving (Show)

2723

2824

2925type RawPattern =

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

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

6258

6359

60+

6461-- FIND VARIABLES

6562

63+

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

6765boundVars (A.A ann pattern) =

6866 case pattern of

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

9997boundVarList pattern =

10098 Set.toList (boundVarSet pattern)

10199

102−

103−-- PRETTY PRINTING

104−

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

106− pretty dealiaser needsParens pattern =

107− case pattern of

108− Var name ->

109− P.text name

110−

111− Literal literal ->

112− P.pretty dealiaser needsParens literal

113−

114− Record fields ->

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

116−

117− Alias x ptrn ->

118− P.parensIf needsParens $

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

120−

121− Anything ->

122− P.text "_"

123−

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

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

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

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

128− <+> P.pretty dealiaser False tl

129− where

130− isCons =

131− case hd of

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

133− _ -> False

134−

135− Data name patterns ->

136− let name' = Var.toString name

137− in

138− if Help.isTuple name'

139− then

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

141− else

142− P.parensIf needsParens $

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

src/AST/Type.hs+19−197

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

1010import Control.Arrow (second)

1111import Data.Binary

1212import qualified Data.Map as Map

13−import qualified Data.Maybe as Maybe

14−import Text.PrettyPrint as P

1513

1614import qualified AST.Variable as Var

17−import qualified AST.Helpers as Help

1815import qualified Reporting.Annotation as A

19−import qualified Reporting.PrettyPrint as P

2016import qualified Reporting.Region as R

2117

2218

19+

2320-- DEFINITION

2421

22+

2523type Raw =

2624 A.Located Raw'

2725

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

3230 | RType Var.Raw

3331 | RApp Raw [Raw]

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

35− deriving (Show)

3633

3734

3835data Canonical

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

4239 | App Canonical [Canonical]

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

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

45− deriving (Eq, Ord, Show)

42+ deriving (Eq, Ord)

4643

4744

4845data Aliased t

4946 = Holey t

5047 | Filled t

51− deriving (Eq, Ord, Show)

48+ deriving (Eq, Ord)

5249

5350

5451data Port t

5552 = Normal t

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

57− deriving (Eq, Show)

54+ deriving (Eq)

5855

5956

6057getPortType :: Port tipe -> tipe

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

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

7269

7370

71+

7472-- DEALIASING

7573

74+

7675deepDealias :: Canonical -> Canonical

7776deepDealias tipe =

7877 case tipe of

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

138137 App (go f) (map go args)

139138

140139

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)

192140

193− Aliased name args _ ->

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

141+-- COLLECT LAMBDAS

199142

200143

201−-- PRETTY HELPERS

202−

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

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−

144+collectLambdas :: Canonical -> [Canonical]

145+collectLambdas tipe =

146+ gatherLambda getCanLambda tipe

214147

215−-- PRETTY LAMBDAS

216148

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

218−prettyLambda dealiaser getLambda arg body =

219− let

220− rest =

221− gatherLambda getLambda body

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

150+gatherLambda get tipe =

151+ case get tipe of

152+ Just (arg, body) ->

153+ arg : gatherLambda get body

222154

223− prettyArg t =

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

225− in

226− P.sep

227− [ prettyArg arg

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

229− ]

155+ Nothing ->

156+ [tipe]

230157

231158

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

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

243170 _ -> Nothing

244171

245172

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−

352173

353174-- BINARY

354175

176+

355177instance Binary Canonical where

356178 put tipe =

357179 case tipe of

src/AST/Variable.hs+18−44

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

33import Data.Binary

44import qualified Data.Map as Map

55import qualified Data.Maybe as Maybe

6−import Text.PrettyPrint as P

76

87import qualified AST.Helpers as Help

98import qualified AST.Module.Name as ModuleName

10−import qualified Reporting.PrettyPrint as P

9+

1110

1211

1312-- RAW NAMES

1413

14+

1515newtype Raw = Raw String

16− deriving (Eq, Ord, Show)

16+ deriving (Eq, Ord)

17+

1718

1819

1920-- TOP LEVEL NAMES

2021

22+

2123data TopLevel = TopLevelVar

2224 { topHome :: ModuleName.Canonical

2325 , topName :: String

2426 }

25− deriving (Eq, Ord, Show)

27+ deriving (Eq, Ord)

2628

2729

2830

2931-- CANONICAL NAMES

3032

33+

3134data Home

3235 = BuiltIn

3336 | Module ModuleName.Canonical

3437 | TopLevel ModuleName.Canonical

3538 | Local

36− deriving (Eq, Ord, Show)

39+ deriving (Eq, Ord)

3740

3841

3942data Canonical = Canonical

4043 { home :: !Home

4144 , name :: !String

4245 }

43− deriving (Eq, Ord, Show)

46+ deriving (Eq, Ord)

4447

4548

4649local :: String -> Canonical

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

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

6972

7073

74+

7175-- VARIABLE RECOGNIZERS

7276

77+

7378isLocalHome :: Home -> Bool

7479isLocalHome home =

7580 case home of

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

190195 name

191196

192197

198+

193199-- LISTINGS

194200

201+

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

196203data Listing a = Listing

197204 { _explicits :: [a]

198205 , _open :: Bool

199206 }

200− deriving (Eq, Ord, Show)

207+ deriving (Eq, Ord)

201208

202209

203210openListing :: Listing a

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

220227 = Value !String

221228 | Alias !String

222229 | Union !String !(Listing String)

223− deriving (Eq, Ord, Show)

230+ deriving (Eq, Ord)

231+

224232

225233

226234-- CATEGORIZING VALUES

227235

236+

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

229238getValues values =

230239 Maybe.mapMaybe getValue values

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

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

265274

266275

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−

303276

304277-- BINARY SERIALIZATION

305278

279+

306280instance Binary Canonical where

307281 put (Canonical home name) =

308282 case home of

src/Elm/Compiler.hs+18−17

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

66 , Dealiaser, dummyDealiaser

77 , Error, errorToString, errorToJson, printError

88 , Warning, warningToString, warningToJson, printWarning

9− ) where

9+ )

10+ where

1011

1112import qualified Data.Aeson as Json

1213import qualified Data.Map as Map

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

2425import qualified Parse.Parse as Parse

2526import qualified Reporting.Annotation as A

2627import qualified Reporting.Error as Error

27−import qualified Reporting.PrettyPrint as P

28+import qualified Reporting.Render.Type as RenderType

2829import qualified Reporting.Result as Result

2930import qualified Reporting.Warning as Warning

3031

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

7172 (Context packageName isRoot isExposed dependencies) =

7273 context

7374

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

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

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

7677 docs <- docsGen isExposed modul

7778

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

8081

8182 return (Result docs interface javascript)

8283 in

83− ( maybe dummyDealiaser Dealiaser dealiaser

84+ ( maybe dummyDealiaser Dealiaser localizer

8485 , map Warning warnings

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

8687 )

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

125126-- DEALIASER

126127

127128newtype Dealiaser =

128− Dealiaser P.Dealiaser

129+ Dealiaser RenderType.Localizer

129130

130131

131132dummyDealiaser :: Dealiaser

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

140141

141142

142143errorToString :: Dealiaser -> String -> String -> Error -> String

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

144− Error.toString dealiaser location source err

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

145+ Error.toString localizer location source err

145146

146147

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

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

149− Error.print dealiaser location source err

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

150+ Error.print localizer location source err

150151

151152

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

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

154− Error.toJson dealiaser location err

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

155+ Error.toJson localizer location err

155156

156157

157158-- WARNINGS

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

161162

162163

163164warningToString :: Dealiaser -> String -> String -> Warning -> String

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

165− Warning.toString dealiaser location source err

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

166+ Warning.toString localizer location source err

166167

167168

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

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

170− Warning.print dealiaser location source err

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

171+ Warning.print localizer location source err

171172

172173

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

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

175− Warning.toJson dealiaser location err

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

176+ Warning.toJson localizer location err

176177

177178

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

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

77import qualified AST.Type as T

88import qualified AST.Variable as Var

99import Generate.JavaScript.Helpers

10−import qualified Reporting.PrettyPrint as P

10+import qualified Reporting.Render.Type as RenderType

1111

1212

1313-- TASK

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

9797 T.Normal tipe ->

9898 _Port "inbound" `call`

9999 [ StringLit () name

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

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

101101 , toTypeFunction tipe

102102 ]

103103

104104 T.Signal _root arg ->

105105 _Port "inboundSignal" `call`

106106 [ StringLit () name

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

107+ , StringLit () (RenderType.tipe Map.empty arg)

108108 , toTypeFunction arg

109109 ]

110110

src/Reporting/Annotation.hs−8

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

11module Reporting.Annotation where

22

33import Prelude hiding (map)

4−import qualified Reporting.PrettyPrint as P

54import qualified Reporting.Region as R

65

76

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

98

109data Annotated annotation a

1110 = A annotation a

12− deriving (Show)

1311

1412

1513type Located a =

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

4846drop (A _ value) =

4947 value

5048

51−

52−-- PRETTY PRINT

53−

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

55− pretty dealiaser parens (A _ value) =

56− P.pretty dealiaser parens value

src/Reporting/Error.hs+19−19

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

1212import qualified Reporting.Error.Pattern as Pattern

1313import qualified Reporting.Error.Syntax as Syntax

1414import qualified Reporting.Error.Type as Type

15−import qualified Reporting.PrettyPrint as P

15+import qualified Reporting.Render.Type as RenderType

1616import qualified Reporting.Report as Report

1717

1818

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

2828

2929-- TO REPORT

3030

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

32−toReport dealiaser err =

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

32+toReport localizer err =

3333 case err of

3434 Syntax syntaxError ->

35− Syntax.toReport dealiaser syntaxError

35+ Syntax.toReport localizer syntaxError

3636

3737 Canonicalize canonicalizeError ->

38− Canonicalize.toReport dealiaser canonicalizeError

38+ Canonicalize.toReport localizer canonicalizeError

3939

4040 Type typeError ->

41− Type.toReport dealiaser typeError

41+ Type.toReport localizer typeError

4242

4343 Pattern patternError ->

44− Pattern.toReport dealiaser patternError

44+ Pattern.toReport localizer patternError

4545

4646 Docs docsError ->

4747 Docs.toReport docsError

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

4949

5050-- TO STRING

5151

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

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

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

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

5555

5656

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

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

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

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

6060

6161

6262-- TO JSON

6363

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

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

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

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

6666 let

6767 (maybeRegion, additionalFields) =

6868 case err of

6969 Syntax syntaxError ->

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

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

7171

7272 Canonicalize canonicalizeError ->

7373 let

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

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

7777 (Canonicalize.extractSuggestions canonicalizeError)

7878 in

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

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

8080

8181 Type typeError ->

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

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

8383

8484 Pattern patternError ->

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

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

8686

8787 Docs docsError ->

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

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

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

11{-# OPTIONS_GHC -Wall #-}

22module Reporting.Error.Canonicalize where

33

4−import qualified Text.PrettyPrint as P

5−

64import qualified AST.Module.Name as ModuleName

75import qualified AST.Type as Type

86import qualified AST.Variable as Var

97import qualified Reporting.Error.Helpers as Help

10−import qualified Reporting.PrettyPrint as P

118import qualified Reporting.Region as Region

9+import qualified Reporting.Render.Type as RenderType

1210import qualified Reporting.Report as Report

1311

1412

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

114112 Report.simple "NAMING ERROR" pre post

115113

116114

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

118−toReport dealiaser err =

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

116+toReport localizer err =

119117 case err of

120118 Var (VarError kind name problem suggestions) ->

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

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

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

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

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

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

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

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

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

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

168165

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

211208 ++ " through " ++ boundPort ++ " `" ++ name ++ "`"

212209

213210 postHint =

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

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

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

212+ ++ "\n"

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

214+ ++ "\n"

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

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

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

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

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

44import qualified AST.Module.Name as ModuleName

55import qualified AST.Variable as Var

66import qualified Nitpick.Pattern as Pattern

7−import qualified Reporting.PrettyPrint as P

7+import qualified Reporting.Render.Type as RenderType

88import qualified Reporting.Report as Report

99

1010

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

2121

2222-- TO REPORT

2323

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

25−toReport dealiaser err =

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

25+toReport _localizer err =

2626 case err of

2727 Incomplete Arg unhandled ->

2828 Report.simple

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

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

44import qualified Data.List as List

55import qualified Data.Set as Set

66import qualified Text.Parsec.Error as Parsec

7−import qualified Text.PrettyPrint as P

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

97

108import qualified AST.Helpers as Help

119import qualified AST.Type as Type

12−import qualified Reporting.PrettyPrint as P

10+import qualified Reporting.Render.Type as RenderType

1311import qualified Reporting.Report as Report

1412

1513

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

3129

3230-- TO REPORT

3331

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

35−toReport dealiaser err =

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

33+toReport localizer err =

3634 case err of

3735 Parse messages ->

3836 parseErrorReport messages

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

135133 )

136134

137135 UnboundTypeVarsInAlias typeName givenVars tvar tvars tipe ->

138− unboundTypeVars typeName tvar tvars $ P.render $

139− P.hang

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

141− 4

142− (P.pretty dealiaser False tipe)

143− where

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

145−

136+ unboundTypeVars typeName tvar tvars $

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

146138

147139 UnboundTypeVarsInUnion typeName givenVars tvar tvars ctors ->

148− unboundTypeVars typeName tvar tvars $ P.render $

149− P.vcat

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

151− , map toDoc ctors

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

153− |> P.vcat

154− |> P.nest 4

155− ]

156− where

157− (|>) = flip ($)

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

159− toDoc (ctor, args) =

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

140+ unboundTypeVars typeName tvar tvars $

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

161142

162143

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

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

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

33

44import qualified Data.Char as Char

55import qualified Data.List as List

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

7−import qualified Text.PrettyPrint as P

86

97import qualified AST.Helpers as AstHelp

108import qualified AST.Type as Type

119import qualified AST.Variable as Var

1210import qualified Reporting.Error.Helpers as Help

13−import qualified Reporting.PrettyPrint as P

1411import qualified Reporting.Region as Region

12+import qualified Reporting.Render.Type as RenderType

1513import qualified Reporting.Report as Report

1614

1715

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

8179-- TO REPORT

8280

8381

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

85−toReport dealiaser err =

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

83+toReport localizer err =

8684 case err of

8785 Mismatch info ->

88− mismatchToReport dealiaser info

86+ mismatchToReport localizer info

8987

9088 InfiniteType name var tipe ->

9189 let

9290 prettyVar =

93− P.pretty dealiaser False var

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

9492

9593 prettyType =

96− P.pretty dealiaser False tipe

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

9795 in

9896 Report.simple "INFINITE TYPE"

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

10098 )

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

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

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

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

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

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

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

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

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

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

113+ ++ RenderType.tipe localizer tipe

116114

117115

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

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

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

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

120118 let

121119 report =

122120 Report.Report "TYPE MISMATCH"

123121

124122 pretty tipe =

125123 "\n\n"

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

124+ ++ RenderType.tipe localizer tipe

127125 ++ "\n\n"

128126 in

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

66

77import qualified Reporting.Annotation as A

88import qualified Reporting.Region as R

9−import qualified Reporting.PrettyPrint as P

9+import qualified Reporting.Render.Type as RenderType

1010

1111

1212-- TASK

1313

1414data Result warning error result =

1515 Result

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

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

1717 (RawResult [A.Located error] result)

1818

1919

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

7070 Result (dealiaser, newWarnings ++ warnings) rawResult

7171

7272

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

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

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

7575 Result (Just dealiaser, warnings) rawResult

7676

src/Reporting/Warning.hs+13−27

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

44

55import Data.Aeson ((.=))

66import qualified Data.Aeson as Json

7−import qualified Text.PrettyPrint as P

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

97

10−import qualified AST.Helpers as Help

118import qualified AST.Module.Name as ModuleName

129import qualified AST.Type as Type

1310import qualified Reporting.Annotation as A

14−import qualified Reporting.PrettyPrint as P

1511import qualified Reporting.Report as Report

12+import qualified Reporting.Render.Type as RenderType

1613

1714

1815-- ALL POSSIBLE WARNINGS

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

2421

2522-- TO STRING

2623

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

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

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

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

3027

3128

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

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

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

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

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

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

3532

3633

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

38−toReport dealiaser warning =

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

35+toReport localizer warning =

3936 case warning of

4037 UnusedImport moduleName ->

4138 Report.simple

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

4845 "missing type annotation"

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

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

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

48+ ++ RenderType.annotation name inferredType

5249 )

53− where

54− nameDoc =

55− if Help.isOp name then

56− P.parens (P.text name)

57− else

58− P.text name

5950

60− typeDoc =

61− P.hang

62− (nameDoc <+> P.colon)

63− 4

64− (P.pretty dealiaser False inferredType)

6551

6652

6753-- TO JSON

6854

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

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

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

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

7157 let

7258 (maybeRegion, additionalFields) =

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

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

7460 in

7561 Json.object $

7662 [ "file" .= filePath

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

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

499499 (P.Var name, Nothing) ->

500500 constrainUnannotatedDef env info qs patternRegion name expr

501501

502− _ -> error ("problem in constrainDef with " ++ show pattern)

502+ _ ->

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

503504

504505

505506constrainAnnotatedDef