@@ -138,8 +138,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
138138 -- Generate code in the simplified Javascript intermediate representation for a declaration
139139 --
140140 bindToJs :: Bind Ann -> m [JS]
141− bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val
142− bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)
141+ bindToJs (NonRec ann ident val) = nonRecToJS ann ident val
142+ bindToJs (Rec vals) = concat <$> forM vals (uncurry . uncurry $ nonRecToJS)
143143
144144 -- |
145145 -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
@@ -147,15 +147,22 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
147147 --
148148 -- The main purpose of this function is to handle code generation for comments.
149149 --
150− nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS
150+ nonRecToJS :: Ann -> Ident -> Expr Ann -> m [JS]
151151 nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
152152 withoutComment <- asks optionsNoComments
153153 if withoutComment
154154 then nonRecToJS a i (modifyAnn removeComments e)
155− else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
155+ else withHead (JSComment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e)
156+ where
157+ withHead _ [] = []
158+ withHead f (x:xs) = f x : xs
156159 nonRecToJS (ss, _, _, _) ident val = do
157− js <- valueToJs val
158− withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)
160+ case constructorToJs ident val of
161+ Just jss ->
162+ traverse (withPos ss) jss
163+ Nothing -> do
164+ js <- valueToJs val
165+ return <$> (withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js))
159166
160167 withPos :: Maybe SourceSpan -> JS -> m JS
161168 withPos (Just ss) js = do
@@ -251,23 +258,37 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
251258 JSObjectLiteral Nothing [("create",
252259 JSFunction Nothing Nothing ["value"]
253260 (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
254− valueToJs' (Constructor _ _ (ProperName ctor) []) =
255− return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])
256− , JSAssignment Nothing (accessorString "value" (JSVar Nothing (properToJs ctor)))
257− (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]
258− valueToJs' (Constructor _ _ (ProperName ctor) fields) =
259− let constructor =
260− let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
261− in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)
262− createFn =
263− let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)
264− in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
265− in return $ iife (properToJs ctor) [ constructor
266− , JSAssignment Nothing (accessorString "create" (JSVar Nothing (properToJs ctor))) createFn
267− ]
268−
269− iife :: Text -> [JS] -> JS
270− iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []
261+ valueToJs' (Constructor _ _ (ProperName ctor) _) =
262+ internalError $ "Unexpected constructor definition: " ++ T.unpack ctor
263+
264+ -- |
265+ -- Attempt to generate code in the simplified JS intermediate representation for a constructor definition.
266+ -- If the argument is not a constructor, this returns Nothing.
267+ --
268+ constructorToJs :: Ident -> Expr Ann -> Maybe [JS]
269+ constructorToJs ident (Constructor _ _ (ProperName ctor) fs) =
270+ Just jss
271+ where
272+ mkAccessor name = JSAssignment Nothing (accessorString name (JSVar Nothing (identToJs ident)))
273+ jss = case fs of
274+ [] ->
275+ [ JSVariableIntroduction Nothing (identToJs ident) (Just $
276+ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing []))
277+ , mkAccessor "value" $
278+ JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (identToJs ident)) []
279+ ]
280+ fields ->
281+ let constructor =
282+ let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
283+ in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)
284+ createFn =
285+ let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)
286+ in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
287+ in [ constructor
288+ , mkAccessor "create" createFn
289+ ]
290+ constructorToJs _ _ =
291+ Nothing
271292
272293 literalToValueJS :: Literal (Expr Ann) -> m JS
273294 literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)