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