@@ -13,32 +13,29 @@
1313--
1414-----------------------------------------------------------------------------
1515
16−{-# LANGUAGE GADTs, DoAndIfThenElse #-}
16+{-# LANGUAGE GADTs #-}
1717
1818module Language.PureScript.CodeGen.JS (
1919 module AST,
20− declToJs,
21− moduleToJs,
22− identNeedsEscaping
20+ module Common,
21+ bindToJs,
22+ moduleToJs
2323) where
2424
25−import Data.Maybe (catMaybes)
2625import Data.Function (on)
27−import Data.List (nub, (\\), delete, sortBy)
26+import Data.List ((\\), delete, sortBy)
27+import Data.Maybe (catMaybes, mapMaybe)
2828
29−import qualified Data.Map as M
30−
31−import Control.Monad (foldM, replicateM, forM)
3229import Control.Applicative
33−import Control.Arrow (second)
30+import Control.Arrow ((&&&))
31+import Control.Monad (foldM, replicateM, forM)
3432
33+import Language.PureScript.CodeGen.JS.AST as AST
34+import Language.PureScript.CodeGen.JS.Common as Common
35+import Language.PureScript.CoreFn
3536import Language.PureScript.Names
36−import Language.PureScript.AST
37+import Language.PureScript.CodeGen.JS.Optimizer
3738import Language.PureScript.Options
38−import Language.PureScript.CodeGen.JS.AST as AST
39−import Language.PureScript.Optimizer
40−import Language.PureScript.CodeGen.Common
41−import Language.PureScript.Environment
4239import Language.PureScript.Supply
4340import Language.PureScript.Traversals (sndM)
4441import qualified Language.PureScript.Constants as C
@@ -47,25 +44,28 @@ import qualified Language.PureScript.Constants as C
4744-- Generate code in the simplified Javascript intermediate representation for all declarations in a
4845-- module.
4946--
50−moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module -> Environment -> SupplyT m [JS]
51−moduleToJs opts (Module name decls (Just exps)) env = do
52− let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls
53− jsDecls <- mapM (\decl -> declToJs opts name decl env) decls
54− let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls
47+moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module Ann -> SupplyT m [JS]
48+moduleToJs opts (Module name imps exps foreigns decls) = do
49+ let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps
50+ let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
51+ jsDecls <- mapM (bindToJs name) decls
52+ let optimized = concatMap (map $ optimize opts) $ catMaybes jsDecls
5553 let isModuleEmpty = null exps
56− let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized
57− let moduleExports = JSObjectLiteral . map (second var) . M.toList . M.unions $ map exportToJs exps
54+ let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ optimized
55+ let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps
5856 return $ case optionsAdditional opts of
59− MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
57+ MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
6058 CompileOptions ns _ _ | not isModuleEmpty ->
6159 [ JSVariableIntroduction ns
6260 (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )
6361 , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))
64− (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
62+ (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn exps']))) [])
6563 ]
6664 _ -> []
67−moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring"
6865
66+-- |
67+-- Generates Javascript code for a module import.
68+--
6969importToJs :: Options mode -> ModuleName -> JS
7070importToJs opts mn =
7171 JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
@@ -74,95 +74,18 @@ importToJs opts mn =
7474 MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
7575 CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)
7676
77−imports :: Declaration -> [ModuleName]
78−imports (ImportDeclaration mn _ _) = [mn]
79−imports other =
80− let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])
81− in f other
82− where
83− collectV :: Expr -> [ModuleName]
84− collectV (Var (Qualified (Just mn) _)) = [mn]
85− collectV (Constructor (Qualified (Just mn) _)) = [mn]
86− collectV (TypeClassDictionaryConstructorApp (Qualified (Just mn) _) _) = [mn]
87− collectV _ = []
88− collectB :: Binder -> [ModuleName]
89− collectB (ConstructorBinder (Qualified (Just mn) _) _) = [mn]
90− collectB _ = []
91−
9277-- |
9378-- Generate code in the simplified Javascript intermediate representation for a declaration
9479--
95−declToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])
96−declToJs opts mp (ValueDeclaration ident _ _ (Right val)) e = do
97− js <- valueToJs opts mp e val
80+bindToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Bind Ann -> SupplyT m (Maybe [JS])
81+bindToJs mp (NonRec ident val) = do
82+ js <- valueToJs mp val
9883 return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]
99−declToJs opts mp (BindingGroupDeclaration vals) e = do
100− jss <- forM vals $ \(ident, _, val) -> do
101− js <- valueToJs opts mp e val
84+bindToJs mp (Rec vals) = do
85+ jss <- forM vals $ \(ident, val) -> do
86+ js <- valueToJs mp val
10287 return $ JSVariableIntroduction (identToJs ident) (Just js)
10388 return $ Just jss
104−declToJs _ _ (DataDeclaration Newtype _ _ [((ProperName ctor), _)]) _ =
105− return $ Just $ [JSVariableIntroduction ctor (Just $
106− JSObjectLiteral [("create",
107− JSFunction Nothing ["value"]
108− (JSBlock [JSReturn $ JSVar "value"]))])]
109−declToJs _ _ (DataDeclaration Newtype _ _ _) _ =
110− error "newtype has multiple constructors"
111−declToJs _ mp (DataDeclaration Data _ _ ctors) e = do
112− return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->
113− let propName = if isNullaryConstructor e (Qualified (Just mp) pn) then "value" else "create"
114− in [ makeConstructor ctor (length tys)
115− , JSAssignment (JSAccessor propName (JSVar ctor)) (go pn 0 (length tys) [])
116− ]
117− where
118− makeConstructor :: String -> Int -> JS
119− makeConstructor ctorName n =
120− let
121− args = [ "value" ++ show index | index <- [0..n-1] ]
122− body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]
123− in JSFunction (Just ctorName) args (JSBlock body)
124− go :: ProperName -> Int -> Int -> [JS] -> JS
125− go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar $ runProperName pn) (reverse values)
126− go pn index n values =
127− JSFunction Nothing ["value" ++ show index]
128− (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))])
129−declToJs opts mp (DataBindingGroupDeclaration ds) e = do
130− jss <- mapM (\decl -> declToJs opts mp decl e) ds
131− return $ Just $ concat $ catMaybes jss
132−declToJs _ _ (TypeClassDeclaration name _ supers members) _ =
133− return $ Just $ [
134− JSFunction (Just $ runProperName name) (identToJs `map` args)
135− (JSBlock $ assn `map` args)]
136− where
137− assn :: Ident -> JS
138− assn arg = JSAssignment (accessor arg (JSVar "this")) (var arg)
139− args :: [Ident]
140− args = sortBy (compare `on` runIdent) $ memberNames ++ superNames
141− memberNames :: [Ident]
142− memberNames = memberToName `map` members
143− superNames :: [Ident]
144− superNames = [ toSuperName superclass index
145− | (index, (superclass, _)) <- zip [0..] supers
146− ]
147− toSuperName :: Qualified ProperName -> Integer -> Ident
148− toSuperName pn index = Ident $ C.__superclass_ ++ show pn ++ "_" ++ show index
149− memberToName :: Declaration -> Ident
150− memberToName (TypeDeclaration ident _) = ident
151− memberToName (PositionedDeclaration _ d) = memberToName d
152− memberToName _ = error "Invalid declaration in type class definition"
153−declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]
154−declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e
155−declToJs _ _ _ _ = return Nothing
156−
157−-- |
158−-- Generate key//value pairs for an object literal exporting values from a module.
159−--
160−exportToJs :: DeclarationRef -> M.Map String Ident
161−exportToJs (TypeRef _ (Just dctors)) = M.fromList [ (n, Ident n) | (ProperName n) <- dctors ]
162−exportToJs (ValueRef name) = M.singleton (runIdent name) name
163−exportToJs (TypeInstanceRef name) = M.singleton (runIdent name) name
164−exportToJs (TypeClassRef name) = M.singleton (runProperName name) (Ident $ runProperName name)
165−exportToJs _ = M.empty
16689
16790-- |
16891-- Generate code in the simplified Javascript intermediate representation for a variable based on a
@@ -187,54 +110,89 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
187110-- |
188111-- Generate code in the simplified Javascript intermediate representation for a value or expression.
189112--
190−valueToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> Expr -> SupplyT m JS
191−valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
192−valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
193−valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
194−valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs
195−valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps
196−valueToJs opts m e (TypeClassDictionaryConstructorApp name (TypedValue _ (ObjectLiteral ps) _)) =
197− JSUnary JSNew . JSApp (qualifiedToJS m (Ident . runProperName) name) <$> mapM (valueToJs opts m e . snd) (sortBy (compare `on` fst) ps)
198−valueToJs _ _ _ TypeClassDictionaryConstructorApp{} =
199− error "TypeClassDictionaryConstructorApp did not contain object literal"
200−valueToJs opts m e (ObjectUpdate o ps) = do
201− obj <- valueToJs opts m e o
202− sts <- mapM (sndM (valueToJs opts m e)) ps
113+valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS
114+valueToJs m (Literal _ l) =
115+ literalToValueJS m l
116+valueToJs m (Var (_, _, Just (IsConstructor _ 0)) name) =
117+ return $ JSAccessor "value" $ qualifiedToJS m id name
118+valueToJs m (Var (_, _, Just (IsConstructor _ _)) name) =
119+ return $ JSAccessor "create" $ qualifiedToJS m id name
120+valueToJs m (Accessor _ prop val) =
121+ accessorString prop <$> valueToJs m val
122+valueToJs m (ObjectUpdate _ o ps) = do
123+ obj <- valueToJs m o
124+ sts <- mapM (sndM (valueToJs m)) ps
203125 extendObj obj sts
204−valueToJs _ m e (Constructor name) =
205− let propName = if isNullaryConstructor e name then "value" else "create"
206− in return $ JSAccessor propName $ qualifiedToJS m (Ident . runProperName) name
207−valueToJs opts m e (Case values binders) = do
208− vals <- mapM (valueToJs opts m e) values
209− bindersToJs opts m e binders vals
210−valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el
211−valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val
212−valueToJs opts m e v@App{} = do
213− let (f, args) = unApp v []
214− args' <- mapM (valueToJs opts m e) args
126+valueToJs _ e@(Abs (_, _, Just IsTypeClassConstructor) _ val) =
127+ let args = unAbs e
128+ in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
129+ where
130+ unAbs :: Expr Ann -> [Ident]
131+ unAbs (Abs _ arg val) = arg : unAbs val
132+ unAbs _ = []
133+ assign :: Ident -> JS
134+ assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
135+ (var name)
136+valueToJs m (Abs _ arg val) = do
137+ ret <- valueToJs m val
138+ return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
139+valueToJs m e@App{} = do
140+ let (f, args) = unApp e []
141+ args' <- mapM (valueToJs m) args
215142 case f of
216− Constructor name | isNewtypeConstructor e name && length args == 1 -> return (head args')
217− Constructor name | getConstructorArity e name == length args ->
218− return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'
219− _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f
143+ Var (_, _, Just IsNewtype) _ -> return (head args')
144+ Var (_, _, Just (IsConstructor _ arity)) name | arity == length args ->
145+ return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
146+ Var (_, _, Just IsTypeClassConstructor) name ->
147+ return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
148+ _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs m f
220149 where
221− unApp :: Expr -> [Expr] -> (Expr, [Expr])
222− unApp (App val arg) args = unApp val (arg : args)
223− unApp (PositionedValue _ val) args = unApp val args
224− unApp (TypedValue _ val _) args = unApp val args
150+ unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
151+ unApp (App _ val arg) args = unApp val (arg : args)
225152 unApp other args = (other, args)
226−valueToJs opts m e (Let ds val) = do
227− decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds
228− ret <- valueToJs opts m e val
153+valueToJs m (Var _ ident) =
154+ return $ varToJs m ident
155+valueToJs m (Case _ values binders) = do
156+ vals <- mapM (valueToJs m) values
157+ bindersToJs m binders vals
158+valueToJs m (Let _ ds val) = do
159+ decls <- concat . catMaybes <$> mapM (bindToJs m) ds
160+ ret <- valueToJs m val
229161 return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
230−valueToJs opts m e (Abs (Left arg) val) = do
231− ret <- valueToJs opts m e val
232− return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
233−valueToJs _ m _ (Var ident) = return $ varToJs m ident
234−valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
235−valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val
236−valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"
237−valueToJs _ _ _ _ = error "Invalid argument to valueToJs"
162+valueToJs _ (Constructor (_, _, Just IsNewtype) _ (ProperName ctor) _) =
163+ return $ JSVariableIntroduction ctor (Just $
164+ JSObjectLiteral [("create",
165+ JSFunction Nothing ["value"]
166+ (JSBlock [JSReturn $ JSVar "value"]))])
167+valueToJs _ (Constructor _ _ (ProperName ctor) 0) =
168+ return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
169+ , JSAssignment (JSAccessor "value" (JSVar ctor))
170+ (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
171+valueToJs _ (Constructor _ _ (ProperName ctor) arity) =
172+ return $ iife ctor [ makeConstructor ctor arity
173+ , JSAssignment (JSAccessor "create" (JSVar ctor)) (go ctor 0 arity [])
174+ ]
175+ where
176+ makeConstructor :: String -> Int -> JS
177+ makeConstructor ctorName n =
178+ let args = [ "value" ++ show index | index <- [0..n-1] ]
179+ body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]
180+ in JSFunction (Just ctorName) args (JSBlock body)
181+ go :: String -> Int -> Int -> [JS] -> JS
182+ go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar pn) (reverse values)
183+ go pn index n values =
184+ JSFunction Nothing ["value" ++ show index]
185+ (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))])
186+
187+iife :: String -> [JS] -> JS
188+iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
189+
190+literalToValueJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Literal (Expr Ann) -> SupplyT m JS
191+literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n
192+literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s
193+literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b
194+literalToValueJS m (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs m) xs
195+literalToValueJS m (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs m)) ps
238196
239197-- |
240198-- Shallow copy an object.
@@ -276,109 +234,111 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
276234-- Generate code in the simplified Javascript intermediate representation for pattern match binders
277235-- and guards.
278236--
279−bindersToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS
280−bindersToJs opts m e binders vals = do
237+bindersToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS
238+bindersToJs m binders vals = do
281239 valNames <- replicateM (length vals) freshName
282240 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
283241 jss <- forM binders $ \(CaseAlternative bs result) -> do
284242 ret <- guardsToJs result
285243 go valNames ret bs
286− return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") $ [JSStringLiteral "Failed pattern match"]])))
244+ return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))
287245 []
288246 where
289− go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> SupplyT m [JS]
247+ go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]
290248 go _ done [] = return done
291249 go (v:vs) done' (b:bs) = do
292250 done'' <- go vs done' bs
293− binderToJs m e v done'' b
251+ binderToJs m v done'' b
294252 go _ _ _ = error "Invalid arguments to bindersToJs"
295253
296− guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard, Expr)] Expr -> SupplyT m [JS]
254+ guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]
297255 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
298− cond' <- valueToJs opts m e cond
299− done <- valueToJs opts m e val
256+ cond' <- valueToJs m cond
257+ done <- valueToJs m val
300258 return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
301− guardsToJs (Right v) = return . JSReturn <$> valueToJs opts m e v
259+ guardsToJs (Right v) = return . JSReturn <$> valueToJs m v
302260
303261-- |
304262-- Generate code in the simplified Javascript intermediate representation for a pattern match
305263-- binder.
306264--
307−binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Environment -> String -> [JS] -> Binder -> SupplyT m [JS]
308−binderToJs _ _ _ done NullBinder = return done
309−binderToJs _ _ varName done (StringBinder str) =
310− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
311−binderToJs _ _ varName done (NumberBinder num) =
312− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
313−binderToJs _ _ varName done (BooleanBinder True) =
314− return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
315−binderToJs _ _ varName done (BooleanBinder False) =
316− return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
317−binderToJs _ _ varName done (VarBinder ident) =
265+binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]
266+binderToJs _ _ done (NullBinder{}) = return done
267+binderToJs m varName done (LiteralBinder _ l) =
268+ literalToBinderJS m varName done l
269+binderToJs _ varName done (VarBinder _ ident) =
318270 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
319−binderToJs m e varName done (ConstructorBinder ctor bs) | isNewtypeConstructor e ctor =
320− case bs of
321− [b] -> binderToJs m e varName done b
322− _ -> error "binder for newtype constructor should have a single argument"
323−binderToJs m e varName done (ConstructorBinder ctor bs) = do
271+binderToJs m varName done (ConstructorBinder (_, _, Just IsNewtype) _ _ [b]) =
272+ binderToJs m varName done b
273+binderToJs m varName done (ConstructorBinder (_, _, Just (IsConstructor ctorType _)) _ ctor bs) = do
324274 js <- go 0 done bs
325− if isOnlyConstructor e ctor
326− then
327− return js
328− else
329− return [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))
330− (JSBlock js)
331− Nothing]
275+ return $ case ctorType of
276+ ProductType -> js
277+ SumType ->
278+ [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))
279+ (JSBlock js)
280+ Nothing]
332281 where
333− go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder] -> SupplyT m [JS]
282+ go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder Ann] -> SupplyT m [JS]
334283 go _ done' [] = return done'
335284 go index done' (binder:bs') = do
336285 argVar <- freshName
337286 done'' <- go (index + 1) done' bs'
338− js <- binderToJs m e argVar done'' binder
287+ js <- binderToJs m argVar done'' binder
339288 return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js)
340−binderToJs m e varName done (ObjectBinder bs) = go done bs
341− where
342− go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]
343− go done' [] = return done'
344− go done' ((prop, binder):bs') = do
345− propVar <- freshName
346− done'' <- go done' bs'
347− js <- binderToJs m e propVar done'' binder
348− return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
349−binderToJs m e varName done (ArrayBinder bs) = do
350− js <- go done 0 bs
351− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
352− where
353− go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder] -> SupplyT m [JS]
354− go done' _ [] = return done'
355− go done' index (binder:bs') = do
356− elVar <- freshName
357− done'' <- go done' (index + 1) bs'
358− js <- binderToJs m e elVar done'' binder
359− return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
360−binderToJs m e varName done binder@(ConsBinder _ _) = do
289+binderToJs m varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do
361290 let (headBinders, tailBinder) = uncons [] binder
362291 numberOfHeadBinders = fromIntegral $ length headBinders
363292 js1 <- foldM (\done' (headBinder, index) -> do
364293 headVar <- freshName
365− jss <- binderToJs m e headVar done' headBinder
294+ jss <- binderToJs m headVar done' headBinder
366295 return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])
367296 tailVar <- freshName
368− js2 <- binderToJs m e tailVar js1 tailBinder
297+ js2 <- binderToJs m tailVar js1 tailBinder
369298 return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock
370299 ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :
371300 js2
372301 )) Nothing]
373302 where
374− uncons :: [Binder] -> Binder -> ([Binder], Binder)
375− uncons acc (ConsBinder h t) = uncons (h : acc) t
376− uncons acc (PositionedBinder _ b) = uncons acc b
303+ uncons :: [Binder Ann] -> Binder Ann -> ([Binder Ann], Binder Ann)
304+ uncons acc (ConstructorBinder _ _ ctor' [h, t]) | isCons ctor' = uncons (h : acc) t
377305 uncons acc tailBinder = (reverse acc, tailBinder)
378−binderToJs m e varName done (NamedBinder ident binder) = do
379− js <- binderToJs m e varName done binder
306+binderToJs _ _ _ b@(ConstructorBinder{}) =
307+ error $ "Invalid ConstructorBinder in binderToJs: " ++ show b
308+binderToJs m varName done (NamedBinder _ ident binder) = do
309+ js <- binderToJs m varName done binder
380310 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
381−binderToJs m e varName done (PositionedBinder _ binder) =
382− binderToJs m e varName done binder
383311
312+literalToBinderJS :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]
313+literalToBinderJS _ varName done (NumericLiteral num) =
314+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
315+literalToBinderJS _ varName done (StringLiteral str) =
316+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
317+literalToBinderJS _ varName done (BooleanLiteral True) =
318+ return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
319+literalToBinderJS _ varName done (BooleanLiteral False) =
320+ return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
321+literalToBinderJS m varName done (ObjectLiteral bs) = go done bs
322+ where
323+ go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]
324+ go done' [] = return done'
325+ go done' ((prop, binder):bs') = do
326+ propVar <- freshName
327+ done'' <- go done' bs'
328+ js <- binderToJs m propVar done'' binder
329+ return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
330+literalToBinderJS m varName done (ArrayLiteral bs) = do
331+ js <- go done 0 bs
332+ return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
333+ where
334+ go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]
335+ go done' _ [] = return done'
336+ go done' index (binder:bs') = do
337+ elVar <- freshName
338+ done'' <- go done' (index + 1) bs'
339+ js <- binderToJs m elVar done'' binder
340+ return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
384341
342+isCons :: Qualified ProperName -> Bool
343+isCons (Qualified (Just mn) ctor) = mn == ModuleName [ProperName C.prim] && ctor == ProperName "Array"
344+isCons name = error $ "Unexpected argument in isCons: " ++ show name