169e4ad · rowtype-yoga/purescript-native

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

on golang help sign in

Update externs codegen for newtypes

169e4adGary Burgess12 years ago

src/Language/PureScript/CodeGen/Common.hs+53

compare with golang

unifiedsplit

@@ -17,7 +17,14 @@ module Language.PureScript.CodeGen.Common where

18import Data.Char

19import Data.List (intercalate)

20+import Data.Maybe (fromMaybe)

21+import Data.Function (on)

22+

23+import qualified Data.Map as M

24+

20import Language.PureScript.Names

25import Language.PureScript.Names

26+import Language.PureScript.Environment

27+import Language.PureScript.Types

22-- |

29-- |

23-- Convert an Ident into a valid Javascript identifier:

30-- Convert an Ident into a valid Javascript identifier:

@@ -138,3 +145,49 @@ nameIsJsReserved name =

138

145

139moduleNameToJs :: ModuleName -> String

146moduleNameToJs :: ModuleName -> String

140moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)

147moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)

148+

149+-- |

150+-- Finds the value stored for a data constructor in the current environment.

151+-- This is a partial function, but if an invalid type has reached this far then

152+-- something has gone wrong in typechecking.

153+--

154+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)

155+lookupConstructor e ctor = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e

156+

157+-- |

158+-- Checks whether a data constructor is the only constructor for that type, used

159+-- to simplify the check when generating code for binders.

160+--

161+isOnlyConstructor :: Environment -> Qualified ProperName -> Bool

162+isOnlyConstructor e ctor = numConstructors (ctor, lookupConstructor e ctor) == 1

163+ where

164+ numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int

165+ numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e

166+ typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)

167+ typeConstructor (Qualified (Just moduleName) _, (_, tyCtor, _)) = (moduleName, tyCtor)

168+ typeConstructor _ = error "Invalid argument to isOnlyConstructor"

169+

170+-- |

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

172+--

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

174+isNewtypeConstructor e ctor = case lookupConstructor e ctor of

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

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

177+

178+-- |

179+-- Checks the number of arguments a data constructor accepts.

180+--

181+getConstructorArity :: Environment -> Qualified ProperName -> Int

182+getConstructorArity e = go . (\(_, _, ctors) -> ctors) . lookupConstructor e

183+ where

184+ go :: Type -> Int

185+ go (TypeApp (TypeApp f _) t) | f == tyFunction = go t + 1

186+ go (ForAll _ ty _) = go ty

187+ go _ = 0

188+

189+-- |

190+-- Checks whether a data constructor has no arguments, for example, `Nothing`.

191+--

192+isNullaryConstructor :: Environment -> Qualified ProperName -> Bool

193+isNullaryConstructor e = (== 0) . getConstructorArity e

src/Language/PureScript/CodeGen/Externs.hs+5−1

@@ -24,6 +24,7 @@ import qualified Data.Map as M

25import Control.Monad.Writer

27+import Language.PureScript.CodeGen.Common

27import Language.PureScript.TypeClassDictionaries

28import Language.PureScript.TypeClassDictionaries

28import Language.PureScript.Declarations

29import Language.PureScript.Declarations

29import Language.PureScript.Pretty

30import Language.PureScript.Pretty

@@ -60,7 +61,10 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

60 printDctor dctor = case dctor `lookup` tys of

61 printDctor dctor = case dctor `lookup` tys of

61 Nothing -> Nothing

62 Nothing -> Nothing

62 Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)

63 Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)

64+ let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')

65+ then "newtype"

66+ else "data"

63− tell ["data " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]

67+ tell [dtype ++ " " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]

64 Just (_, TypeSynonym) ->

68 Just (_, TypeSynonym) ->

65 case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of

69 case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of

66 Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"

70 Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"

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

@@ -23,15 +23,13 @@ module Language.PureScript.CodeGen.JS (

23 identNeedsEscaping

24) where

26−import Data.Maybe (catMaybes, fromJust, fromMaybe)

26+import Data.Maybe (catMaybes, fromJust)

27import Data.Function (on)

28import Data.List (nub, (\\), delete, sortBy)

30import Control.Monad (replicateM, forM)

31import Control.Applicative

33−import qualified Data.Map as M

34−

35import Language.PureScript.Names

33import Language.PureScript.Names

36import Language.PureScript.Declarations

34import Language.PureScript.Declarations

37import Language.PureScript.Options

35import Language.PureScript.Options

@@ -407,49 +405,3 @@ binderToJs m e varName done (NamedBinder ident binder) = do

407 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

405 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

408binderToJs m e varName done (PositionedBinder _ binder) =

406binderToJs m e varName done (PositionedBinder _ binder) =

409 binderToJs m e varName done binder

407 binderToJs m e varName done binder

410−

411−-- |

412−-- Finds the value stored for a data constructor in the current environment.

413−-- This is a partial function, but if an invalid type has reached this far then

414−-- something has gone wrong in typechecking.

415−--

416−lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)

417−lookupConstructor e ctor = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e

418−

419−-- |

420−-- Checks whether a data constructor is the only constructor for that type, used

421−-- to simplify the check when generating code for binders.

422−--

423−isOnlyConstructor :: Environment -> Qualified ProperName -> Bool

424−isOnlyConstructor e ctor = numConstructors (ctor, lookupConstructor e ctor) == 1

425− where

426− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int

427− numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e

428− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)

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

430− typeConstructor _ = error "Invalid argument to isOnlyConstructor"

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−

440−-- |

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

442−--

443−getConstructorArity :: Environment -> Qualified ProperName -> Int

444−getConstructorArity e = go . (\(_, _, ctors) -> ctors) . lookupConstructor e

445− where

446− go :: Type -> Int

447− go (TypeApp (TypeApp f _) t) | f == tyFunction = go t + 1

448− go (ForAll _ ty _) = go ty

449− go _ = 0

450−

451−-- |

452−-- Checks whether a data constructor has no arguments, for example, `Nothing`.

453−--

454−isNullaryConstructor :: Environment -> Qualified ProperName -> Bool

455−isNullaryConstructor e = (== 0) . getConstructorArity e