@@ -138,8 +138,8 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
138 -- Generate code in the simplified Javascript intermediate representation for a declaration
138 -- Generate code in the simplified Javascript intermediate representation for a declaration
140 bindToJs :: Bind Ann -> m [JS]
140 bindToJs :: Bind Ann -> m [JS]
141− bindToJs (NonRec ann ident val) = nonRecToJS ann ident val
141+ bindToJs (NonRec ann ident val) = return <$> nonRecToJS ann ident val
142− bindToJs (Rec vals) = concat <$> forM vals (uncurry . uncurry $ nonRecToJS)
142+ bindToJs (Rec vals) = forM vals (uncurry . uncurry $ nonRecToJS)
145 -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
145 -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
@@ -147,22 +147,15 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
148 -- The main purpose of this function is to handle code generation for comments.
148 -- The main purpose of this function is to handle code generation for comments.
150− nonRecToJS :: Ann -> Ident -> Expr Ann -> m [JS]
150+ nonRecToJS :: Ann -> Ident -> Expr Ann -> m JS
151 nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
151 nonRecToJS a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
152 withoutComment <- asks optionsNoComments
152 withoutComment <- asks optionsNoComments
153 if withoutComment
153 if withoutComment
154 then nonRecToJS a i (modifyAnn removeComments e)
154 then nonRecToJS a i (modifyAnn removeComments e)
155− else withHead (JSComment Nothing com) <$> nonRecToJS a i (modifyAnn removeComments e)
155+ else JSComment Nothing com <$> nonRecToJS a i (modifyAnn removeComments e)
158− withHead f (x:xs) = f x : xs
159 nonRecToJS (ss, _, _, _) ident val = do
156 nonRecToJS (ss, _, _, _) ident val = do
160− case constructorToJs ident val of
162− traverse (withPos ss) jss
164− js <- valueToJs val
157+ js <- valueToJs val
165− return <$> (withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js))
158+ withPos ss $ JSVariableIntroduction Nothing (identToJs ident) (Just js)
167 withPos :: Maybe SourceSpan -> JS -> m JS
160 withPos :: Maybe SourceSpan -> JS -> m JS
168 withPos (Just ss) js = do
161 withPos (Just ss) js = do
@@ -258,37 +251,23 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
258 JSObjectLiteral Nothing [("create",
251 JSObjectLiteral Nothing [("create",
259 JSFunction Nothing Nothing ["value"]
252 JSFunction Nothing Nothing ["value"]
260 (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
253 (JSBlock Nothing [JSReturn Nothing $ JSVar Nothing "value"]))])
261− valueToJs' (Constructor _ _ (ProperName ctor) _) =
254+ valueToJs' (Constructor _ _ (ProperName ctor) []) =
262− internalError $ "Unexpected constructor definition: " ++ T.unpack ctor
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.
268− constructorToJs :: Ident -> Expr Ann -> Maybe [JS]
269− constructorToJs ident (Constructor _ _ (ProperName ctor) fs) =
272− mkAccessor name = JSAssignment Nothing (accessorString name (JSVar Nothing (identToJs ident)))
275− [ JSVariableIntroduction Nothing (identToJs ident) (Just $
276− JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing []))
255+ return $ iife (properToJs ctor) [ JSFunction Nothing (Just (properToJs ctor)) [] (JSBlock Nothing [])
277− , mkAccessor "value" $
256+ , JSAssignment Nothing (accessorString "value" (JSVar Nothing (properToJs ctor)))
278− JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (identToJs ident)) []
257+ (JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) []) ]
279− ]
258+ valueToJs' (Constructor _ _ (ProperName ctor) fields) =
281− let constructor =
259+ let constructor =
282− let body = [ JSAssignment Nothing ((accessorString $ mkString $ identToJs f) (JSVar Nothing "this")) (var f) | f <- fields ]
260+ 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)
261+ in JSFunction Nothing (Just (properToJs ctor)) (identToJs `map` fields) (JSBlock Nothing body)
284− createFn =
262+ createFn =
285− let body = JSUnary Nothing JSNew $ JSApp Nothing (JSVar Nothing (properToJs ctor)) (var `map` fields)
263+ 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
264+ in foldr (\f inner -> JSFunction Nothing Nothing [identToJs f] (JSBlock Nothing [JSReturn Nothing inner])) body fields
287− in [ constructor
265+ in return $ iife (properToJs ctor) [ constructor
288− , mkAccessor "create" createFn
266+ , JSAssignment Nothing (accessorString "create" (JSVar Nothing (properToJs ctor))) createFn
290− constructorToJs _ _ =
268+
291− Nothing
269+ iife :: Text -> [JS] -> JS
270+ iife v exprs = JSApp Nothing (JSFunction Nothing Nothing [] (JSBlock Nothing $ exprs ++ [JSReturn Nothing $ JSVar Nothing v])) []
293 literalToValueJS :: Literal (Expr Ann) -> m JS
272 literalToValueJS :: Literal (Expr Ann) -> m JS
294 literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)
273 literalToValueJS (NumericLiteral (Left i)) = return $ JSNumericLiteral Nothing (Left i)