@@ -55,21 +55,21 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
55 rethrow (addHint (ErrorInModule mn)) $ do
55 rethrow (addHint (ErrorInModule mn)) $ do
56 let usedNames = concatMap getNames decls
56 let usedNames = concatMap getNames decls
57 let mnLookup = renameImports usedNames imps
57 let mnLookup = renameImports usedNames imps
58− jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
58+ jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd $ imps
59 let decls' = renameModules mnLookup decls
59 let decls' = renameModules mnLookup decls
60 jsDecls <- mapM bindToJs decls'
60 jsDecls <- mapM bindToJs decls'
61 optimized <- T.traverse (T.traverse optimize) jsDecls
61 optimized <- T.traverse (T.traverse optimize) jsDecls
62 F.traverse_ (F.traverse_ checkIntegers) optimized
62 F.traverse_ (F.traverse_ checkIntegers) optimized
63 comments <- not <$> asks optionsNoComments
63 comments <- not <$> asks optionsNoComments
64− let strict = JSStringLiteral "use strict"
64+ let strict = JSStringLiteral Nothing "use strict"
65− let header = if comments && not (null coms) then JSComment coms strict else strict
65+ let header = if comments && not (null coms) then JSComment Nothing coms strict else strict
66− let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
66+ let foreign' = [JSVariableIntroduction Nothing "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]
67 let moduleBody = header : foreign' ++ jsImports ++ concat optimized
67 let moduleBody = header : foreign' ++ jsImports ++ concat optimized
68 let foreignExps = exps `intersect` (fst `map` foreigns)
68 let foreignExps = exps `intersect` (fst `map` foreigns)
69 let standardExps = exps \\ foreignExps
69 let standardExps = exps \\ foreignExps
70− let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps
70+ let exps' = JSObjectLiteral Nothing $ map (runIdent &&& (JSVar Nothing) . identToJs) standardExps
71 ++ map (runIdent &&& foreignIdent) foreignExps
71 ++ map (runIdent &&& foreignIdent) foreignExps
72− return $ moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
72+ return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps']
@@ -77,23 +77,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
77 -- Extracts all declaration names from a binding group.
77 -- Extracts all declaration names from a binding group.
79 getNames :: Bind Ann -> [Ident]
79 getNames :: Bind Ann -> [Ident]
80− getNames (NonRec ident _) = [ident]
80+ getNames (NonRec _ ident _) = [ident]
81− getNames (Rec vals) = map fst vals
81+ getNames (Rec vals) = map (snd . fst) vals
84 -- Creates alternative names for each module to ensure they don't collide
84 -- Creates alternative names for each module to ensure they don't collide
85 -- with declaration names.
85 -- with declaration names.
87− renameImports :: [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName
87+ renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
88 renameImports ids mns = go M.empty ids mns
88 renameImports ids mns = go M.empty ids mns
90− go :: M.Map ModuleName ModuleName -> [Ident] -> [ModuleName] -> M.Map ModuleName ModuleName
90+ go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
91− go acc used (mn' : mns') =
91+ go acc used ((ann, mn') : mns') =
92 let mni = Ident $ runModuleName mn'
92 let mni = Ident $ runModuleName mn'
93 in if mn' /= mn && mni `elem` used
93 in if mn' /= mn && mni `elem` used
94 then let newName = freshModuleName 1 mn' used
94 then let newName = freshModuleName 1 mn' used
95− in go (M.insert mn' newName acc) (Ident (runModuleName newName) : used) mns'
95+ in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'
96− else go (M.insert mn' mn' acc) (mni : used) mns'
96+ else go (M.insert mn' (ann, mn') acc) (mni : used) mns'
97 go acc _ [] = acc
97 go acc _ [] = acc
99 freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
99 freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
@@ -107,18 +107,18 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
107 -- Generates Javascript code for a module import, binding the required module
107 -- Generates Javascript code for a module import, binding the required module
108 -- to the alternative
108 -- to the alternative
110− importToJs :: M.Map ModuleName ModuleName -> ModuleName -> m JS
110+ importToJs :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m JS
111 importToJs mnLookup mn' = do
111 importToJs mnLookup mn' = do
112 path <- asks optionsRequirePath
112 path <- asks optionsRequirePath
113− let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
113+ let ((ss, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
114− let moduleBody = JSApp (JSVar "require") [JSStringLiteral (maybe id (</>) path $ runModuleName mn')]
114+ let moduleBody = JSApp Nothing (JSVar Nothing "require") [JSStringLiteral Nothing (maybe id (</>) path $ runModuleName mn')]
115− return $ JSVariableIntroduction (moduleNameToJs mnSafe) (Just moduleBody)
115+ withPos ss $ JSVariableIntroduction Nothing (moduleNameToJs mnSafe) (Just moduleBody)
118 -- Replaces the `ModuleName`s in the AST so that the generated code refers to
118 -- Replaces the `ModuleName`s in the AST so that the generated code refers to
119 -- the collision-avoiding renamed module imports.
119 -- the collision-avoiding renamed module imports.
121− renameModules :: M.Map ModuleName ModuleName -> [Bind Ann] -> [Bind Ann]
121+ renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]
122 renameModules mnLookup binds =
122 renameModules mnLookup binds =
123 let (f, _, _) = everywhereOnValues id goExpr goBinder
123 let (f, _, _) = everywhereOnValues id goExpr goBinder
124 in map f binds
124 in map f binds
@@ -131,7 +131,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
131 goBinder b = b
131 goBinder b = b
132 renameQual :: Qualified a -> Qualified a
132 renameQual :: Qualified a -> Qualified a
133 renameQual (Qualified (Just mn') a) =
133 renameQual (Qualified (Just mn') a) =
134− let mnSafe = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
134+ let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
135 in Qualified (Just mnSafe) a
135 in Qualified (Just mnSafe) a
136 renameQual q = q
136 renameQual q = q
@@ -139,8 +139,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
139 -- Generate code in the simplified Javascript intermediate representation for a declaration
139 -- Generate code in the simplified Javascript intermediate representation for a declaration
141 bindToJs :: Bind Ann -> m [JS]
141 bindToJs :: Bind Ann -> m [JS]
142− bindToJs (NonRec ident val) = return <$> nonRecToJS ident val
142+ bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val
143− bindToJs (Rec vals) = forM vals (uncurry nonRecToJS)
143+ bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)
146 -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
146 -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
@@ -148,22 +148,30 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
149 -- The main purpose of this function is to handle code generation for comments.
149 -- The main purpose of this function is to handle code generation for comments.
151− nonRecToJS :: Ident -> Expr Ann -> m JS
151+ nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS
152− nonRecToJS i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
152+ nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
153 withoutComment <- asks optionsNoComments
153 withoutComment <- asks optionsNoComments
154 if withoutComment
154 if withoutComment
155− then nonRecToJS i (modifyAnn removeComments e)
155+ then nonRecToJS a i (modifyAnn removeComments e)
156− else JSComment com <$> nonRecToJS i (modifyAnn removeComments e)
156+ else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
157− nonRecToJS ident val = do
157+ nonRecToJS (ss, _, _, _) ident val = do
158 js <- valueToJs val
158 js <- valueToJs val
159− return $ JSVariableIntroduction (identToJs ident) (Just js)
159+ withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)
161+ withPos :: Maybe SourceSpan -> JS -> m JS
162+ withPos (Just ss) js = do
163+ withSM <- asks optionsSourceMaps
165+ then withSourceSpan ss js
167+ withPos Nothing js = return js
162 -- Generate code in the simplified Javascript intermediate representation for a variable based on a
170 -- Generate code in the simplified Javascript intermediate representation for a variable based on a
163 -- PureScript identifier.
171 -- PureScript identifier.
165 var :: Ident -> JS
173 var :: Ident -> JS
166− var = JSVar . identToJs
174+ var = JSVar Nothing . identToJs
169 -- Generate code in the simplified Javascript intermediate representation for an accessor based on
177 -- Generate code in the simplified Javascript intermediate representation for an accessor based on
@@ -172,102 +180,106 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
173 accessor :: Ident -> JS -> JS
181 accessor :: Ident -> JS -> JS
174 accessor (Ident prop) = accessorString prop
182 accessor (Ident prop) = accessorString prop
175− accessor (Op op) = JSIndexer (JSStringLiteral op)
183+ accessor (Op op) = JSIndexer Nothing (JSStringLiteral Nothing op)
176 accessor (GenIdent _ _) = internalError "GenIdent in accessor"
184 accessor (GenIdent _ _) = internalError "GenIdent in accessor"
178 accessorString :: String -> JS -> JS
186 accessorString :: String -> JS -> JS
179− accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
187+ accessorString prop | identNeedsEscaping prop = JSIndexer Nothing (JSStringLiteral Nothing prop)
180− | otherwise = JSAccessor prop
188+ | otherwise = JSAccessor Nothing prop
183 -- Generate code in the simplified Javascript intermediate representation for a value or expression.
191 -- Generate code in the simplified Javascript intermediate representation for a value or expression.
185 valueToJs :: Expr Ann -> m JS
193 valueToJs :: Expr Ann -> m JS
195+ let (ss, _, _, _) = extractAnn e in
196+ withPos ss =<< valueToJs' e
198+ valueToJs' :: Expr Ann -> m JS
186− valueToJs (Literal (pos, _, _, _) l) =
199+ valueToJs' (Literal (pos, _, _, _) l) =
187 maybe id rethrowWithPosition pos $ literalToValueJS l
200 maybe id rethrowWithPosition pos $ literalToValueJS l
188− valueToJs (Var (_, _, _, Just (IsConstructor _ [])) name) =
201+ valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) =
189− return $ JSAccessor "value" $ qualifiedToJS id name
202+ return $ JSAccessor Nothing "value" $ qualifiedToJS id name
190− valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) =
203+ valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) =
191− return $ JSAccessor "create" $ qualifiedToJS id name
204+ return $ JSAccessor Nothing "create" $ qualifiedToJS id name
192− valueToJs (Accessor _ prop val) =
205+ valueToJs' (Accessor _ prop val) =
193 accessorString prop <$> valueToJs val
206 accessorString prop <$> valueToJs val
194− valueToJs (ObjectUpdate _ o ps) = do
207+ valueToJs' (ObjectUpdate _ o ps) = do
195 obj <- valueToJs o
208 obj <- valueToJs o
196 sts <- mapM (sndM valueToJs) ps
209 sts <- mapM (sndM valueToJs) ps
197 extendObj obj sts
210 extendObj obj sts
198− valueToJs e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
211+ valueToJs' e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
199 let args = unAbs e
212 let args = unAbs e
200− in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
213+ in return $ JSFunction Nothing Nothing (map identToJs args) (JSBlock Nothing $ map assign args)
202 unAbs :: Expr Ann -> [Ident]
215 unAbs :: Expr Ann -> [Ident]
203 unAbs (Abs _ arg val) = arg : unAbs val
216 unAbs (Abs _ arg val) = arg : unAbs val
204 unAbs _ = []
217 unAbs _ = []
205 assign :: Ident -> JS
218 assign :: Ident -> JS
206− assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
219+ assign name = JSAssignment Nothing (accessorString (runIdent name) (JSVar Nothing "this"))
207 (var name)
220 (var name)
208− valueToJs (Abs _ arg val) = do
221+ valueToJs' (Abs _ arg val) = do
209 ret <- valueToJs val
222 ret <- valueToJs val
210− return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
223+ return $ JSFunction Nothing Nothing [identToJs arg] (JSBlock Nothing [JSReturn Nothing ret])
211− valueToJs e@App{} = do
224+ valueToJs' e@App{} = do
212 let (f, args) = unApp e []
225 let (f, args) = unApp e []
213 args' <- mapM valueToJs args
226 args' <- mapM valueToJs args
214 case f of
227 case f of
215 Var (_, _, _, Just IsNewtype) _ -> return (head args')
228 Var (_, _, _, Just IsNewtype) _ -> return (head args')
216 Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
229 Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
217− return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
230+ return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'
218 Var (_, _, _, Just IsTypeClassConstructor) name ->
231 Var (_, _, _, Just IsTypeClassConstructor) name ->
219− return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
232+ return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'
220− _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs f
233+ _ -> flip (foldl (\fn a -> JSApp Nothing fn [a])) args' <$> valueToJs f
222 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
235 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
223 unApp (App _ val arg) args = unApp val (arg : args)
236 unApp (App _ val arg) args = unApp val (arg : args)
224 unApp other args = (other, args)
237 unApp other args = (other, args)
225− valueToJs (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
238+ valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
226 return $ if mn' == mn
239 return $ if mn' == mn
227 then foreignIdent ident
240 then foreignIdent ident
228 else varToJs qi
241 else varToJs qi
229− valueToJs (Var (_, _, _, Just IsForeign) ident) =
242+ valueToJs' (Var (_, _, _, Just IsForeign) ident) =
230 error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident
243 error $ "Encountered an unqualified reference to a foreign ident " ++ showQualified showIdent ident
231− valueToJs (Var _ ident) =
244+ valueToJs' (Var _ ident) = return $ varToJs ident
232− return $ varToJs ident
233− valueToJs (Case (maybeSpan, _, _, _) values binders) = do
245+ valueToJs' (Case (maybeSpan, _, _, _) values binders) = do
234 vals <- mapM valueToJs values
246 vals <- mapM valueToJs values
235 bindersToJs maybeSpan binders vals
247 bindersToJs maybeSpan binders vals
236− valueToJs (Let _ ds val) = do
248+ valueToJs' (Let _ ds val) = do
237 ds' <- concat <$> mapM bindToJs ds
249 ds' <- concat <$> mapM bindToJs ds
238 ret <- valueToJs val
250 ret <- valueToJs val
239− return $ JSApp (JSFunction Nothing [] (JSBlock (ds' ++ [JSReturn ret]))) []
251+ return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (ds' ++ [JSReturn Nothing ret]))) []
240− valueToJs (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
252+ valueToJs' (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
241− return $ JSVariableIntroduction ctor (Just $
253+ return $ JSVariableIntroduction Nothing ctor (Just $
242− JSObjectLiteral [("create",
254+ JSObjectLiteral Nothing [("create",
243− JSFunction Nothing ["value"]
255+ JSFunction Nothing Nothing ["value"]
244− (JSBlock [JSReturn $ JSVar "value"]))])
256+ (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
245− valueToJs (Constructor _ _ (ProperName ctor) []) =
257+ valueToJs' (Constructor _ _ (ProperName ctor) []) =
246− return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
258+ return $ iife ctor [ JSFunction Nothing (Just ctor) [] (JSBlock Nothing [])
247− , JSAssignment (JSAccessor "value" (JSVar ctor))
259+ , JSAssignment Nothing (JSAccessor Nothing "value" (JSVar Nothing ctor))
248− (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
260+ (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) []) ]
249− valueToJs (Constructor _ _ (ProperName ctor) fields) =
261+ valueToJs' (Constructor _ _ (ProperName ctor) fields) =
250 let constructor =
262 let constructor =
251− let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]
263+ let body = [ JSAssignment Nothing (JSAccessor Nothing (identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
252− in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)
264+ in JSFunction Nothing (Just ctor) (identToJs `map` fields) (JSBlock Nothing body)
253 createFn =
265 createFn =
254− let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)
266+ let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing ctor) (var `map` fields)
255− in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields
267+ in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
256 in return $ iife ctor [ constructor
268 in return $ iife ctor [ constructor
257− , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn
269+ , JSAssignment Nothing (JSAccessor Nothing "create" (JSVar Nothing ctor)) createFn
260 iife :: String -> [JS] -> JS
272 iife :: String -> [JS] -> JS
261− iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
273+ iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []
263 literalToValueJS :: Literal (Expr Ann) -> m JS
275 literalToValueJS :: Literal (Expr Ann) -> m JS
264− literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral (Left i)
276+ literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)
265− literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral (Right n)
277+ literalToValueJS (NumericLiteral (Right n)) = return $ JSNumericLiteral Nothing (Right n)
266− literalToValueJS (StringLiteral s) = return $ JSStringLiteral s
278+ literalToValueJS (StringLiteral s) = return $ JSStringLiteral Nothing s
267− literalToValueJS (CharLiteral c) = return $ JSStringLiteral [c]
279+ literalToValueJS (CharLiteral c) = return $ JSStringLiteral Nothing [c]
268− literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b
280+ literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral Nothing b
269− literalToValueJS (ArrayLiteral xs) = JSArrayLiteral <$> mapM valueToJs xs
281+ literalToValueJS (ArrayLiteral xs) = JSArrayLiteral Nothing <$> mapM valueToJs xs
270− literalToValueJS (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM valueToJs) ps
282+ literalToValueJS (ObjectLiteral ps) = JSObjectLiteral Nothing <$> mapM (sndM valueToJs) ps
273 -- Shallow copy an object.
285 -- Shallow copy an object.
@@ -277,16 +289,16 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
277 newObj <- freshName
289 newObj <- freshName
278 key <- freshName
290 key <- freshName
280− jsKey = JSVar key
292+ jsKey = JSVar Nothing key
281− jsNewObj = JSVar newObj
293+ jsNewObj = JSVar Nothing newObj
282− block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
294+ block = JSBlock Nothing (objAssign:copy:extend ++ [JSReturn Nothing jsNewObj])
283− objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
295+ objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing [])
284− copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
296+ copy = JSForIn Nothing key obj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing]
285− cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
297+ cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" obj) [jsKey]
286− assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
298+ assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey obj)]
287− stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
299+ stToAssign (s, js) = JSAssignment Nothing (JSAccessor Nothing s jsNewObj) js
288 extend = map stToAssign sts
300 extend = map stToAssign sts
289− return $ JSApp (JSFunction Nothing [] block) []
301+ return $ JSApp Nothing (JSFunction Nothing Nothing [] block) []
292 -- Generate code in the simplified Javascript intermediate representation for a reference to a
304 -- Generate code in the simplified Javascript intermediate representation for a reference to a
@@ -301,12 +313,12 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
301 -- variable that may have a qualified name.
313 -- variable that may have a qualified name.
303 qualifiedToJS :: (a -> Ident) -> Qualified a -> JS
315 qualifiedToJS :: (a -> Ident) -> Qualified a -> JS
304− qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar . runIdent $ f a
316+ qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar Nothing . runIdent $ f a
305− qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn'))
317+ qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar Nothing (moduleNameToJs mn'))
306− qualifiedToJS f (Qualified _ a) = JSVar $ identToJs (f a)
318+ qualifiedToJS f (Qualified _ a) = JSVar Nothing $ identToJs (f a)
308 foreignIdent :: Ident -> JS
320 foreignIdent :: Ident -> JS
309− foreignIdent ident = accessorString (runIdent ident) (JSVar "$foreign")
321+ foreignIdent ident = accessorString (runIdent ident) (JSVar Nothing "$foreign")
312 -- Generate code in the simplified Javascript intermediate representation for pattern match binders
324 -- Generate code in the simplified Javascript intermediate representation for pattern match binders
@@ -315,11 +327,11 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
315 bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS
327 bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS
316 bindersToJs maybeSpan binders vals = do
328 bindersToJs maybeSpan binders vals = do
317 valNames <- replicateM (length vals) freshName
329 valNames <- replicateM (length vals) freshName
318− let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
330+ let assignments = zipWith (JSVariableIntroduction Nothing) valNames (map Just vals)
319 jss <- forM binders $ \(CaseAlternative bs result) -> do
331 jss <- forM binders $ \(CaseAlternative bs result) -> do
320 ret <- guardsToJs result
332 ret <- guardsToJs result
321 go valNames ret bs
333 go valNames ret bs
322− return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ failedPatternError valNames])))
334+ return $ JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing (assignments ++ concat jss ++ [JSThrow Nothing $ failedPatternError valNames])))
325 go :: [String] -> [JS] -> [Binder Ann] -> m [JS]
337 go :: [String] -> [JS] -> [Binder Ann] -> m [JS]
@@ -330,43 +342,48 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
330 go _ _ _ = internalError "Invalid arguments to bindersToJs"
342 go _ _ _ = internalError "Invalid arguments to bindersToJs"
332 failedPatternError :: [String] -> JS
344 failedPatternError :: [String] -> JS
333− failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral failedPatternMessage) (JSArrayLiteral $ zipWith valueError names vals)]
345+ failedPatternError names = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing "Error") [JSBinary Nothing Add (JSStringLiteral Nothing failedPatternMessage) (JSArrayLiteral Nothing $ zipWith valueError names vals)]
335 failedPatternMessage :: String
347 failedPatternMessage :: String
336 failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "
348 failedPatternMessage = "Failed pattern match" ++ maybe "" (((" at " ++ runModuleName mn ++ " ") ++) . displayStartEndPos) maybeSpan ++ ": "
338 valueError :: String -> JS -> JS
350 valueError :: String -> JS -> JS
339− valueError _ l@(JSNumericLiteral _) = l
351+ valueError _ l@(JSNumericLiteral _ _) = l
340− valueError _ l@(JSStringLiteral _) = l
352+ valueError _ l@(JSStringLiteral _ _) = l
341− valueError _ l@(JSBooleanLiteral _) = l
353+ valueError _ l@(JSBooleanLiteral _ _) = l
342− valueError s _ = JSAccessor "name" . JSAccessor "constructor" $ JSVar s
354+ valueError s _ = JSAccessor Nothing "name" . JSAccessor Nothing "constructor" $ JSVar Nothing s
344 guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]
356 guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]
345 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
357 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
346 cond' <- valueToJs cond
358 cond' <- valueToJs cond
347 done <- valueToJs val
359 done <- valueToJs val
348− return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
360+ return $ JSIfElse Nothing cond' (JSBlock Nothing [JSReturn Nothing done]) Nothing
349− guardsToJs (Right v) = return . JSReturn <$> valueToJs v
361+ guardsToJs (Right v) = return . JSReturn Nothing <$> valueToJs v
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
352 -- Generate code in the simplified Javascript intermediate representation for a pattern match
369 -- Generate code in the simplified Javascript intermediate representation for a pattern match
353 -- binder.
370 -- binder.
355− binderToJs :: String -> [JS] -> Binder Ann -> m [JS]
372+ binderToJs' :: String -> [JS] -> Binder Ann -> m [JS]
356− binderToJs _ done (NullBinder{}) = return done
373+ binderToJs' _ done (NullBinder{}) = return done
357− binderToJs varName done (LiteralBinder _ l) =
374+ binderToJs' varName done (LiteralBinder _ l) =
358 literalToBinderJS varName done l
375 literalToBinderJS varName done l
359− binderToJs varName done (VarBinder _ ident) =
376+ binderToJs' varName done (VarBinder _ ident) =
360− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
377+ return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : done)
361− binderToJs varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
378+ binderToJs' varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
362 binderToJs varName done b
379 binderToJs varName done b
363− binderToJs varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
380+ binderToJs' varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
364 js <- go (zip fields bs) done
381 js <- go (zip fields bs) done
365 return $ case ctorType of
382 return $ case ctorType of
366 ProductType -> js
383 ProductType -> js
367 SumType ->
384 SumType ->
368− [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS (Ident . runProperName) ctor))
385+ [JSIfElse Nothing (JSInstanceOf Nothing (JSVar Nothing varName) (qualifiedToJS (Ident . runProperName) ctor))
369− (JSBlock js)
386+ (JSBlock Nothing js)
372 go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]
389 go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]
@@ -375,24 +392,24 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
375 argVar <- freshName
392 argVar <- freshName
376 done'' <- go remain done'
393 done'' <- go remain done'
377 js <- binderToJs argVar done'' binder
394 js <- binderToJs argVar done'' binder
378− return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)
395+ return (JSVariableIntroduction Nothing argVar (Just (JSAccessor Nothing (identToJs field) (JSVar Nothing varName))) : js)
379− binderToJs _ _ ConstructorBinder{} =
396+ binderToJs' _ _ ConstructorBinder{} =
380 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"
397 internalError "binderToJs: Invalid ConstructorBinder in binderToJs"
381− binderToJs varName done (NamedBinder _ ident binder) = do
398+ binderToJs' varName done (NamedBinder _ ident binder) = do
382 js <- binderToJs varName done binder
399 js <- binderToJs varName done binder
383− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
400+ return (JSVariableIntroduction Nothing (identToJs ident) (Just (JSVar Nothing varName)) : js)
385 literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]
402 literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]
386 literalToBinderJS varName done (NumericLiteral num) =
403 literalToBinderJS varName done (NumericLiteral num) =
387− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
404+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSNumericLiteral Nothing num)) (JSBlock Nothing done) Nothing]
388 literalToBinderJS varName done (CharLiteral c) =
405 literalToBinderJS varName done (CharLiteral c) =
389− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral [c])) (JSBlock done) Nothing]
406+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing [c])) (JSBlock Nothing done) Nothing]
390 literalToBinderJS varName done (StringLiteral str) =
407 literalToBinderJS varName done (StringLiteral str) =
391− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
408+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSVar Nothing varName) (JSStringLiteral Nothing str)) (JSBlock Nothing done) Nothing]
392 literalToBinderJS varName done (BooleanLiteral True) =
409 literalToBinderJS varName done (BooleanLiteral True) =
393− return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
410+ return [JSIfElse Nothing (JSVar Nothing varName) (JSBlock Nothing done) Nothing]
394 literalToBinderJS varName done (BooleanLiteral False) =
411 literalToBinderJS varName done (BooleanLiteral False) =
395− return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
412+ return [JSIfElse Nothing (JSUnary Nothing Not (JSVar Nothing varName)) (JSBlock Nothing done) Nothing]
396 literalToBinderJS varName done (ObjectLiteral bs) = go done bs
413 literalToBinderJS varName done (ObjectLiteral bs) = go done bs
398 go :: [JS] -> [(String, Binder Ann)] -> m [JS]
415 go :: [JS] -> [(String, Binder Ann)] -> m [JS]
@@ -401,10 +418,10 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
401 propVar <- freshName
418 propVar <- freshName
402 done'' <- go done' bs'
419 done'' <- go done' bs'
403 js <- binderToJs propVar done'' binder
420 js <- binderToJs propVar done'' binder
404− return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
421+ return (JSVariableIntroduction Nothing propVar (Just (accessorString prop (JSVar Nothing varName))) : js)
405 literalToBinderJS varName done (ArrayLiteral bs) = do
422 literalToBinderJS varName done (ArrayLiteral bs) = do
406 js <- go done 0 bs
423 js <- go done 0 bs
407− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
424+ return [JSIfElse Nothing (JSBinary Nothing EqualTo (JSAccessor Nothing "length" (JSVar Nothing varName)) (JSNumericLiteral Nothing (Left (fromIntegral $ length bs)))) (JSBlock Nothing js) Nothing]
409 go :: [JS] -> Integer -> [Binder Ann] -> m [JS]
426 go :: [JS] -> Integer -> [Binder Ann] -> m [JS]
410 go done' _ [] = return done'
427 go done' _ [] = return done'
@@ -412,21 +429,21 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
412 elVar <- freshName
429 elVar <- freshName
413 done'' <- go done' (index + 1) bs'
430 done'' <- go done' (index + 1) bs'
414 js <- binderToJs elVar done'' binder
431 js <- binderToJs elVar done'' binder
415− return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
432+ return (JSVariableIntroduction Nothing elVar (Just (JSIndexer Nothing (JSNumericLiteral Nothing (Left index)) (JSVar Nothing varName))) : js)
417 -- Check that all integers fall within the valid int range for JavaScript.
434 -- Check that all integers fall within the valid int range for JavaScript.
418 checkIntegers :: JS -> m ()
435 checkIntegers :: JS -> m ()
419 checkIntegers = void . everywhereOnJSTopDownM go
436 checkIntegers = void . everywhereOnJSTopDownM go
421 go :: JS -> m JS
438 go :: JS -> m JS
422− go (JSUnary Negate (JSNumericLiteral (Left i))) =
439+ go (JSUnary _ Negate (JSNumericLiteral ss (Left i))) =
423 -- Move the negation inside the literal; since this is a top-down
440 -- Move the negation inside the literal; since this is a top-down
424 -- traversal doing this replacement will stop the next case from raising
441 -- traversal doing this replacement will stop the next case from raising
425 -- the error when attempting to use -2147483648, as if left unrewritten
442 -- the error when attempting to use -2147483648, as if left unrewritten
426 -- the value is `JSUnary Negate (JSNumericLiteral (Left 2147483648))`, and
443 -- the value is `JSUnary Negate (JSNumericLiteral (Left 2147483648))`, and
427 -- 2147483648 is larger than the maximum allowed int.
444 -- 2147483648 is larger than the maximum allowed int.
428− return $ JSNumericLiteral (Left (-i))
445+ return $ JSNumericLiteral ss (Left (-i))
429− go js@(JSNumericLiteral (Left i)) =
446+ go js@(JSNumericLiteral _ (Left i)) =
430 let minInt = -2147483648
447 let minInt = -2147483648
431 maxInt = 2147483647
448 maxInt = 2147483647
432 in if i < minInt || i > maxInt
449 in if i < minInt || i > maxInt