@@ -47,13 +47,13 @@ import qualified Language.PureScript.Constants as C
47-- Generate code in the simplified Javascript intermediate representation for all declarations in a
47-- Generate code in the simplified Javascript intermediate representation for all declarations in a
50−moduleToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
50+moduleToJs :: forall m mode. (Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
51 => Module Ann -> m [JS]
51 => Module Ann -> m [JS]
52−moduleToJs (Module coms name imps exps foreigns decls) = do
52+moduleToJs (Module coms mn imps exps foreigns decls) = do
53 additional <- asks optionsAdditional
53 additional <- asks optionsAdditional
54− jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps
54+ jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
55 let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
55 let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
56− jsDecls <- mapM (bindToJs name) decls
56+ jsDecls <- mapM bindToJs decls
57 optimized <- T.traverse (T.traverse optimize) jsDecls
57 optimized <- T.traverse (T.traverse optimize) jsDecls
58 let isModuleEmpty = null exps
58 let isModuleEmpty = null exps
59 comments <- not <$> asks optionsNoComments
59 comments <- not <$> asks optionsNoComments
@@ -66,300 +66,294 @@ moduleToJs (Module coms name imps exps foreigns decls) = do
66 CompileOptions ns _ _ | not isModuleEmpty ->
66 CompileOptions ns _ _ | not isModuleEmpty ->
67 [ JSVariableIntroduction ns
67 [ JSVariableIntroduction ns
68 (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )
68 (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )
69− , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))
69+ , JSAssignment (JSAccessor (moduleNameToJs mn) (JSVar ns))
70 (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn exps']))) [])
70 (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn exps']))) [])
75−-- Generates Javascript code for a module import.
77−importToJs :: (Monad m, MonadReader (Options mode) m) => ModuleName -> m JS
79− additional <- asks optionsAdditional
80− let moduleBody = case additional of
81− MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
82− CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)
83− return $ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
86−-- Generate code in the simplified Javascript intermediate representation for a declaration
77+ -- Generates Javascript code for a module import.
88−bindToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
89− => ModuleName -> Bind Ann -> m [JS]
79+ importToJs :: ModuleName -> m JS
90−bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val
80+ importToJs mn' = do
91−bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))
81+ additional <- asks optionsAdditional
82+ let moduleBody = case additional of
83+ MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn')]
84+ CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn') (JSVar ns)
85+ return $ JSVariableIntroduction (moduleNameToJs mn') (Just moduleBody)
94−-- Generate code in the simplified Javascript intermediate representation for a single non-recursive
88+ -- Generate code in the simplified Javascript intermediate representation for a declaration
97−-- The main purpose of this function is to handle code generation for comments.
90+ bindToJs :: Bind Ann -> m [JS]
98−--
91+ bindToJs (NonRec ident val) = return <$> nonRecToJS ident val
99−nonRecToJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
92+ bindToJs (Rec vals) = forM vals (uncurry nonRecToJS)
100− => ModuleName -> Ident -> Expr Ann -> m JS
101−nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
102− withoutComment <- asks optionsNoComments
104− then nonRecToJS m i (modifyAnn removeComments e)
105− else JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)
106−nonRecToJS mp ident val = do
107− js <- valueToJs mp val
108− return $ JSVariableIntroduction (identToJs ident) (Just js)
95+ -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
98+ -- The main purpose of this function is to handle code generation for comments.
100+ nonRecToJS :: Ident -> Expr Ann -> m JS
101+ nonRecToJS i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
102+ withoutComment <- asks optionsNoComments
104+ then nonRecToJS i (modifyAnn removeComments e)
105+ else JSComment com <$> nonRecToJS i (modifyAnn removeComments e)
106+ nonRecToJS ident val = do
108+ return $ JSVariableIntroduction (identToJs ident) (Just js)
112−-- Generate code in the simplified Javascript intermediate representation for a variable based on a
111+ -- Generate code in the simplified Javascript intermediate representation for a variable based on a
113−-- PureScript identifier.
112+ -- PureScript identifier.
115−var :: Ident -> JS
114+ var :: Ident -> JS
116−var = JSVar . identToJs
115+ var = JSVar . identToJs
119−-- Generate code in the simplified Javascript intermediate representation for an accessor based on
118+ -- Generate code in the simplified Javascript intermediate representation for an accessor based on
120−-- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
119+ -- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
121−-- indexer is returned.
120+ -- indexer is returned.
123−accessor :: Ident -> JS -> JS
122+ accessor :: Ident -> JS -> JS
124−accessor (Ident prop) = accessorString prop
123+ accessor (Ident prop) = accessorString prop
125−accessor (Op op) = JSIndexer (JSStringLiteral op)
124+ accessor (Op op) = JSIndexer (JSStringLiteral op)
127−accessorString :: String -> JS -> JS
126+ accessorString :: String -> JS -> JS
128−accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
127+ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
129− | otherwise = JSAccessor prop
128+ | otherwise = JSAccessor prop
132−-- Generate code in the simplified Javascript intermediate representation for a value or expression.
131+ -- Generate code in the simplified Javascript intermediate representation for a value or expression.
134−valueToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
135− => ModuleName -> Expr Ann -> m JS
133+ valueToJs :: Expr Ann -> m JS
136−valueToJs m (Literal _ l) =
134+ valueToJs (Literal _ l) =
137− literalToValueJS m l
135+ literalToValueJS l
138−valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =
136+ valueToJs (Var (_, _, _, Just (IsConstructor _ [])) name) =
139− return $ JSAccessor "value" $ qualifiedToJS m id name
137+ return $ JSAccessor "value" $ qualifiedToJS id name
140−valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) =
138+ valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) =
141− return $ JSAccessor "create" $ qualifiedToJS m id name
139+ return $ JSAccessor "create" $ qualifiedToJS id name
142−valueToJs m (Accessor _ prop val) =
140+ valueToJs (Accessor _ prop val) =
143− accessorString prop <$> valueToJs m val
141+ accessorString prop <$> valueToJs val
144−valueToJs m (ObjectUpdate _ o ps) = do
142+ valueToJs (ObjectUpdate _ o ps) = do
145− obj <- valueToJs m o
143+ obj <- valueToJs o
146− sts <- mapM (sndM $ valueToJs m) ps
144+ sts <- mapM (sndM valueToJs) ps
147− extendObj obj sts
145+ extendObj obj sts
148−valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
146+ valueToJs e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
149− let args = unAbs e
147+ let args = unAbs e
150− in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
148+ in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
152− unAbs :: Expr Ann -> [Ident]
150+ unAbs :: Expr Ann -> [Ident]
153− unAbs (Abs _ arg val) = arg : unAbs val
151+ unAbs (Abs _ arg val) = arg : unAbs val
154− unAbs _ = []
152+ unAbs _ = []
155− assign :: Ident -> JS
153+ assign :: Ident -> JS
156− assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
154+ assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
157− (var name)
155+ (var name)
158−valueToJs m (Abs _ arg val) = do
156+ valueToJs (Abs _ arg val) = do
159− ret <- valueToJs m val
157+ ret <- valueToJs val
160− return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
158+ return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
161−valueToJs m e@App{} = do
159+ valueToJs e@App{} = do
162− let (f, args) = unApp e []
160+ let (f, args) = unApp e []
163− args' <- mapM (valueToJs m) args
161+ args' <- mapM valueToJs args
164− case f of
162+ case f of
165− Var (_, _, _, Just IsNewtype) _ -> return (head args')
163+ Var (_, _, _, Just IsNewtype) _ -> return (head args')
166− Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
164+ Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
167− return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
165+ return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
168− Var (_, _, _, Just IsTypeClassConstructor) name ->
166+ Var (_, _, _, Just IsTypeClassConstructor) name ->
169− return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
167+ return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
170− _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs m f
168+ _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs f
172− unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
170+ unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
173− unApp (App _ val arg) args = unApp val (arg : args)
171+ unApp (App _ val arg) args = unApp val (arg : args)
174− unApp other args = (other, args)
172+ unApp other args = (other, args)
175−valueToJs m (Var _ ident) =
173+ valueToJs (Var _ ident) =
176− return $ varToJs m ident
174+ return $ varToJs ident
177−valueToJs m (Case _ values binders) = do
175+ valueToJs (Case _ values binders) = do
178− vals <- mapM (valueToJs m) values
176+ vals <- mapM valueToJs values
179− bindersToJs m binders vals
177+ bindersToJs binders vals
180−valueToJs m (Let _ ds val) = do
178+ valueToJs (Let _ ds val) = do
181− decls <- concat <$> mapM (bindToJs m) ds
179+ ds' <- concat <$> mapM bindToJs ds
182− ret <- valueToJs m val
180+ ret <- valueToJs val
183− return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
181+ return $ JSApp (JSFunction Nothing [] (JSBlock (ds' ++ [JSReturn ret]))) []
184−valueToJs _ (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
182+ valueToJs (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
185− return $ JSVariableIntroduction ctor (Just $
183+ return $ JSVariableIntroduction ctor (Just $
186− JSObjectLiteral [("create",
184+ JSObjectLiteral [("create",
187− JSFunction Nothing ["value"]
185+ JSFunction Nothing ["value"]
188− (JSBlock [JSReturn $ JSVar "value"]))])
186+ (JSBlock [JSReturn $ JSVar "value"]))])
189−valueToJs _ (Constructor _ _ (ProperName ctor) []) =
187+ valueToJs (Constructor _ _ (ProperName ctor) []) =
190− return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
188+ return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
191− , JSAssignment (JSAccessor "value" (JSVar ctor))
189+ , JSAssignment (JSAccessor "value" (JSVar ctor))
192− (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
190+ (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
193−valueToJs _ (Constructor _ _ (ProperName ctor) fields) =
191+ valueToJs (Constructor _ _ (ProperName ctor) fields) =
194− let constructor =
192+ let constructor =
195− let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]
193+ let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]
196− in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)
194+ in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)
197− createFn =
195+ createFn =
198− let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)
196+ let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)
199− in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields
197+ in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields
200− in return $ iife ctor [ constructor
198+ in return $ iife ctor [ constructor
201− , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn
199+ , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn
204−iife :: String -> [JS] -> JS
202+ iife :: String -> [JS] -> JS
205−iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
203+ iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
207−literalToValueJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
208− => ModuleName -> Literal (Expr Ann) -> m JS
205+ literalToValueJS :: Literal (Expr Ann) -> m JS
209−literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n
206+ literalToValueJS (NumericLiteral n) = return $ JSNumericLiteral n
210−literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s
207+ literalToValueJS (StringLiteral s) = return $ JSStringLiteral s
211−literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b
208+ literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b
212−literalToValueJS m (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs m) xs
209+ literalToValueJS (ArrayLiteral xs) = JSArrayLiteral <$> mapM valueToJs xs
213−literalToValueJS m (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs m)) ps
210+ literalToValueJS (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM valueToJs) ps
216−-- Shallow copy an object.
213+ -- Shallow copy an object.
218−extendObj :: (Applicative m, Monad m, MonadSupply m) => JS -> [(String, JS)] -> m JS
215+ extendObj :: JS -> [(String, JS)] -> m JS
219−extendObj obj sts = do
216+ extendObj obj sts = do
220− newObj <- freshName
217+ newObj <- freshName
221− key <- freshName
218+ key <- freshName
223− jsKey = JSVar key
220+ jsKey = JSVar key
224− jsNewObj = JSVar newObj
221+ jsNewObj = JSVar newObj
225− block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
222+ block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
226− objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
223+ objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
227− copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
224+ copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
228− cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
225+ cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
229− assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
226+ assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
230− stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
227+ stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
231− extend = map stToAssign sts
228+ extend = map stToAssign sts
232− return $ JSApp (JSFunction Nothing [] block) []
229+ return $ JSApp (JSFunction Nothing [] block) []
235−-- Generate code in the simplified Javascript intermediate representation for a reference to a
232+ -- Generate code in the simplified Javascript intermediate representation for a reference to a
236−-- variable.
233+ -- variable.
238−varToJs :: ModuleName -> Qualified Ident -> JS
235+ varToJs :: Qualified Ident -> JS
239−varToJs _ (Qualified Nothing ident) = var ident
236+ varToJs (Qualified Nothing ident) = var ident
240−varToJs m qual = qualifiedToJS m id qual
237+ varToJs qual = qualifiedToJS id qual
243−-- Generate code in the simplified Javascript intermediate representation for a reference to a
240+ -- Generate code in the simplified Javascript intermediate representation for a reference to a
244−-- variable that may have a qualified name.
241+ -- variable that may have a qualified name.
246−qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS
243+ qualifiedToJS :: (a -> Ident) -> Qualified a -> JS
247−qualifiedToJS _ f (Qualified (Just (ModuleName [ProperName mn])) a) | mn == C.prim = JSVar . runIdent $ f a
244+ qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar . runIdent $ f a
248−qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m'))
245+ qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn'))
249−qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
246+ qualifiedToJS f (Qualified _ a) = JSVar $ identToJs (f a)
252−-- Generate code in the simplified Javascript intermediate representation for pattern match binders
249+ -- Generate code in the simplified Javascript intermediate representation for pattern match binders
253−-- and guards.
250+ -- and guards.
255−bindersToJs :: forall m mode. (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
256− => ModuleName -> [CaseAlternative Ann] -> [JS] -> m JS
252+ bindersToJs :: [CaseAlternative Ann] -> [JS] -> m JS
257−bindersToJs m binders vals = do
253+ bindersToJs binders vals = do
258− valNames <- replicateM (length vals) freshName
254+ valNames <- replicateM (length vals) freshName
259− let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
255+ let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
260− jss <- forM binders $ \(CaseAlternative bs result) -> do
256+ jss <- forM binders $ \(CaseAlternative bs result) -> do
261− ret <- guardsToJs result
257+ ret <- guardsToJs result
262− go valNames ret bs
258+ go valNames ret bs
263− return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))
259+ return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))
266− go :: [String] -> [JS] -> [Binder Ann] -> m [JS]
262+ go :: [String] -> [JS] -> [Binder Ann] -> m [JS]
267− go _ done [] = return done
263+ go _ done [] = return done
268− go (v:vs) done' (b:bs) = do
264+ go (v:vs) done' (b:bs) = do
269− done'' <- go vs done' bs
265+ done'' <- go vs done' bs
270− binderToJs m v done'' b
266+ binderToJs v done'' b
271− go _ _ _ = error "Invalid arguments to bindersToJs"
267+ go _ _ _ = error "Invalid arguments to bindersToJs"
273− guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]
269+ guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]
274− guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
270+ guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
275− cond' <- valueToJs m cond
271+ cond' <- valueToJs cond
276− done <- valueToJs m val
272+ done <- valueToJs val
277− return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
273+ return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
278− guardsToJs (Right v) = return . JSReturn <$> valueToJs m v
274+ guardsToJs (Right v) = return . JSReturn <$> valueToJs v
281−-- Generate code in the simplified Javascript intermediate representation for a pattern match
277+ -- Generate code in the simplified Javascript intermediate representation for a pattern match
282−-- binder.
278+ -- binder.
284−binderToJs :: forall m mode. (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
285− => ModuleName -> String -> [JS] -> Binder Ann -> m [JS]
280+ binderToJs :: String -> [JS] -> Binder Ann -> m [JS]
286−binderToJs _ _ done (NullBinder{}) = return done
281+ binderToJs _ done (NullBinder{}) = return done
287−binderToJs m varName done (LiteralBinder _ l) =
282+ binderToJs varName done (LiteralBinder _ l) =
288− literalToBinderJS m varName done l
283+ literalToBinderJS varName done l
289−binderToJs _ varName done (VarBinder _ ident) =
284+ binderToJs varName done (VarBinder _ ident) =
290− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
285+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
291−binderToJs m varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
286+ binderToJs varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
292− binderToJs m varName done b
287+ binderToJs varName done b
293−binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
288+ binderToJs varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
294− js <- go (zip fields bs) done
289+ js <- go (zip fields bs) done
295− return $ case ctorType of
290+ return $ case ctorType of
296− ProductType -> js
291+ ProductType -> js
297− SumType ->
292+ SumType ->
298− [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))
293+ [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS (Ident . runProperName) ctor))
299− (JSBlock js)
294+ (JSBlock js)
300− Nothing]
295+ Nothing]
302− go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]
297+ go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]
303− go [] done' = return done'
298+ go [] done' = return done'
304− go ((field, binder) : remain) done' = do
299+ go ((field, binder) : remain) done' = do
305− argVar <- freshName
300+ argVar <- freshName
306− done'' <- go remain done'
301+ done'' <- go remain done'
307− js <- binderToJs m argVar done'' binder
302+ js <- binderToJs argVar done'' binder
308− return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)
303+ return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)
309−binderToJs m varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do
304+ binderToJs varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do
310− let (headBinders, tailBinder) = uncons [] binder
305+ let (headBinders, tailBinder) = uncons [] binder
311− numberOfHeadBinders = fromIntegral $ length headBinders
306+ numberOfHeadBinders = fromIntegral $ length headBinders
312− js1 <- foldM (\done' (headBinder, index) -> do
307+ js1 <- foldM (\done' (headBinder, index) -> do
313− headVar <- freshName
308+ headVar <- freshName
314− jss <- binderToJs m headVar done' headBinder
309+ jss <- binderToJs headVar done' headBinder
315− return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])
310+ return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])
316− tailVar <- freshName
311+ tailVar <- freshName
317− js2 <- binderToJs m tailVar js1 tailBinder
312+ js2 <- binderToJs tailVar js1 tailBinder
318− return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock
313+ return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock
319− ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :
314+ ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :
321− )) Nothing]
316+ )) Nothing]
323− uncons :: [Binder Ann] -> Binder Ann -> ([Binder Ann], Binder Ann)
318+ uncons :: [Binder Ann] -> Binder Ann -> ([Binder Ann], Binder Ann)
324− uncons acc (ConstructorBinder _ _ ctor' [h, t]) | isCons ctor' = uncons (h : acc) t
319+ uncons acc (ConstructorBinder _ _ ctor' [h, t]) | isCons ctor' = uncons (h : acc) t
325− uncons acc tailBinder = (reverse acc, tailBinder)
320+ uncons acc tailBinder = (reverse acc, tailBinder)
326−binderToJs _ _ _ b@(ConstructorBinder{}) =
321+ binderToJs _ _ b@(ConstructorBinder{}) =
327− error $ "Invalid ConstructorBinder in binderToJs: " ++ show b
322+ error $ "Invalid ConstructorBinder in binderToJs: " ++ show b
328−binderToJs m varName done (NamedBinder _ ident binder) = do
323+ binderToJs varName done (NamedBinder _ ident binder) = do
329− js <- binderToJs m varName done binder
324+ js <- binderToJs varName done binder
330− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
325+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
332−literalToBinderJS :: forall m mode. (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
333− => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> m [JS]
327+ literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]
334−literalToBinderJS _ varName done (NumericLiteral num) =
328+ literalToBinderJS varName done (NumericLiteral num) =
335− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
329+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
336−literalToBinderJS _ varName done (StringLiteral str) =
330+ literalToBinderJS varName done (StringLiteral str) =
337− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
331+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
338−literalToBinderJS _ varName done (BooleanLiteral True) =
332+ literalToBinderJS varName done (BooleanLiteral True) =
339− return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
333+ return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
340−literalToBinderJS _ varName done (BooleanLiteral False) =
334+ literalToBinderJS varName done (BooleanLiteral False) =
341− return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
335+ return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
342−literalToBinderJS m varName done (ObjectLiteral bs) = go done bs
336+ literalToBinderJS varName done (ObjectLiteral bs) = go done bs
344− go :: [JS] -> [(String, Binder Ann)] -> m [JS]
338+ go :: [JS] -> [(String, Binder Ann)] -> m [JS]
345− go done' [] = return done'
339+ go done' [] = return done'
346− go done' ((prop, binder):bs') = do
340+ go done' ((prop, binder):bs') = do
347− propVar <- freshName
341+ propVar <- freshName
348− done'' <- go done' bs'
342+ done'' <- go done' bs'
349− js <- binderToJs m propVar done'' binder
343+ js <- binderToJs propVar done'' binder
350− return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
344+ return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
351−literalToBinderJS m varName done (ArrayLiteral bs) = do
345+ literalToBinderJS varName done (ArrayLiteral bs) = do
352− js <- go done 0 bs
346+ js <- go done 0 bs
353− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
347+ return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
355− go :: [JS] -> Integer -> [Binder Ann] -> m [JS]
349+ go :: [JS] -> Integer -> [Binder Ann] -> m [JS]
356− go done' _ [] = return done'
350+ go done' _ [] = return done'
357− go done' index (binder:bs') = do
351+ go done' index (binder:bs') = do
358− elVar <- freshName
352+ elVar <- freshName
359− done'' <- go done' (index + 1) bs'
353+ done'' <- go done' (index + 1) bs'
360− js <- binderToJs m elVar done'' binder
354+ js <- binderToJs elVar done'' binder
361− return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
355+ return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
363−isCons :: Qualified ProperName -> Bool
357+ isCons :: Qualified ProperName -> Bool
364−isCons (Qualified (Just mn) ctor) = mn == ModuleName [ProperName C.prim] && ctor == ProperName "Array"
358+ isCons (Qualified (Just mn') ctor) = mn' == ModuleName [ProperName C.prim] && ctor == ProperName "Array"
365−isCons name = error $ "Unexpected argument in isCons: " ++ show name
359+ isCons name = error $ "Unexpected argument in isCons: " ++ show name