da699d0 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Update codegen for newtypes

da699d0Gary Burgess12 years ago

examples/passing/Newtype.purs+4−1

compare with golang

unifiedsplit

@@ -12,8 +12,11 @@ newtype Box a = Box a

13instance showBox :: (Show a) => Show (Box a) where

14 show (Box x) = "Box " ++ show x

15−

15+

16+apply f x = f x

17+

16main = do

18main = do

17 print $ Thing "hello"

19 print $ Thing "hello"

18 print $ Box 42

20 print $ Box 42

21+ print $ apply Box 9000

19 trace "Done"

22 trace "Done"

src/Language/PureScript/CodeGen/JS.hs+21−1

@@ -106,7 +106,14 @@ declToJs opts mp (BindingGroupDeclaration vals) e = do

106 js <- valueToJs opts mp e val

107 return $ JSVariableIntroduction (identToJs ident) (Just js)

108 return $ Just jss

109+declToJs _ _ (DataDeclaration Newtype _ _ [((ProperName ctor), _)]) _ =

110+ return $ Just $ [JSVariableIntroduction ctor (Just $

111+ JSObjectLiteral [("create",

112+ JSFunction Nothing ["value"]

113+ (JSBlock [JSReturn $ JSVar "value"]))])]

114+declToJs _ _ (DataDeclaration Newtype _ _ _) _ =

115+ error "newtype has multiple constructors"

109−declToJs _ mp (DataDeclaration _ _ _ ctors) e = do

116+declToJs _ mp (DataDeclaration Data _ _ ctors) e = do

110 return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

117 return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

111 let propName = if isNullaryConstructor e (Qualified (Just mp) pn) then "value" else "create"

118 let propName = if isNullaryConstructor e (Qualified (Just mp) pn) then "value" else "create"

112 in [ makeConstructor ctor (length tys)

119 in [ makeConstructor ctor (length tys)

@@ -211,6 +218,7 @@ valueToJs opts m e v@App{} = do

211 let (f, args) = unApp v []

218 let (f, args) = unApp v []

212 args' <- mapM (valueToJs opts m e) args

219 args' <- mapM (valueToJs opts m e) args

213 case f of

220 case f of

221+ Constructor name | isNewtypeConstructor e name && length args == 1 -> return (head args')

214 Constructor name | getConstructorArity e name == length args ->

222 Constructor name | getConstructorArity e name == length args ->

215 return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'

223 return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'

216 _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f

224 _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f

@@ -343,6 +351,10 @@ binderToJs _ _ varName done (BooleanBinder False) =

343 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

351 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

344binderToJs _ _ varName done (VarBinder ident) =

352binderToJs _ _ varName done (VarBinder ident) =

345 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

353 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

354+binderToJs m e varName done (ConstructorBinder ctor bs) | isNewtypeConstructor e ctor =

355+ case bs of

356+ [b] -> binderToJs m e varName done b

357+ _ -> error "binder for newtype constructor should have a single argument"

346binderToJs m e varName done (ConstructorBinder ctor bs) = do

358binderToJs m e varName done (ConstructorBinder ctor bs) = do

347 js <- go 0 done bs

359 js <- go 0 done bs

348 if isOnlyConstructor e ctor

360 if isOnlyConstructor e ctor

@@ -417,6 +429,14 @@ isOnlyConstructor e ctor = numConstructors (ctor, lookupConstructor e ctor) == 1

417 typeConstructor (Qualified (Just moduleName) _, (_, tyCtor, _)) = (moduleName, tyCtor)

429 typeConstructor (Qualified (Just moduleName) _, (_, tyCtor, _)) = (moduleName, tyCtor)

418 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

430 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

419

431

432+-- |

433+-- Checks whether a data constructor is for a newtype.

434+--

435+isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool

436+isNewtypeConstructor e ctor = case lookupConstructor e ctor of

437+ (Newtype, _, _) -> True

438+ (Data, _, _) -> False

439+

420-- |

440-- |

421-- Checks the number of arguments a data constructor accepts.

441-- Checks the number of arguments a data constructor accepts.

422--

442--