849459e · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Add Source Map support.

849459eNicholas Wolverson11 years ago

.travis.yml+1−1

compare with golang

unifiedsplit

@@ -51,7 +51,7 @@ install:

51 - mkdir -p .cabal-sandbox

52 - cabal sandbox init --sandbox .cabal-sandbox

53 # Download stackage cabal.config, not sure whether filtering is necessary

54− - if [ -n "$STACKAGE" ]; then curl https://www.stackage.org/$STACKAGE/cabal.config | grep -v purescript > cabal.config; fi

54+ - if [ -n "$STACKAGE" ]; then curl https://www.stackage.org/$STACKAGE/cabal.config | egrep -v 'purescript|sourcemap' > cabal.config; fi

55 - cabal install --only-dependencies --enable-tests

56 - cabal install hpc-coveralls

57 # Snapshot state of the sandbox now, so we don't need to make new one for test install

LICENSE+34

@@ -63,6 +63,7 @@ PureScript uses the following Haskell library packages. Their license files foll

63 safe

64 scientific

65 semigroups

66+ sourcemap

66 split

67 split

67 stm

68 stm

68 syb

69 syb

@@ -1589,6 +1590,39 @@ semigroups LICENSE file:

1589 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE

1590 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE

1590 POSSIBILITY OF SUCH DAMAGE.

1591 POSSIBILITY OF SUCH DAMAGE.

1591

1592

1593+sourcemap LICENSE file:

1594+

1596+

1598+

1599+ Redistribution and use in source and binary forms, with or without

1600+ modification, are permitted provided that the following conditions are met:

1601+

1602+ * Redistributions of source code must retain the above copyright

1603+ notice, this list of conditions and the following disclaimer.

1604+

1605+ * Redistributions in binary form must reproduce the above

1606+ copyright notice, this list of conditions and the following

1607+ disclaimer in the documentation and/or other materials provided

1608+ with the distribution.

1609+

1610+ * Neither the name of Chris Done nor the names of other

1611+ contributors may be used to endorse or promote products derived

1612+ from this software without specific prior written permission.

1613+

1614+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

1615+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

1616+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

1617+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

1618+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

1619+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

1620+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

1621+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

1622+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

1623+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

1624+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

1625+

1592split LICENSE file:

1626split LICENSE file:

1593

1627

psc/Main.hs+6

@@ -177,6 +177,11 @@ jsonErrors :: Parser Bool

177jsonErrors = switch $

178 long "json-errors"

179 <> help "Print errors to stderr as JSON"

180+sourceMaps :: Parser Bool

181+sourceMaps = switch $

182+ long "source-maps"

183+ <> help "Generate source maps"

184+

180

185

181options :: Parser P.Options

186options :: Parser P.Options

182options = P.Options <$> noTco

187options = P.Options <$> noTco

@@ -186,6 +191,7 @@ options = P.Options <$> noTco

186 <*> verboseErrors

191 <*> verboseErrors

187 <*> (not <$> comments)

192 <*> (not <$> comments)

188 <*> requirePath

193 <*> requirePath

194+ <*> sourceMaps

189

195

190pscMakeOptions :: Parser PSCMakeOptions

196pscMakeOptions :: Parser PSCMakeOptions

191pscMakeOptions = PSCMakeOptions <$> many inputFile

197pscMakeOptions = PSCMakeOptions <$> many inputFile

purescript.cabal+2−1

@@ -79,7 +79,8 @@ library

79 process >= 1.2.0 && < 1.5,

80 safe >= 0.3.9 && < 0.4,

81 semigroups >= 0.16.2 && < 0.19,

82− parallel >= 3.2 && < 3.3

82+ parallel >= 3.2 && < 3.3,

83+ sourcemap >= 0.1.6

84 exposed-modules: Language.PureScript

85 exposed-modules: Language.PureScript

85 Language.PureScript.AST

86 Language.PureScript.AST

src/Language/PureScript/CodeGen/JS.hs+140−123

@@ -55,21 +55,21 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

55 rethrow (addHint (ErrorInModule mn)) $ do

56 let usedNames = concatMap getNames decls

57 let mnLookup = renameImports usedNames imps

58− jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps

58+ jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd $ imps

59 let decls' = renameModules mnLookup decls

60 jsDecls <- mapM bindToJs decls'

61 optimized <- T.traverse (T.traverse optimize) jsDecls

62 F.traverse_ (F.traverse_ checkIntegers) optimized

63 comments <- not <$> asks optionsNoComments

64− let strict = JSStringLiteral "use strict"

64+ let strict = JSStringLiteral Nothing "use strict"

65− let header = if comments && not (null coms) then JSComment coms strict else strict

65+ let header = if comments && not (null coms) then JSComment Nothing coms strict else strict

66− let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]

66+ let foreign' = [JSVariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]

67 let moduleBody = header : foreign' ++ jsImports ++ concat optimized

68 let foreignExps = exps `intersect` (fst `map` foreigns)

69 let standardExps = exps \\ foreignExps

70− let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps

70+ let exps' = JSObjectLiteral Nothing $ map (runIdent &&& (JSVar Nothing) . identToJs) standardExps

71 ++ map (runIdent &&& foreignIdent) foreignExps

72− return $ moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']

72+ return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps']

74 where

@@ -77,23 +77,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

77 -- Extracts all declaration names from a binding group.

78 --

79 getNames :: Bind Ann -> [Ident]

80− getNames (NonRec ident _) = [ident]

80+ getNames (NonRec _ ident _) = [ident]

81− getNames (Rec vals) = map fst vals

81+ getNames (Rec vals) = map (snd . fst) vals

83 -- |

84 -- Creates alternative names for each module to ensure they don't collide

85 -- with declaration names.

86 --

87− renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName

87+ renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)

88 renameImports ids mns = go M.empty ids mns

89 where

90− go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName

90+ go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)

91− go acc used (mn' : mns') =

91+ go acc used ((ann, mn') : mns') =

92 let mni = Ident $ runModuleName mn'

93 in if mn' /= mn && mni `elem` used

94 then let newName = freshModuleName 1 mn' used

95− in go (M.insert mn' newName acc) (Ident (runModuleName newName) : used) mns'

95+ in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'

96− else go (M.insert mn' mn' acc) (mni : used) mns'

96+ else go (M.insert mn' (ann, mn') acc) (mni : used) mns'

97 go acc _ [] = acc

99 freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName

@@ -107,18 +107,18 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

107 -- Generates Javascript code for a module import, binding the required module

108 -- to the alternative

109 --

110− importToJs :: M.Map ModuleName ModuleName -> ModuleName -> m JS

110+ importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS

111 importToJs mnLookup mn' = do

112 path <- asks optionsRequirePath

113− let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

113+ let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

114− let moduleBody = JSApp (JSVar "require") [JSStringLiteral (maybe id (</>) path $ runModuleName mn')]

114+ let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (maybe id (</>) path $ runModuleName mn')]

115− return $ JSVariableIntroduction (moduleNameToJs mnSafe) (Just moduleBody)

115+ withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)

116

117 -- |

118 -- Replaces the `ModuleName`s in the AST so that the generated code refers to

119 -- the collision-avoiding renamed module imports.

120 --

121− renameModules :: M.Map ModuleName ModuleName -> [Bind Ann] -> [Bind Ann]

121+ renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]

122 renameModules mnLookup binds =

123 let (f, _, _) = everywhereOnValues id goExpr goBinder

124 in map f binds

@@ -131,7 +131,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

131 goBinder b = b

132 renameQual :: Qualified a -> Qualified a

133 renameQual (Qualified (Just mn') a) =

134− let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

134+ let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

135 in Qualified (Just mnSafe) a

136 renameQual q = q

137

@@ -139,8 +139,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

139 -- Generate code in the simplified Javascript intermediate representation for a declaration

140 --

141 bindToJs :: Bind Ann -> m [JS]

142− bindToJs (NonRec ident val) = return <$> nonRecToJS ident val

142+ bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val

143− bindToJs (Rec vals) = forM vals (uncurry nonRecToJS)

143+ bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)

144

145 -- |

146 -- Generate code in the simplified Javascript intermediate representation for a single non-recursive

@@ -148,22 +148,30 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

148 --

149 -- The main purpose of this function is to handle code generation for comments.

150 --

151− nonRecToJS :: Ident -> Expr Ann -> m JS

151+ nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS

152− nonRecToJS i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

152+ nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

153 withoutComment <- asks optionsNoComments

154 if withoutComment

155− then nonRecToJS i (modifyAnn removeComments e)

155+ then nonRecToJS a i (modifyAnn removeComments e)

156− else JSComment com <$> nonRecToJS i (modifyAnn removeComments e)

156+ else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)

157− nonRecToJS ident val = do

157+ nonRecToJS (ss, _, _, _) ident val = do

158 js <- valueToJs val

159− return $ JSVariableIntroduction (identToJs ident) (Just js)

159+ withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)

160+

161+ withPos :: Maybe SourceSpan -> JS -> m JS

162+ withPos (Just ss) js = do

163+ withSM <- asks optionsSourceMaps

164+ return $ if withSM

165+ then withSourceSpan ss js

166+ else js

167+ withPos Nothing js = return js

160

168

161 -- |

169 -- |

162 -- Generate code in the simplified Javascript intermediate representation for a variable based on a

170 -- Generate code in the simplified Javascript intermediate representation for a variable based on a

163 -- PureScript identifier.

171 -- PureScript identifier.

164 --

172 --

165 var :: Ident -> JS

173 var :: Ident -> JS

166− var = JSVar . identToJs

174+ var = JSVar Nothing . identToJs

167

175

168 -- |

176 -- |

169 -- Generate code in the simplified Javascript intermediate representation for an accessor based on

177 -- Generate code in the simplified Javascript intermediate representation for an accessor based on

@@ -172,102 +180,106 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

172 --

180 --

173 accessor :: Ident -> JS -> JS

181 accessor :: Ident -> JS -> JS

174 accessor (Ident prop) = accessorString prop

182 accessor (Ident prop) = accessorString prop

175− accessor (Op op) = JSIndexer (JSStringLiteral op)

183+ accessor (Op op) = JSIndexer Nothing (JSStringLiteral Nothing op)

176 accessor (GenIdent _ _) = internalError "GenIdent in accessor"

184 accessor (GenIdent _ _) = internalError "GenIdent in accessor"

177

185

178 accessorString :: String -> JS -> JS

186 accessorString :: String -> JS -> JS

179− accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

187+ accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop)

180− | otherwise = JSAccessor prop

188+ | otherwise = JSAccessor Nothing prop

181

189

182 -- |

190 -- |

183 -- Generate code in the simplified Javascript intermediate representation for a value or expression.

191 -- Generate code in the simplified Javascript intermediate representation for a value or expression.

184 --

192 --

185 valueToJs :: Expr Ann -> m JS

193 valueToJs :: Expr Ann -> m JS

194+ valueToJs e =

195+ let (ss, _, _, _) = extractAnn e in

196+ withPos ss =<< valueToJs' e

197+

198+ valueToJs' :: Expr Ann -> m JS

186− valueToJs (Literal (pos, _, _, _) l) =

199+ valueToJs' (Literal (pos, _, _, _) l) =

187 maybe id rethrowWithPosition pos $ literalToValueJS l

200 maybe id rethrowWithPosition pos $ literalToValueJS l

188− valueToJs (Var (_, _, _, Just (IsConstructor _ [])) name) =

201+ valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) =

189− return $ JSAccessor "value" $ qualifiedToJS id name

202+ return $ JSAccessor Nothing "value" $ qualifiedToJS id name

190− valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) =

203+ valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =

191− return $ JSAccessor "create" $ qualifiedToJS id name

204+ return $ JSAccessor Nothing "create" $ qualifiedToJS id name

192− valueToJs (Accessor _ prop val) =

205+ valueToJs' (Accessor _ prop val) =

193 accessorString prop <$> valueToJs val

206 accessorString prop <$> valueToJs val

194− valueToJs (ObjectUpdate _ o ps) = do

207+ valueToJs' (ObjectUpdate _ o ps) = do

195 obj <- valueToJs o

208 obj <- valueToJs o

196 sts <- mapM (sndM valueToJs) ps

209 sts <- mapM (sndM valueToJs) ps

197 extendObj obj sts

210 extendObj obj sts

198− valueToJs e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =

211+ valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =

199 let args = unAbs e

212 let args = unAbs e

200− in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)

213+ in return $ JSFunction Nothing Nothing (map identToJs args) (JSBlock Nothing $ map assign args)

201 where

214 where

202 unAbs :: Expr Ann -> [Ident]

215 unAbs :: Expr Ann -> [Ident]

203 unAbs (Abs _ arg val) = arg : unAbs val

216 unAbs (Abs _ arg val) = arg : unAbs val

204 unAbs _ = []

217 unAbs _ = []

205 assign :: Ident -> JS

218 assign :: Ident -> JS

206− assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))

219+ assign name = JSAssignment Nothing (accessorString (runIdent name) (JSVar Nothing "this"))

207 (var name)

220 (var name)

208− valueToJs (Abs _ arg val) = do

221+ valueToJs' (Abs _ arg val) = do

209 ret <- valueToJs val

222 ret <- valueToJs val

210− return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])

223+ return $ JSFunction Nothing Nothing [identToJs arg] (JSBlock Nothing [JSReturn Nothing ret])

211− valueToJs e@App{} = do

224+ valueToJs' e@App{} = do

212 let (f, args) = unApp e []

225 let (f, args) = unApp e []

213 args' <- mapM valueToJs args

226 args' <- mapM valueToJs args

214 case f of

227 case f of

215 Var (_, _, _, Just IsNewtype) _ -> return (head args')

228 Var (_, _, _, Just IsNewtype) _ -> return (head args')

216 Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->

229 Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->

217− return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'

230+ return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'

218 Var (_, _, _, Just IsTypeClassConstructor) name ->

231 Var (_, _, _, Just IsTypeClassConstructor) name ->

219− return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'

232+ return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'

220− _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs f

233+ _ -> flip (foldl (\fn a -> JSApp Nothing fn [a])) args' <$> valueToJs f

221 where

234 where

222 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

235 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

223 unApp (App _ val arg) args = unApp val (arg : args)

236 unApp (App _ val arg) args = unApp val (arg : args)

224 unApp other args = (other, args)

237 unApp other args = (other, args)

225− valueToJs (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =

238+ valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =

226 return $ if mn' == mn

239 return $ if mn' == mn

227 then foreignIdent ident

240 then foreignIdent ident

228 else varToJs qi

241 else varToJs qi

229− valueToJs (Var (_, _, _, Just IsForeign) ident) =

242+ valueToJs' (Var (_, _, _, Just IsForeign) ident) =

230 error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident

243 error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident

231− valueToJs (Var _ ident) =

244+ valueToJs' (Var _ ident) = return $ varToJs ident

232− return $ varToJs ident

233− valueToJs (Case (maybeSpan, _, _, _) values binders) = do

245+ valueToJs' (Case (maybeSpan, _, _, _) values binders) = do

234 vals <- mapM valueToJs values

246 vals <- mapM valueToJs values

235 bindersToJs maybeSpan binders vals

247 bindersToJs maybeSpan binders vals

236− valueToJs (Let _ ds val) = do

248+ valueToJs' (Let _ ds val) = do

237 ds' <- concat <$> mapM bindToJs ds

249 ds' <- concat <$> mapM bindToJs ds

238 ret <- valueToJs val

250 ret <- valueToJs val

239− return $ JSApp (JSFunction Nothing [] (JSBlock (ds' ++ [JSReturn ret]))) []

251+ return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) []

240− valueToJs (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =

252+ valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =

241− return $ JSVariableIntroduction ctor (Just $

253+ return $ JSVariableIntroduction Nothing ctor (Just $

242− JSObjectLiteral [("create",

254+ JSObjectLiteral Nothing [("create",

243− JSFunction Nothing ["value"]

255+ JSFunction Nothing Nothing ["value"]

244− (JSBlock [JSReturn $ JSVar "value"]))])

256+ (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])

245− valueToJs (Constructor _ _ (ProperName ctor) []) =

257+ valueToJs' (Constructor _ _ (ProperName ctor) []) =

246− return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])

258+ return $ iife ctor [ JSFunction Nothing (Just ctor) [] (JSBlock Nothing [])

247− , JSAssignment (JSAccessor "value" (JSVar ctor))

259+ , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing ctor))

248− (JSUnary JSNew $ JSApp (JSVar ctor) []) ]

260+ (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) []) ]

249− valueToJs (Constructor _ _ (ProperName ctor) fields) =

261+ valueToJs' (Constructor _ _ (ProperName ctor) fields) =

250 let constructor =

262 let constructor =

251− let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]

263+ let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]

252− in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)

264+ in JSFunction Nothing (Just ctor) (identToJs `map` fields) (JSBlock Nothing body)

253 createFn =

265 createFn =

254− let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)

266+ let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) (var `map` fields)

255− in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields

267+ in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields

256 in return $ iife ctor [ constructor

268 in return $ iife ctor [ constructor

257− , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn

269+ , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing ctor)) createFn

258 ]

270 ]

259

271

260 iife :: String -> [JS] -> JS

272 iife :: String -> [JS] -> JS

261− iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []

273+ iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []

262

274

263 literalToValueJS :: Literal (Expr Ann) -> m JS

275 literalToValueJS :: Literal (Expr Ann) -> m JS

264− literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral (Left i)

276+ literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)

265− literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral (Right n)

277+ literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n)

266− literalToValueJS (StringLiteral s) = return $ JSStringLiteral s

278+ literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s

267− literalToValueJS (CharLiteral c) = return $ JSStringLiteral [c]

279+ literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing [c]

268− literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b

280+ literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b

269− literalToValueJS (ArrayLiteral xs) = JSArrayLiteral <$> mapM valueToJs xs

281+ literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs

270− literalToValueJS (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM valueToJs) ps

282+ literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps

271

283

272 -- |

284 -- |

273 -- Shallow copy an object.

285 -- Shallow copy an object.

@@ -277,16 +289,16 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

277 newObj <- freshName

289 newObj <- freshName

278 key <- freshName

290 key <- freshName

279 let

291 let

280− jsKey = JSVar key

292+ jsKey = JSVar Nothing key

281− jsNewObj = JSVar newObj

293+ jsNewObj = JSVar Nothing newObj

282− block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])

294+ block = JSBlock Nothing (objAssign:copy:extend ++ [JSReturn Nothing jsNewObj])

283− objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])

295+ objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])

284− copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]

296+ copy = JSForIn Nothing key obj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]

285− cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]

297+ cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" obj) [jsKey]

286− assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]

298+ assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey obj)]

287− stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js

299+ stToAssign (s, js) = JSAssignment Nothing (JSAccessor Nothing s jsNewObj) js

288 extend = map stToAssign sts

300 extend = map stToAssign sts

289− return $ JSApp (JSFunction Nothing [] block) []

301+ return $ JSApp Nothing (JSFunction Nothing Nothing [] block) []

290

302

291 -- |

303 -- |

292 -- Generate code in the simplified Javascript intermediate representation for a reference to a

304 -- Generate code in the simplified Javascript intermediate representation for a reference to a

@@ -301,12 +313,12 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

301 -- variable that may have a qualified name.

313 -- variable that may have a qualified name.

302 --

314 --

303 qualifiedToJS :: (a -> Ident) -> Qualified a -> JS

315 qualifiedToJS :: (a -> Ident) -> Qualified a -> JS

304− qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar . runIdent $ f a

316+ qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar Nothing . runIdent $ f a

305− qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn'))

317+ qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar Nothing (moduleNameToJs mn'))

306− qualifiedToJS f (Qualified _ a) = JSVar $ identToJs (f a)

318+ qualifiedToJS f (Qualified _ a) = JSVar Nothing $ identToJs (f a)

307

319

308 foreignIdent :: Ident -> JS

320 foreignIdent :: Ident -> JS

309− foreignIdent ident = accessorString (runIdent ident) (JSVar "$foreign")

321+ foreignIdent ident = accessorString (runIdent ident) (JSVar Nothing "$foreign")

310

322

311 -- |

323 -- |

312 -- Generate code in the simplified Javascript intermediate representation for pattern match binders

324 -- Generate code in the simplified Javascript intermediate representation for pattern match binders

@@ -315,11 +327,11 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

315 bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS

327 bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS

316 bindersToJs maybeSpan binders vals = do

328 bindersToJs maybeSpan binders vals = do

317 valNames <- replicateM (length vals) freshName

329 valNames <- replicateM (length vals) freshName

318− let assignments = zipWith JSVariableIntroduction valNames (map Just vals)

330+ let assignments = zipWith (JSVariableIntroduction Nothing) valNames (map Just vals)

319 jss <- forM binders $ \(CaseAlternative bs result) -> do

331 jss <- forM binders $ \(CaseAlternative bs result) -> do

320 ret <- guardsToJs result

332 ret <- guardsToJs result

321 go valNames ret bs

333 go valNames ret bs

322− return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ failedPatternError valNames])))

334+ return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [JSThrow Nothing $ failedPatternError valNames])))

323 []

335 []

324 where

336 where

325 go :: [String] -> [JS] -> [Binder Ann] -> m [JS]

337 go :: [String] -> [JS] -> [Binder Ann] -> m [JS]

@@ -330,43 +342,48 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

330 go _ _ _ = internalError "Invalid arguments to bindersToJs"

342 go _ _ _ = internalError "Invalid arguments to bindersToJs"

331

343

332 failedPatternError :: [String] -> JS

344 failedPatternError :: [String] -> JS

333− failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral failedPatternMessage) (JSArrayLiteral $ zipWith valueError names vals)]

345+ failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)]

334

346

335 failedPatternMessage :: String

347 failedPatternMessage :: String

336 failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "

348 failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "

337

349

338 valueError :: String -> JS -> JS

350 valueError :: String -> JS -> JS

339− valueError _ l@(JSNumericLiteral _) = l

351+ valueError _ l@(JSNumericLiteral _ _) = l

340− valueError _ l@(JSStringLiteral _) = l

352+ valueError _ l@(JSStringLiteral _ _) = l

341− valueError _ l@(JSBooleanLiteral _) = l

353+ valueError _ l@(JSBooleanLiteral _ _) = l

342− valueError s _ = JSAccessor "name" . JSAccessor "constructor" $ JSVar s

354+ valueError s _ = JSAccessor Nothing "name" . JSAccessor Nothing "constructor" $ JSVar Nothing s

343

355

344 guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]

356 guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]

345 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

357 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

346 cond' <- valueToJs cond

358 cond' <- valueToJs cond

347 done <- valueToJs val

359 done <- valueToJs val

348− return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing

360+ return $ JSIfElse Nothing cond' (JSBlock Nothing [JSReturn Nothing done]) Nothing

349− guardsToJs (Right v) = return . JSReturn <$> valueToJs v

361+ guardsToJs (Right v) = return . JSReturn Nothing <$> valueToJs v

362+

363+ binderToJs :: String -> [JS] -> Binder Ann -> m [JS]

364+ binderToJs s done binder =

365+ let (ss, _, _, _) = extractBinderAnn binder in

366+ traverse (withPos ss) =<< binderToJs' s done binder

350

367

351 -- |

368 -- |

352 -- Generate code in the simplified Javascript intermediate representation for a pattern match

369 -- Generate code in the simplified Javascript intermediate representation for a pattern match

353 -- binder.

370 -- binder.

354 --

371 --

355− binderToJs :: String -> [JS] -> Binder Ann -> m [JS]

372+ binderToJs' :: String -> [JS] -> Binder Ann -> m [JS]

356− binderToJs _ done (NullBinder{}) = return done

373+ binderToJs' _ done (NullBinder{}) = return done

357− binderToJs varName done (LiteralBinder _ l) =

374+ binderToJs' varName done (LiteralBinder _ l) =

358 literalToBinderJS varName done l

375 literalToBinderJS varName done l

359− binderToJs varName done (VarBinder _ ident) =

376+ binderToJs' varName done (VarBinder _ ident) =

360− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

377+ return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : done)

361− binderToJs varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =

378+ binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =

362 binderToJs varName done b

379 binderToJs varName done b

363− binderToJs varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do

380+ binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do

364 js <- go (zip fields bs) done

381 js <- go (zip fields bs) done

365 return $ case ctorType of

382 return $ case ctorType of

366 ProductType -> js

383 ProductType -> js

367 SumType ->

384 SumType ->

368− [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS (Ident . runProperName) ctor))

385+ [JSIfElse Nothing (JSInstanceOf Nothing (JSVar Nothing varName) (qualifiedToJS (Ident . runProperName) ctor))

369− (JSBlock js)

386+ (JSBlock Nothing js)

370 Nothing]

387 Nothing]

371 where

388 where

372 go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]

389 go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]

@@ -375,24 +392,24 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

375 argVar <- freshName

392 argVar <- freshName

376 done'' <- go remain done'

393 done'' <- go remain done'

377 js <- binderToJs argVar done'' binder

394 js <- binderToJs argVar done'' binder

378− return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)

395+ return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js)

379− binderToJs _ _ ConstructorBinder{} =

396+ binderToJs' _ _ ConstructorBinder{} =

380 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"

397 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"

381− binderToJs varName done (NamedBinder _ ident binder) = do

398+ binderToJs' varName done (NamedBinder _ ident binder) = do

382 js <- binderToJs varName done binder

399 js <- binderToJs varName done binder

383− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

400+ return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : js)

384

401

385 literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]

402 literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]

386 literalToBinderJS varName done (NumericLiteral num) =

403 literalToBinderJS varName done (NumericLiteral num) =

387− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]

404+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing]

388 literalToBinderJS varName done (CharLiteral c) =

405 literalToBinderJS varName done (CharLiteral c) =

389− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral [c])) (JSBlock done) Nothing]

406+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing [c])) (JSBlock Nothing done) Nothing]

390 literalToBinderJS varName done (StringLiteral str) =

407 literalToBinderJS varName done (StringLiteral str) =

391− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]

408+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing]

392 literalToBinderJS varName done (BooleanLiteral True) =

409 literalToBinderJS varName done (BooleanLiteral True) =

393− return [JSIfElse (JSVar varName) (JSBlock done) Nothing]

410+ return [JSIfElse Nothing (JSVar Nothing varName) (JSBlock Nothing done) Nothing]

394 literalToBinderJS varName done (BooleanLiteral False) =

411 literalToBinderJS varName done (BooleanLiteral False) =

395− return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

412+ return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing]

396 literalToBinderJS varName done (ObjectLiteral bs) = go done bs

413 literalToBinderJS varName done (ObjectLiteral bs) = go done bs

397 where

414 where

398 go :: [JS] -> [(String, Binder Ann)] -> m [JS]

415 go :: [JS] -> [(String, Binder Ann)] -> m [JS]

@@ -401,10 +418,10 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

401 propVar <- freshName

418 propVar <- freshName

402 done'' <- go done' bs'

419 done'' <- go done' bs'

403 js <- binderToJs propVar done'' binder

420 js <- binderToJs propVar done'' binder

404− return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)

421+ return (JSVariableIntroduction Nothing propVar (Just (accessorString prop (JSVar Nothing varName))) : js)

405 literalToBinderJS varName done (ArrayLiteral bs) = do

422 literalToBinderJS varName done (ArrayLiteral bs) = do

406 js <- go done 0 bs

423 js <- go done 0 bs

407− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

424+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSAccessor Nothing "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing]

408 where

425 where

409 go :: [JS] -> Integer -> [Binder Ann] -> m [JS]

426 go :: [JS] -> Integer -> [Binder Ann] -> m [JS]

410 go done' _ [] = return done'

427 go done' _ [] = return done'

@@ -412,21 +429,21 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =

412 elVar <- freshName

429 elVar <- freshName

413 done'' <- go done' (index + 1) bs'

430 done'' <- go done' (index + 1) bs'

414 js <- binderToJs elVar done'' binder

431 js <- binderToJs elVar done'' binder

415− return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)

432+ return (JSVariableIntroduction Nothing elVar (Just (JSIndexer Nothing (JSNumericLiteral Nothing (Left index)) (JSVar Nothing varName))) : js)

416

433

417 -- Check that all integers fall within the valid int range for JavaScript.

434 -- Check that all integers fall within the valid int range for JavaScript.

418 checkIntegers :: JS -> m ()

435 checkIntegers :: JS -> m ()

419 checkIntegers = void . everywhereOnJSTopDownM go

436 checkIntegers = void . everywhereOnJSTopDownM go

420 where

437 where

421 go :: JS -> m JS

438 go :: JS -> m JS

422− go (JSUnary Negate (JSNumericLiteral (Left i))) =

439+ go (JSUnary _ Negate (JSNumericLiteral ss (Left i))) =

423 -- Move the negation inside the literal; since this is a top-down

440 -- Move the negation inside the literal; since this is a top-down

424 -- traversal doing this replacement will stop the next case from raising

441 -- traversal doing this replacement will stop the next case from raising

425 -- the error when attempting to use -2147483648, as if left unrewritten

442 -- the error when attempting to use -2147483648, as if left unrewritten

426 -- the value is `JSUnary Negate (JSNumericLiteral (Left 2147483648))`, and

443 -- the value is `JSUnary Negate (JSNumericLiteral (Left 2147483648))`, and

427 -- 2147483648 is larger than the maximum allowed int.

444 -- 2147483648 is larger than the maximum allowed int.

428− return $ JSNumericLiteral (Left (-i))

445+ return $ JSNumericLiteral ss (Left (-i))

429− go js@(JSNumericLiteral (Left i)) =

446+ go js@(JSNumericLiteral _ (Left i)) =

430 let minInt = -2147483648

447 let minInt = -2147483648

431 maxInt = 2147483647

448 maxInt = 2147483647

432 in if i < minInt || i > maxInt

449 in if i < minInt || i > maxInt

src/Language/PureScript/CodeGen/JS/AST.hs+168−97

@@ -10,6 +10,7 @@ import Control.Monad.Identity

11import Language.PureScript.Comments

12import Language.PureScript.Traversals

13+import Language.PureScript.AST (SourceSpan(..))

14-- |

15-- |

15-- Built-in unary operators

16-- Built-in unary operators

@@ -126,120 +127,190 @@ data JS

126 -- |

127 -- |

127 -- A numeric literal

128 -- A numeric literal

128 --

129 --

129− = JSNumericLiteral (Either Integer Double)

130+ = JSNumericLiteral (Maybe SourceSpan) (Either Integer Double)

130 -- |

131 -- |

131 -- A string literal

132 -- A string literal

132 --

133 --

133− | JSStringLiteral String

134+ | JSStringLiteral (Maybe SourceSpan) String

134 -- |

135 -- |

135 -- A boolean literal

136 -- A boolean literal

136 --

137 --

137− | JSBooleanLiteral Bool

138+ | JSBooleanLiteral (Maybe SourceSpan) Bool

138 -- |

139 -- |

139 -- A unary operator application

140 -- A unary operator application

140 --

141 --

141− | JSUnary UnaryOperator JS

142+ | JSUnary (Maybe SourceSpan) UnaryOperator JS

142 -- |

143 -- |

143 -- A binary operator application

144 -- A binary operator application

144 --

145 --

145− | JSBinary BinaryOperator JS JS

146+ | JSBinary (Maybe SourceSpan) BinaryOperator JS JS

146 -- |

147 -- |

147 -- An array literal

148 -- An array literal

148 --

149 --

149− | JSArrayLiteral [JS]

150+ | JSArrayLiteral (Maybe SourceSpan) [JS]

150 -- |

151 -- |

151 -- An array indexer expression

152 -- An array indexer expression

152 --

153 --

153− | JSIndexer JS JS

154+ | JSIndexer (Maybe SourceSpan) JS JS

154 -- |

155 -- |

155 -- An object literal

156 -- An object literal

156 --

157 --

157− | JSObjectLiteral [(String, JS)]

158+ | JSObjectLiteral (Maybe SourceSpan) [(String, JS)]

158 -- |

159 -- |

159 -- An object property accessor expression

160 -- An object property accessor expression

160 --

161 --

161− | JSAccessor String JS

162+ | JSAccessor (Maybe SourceSpan) String JS

162 -- |

163 -- |

163 -- A function introduction (optional name, arguments, body)

164 -- A function introduction (optional name, arguments, body)

164 --

165 --

165− | JSFunction (Maybe String) [String] JS

166+ | JSFunction (Maybe SourceSpan) (Maybe String) [String] JS

166 -- |

167 -- |

167 -- Function application

168 -- Function application

168 --

169 --

169− | JSApp JS [JS]

170+ | JSApp (Maybe SourceSpan) JS [JS]

170 -- |

171 -- |

171 -- Variable

172 -- Variable

172 --

173 --

173− | JSVar String

174+ | JSVar (Maybe SourceSpan) String

174 -- |

175 -- |

175 -- Conditional expression

176 -- Conditional expression

176 --

177 --

177− | JSConditional JS JS JS

178+ | JSConditional (Maybe SourceSpan) JS JS JS

178 -- |

179 -- |

179 -- A block of expressions in braces

180 -- A block of expressions in braces

180 --

181 --

181− | JSBlock [JS]

182+ | JSBlock (Maybe SourceSpan) [JS]

182 -- |

183 -- |

183 -- A variable introduction and optional initialization

184 -- A variable introduction and optional initialization

184 --

185 --

185− | JSVariableIntroduction String (Maybe JS)

186+ | JSVariableIntroduction (Maybe SourceSpan) String (Maybe JS)

186 -- |

187 -- |

187 -- A variable assignment

188 -- A variable assignment

188 --

189 --

189− | JSAssignment JS JS

190+ | JSAssignment (Maybe SourceSpan) JS JS

190 -- |

191 -- |

191 -- While loop

192 -- While loop

192 --

193 --

193− | JSWhile JS JS

194+ | JSWhile (Maybe SourceSpan) JS JS

194 -- |

195 -- |

195 -- For loop

196 -- For loop

196 --

197 --

197− | JSFor String JS JS JS

198+ | JSFor (Maybe SourceSpan) String JS JS JS

198 -- |

199 -- |

199 -- ForIn loop

200 -- ForIn loop

200 --

201 --

201− | JSForIn String JS JS

202+ | JSForIn (Maybe SourceSpan) String JS JS

202 -- |

203 -- |

203 -- If-then-else statement

204 -- If-then-else statement

204 --

205 --

205− | JSIfElse JS JS (Maybe JS)

206+ | JSIfElse (Maybe SourceSpan) JS JS (Maybe JS)

206 -- |

207 -- |

207 -- Return statement

208 -- Return statement

208 --

209 --

209− | JSReturn JS

210+ | JSReturn (Maybe SourceSpan) JS

210 -- |

211 -- |

211 -- Throw statement

212 -- Throw statement

212 --

213 --

213− | JSThrow JS

214+ | JSThrow (Maybe SourceSpan) JS

214 -- |

215 -- |

215 -- Type-Of operator

216 -- Type-Of operator

216 --

217 --

217− | JSTypeOf JS

218+ | JSTypeOf (Maybe SourceSpan) JS

218 -- |

219 -- |

219 -- InstanceOf test

220 -- InstanceOf test

220 --

221 --

221− | JSInstanceOf JS JS

222+ | JSInstanceOf (Maybe SourceSpan) JS JS

222 -- |

223 -- |

223 -- Labelled statement

224 -- Labelled statement

224 --

225 --

225− | JSLabel String JS

226+ | JSLabel (Maybe SourceSpan) String JS

226 -- |

227 -- |

227 -- Break statement

228 -- Break statement

228 --

229 --

229− | JSBreak String

230+ | JSBreak (Maybe SourceSpan) String

230 -- |

231 -- |

231 -- Continue statement

232 -- Continue statement

232 --

233 --

233− | JSContinue String

234+ | JSContinue (Maybe SourceSpan) String

234 -- |

235 -- |

235 -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)

236 -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)

236 --

237 --

237− | JSRaw String

238+ | JSRaw (Maybe SourceSpan) String

238 -- |

239 -- |

239 -- Commented Javascript

240 -- Commented Javascript

240 --

241 --

241− | JSComment [Comment] JS

242+ | JSComment (Maybe SourceSpan) [Comment] JS deriving (Show, Read, Eq)

242− deriving (Show, Read, Eq)

243+

244+withSourceSpan :: SourceSpan -> JS -> JS

245+withSourceSpan withSpan = go

246+ where

247+ ss :: Maybe SourceSpan

248+ ss = Just withSpan

249+

250+ go :: JS -> JS

251+ go (JSNumericLiteral _ n) = JSNumericLiteral ss n

252+ go (JSStringLiteral _ s) = JSStringLiteral ss s

253+ go (JSBooleanLiteral _ b) = JSBooleanLiteral ss b

254+ go (JSUnary _ op j) = JSUnary ss op j

255+ go (JSBinary _ op j1 j2) = JSBinary ss op j1 j2

256+ go (JSArrayLiteral _ js) = JSArrayLiteral ss js

257+ go (JSIndexer _ j1 j2) = JSIndexer ss j1 j2

258+ go (JSObjectLiteral _ js) = JSObjectLiteral ss js

259+ go (JSAccessor _ prop j) = JSAccessor ss prop j

260+ go (JSFunction _ name args j) = JSFunction ss name args j

261+ go (JSApp _ j js) = JSApp ss j js

262+ go (JSVar _ s) = JSVar ss s

263+ go (JSConditional _ j1 j2 j3) = JSConditional ss j1 j2 j3

264+ go (JSBlock _ js) = JSBlock ss js

265+ go (JSVariableIntroduction _ name j) = JSVariableIntroduction ss name j

266+ go (JSAssignment _ j1 j2) = JSAssignment ss j1 j2

267+ go (JSWhile _ j1 j2) = JSWhile ss j1 j2

268+ go (JSFor _ name j1 j2 j3) = JSFor ss name j1 j2 j3

269+ go (JSForIn _ name j1 j2) = JSForIn ss name j1 j2

270+ go (JSIfElse _ j1 j2 j3) = JSIfElse ss j1 j2 j3

271+ go (JSReturn _ js) = JSReturn ss js

272+ go (JSThrow _ js) = JSThrow ss js

273+ go (JSTypeOf _ js) = JSTypeOf ss js

274+ go (JSInstanceOf _ j1 j2) = JSInstanceOf ss j1 j2

275+ go (JSLabel _ name js) = JSLabel ss name js

276+ go (JSBreak _ s) = JSBreak ss s

277+ go (JSContinue _ s) = JSContinue ss s

278+ go (JSRaw _ s) = JSRaw ss s

279+ go (JSComment _ com j) = JSComment ss com j

280+

281+getSourceSpan :: JS -> Maybe SourceSpan

282+getSourceSpan = go

283+ where

284+ go :: JS -> Maybe SourceSpan

285+ go (JSNumericLiteral ss _) = ss

286+ go (JSStringLiteral ss _) = ss

287+ go (JSBooleanLiteral ss _) = ss

288+ go (JSUnary ss _ _) = ss

289+ go (JSBinary ss _ _ _) = ss

290+ go (JSArrayLiteral ss _) = ss

291+ go (JSIndexer ss _ _) = ss

292+ go (JSObjectLiteral ss _) = ss

293+ go (JSAccessor ss _ _) = ss

294+ go (JSFunction ss _ _ _) = ss

295+ go (JSApp ss _ _) = ss

296+ go (JSVar ss _) = ss

297+ go (JSConditional ss _ _ _) = ss

298+ go (JSBlock ss _) = ss

299+ go (JSVariableIntroduction ss _ _) = ss

300+ go (JSAssignment ss _ _) = ss

301+ go (JSWhile ss _ _) = ss

302+ go (JSFor ss _ _ _ _) = ss

303+ go (JSForIn ss _ _ _) = ss

304+ go (JSIfElse ss _ _ _) = ss

305+ go (JSReturn ss _) = ss

306+ go (JSThrow ss _) = ss

307+ go (JSTypeOf ss _) = ss

308+ go (JSInstanceOf ss _ _) = ss

309+ go (JSLabel ss _ _) = ss

310+ go (JSBreak ss _) = ss

311+ go (JSContinue ss _) = ss

312+ go (JSRaw ss _) = ss

313+ go (JSComment ss _ _) = ss

243

314

244--

315--

245-- Traversals

316-- Traversals

@@ -249,28 +320,28 @@ everywhereOnJS :: (JS -> JS) -> JS -> JS

249everywhereOnJS f = go

320everywhereOnJS f = go

250 where

321 where

251 go :: JS -> JS

322 go :: JS -> JS

252− go (JSUnary op j) = f (JSUnary op (go j))

323+ go (JSUnary ss op j) = f (JSUnary ss op (go j))

253− go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))

324+ go (JSBinary ss op j1 j2) = f (JSBinary ss op (go j1) (go j2))

254− go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))

325+ go (JSArrayLiteral ss js) = f (JSArrayLiteral ss (map go js))

255− go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))

326+ go (JSIndexer ss j1 j2) = f (JSIndexer ss (go j1) (go j2))

256− go (JSObjectLiteral js) = f (JSObjectLiteral (map (fmap go) js))

327+ go (JSObjectLiteral ss js) = f (JSObjectLiteral ss (map (fmap go) js))

257− go (JSAccessor prop j) = f (JSAccessor prop (go j))

328+ go (JSAccessor ss prop j) = f (JSAccessor ss prop (go j))

258− go (JSFunction name args j) = f (JSFunction name args (go j))

329+ go (JSFunction ss name args j) = f (JSFunction ss name args (go j))

259− go (JSApp j js) = f (JSApp (go j) (map go js))

330+ go (JSApp ss j js) = f (JSApp ss (go j) (map go js))

260− go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))

331+ go (JSConditional ss j1 j2 j3) = f (JSConditional ss (go j1) (go j2) (go j3))

261− go (JSBlock js) = f (JSBlock (map go js))

332+ go (JSBlock ss js) = f (JSBlock ss (map go js))

262− go (JSVariableIntroduction name j) = f (JSVariableIntroduction name (fmap go j))

333+ go (JSVariableIntroduction ss name j) = f (JSVariableIntroduction ss name (fmap go j))

263− go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))

334+ go (JSAssignment ss j1 j2) = f (JSAssignment ss (go j1) (go j2))

264− go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))

335+ go (JSWhile ss j1 j2) = f (JSWhile ss (go j1) (go j2))

265− go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))

336+ go (JSFor ss name j1 j2 j3) = f (JSFor ss name (go j1) (go j2) (go j3))

266− go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))

337+ go (JSForIn ss name j1 j2) = f (JSForIn ss name (go j1) (go j2))

267− go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) (fmap go j3))

338+ go (JSIfElse ss j1 j2 j3) = f (JSIfElse ss (go j1) (go j2) (fmap go j3))

268− go (JSReturn js) = f (JSReturn (go js))

339+ go (JSReturn ss js) = f (JSReturn ss (go js))

269− go (JSThrow js) = f (JSThrow (go js))

340+ go (JSThrow ss js) = f (JSThrow ss (go js))

270− go (JSTypeOf js) = f (JSTypeOf (go js))

341+ go (JSTypeOf ss js) = f (JSTypeOf ss (go js))

271− go (JSLabel name js) = f (JSLabel name (go js))

342+ go (JSLabel ss name js) = f (JSLabel ss name (go js))

272− go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))

343+ go (JSInstanceOf ss j1 j2) = f (JSInstanceOf ss (go j1) (go j2))

273− go (JSComment com j) = f (JSComment com (go j))

344+ go (JSComment ss com j) = f (JSComment ss com (go j))

274 go other = f other

345 go other = f other

275

346

276everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS

347everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS

@@ -280,54 +351,54 @@ everywhereOnJSTopDownM :: (Applicative m, Monad m) => (JS -> m JS) -> JS -> m JS

280everywhereOnJSTopDownM f = f >=> go

351everywhereOnJSTopDownM f = f >=> go

281 where

352 where

282 f' = f >=> go

353 f' = f >=> go

283− go (JSUnary op j) = JSUnary op <$> f' j

354+ go (JSUnary ss op j) = JSUnary ss op <$> f' j

284− go (JSBinary op j1 j2) = JSBinary op <$> f' j1 <*> f' j2

355+ go (JSBinary ss op j1 j2) = JSBinary ss op <$> f' j1 <*> f' j2

285− go (JSArrayLiteral js) = JSArrayLiteral <$> traverse f' js

356+ go (JSArrayLiteral ss js) = JSArrayLiteral ss <$> traverse f' js

286− go (JSIndexer j1 j2) = JSIndexer <$> f' j1 <*> f' j2

357+ go (JSIndexer ss j1 j2) = JSIndexer ss <$> f' j1 <*> f' j2

287− go (JSObjectLiteral js) = JSObjectLiteral <$> traverse (sndM f') js

358+ go (JSObjectLiteral ss js) = JSObjectLiteral ss <$> traverse (sndM f') js

288− go (JSAccessor prop j) = JSAccessor prop <$> f' j

359+ go (JSAccessor ss prop j) = JSAccessor ss prop <$> f' j

289− go (JSFunction name args j) = JSFunction name args <$> f' j

360+ go (JSFunction ss name args j) = JSFunction ss name args <$> f' j

290− go (JSApp j js) = JSApp <$> f' j <*> traverse f' js

361+ go (JSApp ss j js) = JSApp ss <$> f' j <*> traverse f' js

291− go (JSConditional j1 j2 j3) = JSConditional <$> f' j1 <*> f' j2 <*> f' j3

362+ go (JSConditional ss j1 j2 j3) = JSConditional ss <$> f' j1 <*> f' j2 <*> f' j3

292− go (JSBlock js) = JSBlock <$> traverse f' js

363+ go (JSBlock ss js) = JSBlock ss <$> traverse f' js

293− go (JSVariableIntroduction name j) = JSVariableIntroduction name <$> traverse f' j

364+ go (JSVariableIntroduction ss name j) = JSVariableIntroduction ss name <$> traverse f' j

294− go (JSAssignment j1 j2) = JSAssignment <$> f' j1 <*> f' j2

365+ go (JSAssignment ss j1 j2) = JSAssignment ss <$> f' j1 <*> f' j2

295− go (JSWhile j1 j2) = JSWhile <$> f' j1 <*> f' j2

366+ go (JSWhile ss j1 j2) = JSWhile ss <$> f' j1 <*> f' j2

296− go (JSFor name j1 j2 j3) = JSFor name <$> f' j1 <*> f' j2 <*> f' j3

367+ go (JSFor ss name j1 j2 j3) = JSFor ss name <$> f' j1 <*> f' j2 <*> f' j3

297− go (JSForIn name j1 j2) = JSForIn name <$> f' j1 <*> f' j2

368+ go (JSForIn ss name j1 j2) = JSForIn ss name <$> f' j1 <*> f' j2

298− go (JSIfElse j1 j2 j3) = JSIfElse <$> f' j1 <*> f' j2 <*> traverse f' j3

369+ go (JSIfElse ss j1 j2 j3) = JSIfElse ss <$> f' j1 <*> f' j2 <*> traverse f' j3

299− go (JSReturn j) = JSReturn <$> f' j

370+ go (JSReturn ss j) = JSReturn ss <$> f' j

300− go (JSThrow j) = JSThrow <$> f' j

371+ go (JSThrow ss j) = JSThrow ss <$> f' j

301− go (JSTypeOf j) = JSTypeOf <$> f' j

372+ go (JSTypeOf ss j) = JSTypeOf ss <$> f' j

302− go (JSLabel name j) = JSLabel name <$> f' j

373+ go (JSLabel ss name j) = JSLabel ss name <$> f' j

303− go (JSInstanceOf j1 j2) = JSInstanceOf <$> f' j1 <*> f' j2

374+ go (JSInstanceOf ss j1 j2) = JSInstanceOf ss <$> f' j1 <*> f' j2

304− go (JSComment com j) = JSComment com <$> f' j

375+ go (JSComment ss com j) = JSComment ss com <$> f' j

305 go other = f other

376 go other = f other

306

377

307everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r

378everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r

308everythingOnJS (<>) f = go

379everythingOnJS (<>) f = go

309 where

380 where

310− go j@(JSUnary _ j1) = f j <> go j1

381+ go j@(JSUnary _ _ j1) = f j <> go j1

311− go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2

382+ go j@(JSBinary _ _ j1 j2) = f j <> go j1 <> go j2

312− go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)

383+ go j@(JSArrayLiteral _ js) = foldl (<>) (f j) (map go js)

313− go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2

384+ go j@(JSIndexer _ j1 j2) = f j <> go j1 <> go j2

314− go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go . snd) js)

385+ go j@(JSObjectLiteral _ js) = foldl (<>) (f j) (map (go . snd) js)

315− go j@(JSAccessor _ j1) = f j <> go j1

386+ go j@(JSAccessor _ _ j1) = f j <> go j1

316− go j@(JSFunction _ _ j1) = f j <> go j1

387+ go j@(JSFunction _ _ _ j1) = f j <> go j1

317− go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)

388+ go j@(JSApp _ j1 js) = foldl (<>) (f j <> go j1) (map go js)

318− go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3

389+ go j@(JSConditional _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3

319− go j@(JSBlock js) = foldl (<>) (f j) (map go js)

390+ go j@(JSBlock _ js) = foldl (<>) (f j) (map go js)

320− go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1

391+ go j@(JSVariableIntroduction _ _ (Just j1)) = f j <> go j1

321− go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2

392+ go j@(JSAssignment _ j1 j2) = f j <> go j1 <> go j2

322− go j@(JSWhile j1 j2) = f j <> go j1 <> go j2

393+ go j@(JSWhile _ j1 j2) = f j <> go j1 <> go j2

323− go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3

394+ go j@(JSFor _ _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3

324− go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2

395+ go j@(JSForIn _ _ j1 j2) = f j <> go j1 <> go j2

325− go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2

396+ go j@(JSIfElse _ j1 j2 Nothing) = f j <> go j1 <> go j2

326− go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3

397+ go j@(JSIfElse _ j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3

327− go j@(JSReturn j1) = f j <> go j1

398+ go j@(JSReturn _ j1) = f j <> go j1

328− go j@(JSThrow j1) = f j <> go j1

399+ go j@(JSThrow _ j1) = f j <> go j1

329− go j@(JSTypeOf j1) = f j <> go j1

400+ go j@(JSTypeOf _ j1) = f j <> go j1

330− go j@(JSLabel _ j1) = f j <> go j1

401+ go j@(JSLabel _ _ j1) = f j <> go j1

331− go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2

402+ go j@(JSInstanceOf _ j1 j2) = f j <> go j1 <> go j2

332− go j@(JSComment _ j1) = f j <> go j1

403+ go j@(JSComment _ _ j1) = f j <> go j1

333 go other = f other

404 go other = f other

src/Language/PureScript/CodeGen/JS/Optimizer.hs+5−5

@@ -53,11 +53,11 @@ optimize' js = do

53 opts <- ask

54 js' <- untilFixedPoint (inlineFnComposition . tidyUp . applyAll

55 [ inlineCommonValues

56− , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]

56+ , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp Nothing f [x]

57− , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp f [x]

57+ , inlineOperator (C.dataFunction, C.apply) $ \f x -> JSApp Nothing f [x]

58− , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]

58+ , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp Nothing f [x]

59− , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp f [x]

59+ , inlineOperator (C.dataFunction, C.applyFlipped) $ \x f -> JSApp Nothing f [x]

60− , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer

60+ , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip (JSIndexer Nothing)

61 , inlineCommonOperators

62 ]) js

63 untilFixedPoint (return . tidyUp) . tco opts . magicDo opts $ js'

src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs+4−4

@@ -27,16 +27,16 @@ collapseNestedBlocks :: JS -> JS

27collapseNestedBlocks = everywhereOnJS collapse

28 where

29 collapse :: JS -> JS

30− collapse (JSBlock sts) = JSBlock (concatMap go sts)

30+ collapse (JSBlock ss sts) = JSBlock ss (concatMap go sts)

31 collapse js = js

32 go :: JS -> [JS]

33− go (JSBlock sts) = sts

33+ go (JSBlock _ sts) = sts

34 go s = [s]

36collapseNestedIfs :: JS -> JS

37collapseNestedIfs = everywhereOnJS collapse

38 where

39 collapse :: JS -> JS

40− collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) =

40+ collapse (JSIfElse s1 cond1 (JSBlock _ [JSIfElse s2 cond2 body Nothing]) Nothing) =

41− JSIfElse (JSBinary And cond1 cond2) body Nothing

41+ JSIfElse s1 (JSBinary s2 And cond1 cond2) body Nothing

42 collapse js = js

src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs+18−18

@@ -14,67 +14,67 @@ applyAll = foldl1 (.)

14replaceIdent :: String -> JS -> JS -> JS

15replaceIdent var1 js = everywhereOnJS replace

16 where

17− replace (JSVar var2) | var1 == var2 = js

17+ replace (JSVar _ var2) | var1 == var2 = js

18 replace other = other

20replaceIdents :: [(String, JS)] -> JS -> JS

21replaceIdents vars = everywhereOnJS replace

22 where

23− replace v@(JSVar var) = fromMaybe v $ lookup var vars

23+ replace v@(JSVar _ var) = fromMaybe v $ lookup var vars

24 replace other = other

26isReassigned :: String -> JS -> Bool

27isReassigned var1 = everythingOnJS (||) check

28 where

29 check :: JS -> Bool

30− check (JSFunction _ args _) | var1 `elem` args = True

30+ check (JSFunction _ _ args _) | var1 `elem` args = True

31− check (JSVariableIntroduction arg _) | var1 == arg = True

31+ check (JSVariableIntroduction _ arg _) | var1 == arg = True

32− check (JSAssignment (JSVar arg) _) | var1 == arg = True

32+ check (JSAssignment _ (JSVar _ arg) _) | var1 == arg = True

33− check (JSFor arg _ _ _) | var1 == arg = True

33+ check (JSFor _ arg _ _ _) | var1 == arg = True

34− check (JSForIn arg _ _) | var1 == arg = True

34+ check (JSForIn _ arg _ _) | var1 == arg = True

35 check _ = False

37isRebound :: JS -> JS -> Bool

38isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)

39 where

40− variablesOf (JSVar var) = [var]

40+ variablesOf (JSVar _ var) = [var]

41 variablesOf _ = []

43isUsed :: String -> JS -> Bool

44isUsed var1 = everythingOnJS (||) check

45 where

46 check :: JS -> Bool

47− check (JSVar var2) | var1 == var2 = True

47+ check (JSVar _ var2) | var1 == var2 = True

48− check (JSAssignment target _) | var1 == targetVariable target = True

48+ check (JSAssignment _ target _) | var1 == targetVariable target = True

49 check _ = False

51targetVariable :: JS -> String

52−targetVariable (JSVar var) = var

52+targetVariable (JSVar _ var) = var

53−targetVariable (JSAccessor _ tgt) = targetVariable tgt

53+targetVariable (JSAccessor _ _ tgt) = targetVariable tgt

54−targetVariable (JSIndexer _ tgt) = targetVariable tgt

54+targetVariable (JSIndexer _ _ tgt) = targetVariable tgt

55targetVariable _ = internalError "Invalid argument to targetVariable"

57isUpdated :: String -> JS -> Bool

58isUpdated var1 = everythingOnJS (||) check

59 where

60 check :: JS -> Bool

61− check (JSAssignment target _) | var1 == targetVariable target = True

61+ check (JSAssignment _ target _) | var1 == targetVariable target = True

62 check _ = False

64removeFromBlock :: ([JS] -> [JS]) -> JS -> JS

65−removeFromBlock go (JSBlock sts) = JSBlock (go sts)

65+removeFromBlock go (JSBlock ss sts) = JSBlock ss (go sts)

66removeFromBlock _ js = js

68isFn :: (String, String) -> JS -> Bool

69−isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName

69+isFn (moduleName, fnName) (JSAccessor _ x (JSVar _ y)) = x == fnName && y == moduleName

70−isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName

70+isFn (moduleName, fnName) (JSIndexer _ (JSStringLiteral _ x) (JSVar _ y)) = x == fnName && y == moduleName

71isFn _ _ = False

73isFn' :: [(String, String)] -> JS -> Bool

74isFn' xs js = any (`isFn` js) xs

76isDict :: (String, String) -> JS -> Bool

77−isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName

77+isDict (moduleName, dictName) (JSAccessor _ x (JSVar _ y)) = x == dictName && y == moduleName

78isDict _ _ = False

80isDict' :: [(String, String)] -> JS -> Bool

src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+50−50

@@ -29,42 +29,42 @@ import qualified Language.PureScript.Constants as C

29-- Needs to be: { 0..toFixed(10); }

30-- Probably needs to be fixed in pretty-printer instead.

31shouldInline :: JS -> Bool

32−shouldInline (JSVar _) = True

32+shouldInline (JSVar _ _) = True

33−shouldInline (JSNumericLiteral _) = True

33+shouldInline (JSNumericLiteral _ _) = True

34−shouldInline (JSStringLiteral _) = True

34+shouldInline (JSStringLiteral _ _) = True

35−shouldInline (JSBooleanLiteral _) = True

35+shouldInline (JSBooleanLiteral _ _) = True

36−shouldInline (JSAccessor _ val) = shouldInline val

36+shouldInline (JSAccessor _ _ val) = shouldInline val

37−shouldInline (JSIndexer index val) = shouldInline index && shouldInline val

37+shouldInline (JSIndexer _ index val) = shouldInline index && shouldInline val

38shouldInline _ = False

40etaConvert :: JS -> JS

41etaConvert = everywhereOnJS convert

42 where

43 convert :: JS -> JS

44− convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])

44+ convert (JSBlock ss [JSReturn _ (JSApp _ (JSFunction _ Nothing idents block@(JSBlock _ body)) args)])

45 | all shouldInline args &&

46− not (any (`isRebound` block) (map JSVar idents)) &&

46+ not (any (`isRebound` block) (map (JSVar Nothing) idents)) &&

47 not (any (`isRebound` block) args)

48− = JSBlock (map (replaceIdents (zip idents args)) body)

48+ = JSBlock ss (map (replaceIdents (zip idents args)) body)

49− convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn

49+ convert (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ (JSApp _ fn [])])) = fn

50 convert js = js

52unThunk :: JS -> JS

53unThunk = everywhereOnJS convert

54 where

55 convert :: JS -> JS

56− convert (JSBlock []) = JSBlock []

56+ convert (JSBlock ss []) = JSBlock ss []

57− convert (JSBlock jss) =

57+ convert (JSBlock ss jss) =

58 case last jss of

59− JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body

59+ JSReturn _ (JSApp _ (JSFunction _ Nothing [] (JSBlock _ body)) []) -> JSBlock ss $ init jss ++ body

60− _ -> JSBlock jss

60+ _ -> JSBlock ss jss

61 convert js = js

63evaluateIifes :: JS -> JS

64evaluateIifes = everywhereOnJS convert

65 where

66 convert :: JS -> JS

67− convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret

67+ convert (JSApp _ (JSFunction _ Nothing [] (JSBlock _ [JSReturn _ ret])) []) = ret

68 convert js = js

70inlineVariables :: JS -> JS

@@ -72,7 +72,7 @@ inlineVariables = everywhereOnJS $ removeFromBlock go

72 where

73 go :: [JS] -> [JS]

74 go [] = []

75− go (JSVariableIntroduction var (Just js) : sts)

75+ go (JSVariableIntroduction _ var (Just js) : sts)

76 | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =

77 go (map (replaceIdent var js) sts)

78 go (s:sts) = s : go sts

@@ -81,16 +81,16 @@ inlineCommonValues :: JS -> JS

81inlineCommonValues = everywhereOnJS convert

82 where

83 convert :: JS -> JS

84− convert (JSApp fn [dict])

84+ convert (JSApp ss fn [dict])

85− | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral (Left 0)

85+ | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnZero fn = JSNumericLiteral ss (Left 0)

86− | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral (Left 1)

86+ | isDict' (semiringNumber ++ semiringInt) dict && isFn' fnOne fn = JSNumericLiteral ss (Left 1)

87− | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral False

87+ | isDict' boundedBoolean dict && isFn' fnBottom fn = JSBooleanLiteral ss False

88− | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral True

88+ | isDict' boundedBoolean dict && isFn' fnTop fn = JSBooleanLiteral ss True

89− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y])

89+ convert (JSApp ss (JSApp _ (JSApp _ fn [dict]) [x]) [y])

90− | isDict' semiringInt dict && isFn' fnAdd fn = intOp Add x y

90+ | isDict' semiringInt dict && isFn' fnAdd fn = intOp ss Add x y

91− | isDict' semiringInt dict && isFn' fnMultiply fn = intOp Multiply x y

91+ | isDict' semiringInt dict && isFn' fnMultiply fn = intOp ss Multiply x y

92− | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp Divide x y

92+ | isDict' moduloSemiringInt dict && isFn' fnDivide fn = intOp ss Divide x y

93− | isDict' ringInt dict && isFn' fnSubtract fn = intOp Subtract x y

93+ | isDict' ringInt dict && isFn' fnSubtract fn = intOp ss Subtract x y

94 convert other = other

95 fnZero = [(C.prelude, C.zero), (C.dataSemiring, C.zero)]

96 fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)]

@@ -100,16 +100,16 @@ inlineCommonValues = everywhereOnJS convert

100 fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataModuloSemiring, C.div)]

101 fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))]

102 fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]

103− intOp op x y = JSBinary BitwiseOr (JSBinary op x y) (JSNumericLiteral (Left 0))

103+ intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))

104

105inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS

106inlineOperator (m, op) f = everywhereOnJS convert

107 where

108 convert :: JS -> JS

109− convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y

109+ convert (JSApp _ (JSApp _ op' [x]) [y]) | isOp op' = f x y

110 convert other = other

111− isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)

111+ isOp (JSAccessor _ longForm (JSVar _ m')) = m == m' && longForm == identToJs (Op op)

112− isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'

112+ isOp (JSIndexer _ (JSStringLiteral _ op') (JSVar _ m')) = m == m' && op == op'

113 isOp _ = False

114

115inlineCommonOperators :: JS -> JS

@@ -177,49 +177,49 @@ inlineCommonOperators = applyAll $

177 binary dict fns op = everywhereOnJS convert

178 where

179 convert :: JS -> JS

180− convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary op x y

180+ convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y]) | isDict' dict dict' && isFn' fns fn = JSBinary ss op x y

181 convert other = other

182 binary' :: String -> String -> BinaryOperator -> JS -> JS

183 binary' moduleName opString op = everywhereOnJS convert

184 where

185 convert :: JS -> JS

186− convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y

186+ convert (JSApp ss (JSApp _ fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary ss op x y

187 convert other = other

188 unary :: [(String, String)] -> [(String, String)] -> UnaryOperator -> JS -> JS

189 unary dicts fns op = everywhereOnJS convert

190 where

191 convert :: JS -> JS

192− convert (JSApp (JSApp fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary op x

192+ convert (JSApp ss (JSApp _ fn [dict']) [x]) | isDict' dicts dict' && isFn' fns fn = JSUnary ss op x

193 convert other = other

194 unary' :: String -> String -> UnaryOperator -> JS -> JS

195 unary' moduleName fnName op = everywhereOnJS convert

196 where

197 convert :: JS -> JS

198− convert (JSApp fn [x]) | isFn (moduleName, fnName) fn = JSUnary op x

198+ convert (JSApp ss fn [x]) | isFn (moduleName, fnName) fn = JSUnary ss op x

199 convert other = other

200 mkFn :: Int -> JS -> JS

201 mkFn 0 = everywhereOnJS convert

202 where

203 convert :: JS -> JS

204− convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =

204+ convert (JSApp _ mkFnN [JSFunction s1 Nothing [_] (JSBlock s2 js)]) | isNFn C.mkFn 0 mkFnN =

205− JSFunction Nothing [] (JSBlock js)

205+ JSFunction s1 Nothing [] (JSBlock s2 js)

206 convert other = other

207 mkFn n = everywhereOnJS convert

208 where

209 convert :: JS -> JS

210− convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =

210+ convert orig@(JSApp ss mkFnN [fn]) | isNFn C.mkFn n mkFnN =

211 case collectArgs n [] fn of

212− Just (args, js) -> JSFunction Nothing args (JSBlock js)

212+ Just (args, js) -> JSFunction ss Nothing args (JSBlock ss js)

213 Nothing -> orig

214 convert other = other

215 collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])

216− collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)

216+ collectArgs 1 acc (JSFunction _ Nothing [oneArg] (JSBlock _ js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)

217− collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret

217+ collectArgs m acc (JSFunction _ Nothing [oneArg] (JSBlock _ [JSReturn _ ret])) = collectArgs (m - 1) (oneArg : acc) ret

218 collectArgs _ _ _ = Nothing

219

220 isNFn :: String -> Int -> JS -> Bool

221− isNFn prefix n (JSVar name) = name == (prefix ++ show n)

221+ isNFn prefix n (JSVar _ name) = name == (prefix ++ show n)

222− isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)

222+ isNFn prefix n (JSAccessor _ name (JSVar _ dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)

223 isNFn _ _ _ = False

224

225 runFn :: Int -> JS -> JS

@@ -229,8 +229,8 @@ inlineCommonOperators = applyAll $

229 convert js = fromMaybe js $ go n [] js

230

231 go :: Int -> [JS] -> JS -> Maybe JS

232− go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)

232+ go 0 acc (JSApp ss runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp ss fn acc)

233− go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs

233+ go m acc (JSApp _ lhs [arg]) = go (m - 1) (arg : acc) lhs

234 go _ _ _ = Nothing

235

236-- (f <<< g $ x) = f (g x)

@@ -239,16 +239,16 @@ inlineFnComposition :: (Applicative m, MonadSupply m) => JS -> m JS

239inlineFnComposition = everywhereOnJSTopDownM convert

240 where

241 convert :: (MonadSupply m) => JS -> m JS

242− convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z])

242+ convert (JSApp s1 (JSApp s2 (JSApp _ (JSApp _ fn [dict']) [x]) [y]) [z])

243− | isFnCompose dict' fn = return $ JSApp x [JSApp y [z]]

243+ | isFnCompose dict' fn = return $ JSApp s1 x [JSApp s2 y [z]]

244− | isFnComposeFlipped dict' fn = return $ JSApp y [JSApp x [z]]

244+ | isFnComposeFlipped dict' fn = return $ JSApp s2 y [JSApp s1 x [z]]

245− convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y])

245+ convert (JSApp ss (JSApp _ (JSApp _ fn [dict']) [x]) [y])

246 | isFnCompose dict' fn = do

247 arg <- freshName

248− return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])

248+ return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing x [JSApp Nothing y [JSVar Nothing arg]]])

249 | isFnComposeFlipped dict' fn = do

250 arg <- freshName

251− return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp y [JSApp x [JSVar arg]]])

251+ return $ JSFunction ss Nothing [arg] (JSBlock ss [JSReturn Nothing $ JSApp Nothing y [JSApp Nothing x [JSVar Nothing arg]]])

252 convert other = return other

253 isFnCompose :: JS -> JS -> Bool

254 isFnCompose dict' fn = isDict' semigroupoidFn dict' && isFn' fnCompose fn

src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs+34−34

@@ -40,46 +40,46 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert

40 -- Desugar monomorphic calls to >>= and return for the Eff monad

41 convert :: JS -> JS

42 -- Desugar pure & return

43− convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val

43+ convert (JSApp _ (JSApp _ pure' [val]) []) | isPure pure' = val

44 -- Desugar >>

45− convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind =

45+ convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [] (JSBlock s2 js)]) | isBind bind =

46− JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : map applyReturns js )

46+ JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSApp s2 m [] : map applyReturns js )

47 -- Desugar >>=

48− convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind =

48+ convert (JSApp _ (JSApp _ bind [m]) [JSFunction s1 Nothing [arg] (JSBlock s2 js)]) | isBind bind =

49− JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : map applyReturns js)

49+ JSFunction s1 (Just fnName) [] $ JSBlock s2 (JSVariableIntroduction s2 arg (Just (JSApp s2 m [])) : map applyReturns js)

50 -- Desugar untilE

51− convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =

51+ convert (JSApp s1 (JSApp _ f [arg]) []) | isEffFunc C.untilE f =

52− JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn $ JSObjectLiteral []])) []

52+ JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSUnary s1 Not (JSApp s1 arg [])) (JSBlock s1 []), JSReturn s1 $ JSObjectLiteral s1 []])) []

53 -- Desugar whileE

54− convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =

54+ convert (JSApp _ (JSApp _ (JSApp s1 f [arg1]) [arg2]) []) | isEffFunc C.whileE f =

55− JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []

55+ JSApp s1 (JSFunction s1 Nothing [] (JSBlock s1 [ JSWhile s1 (JSApp s1 arg1 []) (JSBlock s1 [ JSApp s1 arg2 [] ]), JSReturn s1 $ JSObjectLiteral s1 []])) []

56 convert other = other

57 -- Check if an expression represents a monomorphic call to >>= for the Eff monad

58− isBind (JSApp fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True

58+ isBind (JSApp _ fn [dict]) | isDict (C.eff, C.bindEffDictionary) dict && isBindPoly fn = True

59 isBind _ = False

60 -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative

61− isPure (JSApp fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True

61+ isPure (JSApp _ fn [dict]) | isDict (C.eff, C.applicativeEffDictionary) dict && isPurePoly fn = True

62 isPure _ = False

63 -- Check if an expression represents the polymorphic >>= function

64 isBindPoly = isFn' [(C.prelude, C.bind), (C.prelude, (C.>>=)), (C.controlBind, C.bind)]

65 -- Check if an expression represents the polymorphic pure or return function

66 isPurePoly = isFn' [(C.prelude, C.pure'), (C.prelude, C.return), (C.controlApplicative, C.pure')]

67 -- Check if an expression represents a function in the Eff module

68− isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'

68+ isEffFunc name (JSAccessor _ name' (JSVar _ eff)) = eff == C.eff && name == name'

69 isEffFunc _ _ = False

71 -- Remove __do function applications which remain after desugaring

72 undo :: JS -> JS

73− undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body

73+ undo (JSReturn _ (JSApp _ (JSFunction _ (Just ident) [] body) [])) | ident == fnName = body

74 undo other = other

76 applyReturns :: JS -> JS

77− applyReturns (JSReturn ret) = JSReturn (JSApp ret [])

77+ applyReturns (JSReturn ss ret) = JSReturn ss (JSApp ss ret [])

78− applyReturns (JSBlock jss) = JSBlock (map applyReturns jss)

78+ applyReturns (JSBlock ss jss) = JSBlock ss (map applyReturns jss)

79− applyReturns (JSWhile cond js) = JSWhile cond (applyReturns js)

79+ applyReturns (JSWhile ss cond js) = JSWhile ss cond (applyReturns js)

80− applyReturns (JSFor v lo hi js) = JSFor v lo hi (applyReturns js)

80+ applyReturns (JSFor ss v lo hi js) = JSFor ss v lo hi (applyReturns js)

81− applyReturns (JSForIn v xs js) = JSForIn v xs (applyReturns js)

81+ applyReturns (JSForIn ss v xs js) = JSForIn ss v xs (applyReturns js)

82− applyReturns (JSIfElse cond t f) = JSIfElse cond (applyReturns t) (applyReturns `fmap` f)

82+ applyReturns (JSIfElse ss cond t f) = JSIfElse ss cond (applyReturns t) (applyReturns `fmap` f)

83 applyReturns other = other

85-- |

@@ -91,7 +91,7 @@ inlineST = everywhereOnJS convertBlock

91 -- Look for runST blocks and inline the STRefs there.

92 -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then

93 -- we can be more aggressive about inlining, and actually turn STRefs into local variables.

94− convertBlock (JSApp f [arg]) | isSTFunc C.runST f =

94+ convertBlock (JSApp _ f [arg]) | isSTFunc C.runST f =

95 let refs = nub . findSTRefsIn $ arg

96 usages = findAllSTUsagesIn arg

97 allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages

@@ -101,34 +101,34 @@ inlineST = everywhereOnJS convertBlock

101 -- Convert a block in a safe way, preserving object wrappers of references,

102 -- or in a more aggressive way, turning wrappers into local variables depending on the

103 -- agg(ressive) parameter.

104− convert agg (JSApp f [arg]) | isSTFunc C.newSTRef f =

104+ convert agg (JSApp s1 f [arg]) | isSTFunc C.newSTRef f =

105− JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]])

105+ JSFunction s1 Nothing [] (JSBlock s1 [JSReturn s1 $ if agg then arg else JSObjectLiteral s1 [(C.stRefValue, arg)]])

106− convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =

106+ convert agg (JSApp _ (JSApp s1 f [ref]) []) | isSTFunc C.readSTRef f =

107− if agg then ref else JSAccessor C.stRefValue ref

107+ if agg then ref else JSAccessor s1 C.stRefValue ref

108− convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =

108+ convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =

109− if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg

109+ if agg then JSAssignment s1 ref arg else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) arg

110− convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =

110+ convert agg (JSApp _ (JSApp _ (JSApp s1 f [ref]) [func]) []) | isSTFunc C.modifySTRef f =

111− if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref])

111+ if agg then JSAssignment s1 ref (JSApp s1 func [ref]) else JSAssignment s1 (JSAccessor s1 C.stRefValue ref) (JSApp s1 func [JSAccessor s1 C.stRefValue ref])

112 convert _ other = other

113 -- Check if an expression represents a function in the ST module

114− isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'

114+ isSTFunc name (JSAccessor _ name' (JSVar _ st)) = st == C.st && name == name'

115 isSTFunc _ _ = False

116 -- Find all ST Refs initialized in this block

117 findSTRefsIn = everythingOnJS (++) isSTRef

118 where

119− isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]

119+ isSTRef (JSVariableIntroduction _ ident (Just (JSApp _ (JSApp _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]

120 isSTRef _ = []

121 -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef

122 findAllSTUsagesIn = everythingOnJS (++) isSTUsage

123 where

124− isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]

124+ isSTUsage (JSApp _ (JSApp _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]

125− isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]

125+ isSTUsage (JSApp _ (JSApp _ (JSApp _ f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]

126 isSTUsage _ = []

127 -- Find all uses of a variable

128 appearingIn ref = everythingOnJS (++) isVar

129 where

130− isVar e@(JSVar v) | v == ref = [e]

130+ isVar e@(JSVar _ v) | v == ref = [e]

131 isVar _ = []

132 -- Convert a JS value to a String if it is a JSVar

133− toVar (JSVar v) = Just v

133+ toVar (JSVar _ v) = Just v

134 toVar _ = Nothing

src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs+33−31

@@ -40,7 +40,7 @@ tco' = everywhereOnJS convert

40 copyVar arg = "__copy_" ++ arg

42 convert :: JS -> JS

43− convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =

43+ convert js@(JSVariableIntroduction ss name (Just fn@JSFunction {})) =

44 let

45 (argss, body', replace) = collectAllFunctionArgs [] id fn

46 in case () of

@@ -48,19 +48,19 @@ tco' = everywhereOnJS convert

48 let

49 allArgs = concat $ reverse argss

50 in

51− JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))

51+ JSVariableIntroduction ss name (Just (replace (toLoop name allArgs body')))

52 | otherwise -> js

53 convert js = js

55 collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)

56− collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =

56+ collectAllFunctionArgs allArgs f (JSFunction s1 ident args (JSBlock s2 (body@(JSReturn _ _):_))) =

57− collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body

57+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction s1 ident (map copyVar args) (JSBlock s2 [b]))) body

58− collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =

58+ collectAllFunctionArgs allArgs f (JSFunction ss ident args body@(JSBlock _ _)) =

59− (args : allArgs, body, f . JSFunction ident (map copyVar args))

59+ (args : allArgs, body, f . JSFunction ss ident (map copyVar args))

60− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =

60+ collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args (JSBlock s3 [body]))) =

61− collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body

61+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn s1 (JSFunction s2 ident (map copyVar args) (JSBlock s3 [b])))) body

62− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =

62+ collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args body@(JSBlock _ _))) =

63− (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))

63+ (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args))

64 collectAllFunctionArgs allArgs f body = (allArgs, body, f)

66 isTailCall :: String -> JS -> Bool

@@ -77,51 +77,53 @@ tco' = everywhereOnJS convert

77 && numSelfCallWithFnArgs == 0

78 where

79 countSelfCalls :: JS -> Int

80− countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1

80+ countSelfCalls (JSApp _ (JSVar _ ident') _) | ident == ident' = 1

81 countSelfCalls _ = 0

82−

82+

83 countSelfCallsInTailPosition :: JS -> Int

84− countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1

84+ countSelfCallsInTailPosition (JSReturn _ ret) | isSelfCall ident ret = 1

85 countSelfCallsInTailPosition _ = 0

86−

86+

87 countSelfCallsUnderFunctions :: JS -> Int

88− countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'

88+ countSelfCallsUnderFunctions (JSFunction _ _ _ js') = everythingOnJS (+) countSelfCalls js'

89 countSelfCallsUnderFunctions _ = 0

90−

90+

91 countSelfCallsWithFnArgs :: JS -> Int

92 countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0

94 toLoop :: String -> [String] -> JS -> JS

95− toLoop ident allArgs js = JSBlock $

95+ toLoop ident allArgs js = JSBlock rootSS $

96− map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++

96+ map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++

97− [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]

97+ [ JSLabel rootSS tcoLabel $ JSWhile rootSS (JSBooleanLiteral rootSS True) (JSBlock rootSS [ everywhereOnJS loopify js ]) ]

98 where

99+ rootSS = Nothing

100+

99 loopify :: JS -> JS

101 loopify :: JS -> JS

100− loopify (JSReturn ret) | isSelfCall ident ret =

102+ loopify (JSReturn ss ret) | isSelfCall ident ret =

101 let

103 let

102 allArgumentValues = concat $ collectSelfCallArgs [] ret

104 allArgumentValues = concat $ collectSelfCallArgs [] ret

103 in

105 in

104− JSBlock $ zipWith (\val arg ->

106+ JSBlock ss $ zipWith (\val arg ->

105− JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs

107+ JSVariableIntroduction ss (tcoVar arg) (Just val)) allArgumentValues allArgs

106 ++ map (\arg ->

108 ++ map (\arg ->

107− JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs

109+ JSAssignment ss (JSVar ss arg) (JSVar ss (tcoVar arg))) allArgs

108− ++ [ JSContinue tcoLabel ]

110+ ++ [ JSContinue ss tcoLabel ]

109 loopify other = other

111 loopify other = other

110 collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]

112 collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]

111− collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn

113+ collectSelfCallArgs allArgumentValues (JSApp _ fn args') = collectSelfCallArgs (args' : allArgumentValues) fn

112 collectSelfCallArgs allArgumentValues _ = allArgumentValues

114 collectSelfCallArgs allArgumentValues _ = allArgumentValues

113

115

114 isSelfCall :: String -> JS -> Bool

116 isSelfCall :: String -> JS -> Bool

115− isSelfCall ident (JSApp (JSVar ident') _) = ident == ident'

117+ isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident'

116− isSelfCall ident (JSApp fn _) = isSelfCall ident fn

118+ isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn

117 isSelfCall _ _ = False

119 isSelfCall _ _ = False

118

120

119 isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool

121 isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool

120− isSelfCallWithFnArgs ident (JSVar ident') args | ident == ident' && any hasFunction args = True

122+ isSelfCallWithFnArgs ident (JSVar _ ident') args | ident == ident' && any hasFunction args = True

121− isSelfCallWithFnArgs ident (JSApp fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)

123+ isSelfCallWithFnArgs ident (JSApp _ fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)

122 isSelfCallWithFnArgs _ _ _ = False

124 isSelfCallWithFnArgs _ _ _ = False

123−

125+

124− hasFunction :: JS -> Bool

126+ hasFunction :: JS -> Bool

125 hasFunction = getAny . everythingOnJS mappend (Any . isFunction)

127 hasFunction = getAny . everythingOnJS mappend (Any . isFunction)

126 where

128 where

127 isFunction JSFunction{} = True

129 isFunction JSFunction{} = True

src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs+3−3

@@ -30,17 +30,17 @@ removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)

30 go :: [JS] -> [JS]

31 go jss | not (any isJSReturn jss) = jss

32 | otherwise = let (body, ret : _) = break isJSReturn jss in body ++ [ret]

33− isJSReturn (JSReturn _) = True

33+ isJSReturn (JSReturn _ _) = True

34 isJSReturn _ = False

36removeUnusedArg :: JS -> JS

37removeUnusedArg = everywhereOnJS convert

38 where

39− convert (JSFunction name [arg] body) | arg == C.__unused = JSFunction name [] body

39+ convert (JSFunction ss name [arg] body) | arg == C.__unused = JSFunction ss name [] body

40 convert js = js

42removeUndefinedApp :: JS -> JS

43removeUndefinedApp = everywhereOnJS convert

44 where

45− convert (JSApp fn [JSVar arg]) | arg == C.undefined = JSApp fn []

45+ convert (JSApp ss fn [JSVar _ arg]) | arg == C.undefined = JSApp ss fn []

46 convert js = js

src/Language/PureScript/CoreFn/Binders.hs+9−2

@@ -31,5 +31,12 @@ data Binder a

31 -- |

32 -- A binder which binds its input to an identifier

33 --

34− | NamedBinder a Ident (Binder a)

34+ | NamedBinder a Ident (Binder a) deriving (Show, Read, Functor)

35− deriving (Show, Read, Functor)

35+

36+

37+extractBinderAnn :: Binder a -> a

38+extractBinderAnn (NullBinder a) = a

39+extractBinderAnn (LiteralBinder a _) = a

40+extractBinderAnn (VarBinder a _) = a

41+extractBinderAnn (ConstructorBinder a _ _ _) = a

42+extractBinderAnn (NamedBinder a _ _) = a

src/Language/PureScript/CoreFn/Desugar.hs+36−17

@@ -1,5 +1,9 @@

1module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where

3+import Prelude ()

4+import Prelude.Compat

3import Data.Function (on)

7import Data.Function (on)

4import Data.List (sort, sortBy, nub)

8import Data.List (sort, sortBy, nub)

5import Data.Maybe (mapMaybe)

9import Data.Maybe (mapMaybe)

@@ -30,38 +34,52 @@ moduleToCoreFn :: Environment -> A.Module -> Module Ann

30moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =

34moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =

31 internalError "Module exports were not elaborated before moduleToCoreFn"

35 internalError "Module exports were not elaborated before moduleToCoreFn"

32moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

36moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

33− let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls

37+ let imports = mapMaybe importToCoreFn decls ++ findQualModules decls

38+ imports' = nub $ filter (keepImp imports) imports-- TODO could be more efficient

34 exps' = nub $ concatMap exportToCoreFn exps

39 exps' = nub $ concatMap exportToCoreFn exps

35 externs = nub $ mapMaybe externToCoreFn decls

40 externs = nub $ mapMaybe externToCoreFn decls

36 decls' = concatMap (declToCoreFn Nothing []) decls

41 decls' = concatMap (declToCoreFn Nothing []) decls

37− in Module coms mn imports exps' externs decls'

42+ in Module coms mn imports' exps' externs decls'

39 where

44 where

46+ -- Remove duplicate imports favoring the one containing sourcespan info

47+ keepImp :: [(Ann, ModuleName)] -> (Ann, ModuleName) -> Bool

48+ keepImp imps (a, i) = hasSS a || not (any hasDup imps)

49+ where

50+ hasDup (a', i') = i == i' && hasSS a'

51+

52+ hasSS :: Ann -> Bool

53+ hasSS (Just _, _, _, _) = True

54+ hasSS _ = False

55+

56+ ssA :: Maybe SourceSpan -> Ann

57+ ssA ss = (ss, [], Nothing, Nothing)

58+

41 -- |

59 -- |

42 -- Desugars member declarations from AST to CoreFn representation.

60 -- Desugars member declarations from AST to CoreFn representation.

43 --

61 --

44 declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]

62 declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]

45 declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =

63 declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =

46− [NonRec (properToIdent ctor) $

64+ [NonRec (ssA ss) (properToIdent ctor) $

47 Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]

65 Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]

48 declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =

66 declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =

49 error $ "Found newtype with multiple constructors: " ++ show d

67 error $ "Found newtype with multiple constructors: " ++ show d

50 declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =

68 declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =

51 flip map ctors $ \(ctor, _) ->

69 flip map ctors $ \(ctor, _) ->

52 let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)

70 let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)

53− in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields

71+ in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields

54 declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds

72 declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds

55 declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =

73 declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =

56− [NonRec name (exprToCoreFn ss com Nothing e)]

74+ [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)]

57 declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =

75 declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =

58 let meta = either getValueMeta (Just . getConstructorMeta) alias

76 let meta = either getValueMeta (Just . getConstructorMeta) alias

59 alias' = either id (fmap properToIdent) alias

77 alias' = either id (fmap properToIdent) alias

60− in [NonRec (Op name) (Var (ss, com, Nothing, meta) alias')]

78+ in [NonRec (ssA ss) (Op name) (Var (ss, com, Nothing, meta) alias')]

61 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

79 declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

62− [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]

80+ [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds]

63 declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =

81 declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =

64− [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]

82+ [NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor ss com supers members]

65 declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =

83 declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =

66 declToCoreFn (Just ss) (com ++ com1) d

84 declToCoreFn (Just ss) (com ++ com1) d

67 declToCoreFn _ _ _ = []

85 declToCoreFn _ _ _ = []

@@ -203,35 +221,36 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

203-- ensure instances are imported from any module that is referenced by the

221-- ensure instances are imported from any module that is referenced by the

204-- current module, not just from those that are imported explicitly (#667).

222-- current module, not just from those that are imported explicitly (#667).

205--

223--

206−findQualModules :: [A.Declaration] -> [ModuleName]

224+findQualModules :: [A.Declaration] -> [(Ann, ModuleName)]

207findQualModules decls =

225findQualModules decls =

208 let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const [])

226 let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const [])

209 in f `concatMap` decls

227 in f `concatMap` decls

210 where

228 where

211− fqDecls :: A.Declaration -> [ModuleName]

229+ fqDecls :: A.Declaration -> [(Ann, ModuleName)]

212 fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q

230 fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q

213 fqDecls (A.FixityDeclaration _ _ (Just eq)) = either getQual getQual eq

231 fqDecls (A.FixityDeclaration _ _ (Just eq)) = either getQual getQual eq

214 fqDecls _ = []

232 fqDecls _ = []

215

233

216− fqValues :: A.Expr -> [ModuleName]

234+ fqValues :: A.Expr -> [(Ann, ModuleName)]

217 fqValues (A.Var q) = getQual q

235 fqValues (A.Var q) = getQual q

218 fqValues (A.Constructor q) = getQual q

236 fqValues (A.Constructor q) = getQual q

219 fqValues _ = []

237 fqValues _ = []

220

238

221− fqBinders :: A.Binder -> [ModuleName]

239+ fqBinders :: A.Binder -> [(Ann, ModuleName)]

222 fqBinders (A.ConstructorBinder q _) = getQual q

240 fqBinders (A.ConstructorBinder q _) = getQual q

223 fqBinders _ = []

241 fqBinders _ = []

224

242

225− getQual :: Qualified a -> [ModuleName]

243+ getQual :: Qualified a -> [(Ann, ModuleName)]

226− getQual (Qualified (Just mn) _) = [mn]

244+ getQual (Qualified (Just mn) _) = [(nullAnn, mn)]

227 getQual _ = []

245 getQual _ = []

228

246

229-- |

247-- |

230-- Desugars import declarations from AST to CoreFn representation.

248-- Desugars import declarations from AST to CoreFn representation.

231--

249--

232−importToCoreFn :: A.Declaration -> Maybe ModuleName

250+importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName)

233−importToCoreFn (A.ImportDeclaration name _ _ _) = Just name

251+importToCoreFn (A.ImportDeclaration name _ _ _) = Just (nullAnn, name)

234−importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d

252+importToCoreFn (A.PositionedDeclaration ss _ d) =

253+ ((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d

235importToCoreFn _ = Nothing

254importToCoreFn _ = Nothing

236

255

237-- |

256-- |

src/Language/PureScript/CoreFn/Expr.hs+3−5

@@ -60,12 +60,11 @@ data Bind a

60 -- |

61 -- Non-recursive binding for a single value

62 --

63− = NonRec Ident (Expr a)

63+ = NonRec a Ident (Expr a)

64 -- |

65 -- Mutually recursive binding group for several values

66 --

67− | Rec [(Ident, Expr a)]

68− deriving (Show, Read, Functor)

67+ | Rec [((a, Ident), Expr a)] deriving (Show, Read, Functor)

70-- |

69-- |

71-- A guard is just a boolean-valued expression that appears alongside a set of binders

70-- A guard is just a boolean-valued expression that appears alongside a set of binders

@@ -84,8 +83,7 @@ data CaseAlternative a = CaseAlternative

84 -- The result expression or a collect of guarded expressions

83 -- The result expression or a collect of guarded expressions

85 --

84 --

86 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

85 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

87− }

88− deriving (Show, Read)

86+ } deriving (Show, Read)

90instance Functor CaseAlternative where

88instance Functor CaseAlternative where

src/Language/PureScript/CoreFn/Meta.hs+2−4

@@ -24,8 +24,7 @@ data Meta

24 -- |

25 -- The contained reference is for a foreign member

26 --

27− | IsForeign

28− deriving (Show, Read)

27+ | IsForeign deriving (Show, Read, Eq)

30-- |

29-- |

31-- Data constructor metadata

30-- Data constructor metadata

@@ -38,5 +37,4 @@ data ConstructorType

38 -- |

37 -- |

39 -- The constructor is for a type with multiple construcors

38 -- The constructor is for a type with multiple construcors

40 --

39 --

41− | SumType

42− deriving (Show, Read)

40+ | SumType deriving (Show, Read, Eq)

src/Language/PureScript/CoreFn/Module.hs+1−1

@@ -22,7 +22,7 @@ import Language.PureScript.Types

22data Module a = Module

23 { moduleComments :: [Comment]

24 , moduleName :: ModuleName

25− , moduleImports :: [ModuleName]

25+ , moduleImports :: [(a, ModuleName)]

26 , moduleExports :: [Ident]

27 , moduleForeign :: [ForeignDecl]

28 , moduleDecls :: [Bind a]

src/Language/PureScript/CoreFn/Traversals.hs+2−2

@@ -26,7 +26,7 @@ everywhereOnValues :: (Bind a -> Bind a) ->

26 (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)

27everywhereOnValues f g h = (f', g', h')

28 where

29− f' (NonRec name e) = f (NonRec name (g' e))

29+ f' (NonRec a name e) = f (NonRec a name (g' e))

30 f' (Rec es) = f (Rec (map (second g') es))

32 g' (Literal ann e) = g (Literal ann (handleLiteral g' e))

@@ -61,7 +61,7 @@ everythingOnValues :: (r -> r -> r) ->

61 (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)

62everythingOnValues (<>) f g h i = (f', g', h', i')

63 where

64− f' b@(NonRec _ e) = f b <> g' e

64+ f' b@(NonRec _ _ e) = f b <> g' e

65 f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)

67 g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l))

src/Language/PureScript/Make.hs+41−6

@@ -31,7 +31,7 @@ import Control.Monad.Writer.Class (MonadWriter(..))

31import Control.Monad.Trans.Class (MonadTrans(..))

32import Control.Monad.Trans.Except

33import Control.Monad.IO.Class

34−import Control.Monad.Reader (MonadReader(..), ReaderT(..))

34+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)

35import Control.Monad.Logger

36import Control.Monad.Supply

37import Control.Monad.Base (MonadBase(..))

@@ -52,9 +52,12 @@ import qualified Data.ByteString.UTF8 as BU8

52import qualified Data.Set as S

53import qualified Data.Map as M

55+import SourceMap.Types

56+import SourceMap

57+

55import System.Directory

58import System.Directory

56− (doesFileExist, getModificationTime, createDirectoryIfMissing)

59+ (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)

57−import System.FilePath ((</>), takeDirectory)

60+import System.FilePath ((</>), takeDirectory, makeRelative, splitPath)

58import System.IO.Error (tryIOError)

61import System.IO.Error (tryIOError)

59import System.IO.UTF8 (readUTF8File, writeUTF8File)

62import System.IO.UTF8 (readUTF8File, writeUTF8File)

@@ -68,6 +71,7 @@ import Language.PureScript.ModuleDependencies

68import Language.PureScript.Names

71import Language.PureScript.Names

69import Language.PureScript.Options

72import Language.PureScript.Options

70import Language.PureScript.Pretty

73import Language.PureScript.Pretty

74+import Language.PureScript.Pretty.Common(SMap(..))

71import Language.PureScript.Renamer

75import Language.PureScript.Renamer

72import Language.PureScript.Sugar

76import Language.PureScript.Sugar

73import Language.PureScript.TypeChecker

77import Language.PureScript.TypeChecker

@@ -324,20 +328,51 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

324 | not $ requiresForeign m -> do

328 | not $ requiresForeign m -> do

325 tell $ errorMessage $ UnnecessaryFFIModule mn path

329 tell $ errorMessage $ UnnecessaryFFIModule mn path

326 return Nothing

330 return Nothing

327− | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]

331+ | otherwise -> return $ Just $ J.JSApp Nothing (J.JSVar Nothing "require") [J.JSStringLiteral Nothing "./foreign"]

328 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn

332 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn

329 | otherwise -> return Nothing

333 | otherwise -> return Nothing

330− pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude

334+ rawJs <- J.moduleToJs m foreignInclude

335+ dir <- lift $ makeIO (const (ErrorMessage [] $ CannotGetFileInfo ".")) getCurrentDirectory

336+ sourceMaps <- lift $ asks optionsSourceMaps

337+ let (pjs, mappings) = if sourceMaps then prettyPrintJSWithSourceMaps rawJs else (prettyPrintJS rawJs, [])

331 let filePath = runModuleName mn

338 let filePath = runModuleName mn

332 jsFile = outputDir </> filePath </> "index.js"

339 jsFile = outputDir </> filePath </> "index.js"

340+ mapFile = outputDir </> filePath </> "index.js.map"

333 externsFile = outputDir </> filePath </> "externs.json"

341 externsFile = outputDir </> filePath </> "externs.json"

334 foreignFile = outputDir </> filePath </> "foreign.js"

342 foreignFile = outputDir </> filePath </> "foreign.js"

335 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]

343 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]

336 js = unlines $ map ("// " ++) prefix ++ [pjs]

344 js = unlines $ map ("// " ++) prefix ++ [pjs]

345+ mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""

337 lift $ do

346 lift $ do

338− writeTextFile jsFile (fromString js)

347+ writeTextFile jsFile (fromString $ js ++ mapRef)

339 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)

348 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)

340 writeTextFile externsFile exts

349 writeTextFile externsFile exts

350+ lift $ when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings

351+

352+ genSourceMap :: String -> String -> Int -> [SMap] -> Make ()

353+ genSourceMap dir mapFile extraLines mappings = do

354+ let pathToDir = iterate (".." </>) ".." !! length (splitPath outputDir)

355+ sourceFile = case mappings of

356+ ((SMap file _ _):_) -> Just $ pathToDir </> makeRelative dir file

357+ _ -> Nothing

358+ let rawMapping = SourceMapping { smFile = "index.js", smSourceRoot = Nothing, smMappings =

359+ map (\(SMap _ orig gen) -> Mapping {

360+ mapOriginal = Just $ convertPos $ add 0 (-1) orig

361+ , mapSourceFile = sourceFile

362+ , mapGenerated = convertPos $ add (extraLines+1) 0 gen

363+ , mapName = Nothing

364+ }) $

365+ mappings

366+ }

367+ let mapping = generate rawMapping

368+ writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping

369+ where

370+ add :: Int -> Int -> SourcePos -> SourcePos

371+ add n m (SourcePos n' m') = SourcePos (n+n') (m+m')

372+

373+ convertPos :: SourcePos -> Pos

374+ convertPos SourcePos { sourcePosLine = l, sourcePosColumn = c } =

375+ Pos { posLine = fromIntegral l, posColumn = fromIntegral c }

341

376

342 requiresForeign :: CF.Module a -> Bool

377 requiresForeign :: CF.Module a -> Bool

343 requiresForeign = not . null . CF.moduleForeign

378 requiresForeign = not . null . CF.moduleForeign

src/Language/PureScript/Options.hs+4−1

@@ -41,9 +41,12 @@ data Options = Options {

41 -- |

42 -- The path to prepend to require statements

43 , optionsRequirePath :: Maybe FilePath

44+ -- |

45+ -- Generate soure maps

46+ , optionsSourceMaps :: Bool

44 } deriving Show

47 } deriving Show

46-- |

49-- |

47-- Default make options

50-- Default make options

48defaultOptions :: Options

51defaultOptions :: Options

49−defaultOptions = Options False False Nothing False False False Nothing

52+defaultOptions = Options False False Nothing False False False Nothing False

src/Language/PureScript/Parser/Declarations.hs+1−1

@@ -374,7 +374,7 @@ parseLet = do

374 return $ Let ds result

375

376parseValueAtom :: TokenParser Expr

377−parseValueAtom = P.choice

377+parseValueAtom = withSourceSpan PositionedValue $ P.choice

378 [ parseAnonymousArgument

379 , parseNumericLiteral

380 , parseCharLiteral

src/Language/PureScript/Pretty.hs−3

@@ -27,6 +27,3 @@ import Language.PureScript.Pretty.Kinds as P

27import Language.PureScript.Pretty.Values as P

28import Language.PureScript.Pretty.Types as P

29import Language.PureScript.Pretty.JS as P

30−

31−

32−

src/Language/PureScript/Pretty/Common.hs+96−9

@@ -13,12 +13,18 @@

13--

14-----------------------------------------------------------------------------

16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17+

16module Language.PureScript.Pretty.Common where

18module Language.PureScript.Pretty.Common where

20+import Prelude ()

21+import Prelude.Compat

22+

18−import Control.Monad.State

23+import Control.Monad.State (StateT, modify, get)

19−import Data.List (intercalate)

24+import Data.List (elemIndices, intersperse)

21import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar)

26import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar)

27+import Language.PureScript.AST (SourcePos(..), SourceSpan(..))

23import Text.PrettyPrint.Boxes

29import Text.PrettyPrint.Boxes

@@ -26,9 +32,90 @@ import Text.PrettyPrint.Boxes

26-- Wrap a string in parentheses

32-- Wrap a string in parentheses

27--

33--

28parens :: String -> String

34parens :: String -> String

29−parens s = ('(':s) ++ ")"

35+parens s = '(':s ++ ")"

36+

37+parensPos :: (Emit gen) => gen -> gen

38+parensPos s = emit "(" `mappend` s `mappend` emit ")"

39+

40+-- |

41+-- Generalize intercalate slightly for monoids

42+--

43+intercalate :: Monoid m => m -> [m] -> m

44+intercalate x xs = mconcat (intersperse x xs)

45+

46+class (Monoid gen) => Emit gen where

47+ emit :: String -> gen

48+ addMapping :: SourceSpan -> gen

49+

50+data SMap = SMap String SourcePos SourcePos

51+

52+-- |

53+-- String with length and source-map entries

54+--

55+newtype StrPos = StrPos (SourcePos, String, [SMap])

56+

57+-- |

58+-- Make a monoid where append consists of concatenating the string part, adding the lengths

59+-- appropriately and advancing source mappings on the right hand side to account for

60+-- the length of the left.

61+--

62+instance Monoid StrPos where

63+ mempty = StrPos (SourcePos 0 0, "", [])

64+

65+ StrPos (a,b,c) `mappend` StrPos (a',b',c') = StrPos (a `addPos` a', b ++ b', c ++ (bumpPos a <$> c'))

66+

67+ mconcat ms =

68+ let s' = concatMap (\(StrPos(_, s, _)) -> s) ms

69+ (p, maps) = foldl plus (SourcePos 0 0, []) ms

70+ in

71+ StrPos (p, s', concat $ reverse maps)

72+ where

73+ plus :: (SourcePos, [[SMap]]) -> StrPos -> (SourcePos, [[SMap]])

74+ plus (a, c) (StrPos (a', _, c')) = (a `addPos` a', (bumpPos a <$> c') : c)

75+

76+instance Emit StrPos where

77+ -- |

78+ -- Augment a string with its length (rows/column)

79+ --

80+ emit str =

81+ let newlines = elemIndices '\n' str

82+ index = if null newlines then 0 else last newlines + 1

83+ in

84+ StrPos (SourcePos { sourcePosLine = length newlines, sourcePosColumn = length str - index }, str, [])

85+

86+ -- |

87+ -- Add a new mapping entry for given source position with initially zero generated position

88+ --

89+ addMapping (SourceSpan { spanName = file, spanStart = startPos }) = StrPos (zeroPos, mempty, [mapping])

90+ where

91+ mapping = SMap file startPos zeroPos

92+ zeroPos = SourcePos 0 0

93+

94+newtype PlainString = PlainString String deriving Monoid

95+

96+runPlainString :: PlainString -> String

97+runPlainString (PlainString s) = s

98+

99+instance Emit PlainString where

100+ emit = PlainString

101+ addMapping _ = mempty

102+

103+addMapping' :: (Emit gen) => Maybe SourceSpan -> gen

104+addMapping' (Just ss) = addMapping ss

105+addMapping' Nothing = mempty

106+

107+bumpPos :: SourcePos -> SMap -> SMap

108+bumpPos p (SMap f s g) = SMap f s $ p `addPos` g

109+

110+addPos :: SourcePos -> SourcePos -> SourcePos

111+addPos (SourcePos n m) (SourcePos 0 m') = SourcePos n (m+m')

112+addPos (SourcePos n _) (SourcePos n' m') = SourcePos (n+n') m'

113+

114+

115+data PrinterState = PrinterState { indent :: Int }

116

31−newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Read, Eq, Ord)

117+emptyPrinterState :: PrinterState

118+emptyPrinterState = PrinterState { indent = 0 }

119

33-- |

120-- |

34-- Number of characters per identation level

121-- Number of characters per identation level

@@ -39,7 +126,7 @@ blockIndent = 4

39-- |

126-- |

40-- Pretty print with a new indentation level

127-- Pretty print with a new indentation level

41--

128--

42−withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String

129+withIndent :: (Emit gen) => StateT PrinterState Maybe gen -> StateT PrinterState Maybe gen

43withIndent action = do

130withIndent action = do

44 modify $ \st -> st { indent = indent st + blockIndent }

131 modify $ \st -> st { indent = indent st + blockIndent }

45 result <- action

132 result <- action

@@ -49,19 +136,19 @@ withIndent action = do

49-- |

136-- |

50-- Get the current indentation level

137-- Get the current indentation level

51--

138--

52−currentIndent :: StateT PrinterState Maybe String

139+currentIndent :: (Emit gen) => StateT PrinterState Maybe gen

53currentIndent = do

140currentIndent = do

54 current <- get

141 current <- get

55− return $ replicate (indent current) ' '

142+ return $ emit $ replicate (indent current) ' '

143

57-- |

144-- |

58-- Print many lines

145-- Print many lines

59--

146--

60−prettyPrintMany :: (a -> StateT PrinterState Maybe String) -> [a] -> StateT PrinterState Maybe String

147+prettyPrintMany :: (Emit gen) => (a -> StateT PrinterState Maybe gen) -> [a] -> StateT PrinterState Maybe gen

61prettyPrintMany f xs = do

148prettyPrintMany f xs = do

62 ss <- mapM f xs

149 ss <- mapM f xs

63 indentString <- currentIndent

150 indentString <- currentIndent

64− return $ intercalate "\n" $ map (indentString ++) ss

151+ return $ intercalate (emit "\n") $ map (\s -> mappend indentString s) ss

152

66-- |

153-- |

67-- Prints an object key, escaping reserved names.

154-- Prints an object key, escaping reserved names.

src/Language/PureScript/Pretty/JS.hs+118−105

@@ -14,13 +14,12 @@

14-----------------------------------------------------------------------------

16module Language.PureScript.Pretty.JS (

17− prettyPrintJS

17+ prettyPrintJS, prettyPrintJSWithSourceMaps

18) where

20import Prelude ()

21import Prelude.Compat

23−import Data.List hiding (concat, concatMap)

24import Data.Maybe (fromMaybe)

23import Data.Maybe (fromMaybe)

26import Control.Arrow ((<+>))

25import Control.Arrow ((<+>))

@@ -34,103 +33,110 @@ import Language.PureScript.CodeGen.JS.Common

34import Language.PureScript.Pretty.Common

33import Language.PureScript.Pretty.Common

35import Language.PureScript.Comments

34import Language.PureScript.Comments

36+

37+import Language.PureScript.AST (SourceSpan(..))

38+

37import Numeric

39import Numeric

41+import Data.Monoid

42+

39−literals :: Pattern PrinterState JS String

43+literals :: (Emit gen) => Pattern PrinterState JS gen

40−literals = mkPattern' match

44+literals = mkPattern' match'

41 where

45 where

46+ match' :: (Emit gen) => JS -> StateT PrinterState Maybe gen

47+ match' js = (addMapping' (getSourceSpan js) <>) <$> match js

48+

42− match :: JS -> StateT PrinterState Maybe String

49+ match :: (Emit gen) => JS -> StateT PrinterState Maybe gen

43− match (JSNumericLiteral n) = return $ either show show n

50+ match (JSNumericLiteral _ n) = return $ emit $ either show show n

44− match (JSStringLiteral s) = return $ string s

51+ match (JSStringLiteral _ s) = return $ string s

45− match (JSBooleanLiteral True) = return "true"

52+ match (JSBooleanLiteral _ True) = return $ emit "true"

46− match (JSBooleanLiteral False) = return "false"

53+ match (JSBooleanLiteral _ False) = return $ emit "false"

47− match (JSArrayLiteral xs) = concat <$> sequence

54+ match (JSArrayLiteral _ xs) = mconcat <$> sequence

48− [ return "[ "

55+ [ return $ emit "[ "

49− , intercalate ", " <$> forM xs prettyPrintJS'

56+ , intercalate (emit ", ") <$> forM xs prettyPrintJS'

50− , return " ]"

57+ , return $ emit " ]"

51 ]

58 ]

52− match (JSObjectLiteral []) = return "{}"

59+ match (JSObjectLiteral _ []) = return $ emit "{}"

53− match (JSObjectLiteral ps) = concat <$> sequence

60+ match (JSObjectLiteral _ ps) = mconcat <$> sequence

54− [ return "{\n"

61+ [ return $ emit "{\n"

55 , withIndent $ do

62 , withIndent $ do

56− jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value

63+ jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key <> emit ": ") <>) . prettyPrintJS' $ value

57 indentString <- currentIndent

64 indentString <- currentIndent

58− return $ intercalate ", \n" $ map (indentString ++) jss

65+ return $ intercalate (emit ", \n") $ map (indentString <>) jss

59− , return "\n"

66+ , return $ emit "\n"

60 , currentIndent

67 , currentIndent

61− , return "}"

68+ , return $ emit "}"

62 ]

69 ]

63 where

70 where

64− objectPropertyToString :: String -> String

71+ objectPropertyToString :: (Emit gen) => String -> gen

65− objectPropertyToString s | identNeedsEscaping s = show s

72+ objectPropertyToString s | identNeedsEscaping s = emit $ show s

66− | otherwise = s

73+ | otherwise = emit s

67− match (JSBlock sts) = concat <$> sequence

74+ match (JSBlock _ sts) = mconcat <$> sequence

68− [ return "{\n"

75+ [ return $ emit "{\n"

69 , withIndent $ prettyStatements sts

76 , withIndent $ prettyStatements sts

70− , return "\n"

77+ , return $ emit "\n"

71 , currentIndent

78 , currentIndent

72− , return "}"

79+ , return $ emit "}"

73 ]

80 ]

74− match (JSVar ident) = return ident

81+ match (JSVar _ ident) = return $ emit ident

75− match (JSVariableIntroduction ident value) = concat <$> sequence

82+ match (JSVariableIntroduction _ ident value) = mconcat <$> sequence

76− [ return "var "

83+ [ return $ emit $ "var " ++ ident

77− , return ident

78− , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value

84+ , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value

79 ]

85 ]

80− match (JSAssignment target value) = concat <$> sequence

86+ match (JSAssignment _ target value) = mconcat <$> sequence

81 [ prettyPrintJS' target

87 [ prettyPrintJS' target

82− , return " = "

88+ , return $ emit " = "

83 , prettyPrintJS' value

89 , prettyPrintJS' value

84 ]

90 ]

85− match (JSWhile cond sts) = concat <$> sequence

91+ match (JSWhile _ cond sts) = mconcat <$> sequence

86− [ return "while ("

92+ [ return $ emit "while ("

87 , prettyPrintJS' cond

93 , prettyPrintJS' cond

88− , return ") "

94+ , return $ emit ") "

89 , prettyPrintJS' sts

95 , prettyPrintJS' sts

90 ]

96 ]

91− match (JSFor ident start end sts) = concat <$> sequence

97+ match (JSFor _ ident start end sts) = mconcat <$> sequence

92− [ return $ "for (var " ++ ident ++ " = "

98+ [ return $ emit $ "for (var " ++ ident ++ " = "

93 , prettyPrintJS' start

99 , prettyPrintJS' start

94− , return $ "; " ++ ident ++ " < "

100+ , return $ emit $ "; " ++ ident ++ " < "

95 , prettyPrintJS' end

101 , prettyPrintJS' end

96− , return $ "; " ++ ident ++ "++) "

102+ , return $ emit $ "; " ++ ident ++ "++) "

97 , prettyPrintJS' sts

103 , prettyPrintJS' sts

98 ]

104 ]

99− match (JSForIn ident obj sts) = concat <$> sequence

105+ match (JSForIn _ ident obj sts) = mconcat <$> sequence

100− [ return $ "for (var " ++ ident ++ " in "

106+ [ return $ emit $ "for (var " ++ ident ++ " in "

101 , prettyPrintJS' obj

107 , prettyPrintJS' obj

102− , return ") "

108+ , return $ emit ") "

103 , prettyPrintJS' sts

109 , prettyPrintJS' sts

104 ]

110 ]

105− match (JSIfElse cond thens elses) = concat <$> sequence

111+ match (JSIfElse _ cond thens elses) = mconcat <$> sequence

106− [ return "if ("

112+ [ return $ emit "if ("

107 , prettyPrintJS' cond

113 , prettyPrintJS' cond

108− , return ") "

114+ , return $ emit ") "

109 , prettyPrintJS' thens

115 , prettyPrintJS' thens

110− , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses

116+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintJS') elses

111 ]

117 ]

112− match (JSReturn value) = concat <$> sequence

118+ match (JSReturn _ value) = mconcat <$> sequence

113− [ return "return "

119+ [ return $ emit "return "

114 , prettyPrintJS' value

120 , prettyPrintJS' value

115 ]

121 ]

116− match (JSThrow value) = concat <$> sequence

122+ match (JSThrow _ value) = mconcat <$> sequence

117− [ return "throw "

123+ [ return $ emit "throw "

118 , prettyPrintJS' value

124 , prettyPrintJS' value

119 ]

125 ]

120− match (JSBreak lbl) = return $ "break " ++ lbl

126+ match (JSBreak _ lbl) = return $ emit $ "break " ++ lbl

121− match (JSContinue lbl) = return $ "continue " ++ lbl

127+ match (JSContinue _ lbl) = return $ emit $ "continue " ++ lbl

122− match (JSLabel lbl js) = concat <$> sequence

128+ match (JSLabel _ lbl js) = mconcat <$> sequence

123− [ return $ lbl ++ ": "

129+ [ return $ emit $ lbl ++ ": "

124 , prettyPrintJS' js

130 , prettyPrintJS' js

125 ]

131 ]

126− match (JSComment com js) = fmap concat $ sequence $

132+ match (JSComment _ com js) = fmap mconcat $ sequence $

127− [ return "\n"

133+ [ return $ emit "\n"

128 , currentIndent

134 , currentIndent

129− , return "/**\n"

135+ , return $ emit "/**\n"

130 ] ++

136 ] ++

131 map asLine (concatMap commentLines com) ++

137 map asLine (concatMap commentLines com) ++

132 [ currentIndent

138 [ currentIndent

133− , return " */\n"

139+ , return $ emit " */\n"

134 , currentIndent

140 , currentIndent

135 , prettyPrintJS' js

141 , prettyPrintJS' js

136 ]

142 ]

@@ -139,21 +145,21 @@ literals = mkPattern' match

139 commentLines (LineComment s) = [s]

145 commentLines (LineComment s) = [s]

140 commentLines (BlockComment s) = lines s

146 commentLines (BlockComment s) = lines s

141

147

142− asLine :: String -> StateT PrinterState Maybe String

148+ asLine :: (Emit gen) => String -> StateT PrinterState Maybe gen

143 asLine s = do

149 asLine s = do

144 i <- currentIndent

150 i <- currentIndent

145− return $ i ++ " * " ++ removeComments s ++ "\n"

151+ return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"

146

152

147 removeComments :: String -> String

153 removeComments :: String -> String

148 removeComments ('*' : '/' : s) = removeComments s

154 removeComments ('*' : '/' : s) = removeComments s

149 removeComments (c : s) = c : removeComments s

155 removeComments (c : s) = c : removeComments s

150

156

151 removeComments [] = []

157 removeComments [] = []

152− match (JSRaw js) = return js

158+ match (JSRaw _ js) = return $ emit js

153 match _ = mzero

159 match _ = mzero

154

160

155−string :: String -> String

161+string :: (Emit gen) => String -> gen

156−string s = '"' : concatMap encodeChar s ++ "\""

162+string s = emit $ '"' : concatMap encodeChar s ++ "\""

157 where

163 where

158 encodeChar :: Char -> String

164 encodeChar :: Char -> String

159 encodeChar '\b' = "\\b"

165 encodeChar '\b' = "\\b"

@@ -175,114 +181,121 @@ string s = '"' : concatMap encodeChar s ++ "\""

175 encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) ""

181 encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) ""

176 encodeChar c = [c]

182 encodeChar c = [c]

177

183

178−conditional :: Pattern PrinterState JS ((JS, JS), JS)

184+conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)

179conditional = mkPattern match

185conditional = mkPattern match

180 where

186 where

181− match (JSConditional cond th el) = Just ((th, el), cond)

187+ match (JSConditional ss cond th el) = Just ((ss, th, el), cond)

182 match _ = Nothing

188 match _ = Nothing

183

189

184−accessor :: Pattern PrinterState JS (String, JS)

190+accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS)

185accessor = mkPattern match

191accessor = mkPattern match

186 where

192 where

187− match (JSAccessor prop val) = Just (prop, val)

193+ match (JSAccessor _ prop val) = Just (emit prop, val)

188 match _ = Nothing

194 match _ = Nothing

189

195

190−indexer :: Pattern PrinterState JS (String, JS)

196+indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)

191indexer = mkPattern' match

197indexer = mkPattern' match

192 where

198 where

193− match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val

199+ match (JSIndexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val

200+

194 match _ = mzero

201 match _ = mzero

195

202

196−lam :: Pattern PrinterState JS ((Maybe String, [String]), JS)

203+lam :: Pattern PrinterState JS ((Maybe String, [String], Maybe SourceSpan), JS)

197lam = mkPattern match

204lam = mkPattern match

198 where

205 where

199− match (JSFunction name args ret) = Just ((name, args), ret)

206+ match (JSFunction ss name args ret) = Just ((name, args, ss), ret)

200 match _ = Nothing

207 match _ = Nothing

201

208

202−app :: Pattern PrinterState JS (String, JS)

209+app :: (Emit gen) => Pattern PrinterState JS (gen, JS)

203app = mkPattern' match

210app = mkPattern' match

204 where

211 where

205− match (JSApp val args) = do

212+ match (JSApp _ val args) = do

206 jss <- traverse prettyPrintJS' args

213 jss <- traverse prettyPrintJS' args

207− return (intercalate ", " jss, val)

214+ return (intercalate (emit ", ") jss, val)

208 match _ = mzero

215 match _ = mzero

209

216

210typeOf :: Pattern PrinterState JS ((), JS)

217typeOf :: Pattern PrinterState JS ((), JS)

211typeOf = mkPattern match

218typeOf = mkPattern match

212 where

219 where

213− match (JSTypeOf val) = Just ((), val)

220+ match (JSTypeOf _ val) = Just ((), val)

214 match _ = Nothing

221 match _ = Nothing

215

222

216instanceOf :: Pattern PrinterState JS (JS, JS)

223instanceOf :: Pattern PrinterState JS (JS, JS)

217instanceOf = mkPattern match

224instanceOf = mkPattern match

218 where

225 where

219− match (JSInstanceOf val ty) = Just (val, ty)

226+ match (JSInstanceOf _ val ty) = Just (val, ty)

220 match _ = Nothing

227 match _ = Nothing

221

228

222−unary' :: UnaryOperator -> (JS -> String) -> Operator PrinterState JS String

229+unary' :: (Emit gen) => UnaryOperator -> (JS -> String) -> Operator PrinterState JS gen

223−unary' op mkStr = Wrap match (++)

230+unary' op mkStr = Wrap match (<>)

224 where

231 where

225− match :: Pattern PrinterState JS (String, JS)

232+ match :: (Emit gen) => Pattern PrinterState JS (gen, JS)

226 match = mkPattern match'

233 match = mkPattern match'

227 where

234 where

228− match' (JSUnary op' val) | op' == op = Just (mkStr val, val)

235+ match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val)

229 match' _ = Nothing

236 match' _ = Nothing

230

237

231−unary :: UnaryOperator -> String -> Operator PrinterState JS String

238+unary :: (Emit gen) => UnaryOperator -> String -> Operator PrinterState JS gen

232unary op str = unary' op (const str)

239unary op str = unary' op (const str)

233

240

234−negateOperator :: Operator PrinterState JS String

241+negateOperator :: (Emit gen) => Operator PrinterState JS gen

235negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")

242negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")

236 where

243 where

237− isNegate (JSUnary Negate _) = True

244+ isNegate (JSUnary _ Negate _) = True

238 isNegate _ = False

245 isNegate _ = False

239

246

240−binary :: BinaryOperator -> String -> Operator PrinterState JS String

247+binary :: (Emit gen) => BinaryOperator -> String -> Operator PrinterState JS gen

241−binary op str = AssocL match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

248+binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " ++ str ++ " ") <> v2)

242 where

249 where

243 match :: Pattern PrinterState JS (JS, JS)

250 match :: Pattern PrinterState JS (JS, JS)

244 match = mkPattern match'

251 match = mkPattern match'

245 where

252 where

246− match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)

253+ match' (JSBinary _ op' v1 v2) | op' == op = Just (v1, v2)

247 match' _ = Nothing

254 match' _ = Nothing

248

255

249−prettyStatements :: [JS] -> StateT PrinterState Maybe String

256+prettyStatements :: (Emit gen) => [JS] -> StateT PrinterState Maybe gen

250prettyStatements sts = do

257prettyStatements sts = do

251 jss <- forM sts prettyPrintJS'

258 jss <- forM sts prettyPrintJS'

252 indentString <- currentIndent

259 indentString <- currentIndent

253− return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss

260+ return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss

254

261

255-- |

262-- |

256-- Generate a pretty-printed string representing a Javascript expression

263-- Generate a pretty-printed string representing a Javascript expression

257--

264--

258−prettyPrintJS1 :: JS -> String

265+prettyPrintJS1 :: (Emit gen) => JS -> gen

259prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

266prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

260

267

261-- |

268-- |

262-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

269-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

263--

270--

271+prettyPrintJSWithSourceMaps :: [JS] -> (String, [SMap])

272+prettyPrintJSWithSourceMaps js =

273+ let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js

274+ in (s, mp)

275+

264prettyPrintJS :: [JS] -> String

276prettyPrintJS :: [JS] -> String

265−prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements

277+prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . fmap runPlainString . flip evalStateT (PrinterState 0) . prettyStatements

266

278

267-- |

279-- |

268-- Generate an indented, pretty-printed string representing a Javascript expression

280-- Generate an indented, pretty-printed string representing a Javascript expression

269--

281--

270−prettyPrintJS' :: JS -> StateT PrinterState Maybe String

282+prettyPrintJS' :: (Emit gen) => JS -> StateT PrinterState Maybe gen

271prettyPrintJS' = A.runKleisli $ runPattern matchValue

283prettyPrintJS' = A.runKleisli $ runPattern matchValue

272 where

284 where

273− matchValue :: Pattern PrinterState JS String

285+ matchValue :: (Emit gen) => Pattern PrinterState JS gen

274− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

286+ matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)

275− operators :: OperatorTable PrinterState JS String

287+ operators :: (Emit gen) => OperatorTable PrinterState JS gen

276 operators =

288 operators =

277− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

289+ OperatorTable [ [ Wrap accessor $ \prop val -> val <> emit "." <> prop ]

278− , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

290+ , [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]

279− , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

291+ , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ]

280 , [ unary JSNew "new " ]

292 , [ unary JSNew "new " ]

281− , [ Wrap lam $ \(name, args) ret -> "function "

293+ , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>

294+ emit ("function "

282 ++ fromMaybe "" name

295 ++ fromMaybe "" name

283− ++ "(" ++ intercalate ", " args ++ ") "

296+ ++ "(" ++ intercalate ", " args ++ ") ")

284− ++ ret ]

297+ <> ret ]

285− , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]

298+ , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ]

286 , [ unary Not "!"

299 , [ unary Not "!"

287 , unary BitwiseNot "~"

300 , unary BitwiseNot "~"

288 , unary Positive "+"

301 , unary Positive "+"

@@ -299,7 +312,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

299 , binary LessThanOrEqualTo "<="

312 , binary LessThanOrEqualTo "<="

300 , binary GreaterThan ">"

313 , binary GreaterThan ">"

301 , binary GreaterThanOrEqualTo ">="

314 , binary GreaterThanOrEqualTo ">="

302− , AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]

315+ , AssocR instanceOf $ \v1 v2 -> v1 <> emit " instanceof " <> v2 ]

303 , [ binary EqualTo "==="

316 , [ binary EqualTo "==="

304 , binary NotEqualTo "!==" ]

317 , binary NotEqualTo "!==" ]

305 , [ binary BitwiseAnd "&" ]

318 , [ binary BitwiseAnd "&" ]

@@ -307,5 +320,5 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

307 , [ binary BitwiseOr "|" ]

320 , [ binary BitwiseOr "|" ]

308 , [ binary And "&&" ]

321 , [ binary And "&&" ]

309 , [ binary Or "||" ]

322 , [ binary Or "||" ]

310− , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]

323+ , [ Wrap conditional $ \(ss, th, el) cond -> cond <> addMapping' ss <> emit " ? " <> prettyPrintJS1 th <> addMapping' ss <> emit " : " <> prettyPrintJS1 el ]

311 ]

324 ]

src/Language/PureScript/Pretty/Values.hs−2

@@ -19,8 +19,6 @@ module Language.PureScript.Pretty.Values (

19 prettyPrintBinderAtom

20) where

22−import Data.List (intercalate)

23−

24import Control.Arrow (second)

22import Control.Arrow (second)

26import Language.PureScript.Crash

24import Language.PureScript.Crash

src/Language/PureScript/Renamer.hs+9−9

@@ -105,8 +105,8 @@ lookupIdent name = do

105findDeclIdents :: [Bind Ann] -> [Ident]

106findDeclIdents = concatMap go

107 where

108− go (NonRec ident _) = [ident]

108+ go (NonRec _ ident _) = [ident]

109− go (Rec ds) = map fst ds

109+ go (Rec ds) = map (snd . fst) ds

110

111-- |

112-- Renames within each declaration in a module.

@@ -128,19 +128,19 @@ renameInModules = map go

128-- another in the current scope.

129--

130renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann)

131−renameInDecl isTopLevel (NonRec name val) = do

131+renameInDecl isTopLevel (NonRec a name val) = do

132 name' <- if isTopLevel then return name else updateScope name

133− NonRec name' <$> renameInValue val

133+ NonRec a name' <$> renameInValue val

134renameInDecl isTopLevel (Rec ds) = do

135 ds' <- traverse updateNames ds

136 Rec <$> traverse updateValues ds'

137 where

138− updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)

138+ updateNames :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)

139− updateNames (name, val) = do

139+ updateNames ((a, name), val) = do

140 name' <- if isTopLevel then return name else updateScope name

141− return (name', val)

141+ return ((a, name'), val)

142− updateValues :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)

142+ updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)

143− updateValues (name, val) = (,) name <$> renameInValue val

143+ updateValues (aname, val) = (,) aname <$> renameInValue val

144

145-- |

146-- Renames within a value.

src/Language/PureScript/TypeChecker/Types.hs+6−3

@@ -297,7 +297,9 @@ infer' (TypedValue checkType val ty) = do

297 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

298 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

299 return $ TypedValue True val' ty'

300−infer' (PositionedValue pos _ val) = warnAndRethrowWithPosition pos $ infer' val

300+infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do

301+ TypedValue t v ty <- infer' val

302+ return $ TypedValue t (PositionedValue pos c v) ty

301infer' _ = internalError "Invalid argument to infer"

303infer' _ = internalError "Invalid argument to infer"

302

304

303inferLetBinding ::

305inferLetBinding ::

@@ -623,8 +625,9 @@ check' val kt@(KindedType ty kind) = do

623 checkTypeKind ty kind

625 checkTypeKind ty kind

624 val' <- check' val ty

626 val' <- check' val ty

625 return $ TypedValue True val' kt

627 return $ TypedValue True val' kt

626−check' (PositionedValue pos _ val) ty =

628+check' (PositionedValue pos c val) ty = warnAndRethrowWithPosition pos $ do

627− warnAndRethrowWithPosition pos $ check' val ty

629+ TypedValue t v ty' <- check' val ty

630+ return $ TypedValue t (PositionedValue pos c v) ty'

628check' val ty = do

631check' val ty = do

629 TypedValue _ val' ty' <- infer val

632 TypedValue _ val' ty' <- infer val

630 mt <- subsumes (Just val') ty' ty

633 mt <- subsumes (Just val') ty' ty

stack-lts-2.yaml+1

@@ -6,4 +6,5 @@ extra-deps:

6- bower-json-0.7.0.0

7- boxes-0.1.4

8- pattern-arrows-0.0.2

9+- sourcemap-0.1.6

9resolver: lts-2.22

10resolver: lts-2.22

stack-lts-3.yaml+2−1

@@ -1,5 +1,6 @@

1flags: {}

2packages:

3- '.'

4−extra-deps: []

4+extra-deps:

5+- sourcemap-0.1.6

5resolver: lts-3.6

6resolver: lts-3.6

stack-nightly.yaml+1

@@ -2,4 +2,5 @@ flags: {}

2packages:

3- '.'

4extra-deps:

5+- sourcemap-0.1.6

5resolver: nightly-2015-09-29

6resolver: nightly-2015-09-29