git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Add named fields to data constructor representation
a74bae6Gary Burgess
src/Language/PureScript/CodeGen/JS.hs+14−17
compare with golang
unifiedsplit
@@ -81,7 +81,7 @@ bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val
81bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))
81bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))
82
82
83-- |
83-- |
84−-- Generate code in the simplified Javascript intermediate representation for a single non-recursive
84+-- Generate code in the simplified Javascript intermediate representation for a single non-recursive
85-- declaration.
85-- declaration.
86--
86--
87-- The main purpose of this function is to handle code generation for comments.
87-- The main purpose of this function is to handle code generation for comments.
@@ -92,7 +92,7 @@ nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) =
92nonRecToJS mp ident val = do
92nonRecToJS mp ident val = do
93 js <- valueToJs mp val
93 js <- valueToJs mp val
94 return $ JSVariableIntroduction (identToJs ident) (Just js)
94 return $ JSVariableIntroduction (identToJs ident) (Just js)
95−
95+
96
96
97-- |
97-- |
98-- Generate code in the simplified Javascript intermediate representation for a variable based on a
98-- Generate code in the simplified Javascript intermediate representation for a variable based on a
@@ -171,26 +171,23 @@ valueToJs _ (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
171 JSObjectLiteral [("create",
171 JSObjectLiteral [("create",
172 JSFunction Nothing ["value"]
172 JSFunction Nothing ["value"]
173 (JSBlock [JSReturn $ JSVar "value"]))])
173 (JSBlock [JSReturn $ JSVar "value"]))])
174−valueToJs _ (Constructor _ _ (ProperName ctor) 0) =
174+valueToJs _ (Constructor _ _ (ProperName ctor) []) =
175 return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
175 return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
176 , JSAssignment (JSAccessor "value" (JSVar ctor))
176 , JSAssignment (JSAccessor "value" (JSVar ctor))
177 (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
177 (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
178−valueToJs _ (Constructor _ _ (ProperName ctor) arity) =
178+valueToJs _ (Constructor _ _ (ProperName ctor) fields) =
179− return $ iife ctor [ makeConstructor ctor arity
179+ return $ iife ctor [ makeConstructor ctor fields
180− , JSAssignment (JSAccessor "create" (JSVar ctor)) (go ctor 0 arity [])
180+ , JSAssignment (JSAccessor "create" (JSVar ctor)) (makeCreateFn ctor fields)
181 ]
181 ]
182 where
182 where
183− makeConstructor :: String -> Int -> JS
183+ makeConstructor :: String -> [Ident] -> JS
184− makeConstructor ctorName n =
184+ makeConstructor ctorName fs =
185− let args = [ "value" ++ show index | index <- [0..n-1] ]
186− body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]
185+ let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fs ]
187− in JSFunction (Just ctorName) args (JSBlock body)
186+ in JSFunction (Just ctorName) (identToJs `map` fs) (JSBlock body)
188− go :: String -> Int -> Int -> [JS] -> JS
187+ makeCreateFn :: String -> [Ident] -> JS
188+ makeCreateFn ctorName fs =
189− go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar pn) (reverse values)
189+ let body = JSUnary JSNew $ JSApp (JSVar ctorName) (var `map` fs)
190− go pn index n values =
190+ in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields
191− JSFunction Nothing ["value" ++ show index]
192− (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))])
193−
194iife :: String -> [JS] -> JS
191iife :: String -> [JS] -> JS
195iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
192iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
196
193
src/Language/PureScript/CoreFn/Desugar.hs+2−1
@@ -104,7 +104,8 @@ declToCoreFn _ _ _ d@(A.DataDeclaration Newtype _ _ _) =
104 error $ "Found newtype with multiple constructors: " ++ show d
104 error $ "Found newtype with multiple constructors: " ++ show d
105declToCoreFn _ ss com (A.DataDeclaration Data tyName _ ctors) =
105declToCoreFn _ ss com (A.DataDeclaration Data tyName _ ctors) =
106 flip map ctors $ \(ctor, tys) ->
106 flip map ctors $ \(ctor, tys) ->
107+ let fields = (\n -> Ident $ "value_" ++ show n) `map` [0..length tys]
107− NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor (length tys)
108+ in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
108declToCoreFn env ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn env ss []) ds
109declToCoreFn env ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn env ss []) ds
109declToCoreFn env ss com (A.ValueDeclaration name _ _ (Right e)) =
110declToCoreFn env ss com (A.ValueDeclaration name _ _ (Right e)) =
110 [NonRec name (exprToCoreFn env ss com Nothing e)]
111 [NonRec name (exprToCoreFn env ss com Nothing e)]
src/Language/PureScript/CoreFn/Expr.hs+2−3
@@ -20,7 +20,6 @@ import qualified Data.Data as D
20
20
21import Language.PureScript.CoreFn.Binders
21import Language.PureScript.CoreFn.Binders
22import Language.PureScript.CoreFn.Literals
22import Language.PureScript.CoreFn.Literals
23−import Language.PureScript.CoreFn.Meta
24import Language.PureScript.Names
23import Language.PureScript.Names
25
24
26-- |
25-- |
@@ -32,9 +31,9 @@ data Expr a
32 --
31 --
33 = Literal a (Literal (Expr a))
32 = Literal a (Literal (Expr a))
34 -- |
33 -- |
35− -- A data constructor (type name, constructor name, arity)
34+ -- A data constructor (type name, constructor name, field names)
36 --
35 --
37− | Constructor a ProperName ProperName Arity
36+ | Constructor a ProperName ProperName [Ident]
38 -- |
37 -- |
39 -- A record property accessor
38 -- A record property accessor
40 --
39 --