849459e · rowtype-yoga/purescript-native

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

Add Source Map support.

- Add sourcemaps license. Manually removed a few deletions - Use Emit typeclass, move JS sourcespans into each ctor - Remove sourcemaps from stackage build plans for travis, version is too old - Keep source positions for literals

commit849459eb97e17ea37540a0c8d9eb1b6021c99ed3 authorNicholas Wolverson <nicholas.wolverson@gmail.com> dateSun 21 Feb 2016, 13:06 (11 years ago) parent47d547d

31 files changed+830−538

compare with golang

unifiedsplit

.travis.yml+1−1

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

5151 - mkdir -p .cabal-sandbox

5252 - cabal sandbox init --sandbox .cabal-sandbox

5353 # 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

5555 - cabal install --only-dependencies --enable-tests

5656 - cabal install hpc-coveralls

5757 # 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

6363 safe

6464 scientific

6565 semigroups

66+ sourcemap

6667 split

6768 stm

6869 syb

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

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

15901591 POSSIBILITY OF SUCH DAMAGE.

15911592

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+

15921626split LICENSE file:

15931627

psc/Main.hs+6

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

177177jsonErrors = switch $

178178 long "json-errors"

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

180+sourceMaps :: Parser Bool

181+sourceMaps = switch $

182+ long "source-maps"

183+ <> help "Generate source maps"

184+

180185

181186options :: Parser P.Options

182187options = P.Options <$> noTco

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

186191 <*> verboseErrors

187192 <*> (not <$> comments)

188193 <*> requirePath

194+ <*> sourceMaps

189195

190196pscMakeOptions :: Parser PSCMakeOptions

191197pscMakeOptions = PSCMakeOptions <$> many inputFile

purescript.cabal+2−1

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

7979 process >= 1.2.0 && < 1.5,

8080 safe >= 0.3.9 && < 0.4,

8181 semigroups >= 0.16.2 && < 0.19,

82− parallel >= 3.2 && < 3.3

82+ parallel >= 3.2 && < 3.3,

83+ sourcemap >= 0.1.6

8384

8485 exposed-modules: Language.PureScript

8586 Language.PureScript.AST

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

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

5555 rethrow (addHint (ErrorInModule mn)) $ do

5656 let usedNames = concatMap getNames decls

5757 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

5959 let decls' = renameModules mnLookup decls

6060 jsDecls <- mapM bindToJs decls'

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

6262 F.traverse_ (F.traverse_ checkIntegers) optimized

6363 comments <- not <$> asks optionsNoComments

64− let strict = JSStringLiteral "use strict"

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

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

64+ let strict = JSStringLiteral Nothing "use strict"

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

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

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

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

6969 let standardExps = exps \\ foreignExps

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

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

7171 ++ 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']

7373

7474 where

7575

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

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

7878 --

7979 getNames :: Bind Ann -> [Ident]

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

81− getNames (Rec vals) = map fst vals

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

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

8282

8383 -- |

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

8585 -- with declaration names.

8686 --

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

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

8888 renameImports ids mns = go M.empty ids mns

8989 where

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

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

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

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

9292 let mni = Ident $ runModuleName mn'

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

9494 then let newName = freshModuleName 1 mn' used

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

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

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

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

9797 go acc _ [] = acc

9898

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

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

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

108108 -- to the alternative

109109 --

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

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

111111 importToJs mnLookup mn' = do

112112 path <- asks optionsRequirePath

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

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

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

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

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

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

116116

117117 -- |

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

119119 -- the collision-avoiding renamed module imports.

120120 --

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

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

122122 renameModules mnLookup binds =

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

124124 in map f binds

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

131131 goBinder b = b

132132 renameQual :: Qualified a -> Qualified a

133133 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

135135 in Qualified (Just mnSafe) a

136136 renameQual q = q

137137

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

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

140140 --

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

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

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

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

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

144144

145145 -- |

146146 -- 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_ =

148148 --

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

150150 --

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

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

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

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

153153 withoutComment <- asks optionsNoComments

154154 if withoutComment

155− then nonRecToJS i (modifyAnn removeComments e)

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

157− nonRecToJS ident val = do

155+ then nonRecToJS a i (modifyAnn removeComments e)

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

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

158158 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

160168

161169 -- |

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

163171 -- PureScript identifier.

164172 --

165173 var :: Ident -> JS

166− var = JSVar . identToJs

174+ var = JSVar Nothing . identToJs

167175

168176 -- |

169177 -- 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_ =

172180 --

173181 accessor :: Ident -> JS -> JS

174182 accessor (Ident prop) = accessorString prop

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

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

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

177185

178186 accessorString :: String -> JS -> JS

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

180− | otherwise = JSAccessor prop

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

188+ | otherwise = JSAccessor Nothing prop

181189

182190 -- |

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

184192 --

185193 valueToJs :: Expr Ann -> m JS

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

194+ valueToJs e =

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

196+ withPos ss =<< valueToJs' e

197+

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

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

187200 maybe id rethrowWithPosition pos $ literalToValueJS l

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

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

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

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

192− valueToJs (Accessor _ prop val) =

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

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

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

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

205+ valueToJs' (Accessor _ prop val) =

193206 accessorString prop <$> valueToJs val

194− valueToJs (ObjectUpdate _ o ps) = do

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

195208 obj <- valueToJs o

196209 sts <- mapM (sndM valueToJs) ps

197210 extendObj obj sts

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

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

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

201214 where

202215 unAbs :: Expr Ann -> [Ident]

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

204217 unAbs _ = []

205218 assign :: Ident -> JS

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

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

207220 (var name)

208− valueToJs (Abs _ arg val) = do

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

209222 ret <- valueToJs val

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

211− valueToJs e@App{} = do

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

224+ valueToJs' e@App{} = do

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

213226 args' <- mapM valueToJs args

214227 case f of

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

216229 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'

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

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

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

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

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

221234 where

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

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

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

226239 return $ if mn' == mn

227240 then foreignIdent ident

228241 else varToJs qi

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

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

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

231− valueToJs (Var _ ident) =

232− return $ varToJs ident

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

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

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

234246 vals <- mapM valueToJs values

235247 bindersToJs maybeSpan binders vals

236− valueToJs (Let _ ds val) = do

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

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

238250 ret <- valueToJs val

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

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

241− return $ JSVariableIntroduction ctor (Just $

242− JSObjectLiteral [("create",

243− JSFunction Nothing ["value"]

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

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

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

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

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

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

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

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

253+ return $ JSVariableIntroduction Nothing ctor (Just $

254+ JSObjectLiteral Nothing [("create",

255+ JSFunction Nothing Nothing ["value"]

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

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

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

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

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

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

250262 let constructor =

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

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

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

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

253265 createFn =

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

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

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

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

256268 in return $ iife ctor [ constructor

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

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

258270 ]

259271

260272 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])) []

262274

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

271283

272284 -- |

273285 -- Shallow copy an object.

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

277289 newObj <- freshName

278290 key <- freshName

279291 let

280− jsKey = JSVar key

281− jsNewObj = JSVar newObj

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

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

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

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

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

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

292+ jsKey = JSVar Nothing key

293+ jsNewObj = JSVar Nothing newObj

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

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

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

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

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

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

288300 extend = map stToAssign sts

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

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

290302

291303 -- |

292304 -- 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_ =

301313 -- variable that may have a qualified name.

302314 --

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

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

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

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

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

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

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

307319

308320 foreignIdent :: Ident -> JS

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

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

310322

311323 -- |

312324 -- 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_ =

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

316328 bindersToJs maybeSpan binders vals = do

317329 valNames <- replicateM (length vals) freshName

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

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

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

320332 ret <- guardsToJs result

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

323335 []

324336 where

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

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

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

331343

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

334346

335347 failedPatternMessage :: String

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

337349

338350 valueError :: String -> JS -> JS

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

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

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

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

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

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

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

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

343355

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

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

346358 cond' <- valueToJs cond

347359 done <- valueToJs val

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

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

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

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

350367

351368 -- |

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

353370 -- binder.

354371 --

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

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

357− binderToJs varName done (LiteralBinder _ l) =

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

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

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

358375 literalToBinderJS varName done l

359− binderToJs varName done (VarBinder _ ident) =

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

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

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

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

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

362379 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

364381 js <- go (zip fields bs) done

365382 return $ case ctorType of

366383 ProductType -> js

367384 SumType ->

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

369− (JSBlock js)

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

386+ (JSBlock Nothing js)

370387 Nothing]

371388 where

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

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

375392 argVar <- freshName

376393 done'' <- go remain done'

377394 js <- binderToJs argVar done'' binder

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

379− binderToJs _ _ ConstructorBinder{} =

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

396+ binderToJs' _ _ ConstructorBinder{} =

380397 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"

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

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

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

384401

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

386403 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]

388405 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]

390407 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]

392409 literalToBinderJS varName done (BooleanLiteral True) =

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

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

394411 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]

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

397414 where

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

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

401418 propVar <- freshName

402419 done'' <- go done' bs'

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

405422 literalToBinderJS varName done (ArrayLiteral bs) = do

406423 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]

408425 where

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

410427 go done' _ [] = return done'

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

412429 elVar <- freshName

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

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

416433

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

418435 checkIntegers :: JS -> m ()

419436 checkIntegers = void . everywhereOnJSTopDownM go

420437 where

421438 go :: JS -> m JS

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

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

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

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

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

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

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

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

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

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

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

430447 let minInt = -2147483648

431448 maxInt = 2147483647

432449 in if i < minInt || i > maxInt

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

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

1010

1111import Language.PureScript.Comments

1212import Language.PureScript.Traversals

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

1314

1415-- |

1516-- Built-in unary operators

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

126127 -- |

127128 -- A numeric literal

128129 --

129− = JSNumericLiteral (Either Integer Double)

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

130131 -- |

131132 -- A string literal

132133 --

133− | JSStringLiteral String

134+ | JSStringLiteral (Maybe SourceSpan) String

134135 -- |

135136 -- A boolean literal

136137 --

137− | JSBooleanLiteral Bool

138+ | JSBooleanLiteral (Maybe SourceSpan) Bool

138139 -- |

139140 -- A unary operator application

140141 --

141− | JSUnary UnaryOperator JS

142+ | JSUnary (Maybe SourceSpan) UnaryOperator JS

142143 -- |

143144 -- A binary operator application

144145 --

145− | JSBinary BinaryOperator JS JS

146+ | JSBinary (Maybe SourceSpan) BinaryOperator JS JS

146147 -- |

147148 -- An array literal

148149 --

149− | JSArrayLiteral [JS]

150+ | JSArrayLiteral (Maybe SourceSpan) [JS]

150151 -- |

151152 -- An array indexer expression

152153 --

153− | JSIndexer JS JS

154+ | JSIndexer (Maybe SourceSpan) JS JS

154155 -- |

155156 -- An object literal

156157 --

157− | JSObjectLiteral [(String, JS)]

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

158159 -- |

159160 -- An object property accessor expression

160161 --

161− | JSAccessor String JS

162+ | JSAccessor (Maybe SourceSpan) String JS

162163 -- |

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

164165 --

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

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

166167 -- |

167168 -- Function application

168169 --

169− | JSApp JS [JS]

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

170171 -- |

171172 -- Variable

172173 --

173− | JSVar String

174+ | JSVar (Maybe SourceSpan) String

174175 -- |

175176 -- Conditional expression

176177 --

177− | JSConditional JS JS JS

178+ | JSConditional (Maybe SourceSpan) JS JS JS

178179 -- |

179180 -- A block of expressions in braces

180181 --

181− | JSBlock [JS]

182+ | JSBlock (Maybe SourceSpan) [JS]

182183 -- |

183184 -- A variable introduction and optional initialization

184185 --

185− | JSVariableIntroduction String (Maybe JS)

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

186187 -- |

187188 -- A variable assignment

188189 --

189− | JSAssignment JS JS

190+ | JSAssignment (Maybe SourceSpan) JS JS

190191 -- |

191192 -- While loop

192193 --

193− | JSWhile JS JS

194+ | JSWhile (Maybe SourceSpan) JS JS

194195 -- |

195196 -- For loop

196197 --

197− | JSFor String JS JS JS

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

198199 -- |

199200 -- ForIn loop

200201 --

201− | JSForIn String JS JS

202+ | JSForIn (Maybe SourceSpan) String JS JS

202203 -- |

203204 -- If-then-else statement

204205 --

205− | JSIfElse JS JS (Maybe JS)

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

206207 -- |

207208 -- Return statement

208209 --

209− | JSReturn JS

210+ | JSReturn (Maybe SourceSpan) JS

210211 -- |

211212 -- Throw statement

212213 --

213− | JSThrow JS

214+ | JSThrow (Maybe SourceSpan) JS

214215 -- |

215216 -- Type-Of operator

216217 --

217− | JSTypeOf JS

218+ | JSTypeOf (Maybe SourceSpan) JS

218219 -- |

219220 -- InstanceOf test

220221 --

221− | JSInstanceOf JS JS

222+ | JSInstanceOf (Maybe SourceSpan) JS JS

222223 -- |

223224 -- Labelled statement

224225 --

225− | JSLabel String JS

226+ | JSLabel (Maybe SourceSpan) String JS

226227 -- |

227228 -- Break statement

228229 --

229− | JSBreak String

230+ | JSBreak (Maybe SourceSpan) String

230231 -- |

231232 -- Continue statement

232233 --

233− | JSContinue String

234+ | JSContinue (Maybe SourceSpan) String

234235 -- |

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

236237 --

237− | JSRaw String

238+ | JSRaw (Maybe SourceSpan) String

238239 -- |

239240 -- Commented Javascript

240241 --

241− | JSComment [Comment] JS

242− deriving (Show, Read, Eq)

242+ | JSComment (Maybe SourceSpan) [Comment] JS 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

243314

244315--

245316-- Traversals

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

249320everywhereOnJS f = go

250321 where

251322 go :: JS -> JS

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

274345 go other = f other

275346

276347everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS

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

280351everywhereOnJSTopDownM f = f >=> go

281352 where

282353 f' = f >=> go

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

305376 go other = f other

306377

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

308379everythingOnJS (<>) f = go

309380 where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

333404 go other = f other

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

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

5353 opts <- ask

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

5555 [ inlineCommonValues

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

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

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

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

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

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

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

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

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

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

6161 , inlineCommonOperators

6262 ]) js

6363 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

2727collapseNestedBlocks = everywhereOnJS collapse

2828 where

2929 collapse :: JS -> JS

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

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

3131 collapse js = js

3232 go :: JS -> [JS]

33− go (JSBlock sts) = sts

33+ go (JSBlock _ sts) = sts

3434 go s = [s]

3535

3636collapseNestedIfs :: JS -> JS

3737collapseNestedIfs = everywhereOnJS collapse

3838 where

3939 collapse :: JS -> JS

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

41− JSIfElse (JSBinary And cond1 cond2) body Nothing

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

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

4242 collapse js = js

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

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

1414replaceIdent :: String -> JS -> JS -> JS

1515replaceIdent var1 js = everywhereOnJS replace

1616 where

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

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

1818 replace other = other

1919

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

2121replaceIdents vars = everywhereOnJS replace

2222 where

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

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

2424 replace other = other

2525

2626isReassigned :: String -> JS -> Bool

2727isReassigned var1 = everythingOnJS (||) check

2828 where

2929 check :: JS -> Bool

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

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

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

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

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

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

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

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

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

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

3535 check _ = False

3636

3737isRebound :: JS -> JS -> Bool

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

3939 where

40− variablesOf (JSVar var) = [var]

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

4141 variablesOf _ = []

4242

4343isUsed :: String -> JS -> Bool

4444isUsed var1 = everythingOnJS (||) check

4545 where

4646 check :: JS -> Bool

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

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

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

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

4949 check _ = False

5050

5151targetVariable :: JS -> String

52−targetVariable (JSVar var) = var

53−targetVariable (JSAccessor _ tgt) = targetVariable tgt

54−targetVariable (JSIndexer _ tgt) = targetVariable tgt

52+targetVariable (JSVar _ var) = var

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

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

5555targetVariable _ = internalError "Invalid argument to targetVariable"

5656

5757isUpdated :: String -> JS -> Bool

5858isUpdated var1 = everythingOnJS (||) check

5959 where

6060 check :: JS -> Bool

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

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

6262 check _ = False

6363

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

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

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

6666removeFromBlock _ js = js

6767

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

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

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

7171isFn _ _ = False

7272

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

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

7575

7676isDict :: (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

7878isDict _ _ = False

7979

8080isDict' :: [(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

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

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

3131shouldInline :: JS -> Bool

32−shouldInline (JSVar _) = True

33−shouldInline (JSNumericLiteral _) = True

34−shouldInline (JSStringLiteral _) = True

35−shouldInline (JSBooleanLiteral _) = True

36−shouldInline (JSAccessor _ val) = shouldInline val

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

32+shouldInline (JSVar _ _) = True

33+shouldInline (JSNumericLiteral _ _) = True

34+shouldInline (JSStringLiteral _ _) = True

35+shouldInline (JSBooleanLiteral _ _) = True

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

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

3838shouldInline _ = False

3939

4040etaConvert :: JS -> JS

4141etaConvert = everywhereOnJS convert

4242 where

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

4545 | all shouldInline args &&

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

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

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

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

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

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

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

5050 convert js = js

5151

5252unThunk :: JS -> JS

5353unThunk = everywhereOnJS convert

5454 where

5555 convert :: JS -> JS

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

57− convert (JSBlock jss) =

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

57+ convert (JSBlock ss jss) =

5858 case last jss of

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

60− _ -> JSBlock jss

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

60+ _ -> JSBlock ss jss

6161 convert js = js

6262

6363evaluateIifes :: JS -> JS

6464evaluateIifes = everywhereOnJS convert

6565 where

6666 convert :: JS -> JS

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

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

6868 convert js = js

6969

7070inlineVariables :: JS -> JS

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

7272 where

7373 go :: [JS] -> [JS]

7474 go [] = []

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

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

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

7777 go (map (replaceIdent var js) sts)

7878 go (s:sts) = s : go sts

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

8181inlineCommonValues = everywhereOnJS convert

8282 where

8383 convert :: JS -> JS

84− convert (JSApp fn [dict])

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

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

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

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

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

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

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

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

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

84+ convert (JSApp ss fn [dict])

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

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

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

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

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

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

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

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

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

9494 convert other = other

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

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

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

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

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

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

104104

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

106106inlineOperator (m, op) f = everywhereOnJS convert

107107 where

108108 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

110110 convert other = other

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

112− isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && 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'

113113 isOp _ = False

114114

115115inlineCommonOperators :: JS -> JS

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

177177 binary dict fns op = everywhereOnJS convert

178178 where

179179 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

181181 convert other = other

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

183183 binary' moduleName opString op = everywhereOnJS convert

184184 where

185185 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

187187 convert other = other

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

189189 unary dicts fns op = everywhereOnJS convert

190190 where

191191 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

193193 convert other = other

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

195195 unary' moduleName fnName op = everywhereOnJS convert

196196 where

197197 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

199199 convert other = other

200200 mkFn :: Int -> JS -> JS

201201 mkFn 0 = everywhereOnJS convert

202202 where

203203 convert :: JS -> JS

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

205− JSFunction Nothing [] (JSBlock js)

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

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

206206 convert other = other

207207 mkFn n = everywhereOnJS convert

208208 where

209209 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 =

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

213213 Nothing -> orig

214214 convert other = other

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

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

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

218218 collectArgs _ _ _ = Nothing

219219

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

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)

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)

223223 isNFn _ _ _ = False

224224

225225 runFn :: Int -> JS -> JS

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

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

230230

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

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

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

234234 go _ _ _ = Nothing

235235

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

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

239239inlineFnComposition = everywhereOnJSTopDownM convert

240240 where

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

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

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

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

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

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

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

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

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

246246 | isFnCompose dict' fn = do

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

249249 | isFnComposeFlipped dict' fn = do

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

252252 convert other = return other

253253 isFnCompose :: JS -> JS -> Bool

254254 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

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

4141 convert :: JS -> JS

4242 -- Desugar pure & return

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

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

4444 -- Desugar >>

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

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

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

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

4747 -- Desugar >>=

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

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

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

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

5050 -- Desugar untilE

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

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

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

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

5353 -- Desugar whileE

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

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

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

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

5656 convert other = other

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

5959 isBind _ = False

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

6262 isPure _ = False

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

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

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

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

6767 -- 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'

6969 isEffFunc _ _ = False

7070

7171 -- Remove __do function applications which remain after desugaring

7272 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

7474 undo other = other

7575

7676 applyReturns :: JS -> JS

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

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

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

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

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

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

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

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

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

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

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

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

8383 applyReturns other = other

8484

8585-- |

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

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

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

9393 -- 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 =

9595 let refs = nub . findSTRefsIn $ arg

9696 usages = findAllSTUsagesIn arg

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

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

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

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

103103 -- agg(ressive) parameter.

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

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

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

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

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

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

110− convert agg (JSApp (JSApp (JSApp 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])

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

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

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

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

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

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

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

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

112112 convert _ other = other

113113 -- 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'

115115 isSTFunc _ _ = False

116116 -- Find all ST Refs initialized in this block

117117 findSTRefsIn = everythingOnJS (++) isSTRef

118118 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]

120120 isSTRef _ = []

121121 -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef

122122 findAllSTUsagesIn = everythingOnJS (++) isSTUsage

123123 where

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]

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]

126126 isSTUsage _ = []

127127 -- Find all uses of a variable

128128 appearingIn ref = everythingOnJS (++) isVar

129129 where

130− isVar e@(JSVar v) | v == ref = [e]

130+ isVar e@(JSVar _ v) | v == ref = [e]

131131 isVar _ = []

132132 -- Convert a JS value to a String if it is a JSVar

133− toVar (JSVar v) = Just v

133+ toVar (JSVar _ v) = Just v

134134 toVar _ = Nothing

src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs+33−31

@@ -40,7 +40,7 @@ tco' = everywhereOnJS convert

4040 copyVar arg = "__copy_" ++ arg

4141

4242 convert :: JS -> JS

43− convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =

43+ convert js@(JSVariableIntroduction ss name (Just fn@JSFunction {})) =

4444 let

4545 (argss, body', replace) = collectAllFunctionArgs [] id fn

4646 in case () of

@@ -48,19 +48,19 @@ tco' = everywhereOnJS convert

4848 let

4949 allArgs = concat $ reverse argss

5050 in

51− JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))

51+ JSVariableIntroduction ss name (Just (replace (toLoop name allArgs body')))

5252 | otherwise -> js

5353 convert js = js

5454

5555 collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)

56− collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =

57− collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body

58− collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =

59− (args : allArgs, body, f . JSFunction ident (map copyVar args))

60− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =

61− collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body

62− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =

63− (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))

56+ collectAllFunctionArgs allArgs f (JSFunction s1 ident args (JSBlock s2 (body@(JSReturn _ _):_))) =

57+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction s1 ident (map copyVar args) (JSBlock s2 [b]))) body

58+ collectAllFunctionArgs allArgs f (JSFunction ss ident args body@(JSBlock _ _)) =

59+ (args : allArgs, body, f . JSFunction ss ident (map copyVar args))

60+ collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args (JSBlock s3 [body]))) =

61+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn s1 (JSFunction s2 ident (map copyVar args) (JSBlock s3 [b])))) body

62+ collectAllFunctionArgs allArgs f (JSReturn s1 (JSFunction s2 ident args body@(JSBlock _ _))) =

63+ (args : allArgs, body, f . JSReturn s1 . JSFunction s2 ident (map copyVar args))

6464 collectAllFunctionArgs allArgs f body = (allArgs, body, f)

6565

6666 isTailCall :: String -> JS -> Bool

@@ -77,51 +77,53 @@ tco' = everywhereOnJS convert

7777 && numSelfCallWithFnArgs == 0

7878 where

7979 countSelfCalls :: JS -> Int

80− countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1

80+ countSelfCalls (JSApp _ (JSVar _ ident') _) | ident == ident' = 1

8181 countSelfCalls _ = 0

82−

82+

8383 countSelfCallsInTailPosition :: JS -> Int

84− countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1

84+ countSelfCallsInTailPosition (JSReturn _ ret) | isSelfCall ident ret = 1

8585 countSelfCallsInTailPosition _ = 0

86−

86+

8787 countSelfCallsUnderFunctions :: JS -> Int

88− countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'

88+ countSelfCallsUnderFunctions (JSFunction _ _ _ js') = everythingOnJS (+) countSelfCalls js'

8989 countSelfCallsUnderFunctions _ = 0

90−

90+

9191 countSelfCallsWithFnArgs :: JS -> Int

9292 countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0

9393

9494 toLoop :: String -> [String] -> JS -> JS

95− toLoop ident allArgs js = JSBlock $

96− map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++

97− [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]

95+ toLoop ident allArgs js = JSBlock rootSS $

96+ map (\arg -> JSVariableIntroduction rootSS arg (Just (JSVar rootSS (copyVar arg)))) allArgs ++

97+ [ JSLabel rootSS tcoLabel $ JSWhile rootSS (JSBooleanLiteral rootSS True) (JSBlock rootSS [ everywhereOnJS loopify js ]) ]

9898 where

99+ rootSS = Nothing

100+

99101 loopify :: JS -> JS

100− loopify (JSReturn ret) | isSelfCall ident ret =

102+ loopify (JSReturn ss ret) | isSelfCall ident ret =

101103 let

102104 allArgumentValues = concat $ collectSelfCallArgs [] ret

103105 in

104− JSBlock $ zipWith (\val arg ->

105− JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs

106+ JSBlock ss $ zipWith (\val arg ->

107+ JSVariableIntroduction ss (tcoVar arg) (Just val)) allArgumentValues allArgs

106108 ++ map (\arg ->

107− JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs

108− ++ [ JSContinue tcoLabel ]

109+ JSAssignment ss (JSVar ss arg) (JSVar ss (tcoVar arg))) allArgs

110+ ++ [ JSContinue ss tcoLabel ]

109111 loopify other = other

110112 collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]

111− collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn

113+ collectSelfCallArgs allArgumentValues (JSApp _ fn args') = collectSelfCallArgs (args' : allArgumentValues) fn

112114 collectSelfCallArgs allArgumentValues _ = allArgumentValues

113115

114116 isSelfCall :: String -> JS -> Bool

115− isSelfCall ident (JSApp (JSVar ident') _) = ident == ident'

116− isSelfCall ident (JSApp fn _) = isSelfCall ident fn

117+ isSelfCall ident (JSApp _ (JSVar _ ident') _) = ident == ident'

118+ isSelfCall ident (JSApp _ fn _) = isSelfCall ident fn

117119 isSelfCall _ _ = False

118120

119121 isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool

120− isSelfCallWithFnArgs ident (JSVar ident') args | ident == ident' && any hasFunction args = True

121− isSelfCallWithFnArgs ident (JSApp fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)

122+ isSelfCallWithFnArgs ident (JSVar _ ident') args | ident == ident' && any hasFunction args = True

123+ isSelfCallWithFnArgs ident (JSApp _ fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)

122124 isSelfCallWithFnArgs _ _ _ = False

123−

124− hasFunction :: JS -> Bool

125+

126+ hasFunction :: JS -> Bool

125127 hasFunction = getAny . everythingOnJS mappend (Any . isFunction)

126128 where

127129 isFunction JSFunction{} = True

src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs+3−3

@@ -30,17 +30,17 @@ removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)

3030 go :: [JS] -> [JS]

3131 go jss | not (any isJSReturn jss) = jss

3232 | otherwise = let (body, ret : _) = break isJSReturn jss in body ++ [ret]

33− isJSReturn (JSReturn _) = True

33+ isJSReturn (JSReturn _ _) = True

3434 isJSReturn _ = False

3535

3636removeUnusedArg :: JS -> JS

3737removeUnusedArg = everywhereOnJS convert

3838 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

4040 convert js = js

4141

4242removeUndefinedApp :: JS -> JS

4343removeUndefinedApp = everywhereOnJS convert

4444 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 []

4646 convert js = js

src/Language/PureScript/CoreFn/Binders.hs+9−2

@@ -31,5 +31,12 @@ data Binder a

3131 -- |

3232 -- A binder which binds its input to an identifier

3333 --

34− | NamedBinder a Ident (Binder a)

35− deriving (Show, Read, Functor)

34+ | NamedBinder a Ident (Binder a) 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 @@

11module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where

3+import Prelude ()

4+import Prelude.Compat

37import Data.Function (on)

48import Data.List (sort, sortBy, nub)

59import Data.Maybe (mapMaybe)

@@ -30,38 +34,52 @@ moduleToCoreFn :: Environment -> A.Module -> Module Ann

3034moduleToCoreFn _ (A.Module _ _ _ _ Nothing) =

3135 internalError "Module exports were not elaborated before moduleToCoreFn"

3236moduleToCoreFn 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

3439 exps' = nub $ concatMap exportToCoreFn exps

3540 externs = nub $ mapMaybe externToCoreFn decls

3641 decls' = concatMap (declToCoreFn Nothing []) decls

37− in Module coms mn imports exps' externs decls'

42+ in Module coms mn imports' exps' externs decls'

3843

3944 where

4045

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+

4159 -- |

4260 -- Desugars member declarations from AST to CoreFn representation.

4361 --

4462 declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]

4563 declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =

46− [NonRec (properToIdent ctor) $

64+ [NonRec (ssA ss) (properToIdent ctor) $

4765 Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]

4866 declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =

4967 error $ "Found newtype with multiple constructors: " ++ show d

5068 declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =

5169 flip map ctors $ \(ctor, _) ->

5270 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

5472 declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds

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

5775 declToCoreFn ss com (A.FixityDeclaration _ name (Just alias)) =

5876 let meta = either getValueMeta (Just . getConstructorMeta) alias

5977 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')]

6179 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]

6381 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]

6583 declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =

6684 declToCoreFn (Just ss) (com ++ com1) d

6785 declToCoreFn _ _ _ = []

@@ -203,35 +221,36 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

203221-- ensure instances are imported from any module that is referenced by the

204222-- current module, not just from those that are imported explicitly (#667).

205223--

206−findQualModules :: [A.Declaration] -> [ModuleName]

224+findQualModules :: [A.Declaration] -> [(Ann, ModuleName)]

207225findQualModules decls =

208226 let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const [])

209227 in f `concatMap` decls

210228 where

211− fqDecls :: A.Declaration -> [ModuleName]

229+ fqDecls :: A.Declaration -> [(Ann, ModuleName)]

212230 fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual q

213231 fqDecls (A.FixityDeclaration _ _ (Just eq)) = either getQual getQual eq

214232 fqDecls _ = []

215233

216− fqValues :: A.Expr -> [ModuleName]

234+ fqValues :: A.Expr -> [(Ann, ModuleName)]

217235 fqValues (A.Var q) = getQual q

218236 fqValues (A.Constructor q) = getQual q

219237 fqValues _ = []

220238

221− fqBinders :: A.Binder -> [ModuleName]

239+ fqBinders :: A.Binder -> [(Ann, ModuleName)]

222240 fqBinders (A.ConstructorBinder q _) = getQual q

223241 fqBinders _ = []

224242

225− getQual :: Qualified a -> [ModuleName]

226− getQual (Qualified (Just mn) _) = [mn]

243+ getQual :: Qualified a -> [(Ann, ModuleName)]

244+ getQual (Qualified (Just mn) _) = [(nullAnn, mn)]

227245 getQual _ = []

228246

229247-- |

230248-- Desugars import declarations from AST to CoreFn representation.

231249--

232−importToCoreFn :: A.Declaration -> Maybe ModuleName

233−importToCoreFn (A.ImportDeclaration name _ _ _) = Just name

234−importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d

250+importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName)

251+importToCoreFn (A.ImportDeclaration name _ _ _) = Just (nullAnn, name)

252+importToCoreFn (A.PositionedDeclaration ss _ d) =

253+ ((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d

235254importToCoreFn _ = Nothing

236255

237256-- |

src/Language/PureScript/CoreFn/Expr.hs+3−5

@@ -60,12 +60,11 @@ data Bind a

6060 -- |

6161 -- Non-recursive binding for a single value

6262 --

63− = NonRec Ident (Expr a)

63+ = NonRec a Ident (Expr a)

6464 -- |

6565 -- Mutually recursive binding group for several values

6666 --

67− | Rec [(Ident, Expr a)]

68− deriving (Show, Read, Functor)

67+ | Rec [((a, Ident), Expr a)] deriving (Show, Read, Functor)

6968

7069-- |

7170-- A guard is just a boolean-valued expression that appears alongside a set of binders

@@ -84,8 +83,7 @@ data CaseAlternative a = CaseAlternative

8483 -- The result expression or a collect of guarded expressions

8584 --

8685 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

87− }

88− deriving (Show, Read)

86+ } deriving (Show, Read)

8987

9088instance Functor CaseAlternative where

9189

src/Language/PureScript/CoreFn/Meta.hs+2−4

@@ -24,8 +24,7 @@ data Meta

2424 -- |

2525 -- The contained reference is for a foreign member

2626 --

27− | IsForeign

28− deriving (Show, Read)

27+ | IsForeign deriving (Show, Read, Eq)

2928

3029-- |

3130-- Data constructor metadata

@@ -38,5 +37,4 @@ data ConstructorType

3837 -- |

3938 -- The constructor is for a type with multiple construcors

4039 --

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

2222data Module a = Module

2323 { moduleComments :: [Comment]

2424 , moduleName :: ModuleName

25− , moduleImports :: [ModuleName]

25+ , moduleImports :: [(a, ModuleName)]

2626 , moduleExports :: [Ident]

2727 , moduleForeign :: [ForeignDecl]

2828 , moduleDecls :: [Bind a]

src/Language/PureScript/CoreFn/Traversals.hs+2−2

@@ -26,7 +26,7 @@ everywhereOnValues :: (Bind a -> Bind a) ->

2626 (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)

2727everywhereOnValues f g h = (f', g', h')

2828 where

29− f' (NonRec name e) = f (NonRec name (g' e))

29+ f' (NonRec a name e) = f (NonRec a name (g' e))

3030 f' (Rec es) = f (Rec (map (second g') es))

3131

3232 g' (Literal ann e) = g (Literal ann (handleLiteral g' e))

@@ -61,7 +61,7 @@ everythingOnValues :: (r -> r -> r) ->

6161 (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)

6262everythingOnValues (<>) f g h i = (f', g', h', i')

6363 where

64− f' b@(NonRec _ e) = f b <> g' e

64+ f' b@(NonRec _ _ e) = f b <> g' e

6565 f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)

6666

6767 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(..))

3131import Control.Monad.Trans.Class (MonadTrans(..))

3232import Control.Monad.Trans.Except

3333import Control.Monad.IO.Class

34−import Control.Monad.Reader (MonadReader(..), ReaderT(..))

34+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)

3535import Control.Monad.Logger

3636import Control.Monad.Supply

3737import Control.Monad.Base (MonadBase(..))

@@ -52,9 +52,12 @@ import qualified Data.ByteString.UTF8 as BU8

5252import qualified Data.Set as S

5353import qualified Data.Map as M

5454

55+import SourceMap.Types

56+import SourceMap

57+

5558import System.Directory

56− (doesFileExist, getModificationTime, createDirectoryIfMissing)

57−import System.FilePath ((</>), takeDirectory)

59+ (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)

60+import System.FilePath ((</>), takeDirectory, makeRelative, splitPath)

5861import System.IO.Error (tryIOError)

5962import System.IO.UTF8 (readUTF8File, writeUTF8File)

6063

@@ -68,6 +71,7 @@ import Language.PureScript.ModuleDependencies

6871import Language.PureScript.Names

6972import Language.PureScript.Options

7073import Language.PureScript.Pretty

74+import Language.PureScript.Pretty.Common(SMap(..))

7175import Language.PureScript.Renamer

7276import Language.PureScript.Sugar

7377import Language.PureScript.TypeChecker

@@ -324,20 +328,51 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

324328 | not $ requiresForeign m -> do

325329 tell $ errorMessage $ UnnecessaryFFIModule mn path

326330 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"]

328332 Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn

329333 | 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, [])

331338 let filePath = runModuleName mn

332339 jsFile = outputDir </> filePath </> "index.js"

340+ mapFile = outputDir </> filePath </> "index.js.map"

333341 externsFile = outputDir </> filePath </> "externs.json"

334342 foreignFile = outputDir </> filePath </> "foreign.js"

335343 prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]

336344 js = unlines $ map ("// " ++) prefix ++ [pjs]

345+ mapRef = if sourceMaps then "//# sourceMappingURL=index.js.map\n" else ""

337346 lift $ do

338− writeTextFile jsFile (fromString js)

347+ writeTextFile jsFile (fromString $ js ++ mapRef)

339348 for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)

340349 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 }

341376

342377 requiresForeign :: CF.Module a -> Bool

343378 requiresForeign = not . null . CF.moduleForeign

src/Language/PureScript/Options.hs+4−1

@@ -41,9 +41,12 @@ data Options = Options {

4141 -- |

4242 -- The path to prepend to require statements

4343 , optionsRequirePath :: Maybe FilePath

44+ -- |

45+ -- Generate soure maps

46+ , optionsSourceMaps :: Bool

4447 } deriving Show

4548

4649-- |

4750-- Default make options

4851defaultOptions :: 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

374374 return $ Let ds result

375375

376376parseValueAtom :: TokenParser Expr

377−parseValueAtom = P.choice

377+parseValueAtom = withSourceSpan PositionedValue $ P.choice

378378 [ parseAnonymousArgument

379379 , parseNumericLiteral

380380 , parseCharLiteral

src/Language/PureScript/Pretty.hs−3

@@ -27,6 +27,3 @@ import Language.PureScript.Pretty.Kinds as P

2727import Language.PureScript.Pretty.Values as P

2828import Language.PureScript.Pretty.Types as P

2929import Language.PureScript.Pretty.JS as P

30−

31−

32−

src/Language/PureScript/Pretty/Common.hs+96−9

@@ -13,12 +13,18 @@

1313--

1414-----------------------------------------------------------------------------

1515

16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17+

1618module Language.PureScript.Pretty.Common where

1719

18−import Control.Monad.State

19−import Data.List (intercalate)

20+import Prelude ()

21+import Prelude.Compat

22+

23+import Control.Monad.State (StateT, modify, get)

24+import Data.List (elemIndices, intersperse)

2025

2126import Language.PureScript.Parser.Lexer (reservedPsNames, isSymbolChar)

27+import Language.PureScript.AST (SourcePos(..), SourceSpan(..))

2228

2329import Text.PrettyPrint.Boxes

2430

@@ -26,9 +32,90 @@ import Text.PrettyPrint.Boxes

2632-- Wrap a string in parentheses

2733--

2834parens :: 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 }

30116

31−newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Read, Eq, Ord)

117+emptyPrinterState :: PrinterState

118+emptyPrinterState = PrinterState { indent = 0 }

32119

33120-- |

34121-- Number of characters per identation level

@@ -39,7 +126,7 @@ blockIndent = 4

39126-- |

40127-- Pretty print with a new indentation level

41128--

42−withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String

129+withIndent :: (Emit gen) => StateT PrinterState Maybe gen -> StateT PrinterState Maybe gen

43130withIndent action = do

44131 modify $ \st -> st { indent = indent st + blockIndent }

45132 result <- action

@@ -49,19 +136,19 @@ withIndent action = do

49136-- |

50137-- Get the current indentation level

51138--

52−currentIndent :: StateT PrinterState Maybe String

139+currentIndent :: (Emit gen) => StateT PrinterState Maybe gen

53140currentIndent = do

54141 current <- get

55− return $ replicate (indent current) ' '

142+ return $ emit $ replicate (indent current) ' '

56143

57144-- |

58145-- Print many lines

59146--

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

61148prettyPrintMany f xs = do

62149 ss <- mapM f xs

63150 indentString <- currentIndent

64− return $ intercalate "\n" $ map (indentString ++) ss

151+ return $ intercalate (emit "\n") $ map (\s -> mappend indentString s) ss

65152

66153-- |

67154-- Prints an object key, escaping reserved names.

src/Language/PureScript/Pretty/JS.hs+118−105

@@ -14,13 +14,12 @@

1414-----------------------------------------------------------------------------

1515

1616module Language.PureScript.Pretty.JS (

17− prettyPrintJS

17+ prettyPrintJS, prettyPrintJSWithSourceMaps

1818) where

1919

2020import Prelude ()

2121import Prelude.Compat

2222

23−import Data.List hiding (concat, concatMap)

2423import Data.Maybe (fromMaybe)

2524

2625import Control.Arrow ((<+>))

@@ -34,103 +33,110 @@ import Language.PureScript.CodeGen.JS.Common

3433import Language.PureScript.Pretty.Common

3534import Language.PureScript.Comments

3635

36+

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

38+

3739import Numeric

3840

39−literals :: Pattern PrinterState JS String

40−literals = mkPattern' match

41+import Data.Monoid

42+

43+literals :: (Emit gen) => Pattern PrinterState JS gen

44+literals = mkPattern' match'

4145 where

42− match :: JS -> StateT PrinterState Maybe String

43− match (JSNumericLiteral n) = return $ either show show n

44− match (JSStringLiteral s) = return $ string s

45− match (JSBooleanLiteral True) = return "true"

46− match (JSBooleanLiteral False) = return "false"

47− match (JSArrayLiteral xs) = concat <$> sequence

48− [ return "[ "

49− , intercalate ", " <$> forM xs prettyPrintJS'

50− , return " ]"

46+ match' :: (Emit gen) => JS -> StateT PrinterState Maybe gen

47+ match' js = (addMapping' (getSourceSpan js) <>) <$> match js

48+

49+ match :: (Emit gen) => JS -> StateT PrinterState Maybe gen

50+ match (JSNumericLiteral _ n) = return $ emit $ either show show n

51+ match (JSStringLiteral _ s) = return $ string s

52+ match (JSBooleanLiteral _ True) = return $ emit "true"

53+ match (JSBooleanLiteral _ False) = return $ emit "false"

54+ match (JSArrayLiteral _ xs) = mconcat <$> sequence

55+ [ return $ emit "[ "

56+ , intercalate (emit ", ") <$> forM xs prettyPrintJS'

57+ , return $ emit " ]"

5158 ]

52− match (JSObjectLiteral []) = return "{}"

53− match (JSObjectLiteral ps) = concat <$> sequence

54− [ return "{\n"

59+ match (JSObjectLiteral _ []) = return $ emit "{}"

60+ match (JSObjectLiteral _ ps) = mconcat <$> sequence

61+ [ return $ emit "{\n"

5562 , 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

5764 indentString <- currentIndent

58− return $ intercalate ", \n" $ map (indentString ++) jss

59− , return "\n"

65+ return $ intercalate (emit ", \n") $ map (indentString <>) jss

66+ , return $ emit "\n"

6067 , currentIndent

61− , return "}"

68+ , return $ emit "}"

6269 ]

6370 where

64− objectPropertyToString :: String -> String

65− objectPropertyToString s | identNeedsEscaping s = show s

66− | otherwise = s

67− match (JSBlock sts) = concat <$> sequence

68− [ return "{\n"

71+ objectPropertyToString :: (Emit gen) => String -> gen

72+ objectPropertyToString s | identNeedsEscaping s = emit $ show s

73+ | otherwise = emit s

74+ match (JSBlock _ sts) = mconcat <$> sequence

75+ [ return $ emit "{\n"

6976 , withIndent $ prettyStatements sts

70− , return "\n"

77+ , return $ emit "\n"

7178 , currentIndent

72− , return "}"

79+ , return $ emit "}"

7380 ]

74− match (JSVar ident) = return ident

75− match (JSVariableIntroduction ident value) = concat <$> sequence

76− [ return "var "

77− , return ident

78− , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value

81+ match (JSVar _ ident) = return $ emit ident

82+ match (JSVariableIntroduction _ ident value) = mconcat <$> sequence

83+ [ return $ emit $ "var " ++ ident

84+ , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value

7985 ]

80− match (JSAssignment target value) = concat <$> sequence

86+ match (JSAssignment _ target value) = mconcat <$> sequence

8187 [ prettyPrintJS' target

82− , return " = "

88+ , return $ emit " = "

8389 , prettyPrintJS' value

8490 ]

85− match (JSWhile cond sts) = concat <$> sequence

86− [ return "while ("

91+ match (JSWhile _ cond sts) = mconcat <$> sequence

92+ [ return $ emit "while ("

8793 , prettyPrintJS' cond

88− , return ") "

94+ , return $ emit ") "

8995 , prettyPrintJS' sts

9096 ]

91− match (JSFor ident start end sts) = concat <$> sequence

92− [ return $ "for (var " ++ ident ++ " = "

97+ match (JSFor _ ident start end sts) = mconcat <$> sequence

98+ [ return $ emit $ "for (var " ++ ident ++ " = "

9399 , prettyPrintJS' start

94− , return $ "; " ++ ident ++ " < "

100+ , return $ emit $ "; " ++ ident ++ " < "

95101 , prettyPrintJS' end

96− , return $ "; " ++ ident ++ "++) "

102+ , return $ emit $ "; " ++ ident ++ "++) "

97103 , prettyPrintJS' sts

98104 ]

99− match (JSForIn ident obj sts) = concat <$> sequence

100− [ return $ "for (var " ++ ident ++ " in "

105+ match (JSForIn _ ident obj sts) = mconcat <$> sequence

106+ [ return $ emit $ "for (var " ++ ident ++ " in "

101107 , prettyPrintJS' obj

102− , return ") "

108+ , return $ emit ") "

103109 , prettyPrintJS' sts

104110 ]

105− match (JSIfElse cond thens elses) = concat <$> sequence

106− [ return "if ("

111+ match (JSIfElse _ cond thens elses) = mconcat <$> sequence

112+ [ return $ emit "if ("

107113 , prettyPrintJS' cond

108− , return ") "

114+ , return $ emit ") "

109115 , prettyPrintJS' thens

110− , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses

116+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintJS') elses

111117 ]

112− match (JSReturn value) = concat <$> sequence

113− [ return "return "

118+ match (JSReturn _ value) = mconcat <$> sequence

119+ [ return $ emit "return "

114120 , prettyPrintJS' value

115121 ]

116− match (JSThrow value) = concat <$> sequence

117− [ return "throw "

122+ match (JSThrow _ value) = mconcat <$> sequence

123+ [ return $ emit "throw "

118124 , prettyPrintJS' value

119125 ]

120− match (JSBreak lbl) = return $ "break " ++ lbl

121− match (JSContinue lbl) = return $ "continue " ++ lbl

122− match (JSLabel lbl js) = concat <$> sequence

123− [ return $ lbl ++ ": "

126+ match (JSBreak _ lbl) = return $ emit $ "break " ++ lbl

127+ match (JSContinue _ lbl) = return $ emit $ "continue " ++ lbl

128+ match (JSLabel _ lbl js) = mconcat <$> sequence

129+ [ return $ emit $ lbl ++ ": "

124130 , prettyPrintJS' js

125131 ]

126− match (JSComment com js) = fmap concat $ sequence $

127− [ return "\n"

132+ match (JSComment _ com js) = fmap mconcat $ sequence $

133+ [ return $ emit "\n"

128134 , currentIndent

129− , return "/**\n"

135+ , return $ emit "/**\n"

130136 ] ++

131137 map asLine (concatMap commentLines com) ++

132138 [ currentIndent

133− , return " */\n"

139+ , return $ emit " */\n"

134140 , currentIndent

135141 , prettyPrintJS' js

136142 ]

@@ -139,21 +145,21 @@ literals = mkPattern' match

139145 commentLines (LineComment s) = [s]

140146 commentLines (BlockComment s) = lines s

141147

142− asLine :: String -> StateT PrinterState Maybe String

148+ asLine :: (Emit gen) => String -> StateT PrinterState Maybe gen

143149 asLine s = do

144150 i <- currentIndent

145− return $ i ++ " * " ++ removeComments s ++ "\n"

151+ return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"

146152

147153 removeComments :: String -> String

148154 removeComments ('*' : '/' : s) = removeComments s

149155 removeComments (c : s) = c : removeComments s

150156

151157 removeComments [] = []

152− match (JSRaw js) = return js

158+ match (JSRaw _ js) = return $ emit js

153159 match _ = mzero

154160

155−string :: String -> String

156−string s = '"' : concatMap encodeChar s ++ "\""

161+string :: (Emit gen) => String -> gen

162+string s = emit $ '"' : concatMap encodeChar s ++ "\""

157163 where

158164 encodeChar :: Char -> String

159165 encodeChar '\b' = "\\b"

@@ -175,114 +181,121 @@ string s = '"' : concatMap encodeChar s ++ "\""

175181 encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) ""

176182 encodeChar c = [c]

177183

178−conditional :: Pattern PrinterState JS ((JS, JS), JS)

184+conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)

179185conditional = mkPattern match

180186 where

181− match (JSConditional cond th el) = Just ((th, el), cond)

187+ match (JSConditional ss cond th el) = Just ((ss, th, el), cond)

182188 match _ = Nothing

183189

184−accessor :: Pattern PrinterState JS (String, JS)

190+accessor :: (Emit gen) => Pattern PrinterState JS (gen, JS)

185191accessor = mkPattern match

186192 where

187− match (JSAccessor prop val) = Just (prop, val)

193+ match (JSAccessor _ prop val) = Just (emit prop, val)

188194 match _ = Nothing

189195

190−indexer :: Pattern PrinterState JS (String, JS)

196+indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)

191197indexer = mkPattern' match

192198 where

193− match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val

199+ match (JSIndexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val

200+

194201 match _ = mzero

195202

196−lam :: Pattern PrinterState JS ((Maybe String, [String]), JS)

203+lam :: Pattern PrinterState JS ((Maybe String, [String], Maybe SourceSpan), JS)

197204lam = mkPattern match

198205 where

199− match (JSFunction name args ret) = Just ((name, args), ret)

206+ match (JSFunction ss name args ret) = Just ((name, args, ss), ret)

200207 match _ = Nothing

201208

202−app :: Pattern PrinterState JS (String, JS)

209+app :: (Emit gen) => Pattern PrinterState JS (gen, JS)

203210app = mkPattern' match

204211 where

205− match (JSApp val args) = do

212+ match (JSApp _ val args) = do

206213 jss <- traverse prettyPrintJS' args

207− return (intercalate ", " jss, val)

214+ return (intercalate (emit ", ") jss, val)

208215 match _ = mzero

209216

210217typeOf :: Pattern PrinterState JS ((), JS)

211218typeOf = mkPattern match

212219 where

213− match (JSTypeOf val) = Just ((), val)

220+ match (JSTypeOf _ val) = Just ((), val)

214221 match _ = Nothing

215222

216223instanceOf :: Pattern PrinterState JS (JS, JS)

217224instanceOf = mkPattern match

218225 where

219− match (JSInstanceOf val ty) = Just (val, ty)

226+ match (JSInstanceOf _ val ty) = Just (val, ty)

220227 match _ = Nothing

221228

222−unary' :: UnaryOperator -> (JS -> String) -> Operator PrinterState JS String

223−unary' op mkStr = Wrap match (++)

229+unary' :: (Emit gen) => UnaryOperator -> (JS -> String) -> Operator PrinterState JS gen

230+unary' op mkStr = Wrap match (<>)

224231 where

225− match :: Pattern PrinterState JS (String, JS)

232+ match :: (Emit gen) => Pattern PrinterState JS (gen, JS)

226233 match = mkPattern match'

227234 where

228− match' (JSUnary op' val) | op' == op = Just (mkStr val, val)

235+ match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val)

229236 match' _ = Nothing

230237

231−unary :: UnaryOperator -> String -> Operator PrinterState JS String

238+unary :: (Emit gen) => UnaryOperator -> String -> Operator PrinterState JS gen

232239unary op str = unary' op (const str)

233240

234−negateOperator :: Operator PrinterState JS String

241+negateOperator :: (Emit gen) => Operator PrinterState JS gen

235242negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")

236243 where

237− isNegate (JSUnary Negate _) = True

244+ isNegate (JSUnary _ Negate _) = True

238245 isNegate _ = False

239246

240−binary :: BinaryOperator -> String -> Operator PrinterState JS String

241−binary op str = AssocL match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

247+binary :: (Emit gen) => BinaryOperator -> String -> Operator PrinterState JS gen

248+binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " ++ str ++ " ") <> v2)

242249 where

243250 match :: Pattern PrinterState JS (JS, JS)

244251 match = mkPattern match'

245252 where

246− match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)

253+ match' (JSBinary _ op' v1 v2) | op' == op = Just (v1, v2)

247254 match' _ = Nothing

248255

249−prettyStatements :: [JS] -> StateT PrinterState Maybe String

256+prettyStatements :: (Emit gen) => [JS] -> StateT PrinterState Maybe gen

250257prettyStatements sts = do

251258 jss <- forM sts prettyPrintJS'

252259 indentString <- currentIndent

253− return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss

260+ return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss

254261

255262-- |

256263-- Generate a pretty-printed string representing a Javascript expression

257264--

258−prettyPrintJS1 :: JS -> String

265+prettyPrintJS1 :: (Emit gen) => JS -> gen

259266prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

260267

261268-- |

262269-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

263270--

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+

264276prettyPrintJS :: [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

266278

267279-- |

268280-- Generate an indented, pretty-printed string representing a Javascript expression

269281--

270−prettyPrintJS' :: JS -> StateT PrinterState Maybe String

282+prettyPrintJS' :: (Emit gen) => JS -> StateT PrinterState Maybe gen

271283prettyPrintJS' = A.runKleisli $ runPattern matchValue

272284 where

273− matchValue :: Pattern PrinterState JS String

274− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

275− operators :: OperatorTable PrinterState JS String

285+ matchValue :: (Emit gen) => Pattern PrinterState JS gen

286+ matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)

287+ operators :: (Emit gen) => OperatorTable PrinterState JS gen

276288 operators =

277− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

278− , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

279− , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

289+ OperatorTable [ [ Wrap accessor $ \prop val -> val <> emit "." <> prop ]

290+ , [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]

291+ , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ]

280292 , [ unary JSNew "new " ]

281− , [ Wrap lam $ \(name, args) ret -> "function "

293+ , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>

294+ emit ("function "

282295 ++ fromMaybe "" name

283− ++ "(" ++ intercalate ", " args ++ ") "

284− ++ ret ]

285− , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]

296+ ++ "(" ++ intercalate ", " args ++ ") ")

297+ <> ret ]

298+ , [ Wrap typeOf $ \_ s -> emit "typeof " <> s ]

286299 , [ unary Not "!"

287300 , unary BitwiseNot "~"

288301 , unary Positive "+"

@@ -299,7 +312,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

299312 , binary LessThanOrEqualTo "<="

300313 , binary GreaterThan ">"

301314 , binary GreaterThanOrEqualTo ">="

302− , AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]

315+ , AssocR instanceOf $ \v1 v2 -> v1 <> emit " instanceof " <> v2 ]

303316 , [ binary EqualTo "==="

304317 , binary NotEqualTo "!==" ]

305318 , [ binary BitwiseAnd "&" ]

@@ -307,5 +320,5 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

307320 , [ binary BitwiseOr "|" ]

308321 , [ binary And "&&" ]

309322 , [ 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 ]

311324 ]

src/Language/PureScript/Pretty/Values.hs−2

@@ -19,8 +19,6 @@ module Language.PureScript.Pretty.Values (

1919 prettyPrintBinderAtom

2020) where

2121

22−import Data.List (intercalate)

23−

2422import Control.Arrow (second)

2523

2624import Language.PureScript.Crash

src/Language/PureScript/Renamer.hs+9−9

@@ -105,8 +105,8 @@ lookupIdent name = do

105105findDeclIdents :: [Bind Ann] -> [Ident]

106106findDeclIdents = concatMap go

107107 where

108− go (NonRec ident _) = [ident]

109− go (Rec ds) = map fst ds

108+ go (NonRec _ ident _) = [ident]

109+ go (Rec ds) = map (snd . fst) ds

110110

111111-- |

112112-- Renames within each declaration in a module.

@@ -128,19 +128,19 @@ renameInModules = map go

128128-- another in the current scope.

129129--

130130renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann)

131−renameInDecl isTopLevel (NonRec name val) = do

131+renameInDecl isTopLevel (NonRec a name val) = do

132132 name' <- if isTopLevel then return name else updateScope name

133− NonRec name' <$> renameInValue val

133+ NonRec a name' <$> renameInValue val

134134renameInDecl isTopLevel (Rec ds) = do

135135 ds' <- traverse updateNames ds

136136 Rec <$> traverse updateValues ds'

137137 where

138− updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)

139− updateNames (name, val) = do

138+ updateNames :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)

139+ updateNames ((a, name), val) = do

140140 name' <- if isTopLevel then return name else updateScope name

141− return (name', val)

142− updateValues :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)

143− updateValues (name, val) = (,) name <$> renameInValue val

141+ return ((a, name'), val)

142+ updateValues :: ((Ann, Ident), Expr Ann) -> Rename ((Ann, Ident), Expr Ann)

143+ updateValues (aname, val) = (,) aname <$> renameInValue val

144144

145145-- |

146146-- Renames within a value.

src/Language/PureScript/TypeChecker/Types.hs+6−3

@@ -297,7 +297,9 @@ infer' (TypedValue checkType val ty) = do

297297 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

298298 val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

299299 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

301303infer' _ = internalError "Invalid argument to infer"

302304

303305inferLetBinding ::

@@ -623,8 +625,9 @@ check' val kt@(KindedType ty kind) = do

623625 checkTypeKind ty kind

624626 val' <- check' val ty

625627 return $ TypedValue True val' kt

626−check' (PositionedValue pos _ val) ty =

627− warnAndRethrowWithPosition pos $ check' val ty

628+check' (PositionedValue pos c val) ty = warnAndRethrowWithPosition pos $ do

629+ TypedValue t v ty' <- check' val ty

630+ return $ TypedValue t (PositionedValue pos c v) ty'

628631check' val ty = do

629632 TypedValue _ val' ty' <- infer val

630633 mt <- subsumes (Just val') ty' ty

stack-lts-2.yaml+1

@@ -6,4 +6,5 @@ extra-deps:

66- bower-json-0.7.0.0

77- boxes-0.1.4

88- pattern-arrows-0.0.2

9+- sourcemap-0.1.6

910resolver: lts-2.22

stack-lts-3.yaml+2−1

@@ -1,5 +1,6 @@

11flags: {}

22packages:

33- '.'

4−extra-deps: []

4+extra-deps:

5+- sourcemap-0.1.6

56resolver: lts-3.6

stack-nightly.yaml+1

@@ -2,4 +2,5 @@ flags: {}

22packages:

33- '.'

44extra-deps:

5+- sourcemap-0.1.6

56resolver: nightly-2015-09-29