e33c47b · elk · git.iko.soy

src/AST/Expression/Canonical.hs+7−3

@@ -28,11 +28,13 @@ data Def

2828

2929

3030instance P.Pretty Def where

31− pretty _ (Definition pattern expr maybeTipe) =

31+ pretty dealiaser _ (Definition pattern expr maybeTipe) =

3232 P.vcat [ annotation, definition ]

3333 where

3434 definition =

35− P.pretty True pattern <+> P.equals <+> P.pretty False expr

35+ P.pretty dealiaser True pattern

36+ <+> P.equals

37+ <+> P.pretty dealiaser False expr

3638

3739 annotation =

3840 case maybeTipe of

@@ -40,4 +42,6 @@ instance P.Pretty Def where

4042 P.empty

4143

4244 Just tipe ->

43− P.pretty True pattern <+> P.colon <+> P.pretty False tipe

45+ P.pretty dealiaser True pattern

46+ <+> P.colon

47+ <+> P.pretty dealiaser False tipe

src/AST/Expression/General.hs+33−33

@@ -113,53 +113,53 @@ dummyLet defs =

113113-- PRETTY PRINTING

114114

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

116− pretty needsParens expression =

116+ pretty dealiaser needsParens expression =

117117 case expression of

118118 Literal literal ->

119− P.pretty needsParens literal

119+ P.pretty dealiaser needsParens literal

120120

121121 Var x ->

122− P.pretty needsParens x

122+ P.pretty dealiaser needsParens x

123123

124124 Range lowExpr highExpr ->

125125 P.brackets $

126− P.pretty False lowExpr

126+ P.pretty dealiaser False lowExpr

127127 <> P.text ".."

128− <> P.pretty False highExpr

128+ <> P.pretty dealiaser False highExpr

129129

130130 ExplicitList elements ->

131− P.brackets (P.commaCat (map (P.pretty False) elements))

131+ P.brackets (P.commaCat (map (P.pretty dealiaser False) elements))

132132

133133 Binop op (A.A _ (Literal (Literal.IntNum 0))) expr

134134 | Var.toString op == "-" ->

135− P.text "-" <> P.pretty True expr

135+ P.text "-" <> P.pretty dealiaser True expr

136136

137137 Binop op leftExpr rightExpr ->

138138 P.parensIf needsParens $

139139 P.hang

140− (P.pretty True leftExpr)

140+ (P.pretty dealiaser True leftExpr)

141141 2

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

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

143143 where

144144 op' = Var.toString op

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

146146

147147 Lambda pattern expr ->

148148 P.parensIf needsParens $

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

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

150150 where

151151 (patterns, body) =

152152 collectLambdas expr

153153

154154 args =

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

155+ P.sep (map (P.pretty dealiaser True) (pattern : patterns))

156156

157157 App expr arg ->

158158 P.parensIf needsParens $

159159 P.hang func 2 (P.sep args)

160160 where

161161 func:args =

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

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

163163

164164 MultiIf branches ->

165165 P.parensIf needsParens $

@@ -168,9 +168,9 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

168168 iff (condition, branch) =

169169 P.text "|" <+>

170170 P.hang

171− (P.pretty False condition <+> P.text "->")

171+ (P.pretty dealiaser False condition <+> P.text "->")

172172 2

173− (P.pretty False branch)

173+ (P.pretty dealiaser False branch)

174174

175175 Let defs body ->

176176 P.parensIf needsParens $

@@ -178,8 +178,8 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

178178 [ P.hang

179179 (P.text "let")

180180 4

181− (P.vcat (map (P.pretty False) defs))

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

181+ (P.vcat (map (P.pretty dealiaser False) defs))

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

183183 ]

184184

185185 Case expr branches ->

@@ -187,16 +187,16 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

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

188188 where

189189 pexpr =

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

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

191191

192192 pretty' (pattern, branch) =

193− P.pretty False pattern

193+ P.pretty dealiaser False pattern

194194 <+> P.text "->"

195− <+> P.pretty False branch

195+ <+> P.pretty dealiaser False branch

196196

197197 Data "::" [hd,tl] ->

198198 P.parensIf needsParens $

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

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

200200

201201 Data "[]" [] ->

202202 P.text "[]"

@@ -204,49 +204,49 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

204204 Data name exprs ->

205205 if Help.isTuple name

206206 then

207− P.parens (P.commaCat (map (P.pretty False) exprs))

207+ P.parens (P.commaCat (map (P.pretty dealiaser False) exprs))

208208 else

209209 P.parensIf (needsParens && not (null exprs)) $

210210 P.hang

211211 (P.text name)

212212 2

213− (P.sep (map (P.pretty True) exprs))

213+ (P.sep (map (P.pretty dealiaser True) exprs))

214214

215215 Access record field ->

216− P.pretty True record <> P.text "." <> P.text field

216+ P.pretty dealiaser True record <> P.text "." <> P.text field

217217

218218 Remove record field ->

219− P.braces (P.pretty False record <+> P.text "-" <+> P.text field)

219+ P.braces (P.pretty dealiaser False record <+> P.text "-" <+> P.text field)

220220

221221 Insert (A.A _ (Remove record oldField)) newField expr ->

222222 P.braces $

223223 P.hsep

224− [ P.pretty False record

224+ [ P.pretty dealiaser False record

225225 , P.text "-"

226226 , P.text oldField

227227 , P.text "|"

228228 , P.text newField

229229 , P.equals

230− , P.pretty False expr

230+ , P.pretty dealiaser False expr

231231 ]

232232

233233 Insert record field expr ->

234234 P.braces $

235− P.pretty False record

235+ P.pretty dealiaser False record

236236 <+> P.text "|"

237237 <+> P.text field

238238 <+> P.equals

239− <+> P.pretty False expr

239+ <+> P.pretty dealiaser False expr

240240

241241 Modify record fields ->

242242 P.braces $

243243 P.hang

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

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

245245 4

246246 (P.commaSep $ map prettyField fields)

247247 where

248248 prettyField (field, expr) =

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

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

250250

251251 Record fields ->

252252 P.sep

@@ -255,17 +255,17 @@ instance (P.Pretty def, P.Pretty var, Var.ToString var) => P.Pretty (Expr' ann d

255255 ]

256256 where

257257 field (name, expr) =

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

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

259259

260260 GLShader _ _ _ ->

261261 P.text "[glsl| ... |]"

262262

263263 Port portImpl ->

264− P.pretty needsParens portImpl

264+ P.pretty dealiaser needsParens portImpl

265265

266266

267267instance P.Pretty (PortImpl expr tipe) where

268− pretty _ impl =

268+ pretty _ _ impl =

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

270270

271271

src/AST/Literal.hs+1−1

@@ -17,7 +17,7 @@ data Literal

1717

1818

1919instance P.Pretty Literal where

20− pretty _ literal =

20+ pretty _ _ literal =

2121 case literal of

2222 IntNum n -> P.int n

2323 FloatNum n -> P.double n

src/AST/Pattern.hs+7−7

@@ -103,29 +103,29 @@ boundVarList pattern =

103103-- PRETTY PRINTING

104104

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

106− pretty needsParens pattern =

106+ pretty dealiaser needsParens pattern =

107107 case pattern of

108108 Var name ->

109109 P.text name

110110

111111 Literal literal ->

112− P.pretty needsParens literal

112+ P.pretty dealiaser needsParens literal

113113

114114 Record fields ->

115115 P.braces (P.commaCat (map P.text fields))

116116

117117 Alias x ptrn ->

118118 P.parensIf needsParens $

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

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

120120

121121 Anything ->

122122 P.text "_"

123123

124124 Data name [A.A _ hd, A.A _ tl]

125125 | Var.toString name == "::" ->

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

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

127127 <+> P.text "::"

128− <+> P.pretty False tl

128+ <+> P.pretty dealiaser False tl

129129 where

130130 isCons =

131131 case hd of

@@ -137,7 +137,7 @@ instance Var.ToString var => P.Pretty (Pattern' ann var) where

137137 in

138138 if Help.isTuple name'

139139 then

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

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

141141 else

142142 P.parensIf needsParens $

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

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

src/AST/Type.hs+36−37

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

11module AST.Type

22 ( Raw, Raw'(..)

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

4− , Port(..), portType

4+ , Port(..), getPortType

55 , deepDealias, dealias

66 , collectLambdas

77 , fieldMap

@@ -59,8 +59,8 @@ data Port t

5959 deriving (Show)

6060

6161

62−portType :: Port tipe -> tipe

63−portType portType =

62+getPortType :: Port tipe -> tipe

63+getPortType portType =

6464 case portType of

6565 Normal tipe -> tipe

6666 Signal tipe _ -> tipe

@@ -152,88 +152,87 @@ dealiasHelp typeTable tipe =

152152-- PRETTY PRINTING

153153

154154instance (P.Pretty t) => P.Pretty (Port t) where

155− pretty needsParens portType =

156− case portType of

157− Normal tipe ->

158− P.pretty needsParens tipe

159−

160− Signal tipe _ ->

161− P.pretty needsParens tipe

155+ pretty dealiaser needsParens portType =

156+ P.pretty dealiaser needsParens (getPortType portType)

162157

163158

164159instance P.Pretty Raw' where

165− pretty needsParens tipe =

160+ pretty dealiaser needsParens tipe =

166161 case tipe of

167162 RLambda arg body ->

168− P.parensIf needsParens (prettyLambda getRawLambda arg body)

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

169164

170165 RVar x ->

171166 P.text x

172167

173168 RType var ->

174− prettyType var

169+ prettyType dealiaser var

175170

176171 RApp func args ->

177172 let

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

179174 isTuple _ = False

180175 in

181− prettyApp needsParens isTuple func args

176+ prettyApp dealiaser needsParens isTuple func args

182177

183178 RRecord fields ext ->

184− prettyRecord (flattenRawRecord fields ext)

179+ prettyRecord dealiaser (flattenRawRecord fields ext)

185180

186181

187182instance P.Pretty Canonical where

188− pretty needsParens tipe =

183+ pretty dealiaser needsParens tipe =

189184 case tipe of

190185 Lambda arg body ->

191− P.parensIf needsParens (prettyLambda getCanLambda arg body)

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

192187

193188 Var x ->

194189 P.text x

195190

196191 Type var ->

197− prettyType var

192+ prettyType dealiaser var

198193

199194 App func args ->

200195 let

201196 isTuple (Type name) = Help.isTuple (Var.toString name)

202197 isTuple _ = False

203198 in

204− prettyApp needsParens isTuple func args

199+ prettyApp dealiaser needsParens isTuple func args

205200

206201 Record fields ext ->

207− prettyRecord (flattenCanRecord fields ext)

202+ prettyRecord dealiaser (flattenCanRecord fields ext)

208203

209204 Aliased name args _ ->

210205 P.parensIf (needsParens && not (null args)) $

211206 P.hang

212− (P.pretty False name)

207+ (P.pretty dealiaser False name)

213208 2

214− (P.sep (map (P.pretty True . snd) args))

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

215210

216211

217212-- PRETTY HELPERS

218213

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

220−prettyType var =

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

215+prettyType dealiaser var =

221216 let

222217 v = Var.toString var

223218 in

224− P.text (if v == "_Tuple0" then "()" else v)

219+ P.text $

220+ if v == "_Tuple0" then

221+ "()"

222+ else

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

225224

226225

227226-- PRETTY LAMBDAS

228227

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

230−prettyLambda getLambda arg body =

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

229+prettyLambda dealiaser getLambda arg body =

231230 let

232231 rest =

233232 gatherLambda getLambda body

234233

235234 prettyArg t =

236− P.pretty (Maybe.isJust (getLambda t)) t

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

237236 in

238237 P.sep

239238 [ prettyArg arg

@@ -272,33 +271,33 @@ collectLambdas tipe =

272271

273272-- PRETTY APP

274273

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

276−prettyApp needsParens isTuple func args

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

275+prettyApp dealiaser needsParens isTuple func args

277276 | isTuple func =

278277 P.parens $ P.sep $

279− P.punctuate P.comma (map (P.pretty False) args)

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

280279

281280 | null args =

282− P.pretty needsParens func

281+ P.pretty dealiaser needsParens func

283282

284283 | otherwise =

285284 P.parensIf needsParens $

286285 P.hang

287− (P.pretty True func)

286+ (P.pretty dealiaser True func)

288287 2

289− (P.sep (map (P.pretty True) args))

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

290289

291290

292291-- PRETTY RECORD

293292

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

295−prettyRecord recordInfo =

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

294+prettyRecord dealiaser recordInfo =

296295 let

297296 prettyField (field, tipe) =

298297 P.hang

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

300299 4

301− (P.pretty False tipe)

300+ (P.pretty dealiaser False tipe)

302301 in

303302 case recordInfo of

304303 ([], Nothing) ->

src/AST/Variable.hs+11−7

@@ -3,6 +3,7 @@ module AST.Variable where

33import Control.Applicative ((<$>), (<*>))

44import Data.Binary

55import qualified Data.List as List

6+import qualified Data.Map as Map

67import qualified Data.Maybe as Maybe

78import Text.PrettyPrint as P

89

@@ -203,26 +204,29 @@ getUnion value =

203204-- PRETTY VARIABLES

204205

205206instance P.Pretty Raw where

206− pretty _ (Raw name) =

207+ pretty _ _ (Raw name) =

207208 if Help.isOp name

208209 then P.parens (P.text name)

209210 else P.text name

210211

211212

212213instance P.Pretty Canonical where

213− pretty _ var =

214− P.text (toString var)

214+ pretty dealiaser _ var =

215+ let

216+ name = toString var

217+ in

218+ P.text (maybe name id (Map.lookup name dealiaser))

215219

216220

217221instance P.Pretty a => P.Pretty (Listing a) where

218− pretty _ (Listing explicits open) =

222+ pretty dealiaser _ (Listing explicits open) =

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

220224 in

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

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

222226

223227

224228instance P.Pretty Value where

225− pretty _ portable =

229+ pretty dealiaser _ portable =

226230 case portable of

227231 Value name ->

228232 P.text name

@@ -231,7 +235,7 @@ instance P.Pretty Value where

231235 P.text name

232236

233237 Union name ctors ->

234− P.text name <> P.pretty False ctors

238+ P.text name <> P.pretty dealiaser False ctors

235239

236240

237241-- BINARY SERIALIZATION

src/Canonicalize.hs+7−5

@@ -44,8 +44,9 @@ module' interfaces modul =

4444 moduleHelp interfaces modul

4545 in

4646 case rawResults of

47− Result.Ok almostCanonicalModule ->

48− filterImports uses almostCanonicalModule

47+ Result.Ok (env, almostCanonicalModule) ->

48+ R.addDealiaser (Env.toDealiaser env) $

49+ filterImports uses almostCanonicalModule

4950

5051 Result.Err msgs ->

5152 R.throwMany (map (A.map Error.Canonicalize) msgs)

@@ -61,13 +62,14 @@ type AlmostCanonicalModule =

6162moduleHelp

6263 :: Module.Interfaces

6364 -> Module.ValidModule

64− -> Result.ResultErr AlmostCanonicalModule

65+ -> Result.ResultErr (Env.Environment, AlmostCanonicalModule)

6566moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =

6667 canonicalModule

6768 <$> canonicalDeclsResult

6869 <*> resolveExports locals exports

6970 where

70− canonicalModule canonicalDecls canonicalExports =

71+ canonicalModule (env, canonicalDecls) canonicalExports =

72+ (,) env $

7173 modul

7274 { Module.exports = canonicalExports

7375 , Module.body = body canonicalDecls

@@ -79,7 +81,7 @@ moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =

7981

8082 canonicalDeclsResult =

8183 Setup.environment interfaces modul

82− `Result.andThen` \env -> T.traverse (declaration env) decls

84+ `Result.andThen` \env -> (,) env <$> T.traverse (declaration env) decls

8385

8486 body :: [D.CanonicalDecl] -> Module.CanonicalBody

8587 body decls =

src/Canonicalize/Declaration.hs+3−3

@@ -70,13 +70,13 @@ toDefs moduleName (A.A region decl) =

7070 in

7171 case impl of

7272 E.In name tipe ->

73− [ definition name body (T.portType tipe) ]

73+ [ definition name body (T.getPortType tipe) ]

7474

7575 E.Out name _expr tipe ->

76− [ definition name body (T.portType tipe) ]

76+ [ definition name body (T.getPortType tipe) ]

7777

7878 E.Task name _expr tipe ->

79− [ definition name body (T.portType tipe) ]

79+ [ definition name body (T.getPortType tipe) ]

8080

8181 -- no constraints are needed for fixity declarations

8282 D.Fixity _ _ _ ->

src/Canonicalize/Environment.hs+34

@@ -3,6 +3,7 @@ module Canonicalize.Environment where

33

44import qualified Data.List as List

55import qualified Data.Map as Map

6+import qualified Data.Maybe as Maybe

67import qualified Data.Set as Set

78

89import AST.Expression.General (saveEnvName)

@@ -10,6 +11,7 @@ import qualified AST.Module as Module

1011import qualified AST.Pattern as P

1112import qualified AST.Type as Type

1213import qualified AST.Variable as Var

14+import Elm.Utils ((|>))

1315

1416

1517-- ENVIRONMENT

@@ -104,3 +106,35 @@ builtinPatches =

104106 toTuple :: Int -> (String, Int)

105107 toTuple n =

106108 ("_Tuple" ++ show n, n)

109+

110+

111+-- TO TYPE DEALIASER

112+

113+toDealiaser :: Environment -> Map.Map String String

114+toDealiaser (Env _ _ adts aliases _) =

115+ let

116+ dealiasAdt (localName, canonicalSet) =

117+ case Set.toList canonicalSet of

118+ [canonicalName] ->

119+ Just (Var.toString canonicalName, localName)

120+ _ ->

121+ Nothing

122+

123+ dealiasAlias (localName, canonicalSet) =

124+ case Set.toList canonicalSet of

125+ [(canonicalName,_,_)] ->

126+ Just (Var.toString canonicalName, localName)

127+ _ ->

128+ Nothing

129+

130+ adtPairs =

131+ Maybe.mapMaybe dealiasAdt (Map.toList adts)

132+

133+ aliasPairs =

134+ Maybe.mapMaybe dealiasAlias (Map.toList aliases)

135+

136+ add (key,value) dict =

137+ Map.insertWith (\v v' -> if length v < length v' then v else v') key value dict

138+ in

139+ adtPairs ++ aliasPairs

140+ |> foldr add Map.empty

src/Elm/Compiler.hs+38−23

@@ -2,6 +2,7 @@

22module Elm.Compiler

33 ( version, rawVersion

44 , parseDependencies, compile

5+ , Dealiaser, dummyDealiaser

56 , Error, errorToString, errorToJson, printError

67 , Warning, warningToString, warningToJson, printWarning

78 ) where

@@ -18,6 +19,7 @@ import qualified Parse.Module as Parse

1819import qualified Parse.Parse as Parse

1920import qualified Reporting.Annotation as A

2021import qualified Reporting.Error as Error

22+import qualified Reporting.PrettyPrint as P

2123import qualified Reporting.Result as Result

2224import qualified Reporting.Warning as Warning

2325

@@ -64,15 +66,15 @@ compile

6466 -> Bool

6567 -> String

6668 -> Map.Map PublicModule.Name PublicModule.Interface

67− -> ([Warning], Either [Error] (PublicModule.Interface, String))

69+ -> (Dealiaser, [Warning], Either [Error] (PublicModule.Interface, String))

6870compile user packageName isRoot source interfaces =

6971 let unwrappedInterfaces =

7072 Map.mapKeysMonotonic (\(PublicModule.Name name) -> name) interfaces

7173

72− (Result.Result warnings rawResult) =

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

7375 Compile.compile user packageName isRoot unwrappedInterfaces source

7476 in

75− (,) (map Warning warnings) $

77+ (,,) (maybe dummyDealiaser Dealiaser dealiaser) (map Warning warnings) $

7678 case rawResult of

7779 Result.Ok modul ->

7880 Right (Module.toInterface modul, JS.generate modul)

@@ -81,43 +83,56 @@ compile user packageName isRoot source interfaces =

8183 Left (map Error errors)

8284

8385

86+-- DEALIASER

87+

88+newtype Dealiaser =

89+ Dealiaser P.Dealiaser

90+

91+

92+dummyDealiaser :: Dealiaser

93+dummyDealiaser =

94+ Dealiaser Map.empty

95+

96+

8497-- ERRORS

8598

86−newtype Error = Error (A.Located Error.Error)

99+newtype Error =

100+ Error (A.Located Error.Error)

87101

88102

89−errorToString :: String -> String -> Error -> String

90−errorToString location source (Error err) =

91− Error.toString location source err

103+errorToString :: Dealiaser -> String -> String -> Error -> String

104+errorToString (Dealiaser dealiaser) location source (Error err) =

105+ Error.toString dealiaser location source err

92106

93107

94−printError :: String -> String -> Error -> IO ()

95−printError location source (Error err) =

96− Error.print location source err

108+printError :: Dealiaser -> String -> String -> Error -> IO ()

109+printError (Dealiaser dealiaser) location source (Error err) =

110+ Error.print dealiaser location source err

97111

98112

99−errorToJson :: String -> Error -> Json.Value

100−errorToJson location (Error err) =

101− Error.toJson location err

113+errorToJson :: Dealiaser -> String -> Error -> Json.Value

114+errorToJson (Dealiaser dealiaser) location (Error err) =

115+ Error.toJson dealiaser location err

102116

103117

104118-- WARNINGS

105119

106−newtype Warning = Warning (A.Located Warning.Warning)

120+newtype Warning =

121+ Warning (A.Located Warning.Warning)

107122

108123

109−warningToString :: String -> String -> Warning -> String

110−warningToString location source (Warning err) =

111− Warning.toString location source err

124+warningToString :: Dealiaser -> String -> String -> Warning -> String

125+warningToString (Dealiaser dealiaser) location source (Warning err) =

126+ Warning.toString dealiaser location source err

112127

113128

114−printWarning :: String -> String -> Warning -> IO ()

115−printWarning location source (Warning err) =

116− Warning.print location source err

129+printWarning :: Dealiaser -> String -> String -> Warning -> IO ()

130+printWarning (Dealiaser dealiaser) location source (Warning err) =

131+ Warning.print dealiaser location source err

117132

118133

119−warningToJson :: String -> Warning -> Json.Value

120−warningToJson location (Warning err) =

121− Warning.toJson location err

134+warningToJson :: Dealiaser -> String -> Warning -> Json.Value

135+warningToJson (Dealiaser dealiaser) location (Warning err) =

136+ Warning.toJson dealiaser location err

122137

123138

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

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

11module Generate.JavaScript.Port (inbound, outbound, task) where

22

33import qualified Data.List as List

4+import qualified Data.Map as Map

45import Language.ECMAScript3.Syntax

56

67import qualified AST.Type as T

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

9697 T.Normal tipe ->

9798 _Port "inbound" `call`

9899 [ string name

99− , string (show (P.pretty False tipe))

100+ , string (show (P.pretty Map.empty False tipe))

100101 , toTypeFunction tipe

101102 ]

102103

103104 T.Signal _root arg ->

104105 _Port "inboundSignal" `call`

105106 [ string name

106− , string (show (P.pretty False arg))

107+ , string (show (P.pretty Map.empty False arg))

107108 , toTypeFunction arg

108109 ]

109110

src/Reporting/Annotation.hs+2−2

@@ -52,5 +52,5 @@ drop (A _ value) =

5252-- PRETTY PRINT

5353

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

55− pretty parens (A _ value) =

56− P.pretty parens value

55+ pretty dealiaser parens (A _ value) =

56+ P.pretty dealiaser parens value

src/Reporting/Error.hs+17−16

@@ -10,6 +10,7 @@ import qualified Reporting.Annotation as A

1010import qualified Reporting.Error.Canonicalize as Canonicalize

1111import qualified Reporting.Error.Syntax as Syntax

1212import qualified Reporting.Error.Type as Type

13+import qualified Reporting.PrettyPrint as P

1314import qualified Reporting.Report as Report

1415

1516

@@ -23,40 +24,40 @@ data Error

2324

2425-- TO REPORT

2526

26−toReport :: Error -> Report.Report

27−toReport err =

27+toReport :: P.Dealiaser -> Error -> Report.Report

28+toReport dealiaser err =

2829 case err of

2930 Syntax syntaxError ->

30− Syntax.toReport syntaxError

31+ Syntax.toReport dealiaser syntaxError

3132

3233 Canonicalize canonicalizeError ->

33− Canonicalize.toReport canonicalizeError

34+ Canonicalize.toReport dealiaser canonicalizeError

3435

3536 Type typeError ->

36− Type.toReport typeError

37+ Type.toReport dealiaser typeError

3738

3839

3940-- TO STRING

4041

41−toString :: String -> String -> A.Located Error -> String

42−toString location source (A.A region err) =

43− Report.toString location region (toReport err) source

42+toString :: P.Dealiaser -> String -> String -> A.Located Error -> String

43+toString dealiaser location source (A.A region err) =

44+ Report.toString location region (toReport dealiaser err) source

4445

4546

46−print :: String -> String -> A.Located Error -> IO ()

47−print location source (A.A region err) =

48− Report.printError location region (toReport err) source

47+print :: P.Dealiaser -> String -> String -> A.Located Error -> IO ()

48+print dealiaser location source (A.A region err) =

49+ Report.printError location region (toReport dealiaser err) source

4950

5051

5152-- TO JSON

5253

53−toJson :: FilePath -> A.Located Error -> Json.Value

54−toJson filePath (A.A region err) =

54+toJson :: P.Dealiaser -> FilePath -> A.Located Error -> Json.Value

55+toJson dealiaser filePath (A.A region err) =

5556 let

5657 (maybeRegion, additionalFields) =

5758 case err of

5859 Syntax syntaxError ->

59− Report.toJson [] (Syntax.toReport syntaxError)

60+ Report.toJson [] (Syntax.toReport dealiaser syntaxError)

6061

6162 Canonicalize canonicalizeError ->

6263 let

@@ -65,10 +66,10 @@ toJson filePath (A.A region err) =

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

6667 (Canonicalize.extractSuggestions canonicalizeError)

6768 in

68− Report.toJson suggestions (Canonicalize.toReport canonicalizeError)

69+ Report.toJson suggestions (Canonicalize.toReport dealiaser canonicalizeError)

6970

7071 Type typeError ->

71− Report.toJson [] (Type.toReport typeError)

72+ Report.toJson [] (Type.toReport dealiaser typeError)

7273 in

7374 Json.object $

7475 [ "file" .= filePath

src/Reporting/Error/Canonicalize.hs+4−4

@@ -135,8 +135,8 @@ namingError pre post =

135135 Report.simple "NAMING ERROR" pre post

136136

137137

138−toReport :: Error -> Report.Report

139−toReport err =

138+toReport :: P.Dealiaser -> Error -> Report.Report

139+toReport dealiaser err =

140140 case err of

141141 Var (VarError kind name problem suggestions) ->

142142 let var = kind ++ " '" ++ name ++ "'"

@@ -179,7 +179,7 @@ toReport err =

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

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

181181 ++ " type " ++ name ++ concatMap (' ':) tvars ++ " ="

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

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

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

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

185185

@@ -224,7 +224,7 @@ toReport err =

224224

225225 postHint =

226226 "The specific unsupported type is:\n\n"

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

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

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

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

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

src/Reporting/Error/Syntax.hs+4−4

@@ -28,8 +28,8 @@ data Error

2828

2929-- TO REPORT

3030

31−toReport :: Error -> Report.Report

32−toReport err =

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

32+toReport dealiaser err =

3333 case err of

3434 Parse messages ->

3535 parseErrorReport messages

@@ -110,7 +110,7 @@ toReport err =

110110 P.hang

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

112112 4

113− (P.pretty False tipe)

113+ (P.pretty dealiaser False tipe)

114114 where

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

116116

@@ -128,7 +128,7 @@ toReport err =

128128 (|>) = flip ($)

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

130130 toDoc (ctor, args) =

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

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

132132

133133

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

src/Reporting/Error/Type.hs+6−6

@@ -50,8 +50,8 @@ data Note

5050

5151-- TO REPORT

5252

53−toReport :: Error -> Report.Report

54−toReport err =

53+toReport :: P.Dealiaser -> Error -> Report.Report

54+toReport dealiaser err =

5555 case err of

5656 Mismatch (MismatchInfo hint leftType rightType note) ->

5757 let

@@ -59,9 +59,9 @@ toReport err =

5959

6060 postHint =

6161 "To be more specific, type inference is leading to a conflict between this type:\n\n"

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

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

6363 ++ "\n\nand this type:\n\n"

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

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

6565 in

6666 case note of

6767 PreNote msg ->

@@ -78,7 +78,7 @@ toReport err =

7878 "Maybe you are trying to do some tricky recursion? Try breaking the expression\n"

7979 ++ "into smaller pieces. Give each piece a name and try to write down its type.\n\n"

8080 ++ "Type inference got stuck when type '" ++ var ++ "' needed equal to:\n\n"

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

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

8282 ++ "\n\nNotice that type variable '" ++ var ++ "' appears there too, so if we\n"

8383 ++ "expanded this type, it would just keep getting bigger and bigger."

8484

@@ -86,7 +86,7 @@ toReport err =

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

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

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

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

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

9090

9191

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

src/Reporting/PrettyPrint.hs+14−2

@@ -1,19 +1,31 @@

11{-# LANGUAGE FlexibleInstances #-}

22module Reporting.PrettyPrint where

33

4+import qualified Data.Map as Map

45import Text.PrettyPrint as P

6+

57import qualified AST.Helpers as Help

68

79

10+-- PRETTY

11+

812class Pretty a where

9− pretty :: Bool -> a -> Doc

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

14+

1015

16+type Dealiaser =

17+ Map.Map String String

18+

19+

20+-- INSTANCES

1121

1222instance Pretty String where

13− pretty _ str =

23+ pretty _ _ str =

1424 P.text str

1525

1626

27+-- HELPERS

28+

1729commaCat :: [Doc] -> Doc

1830commaCat docs =

1931 cat (punctuate comma docs)

src/Reporting/Result.hs+31−15

@@ -1,17 +1,21 @@

11module Reporting.Result where

22

3−import qualified Control.Applicative as A

3+import Control.Applicative (Applicative, (<*>), (<|>), pure)

44import qualified Control.Monad as M

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

910

1011

1112-- TASK

1213

1314data Result warning error result =

14− Result [A.Located warning] (RawResult [A.Located error] result)

15+ Result

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

17+ (RawResult [A.Located error] result)

18+

1519

1620data RawResult e a

1721 = Ok a

@@ -22,17 +26,17 @@ data RawResult e a

2226

2327ok :: a -> Result w e a

2428ok value =

25− Result [] (Ok value)

29+ Result (Nothing, []) (Ok value)

2630

2731

2832throw :: R.Region -> e -> Result w e a

2933throw region err =

30− Result [] (Err [A.A region err])

34+ Result (Nothing, []) (Err [A.A region err])

3135

3236

3337throwMany :: [A.Located e] -> Result w e a

3438throwMany errors =

35− Result [] (Err errors)

39+ Result (Nothing, []) (Err errors)

3640

3741

3842from :: (e -> e') -> Except [A.Located e] a -> Result w e' a

@@ -58,12 +62,17 @@ mapError f (Result warnings rawResult) =

5862

5963warn :: R.Region -> w -> Result w e ()

6064warn region warning =

61− Result [A.A region warning] (Ok ())

65+ Result (Nothing, [A.A region warning]) (Ok ())

6266

6367

6468addWarnings :: [A.Located w] -> Result w e a -> Result w e a

65−addWarnings newWarnings (Result warnings rawResult) =

66− Result (newWarnings ++ warnings) rawResult

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

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

75+ Result (Just dealiaser, warnings) rawResult

6776

6877

6978-- EXTRA FANCY HELPERS

@@ -78,12 +87,12 @@ instance M.Functor (Result w e) where

7887 Result warnings (Err msgs)

7988

8089

81−instance A.Applicative (Result w e) where

90+instance Applicative (Result w e) where

8291 pure value =

8392 ok value

8493

85− (<*>) (Result warnings resultFunc) (Result warnings' resultVal) =

86− Result (warnings ++ warnings') $

94+ (<*>) (Result context resultFunc) (Result context' resultVal) =

95+ Result (merge context context') $

8796 case (resultFunc, resultVal) of

8897 (Ok func, Ok val) ->

8998 Ok (func val)

@@ -102,12 +111,19 @@ instance M.Monad (Result w e) where

102111 return value =

103112 ok value

104113

105− (>>=) (Result warnings rawResult) callback =

114+ (>>=) (Result context rawResult) callback =

106115 case rawResult of

107116 Err msg ->

108− Result warnings (Err msg)

117+ Result context (Err msg)

109118

110119 Ok value ->

111− let (Result warnings' rawResult') = callback value

120+ let (Result context' rawResult') = callback value

112121 in

113− Result (warnings ++ warnings') rawResult'

122+ Result (merge context context') rawResult'

123+

124+

125+merge :: (Maybe a, [b]) -> (Maybe a, [b]) -> (Maybe a, [b])

126+merge (dealiaser, warnings) (dealiaser', warnings') =

127+ ( dealiaser <|> dealiaser'

128+ , warnings ++ warnings'

129+ )

src/Reporting/Warning.hs+12−12

@@ -23,18 +23,18 @@ data Warning

2323

2424-- TO STRING

2525

26−toString :: String -> String -> A.Located Warning -> String

27−toString location source (A.A region warning) =

28− Report.toString location region (toReport warning) source

26+toString :: P.Dealiaser -> String -> String -> A.Located Warning -> String

27+toString dealiaser location source (A.A region warning) =

28+ Report.toString location region (toReport dealiaser warning) source

2929

3030

31−print :: String -> String -> A.Located Warning -> IO ()

32−print location source (A.A region warning) =

33− Report.printWarning location region (toReport warning) source

31+print :: P.Dealiaser -> String -> String -> A.Located Warning -> IO ()

32+print dealiaser location source (A.A region warning) =

33+ Report.printWarning location region (toReport dealiaser warning) source

3434

3535

36−toReport :: Warning -> Report.Report

37−toReport warning =

36+toReport :: P.Dealiaser -> Warning -> Report.Report

37+toReport dealiaser warning =

3838 case warning of

3939 UnusedImport moduleName ->

4040 Report.simple

@@ -54,16 +54,16 @@ toReport warning =

5454 P.hang

5555 (P.text name <+> P.colon)

5656 4

57− (P.pretty False inferredType)

57+ (P.pretty dealiaser False inferredType)

5858

5959

6060-- TO JSON

6161

62−toJson :: FilePath -> A.Located Warning -> Json.Value

63−toJson filePath (A.A region warning) =

62+toJson :: P.Dealiaser -> FilePath -> A.Located Warning -> Json.Value

63+toJson dealiaser filePath (A.A region warning) =

6464 let

6565 (maybeRegion, additionalFields) =

66− Report.toJson [] (toReport warning)

66+ Report.toJson [] (toReport dealiaser warning)

6767 in

6868 Json.object $

6969 [ "file" .= filePath

tests/Test/Compiler.hs+8−9

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

11{-# OPTIONS_GHC -W #-}

22module Test.Compiler (compilerTests) where

33

4−import Control.Arrow (second)

54import qualified Data.Map as Map

65import Data.Traversable (traverse)

76

@@ -46,7 +45,7 @@ testsDir =

4645-- RUN COMPILER

4746

4847testIf

49− :: (([Compiler.Warning], Either String (Module.Interface, String)) -> Assertion)

48+ :: (Either String (Module.Interface, String) -> Assertion)

5049 -> [FilePath]

5150 -> IO [Test]

5251testIf handleResult filePaths =

@@ -55,20 +54,20 @@ testIf handleResult filePaths =

5554 setupTest filePath = do

5655 source <- readFile filePath

5756

58− let result =

57+ let (dealiaser, _warnings, result) =

5958 Compiler.compile "elm-lang" "core" True source Map.empty

6059 let formatErrors errors =

61− concatMap (Compiler.errorToString filePath source) errors

60+ concatMap (Compiler.errorToString dealiaser filePath source) errors

6261 let formattedResult =

63− second (either (Left . formatErrors) Right) result

62+ either (Left . formatErrors) Right result

6463

6564 return $ testCase filePath (handleResult formattedResult)

6665

6766

6867-- CHECK RESULTS

6968

70−isSuccess :: ([Compiler.Warning], Either String a) -> Assertion

71−isSuccess (_, result) =

69+isSuccess :: Either String a -> Assertion

70+isSuccess result =

7271 case result of

7372 Right _ ->

7473 assertBool "" True

@@ -77,8 +76,8 @@ isSuccess (_, result) =

7776 assertFailure errorMessages

7877

7978

80−isFailure :: ([Compiler.Warning], Either a b) -> Assertion

81−isFailure (_, result) =

79+isFailure :: Either a b -> Assertion

80+isFailure result =

8281 case result of

8382 Right _ ->

8483 assertFailure "Compilation succeeded but should have failed"