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