18ba0fb · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #263 from garyb/master

18ba0fbPhil Freeman13 years ago

src/Language/PureScript/CodeGen/JS.hs+24−15

compare with golang

unifiedsplit

@@ -49,28 +49,29 @@ import qualified Language.PureScript.Constants as C

49-- module.

50--

51moduleToJs :: Options -> Module -> Environment -> Maybe JS

52−moduleToJs opts (Module name decls _) env =

52+moduleToJs opts (Module name decls (Just exps)) env =

53 case jsDecls of

54 [] -> Nothing

55 _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar C._ps)) $

56 JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))

57 [JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar C._ps)) (JSObjectLiteral [])]

58 where

59− jsDecls = concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls

59+ jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls)

60+ ++ concatMap exportToJs exps

61+moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring"

61-- |

63-- |

62-- Generate code in the simplified Javascript intermediate representation for a declaration

64-- Generate code in the simplified Javascript intermediate representation for a declaration

63--

65--

64declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]

66declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]

65declToJs opts mp (ValueDeclaration ident _ _ _ val) e =

67declToJs opts mp (ValueDeclaration ident _ _ _ val) e =

66− Just $ export ident $ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))

68+ Just [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]

67declToJs opts mp (BindingGroupDeclaration vals) e =

69declToJs opts mp (BindingGroupDeclaration vals) e =

68− Just $ concatMap (\(ident, _, val) ->

70+ Just $ flip concatMap vals $ \(ident, _, val) ->

69− export ident $ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))

71+ [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]

70− ) vals

71declToJs _ mp (DataDeclaration _ _ ctors) _ =

72declToJs _ mp (DataDeclaration _ _ ctors) _ =

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

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

73− export (Escaped ctor) $ JSVariableIntroduction ctor (Just (go pn 0 tys []))

74+ [JSVariableIntroduction ctor (Just (go pn 0 tys []))]

74 where

75 where

75 go :: ProperName -> Integer -> [Type] -> [JS] -> JS

76 go :: ProperName -> Integer -> [Type] -> [JS] -> JS

76 go pn _ [] values =

77 go pn _ [] values =

@@ -78,18 +79,26 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =

78 go pn index (_ : tys') values =

79 go pn index (_ : tys') values =

79 JSFunction Nothing ["value" ++ show index]

80 JSFunction Nothing ["value" ++ show index]

80 (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])

81 (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])

81−declToJs opts mp (DataBindingGroupDeclaration ds) e =

82+declToJs opts mp (DataBindingGroupDeclaration ds) e = Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds

82− Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds

83−declToJs _ _ (ExternDeclaration _ ident (Just js) _) _ =

83+declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = Just [js]

84− Just $ export ident js

85declToJs _ _ _ _ = Nothing

84declToJs _ _ _ _ = Nothing

87-- |

86-- |

88−-- Generate code in the simplified Javascript intermediate representation for exporting a

87+-- Generate code in the simplified Javascript intermediate representation for an export from a

89−-- declaration from a module.

88+-- module.

89+--

90+exportToJs :: DeclarationRef -> [JS]

91+exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Escaped . runProperName)

92+exportToJs (ValueRef name) = [export name]

93+exportToJs (TypeInstanceRef name _ _) = [export name]

94+exportToJs _ = []

95+

96+-- |

97+-- Generate code in the simplified Javascript intermediate representation for assigning an exported

98+-- value to the current module object.

90--

99--

91−export :: Ident -> JS -> [JS]

100+export :: Ident -> JS

92−export ident value = [ value, JSAssignment (accessor ident (JSVar "module")) (var ident) ]

101+export ident = JSAssignment (accessor ident (JSVar "module")) (var ident)

102

94-- |

103-- |

95-- Generate code in the simplified Javascript intermediate representation for a variable based on a

104-- Generate code in the simplified Javascript intermediate representation for a variable based on a

src/Language/PureScript/DeadCodeElimination.hs+27−5

@@ -30,11 +30,33 @@ import Language.PureScript.Declarations

30-- Eliminate all declarations which are not a transitive dependency of the entry point module

31--

32eliminateDeadCode :: [ModuleName] -> [Module] -> [Module]

33−eliminateDeadCode entryPoints ms =

33+eliminateDeadCode entryPoints ms = map go ms

34+ where

35+ go (Module moduleName ds (Just exps)) = Module moduleName ds' (Just exps')

36+ where

37+ ds' = filter (isUsed moduleName graph vertexFor entryPointVertices) ds

38+ exps' = mapMaybe (filterExport ds') exps

39+ go _ = error "Exports should have been elaborated in name desugaring"

34− let declarations = concatMap declarationsByModule ms

40+ declarations = concatMap declarationsByModule ms

35− (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations

41+ (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations

36− entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations

42+ entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations

37− in flip map ms $ \(Module moduleName ds exps) -> Module moduleName (filter (isUsed moduleName graph vertexFor entryPointVertices) ds) exps

43+

44+ filterExport :: [Declaration] -> DeclarationRef -> Maybe DeclarationRef

45+ filterExport decls r@(TypeRef name _) | (any $ typeExists name) decls = Just r

46+ filterExport decls r@(ValueRef name) | (any $ valueExists name) decls = Just r

47+ filterExport decls r@(TypeInstanceRef name _ _) | (any $ valueExists name) decls = Just r

48+ filterExport _ _ = Nothing

49+

50+ valueExists :: Ident -> Declaration -> Bool

51+ valueExists name (ValueDeclaration name' _ _ _ _) = name == name'

52+ valueExists name (ExternDeclaration _ name' _ _) = name == name'

53+ valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls

54+ valueExists _ _ = False

55+

56+ typeExists :: ProperName -> Declaration -> Bool

57+ typeExists name (DataDeclaration name' _ _) = name == name'

58+ typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls

59+ typeExists _ _ = False

39type Key = (ModuleName, Either Ident ProperName)

61type Key = (ModuleName, Either Ident ProperName)

src/Language/PureScript/Declarations.hs+6−1

@@ -61,6 +61,10 @@ data DeclarationRef

61 -- A type class

62 --

63 | TypeClassRef ProperName

64+ -- |

65+ -- A type class instance, created during typeclass desugaring (name, class name, instance types)

66+ --

67+ | TypeInstanceRef Ident (Qualified ProperName) [Type]

64 deriving (Show, Eq, D.Data, D.Typeable)

68 deriving (Show, Eq, D.Data, D.Typeable)

66-- |

70-- |

@@ -112,7 +116,8 @@ data Declaration

112 --

116 --

113 | TypeClassDeclaration ProperName [String] [Declaration]

117 | TypeClassDeclaration ProperName [String] [Declaration]

114 -- |

118 -- |

115− -- A type instance declaration (dependencies, class name, instance type, member declarations)

119+ -- A type instance declaration (name, dependencies, class name, instance types, member

120+ -- declarations)

116 --

121 --

117 | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]

122 | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]

118 deriving (Show, D.Data, D.Typeable)

123 deriving (Show, D.Data, D.Typeable)

src/Language/PureScript/Sugar/Names.hs+14−3

@@ -147,9 +147,10 @@ desugarImports modules = do

147 -- the module has access to an unfiltered list of its own members.

148 renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either String Module

149 renameInModule' unfilteredExports exports m@(Module mn _ _) = rethrowForModule m $ do

150− let exports' = M.update (\_ -> M.lookup mn unfilteredExports) mn exports

150+ let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports

151+ let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports

151− imports <- resolveImports exports' m

152+ imports <- resolveImports env m

152− renameInModule imports exports' m

153+ renameInModule imports env (elaborateExports exps m)

153

154

154-- |

155-- |

155-- Rethrow an error with the name of the current module in the case of a failure

156-- Rethrow an error with the name of the current module in the case of a failure

@@ -157,6 +158,16 @@ desugarImports modules = do

157rethrowForModule :: Module -> Either String a -> Either String a

158rethrowForModule :: Module -> Either String a -> Either String a

158rethrowForModule (Module mn _ _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)

159rethrowForModule (Module mn _ _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)

159

160

161+-- |

162+-- Make all exports for a module explicit. This may still effect modules that have an exports list,

163+-- as it will also make all data constructor exports explicit.

164+--

165+elaborateExports :: Exports -> Module -> Module

166+elaborateExports exps (Module mn decls _) = Module mn decls (Just $

167+ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++

168+ map TypeClassRef (exportedTypeClasses exps) ++

169+ map ValueRef (exportedValues exps))

170+

160-- |

171-- |

161-- Replaces all local names with qualified names within a module and checks that all existing

172-- Replaces all local names with qualified names within a module and checks that all existing

162-- qualified names are valid.

173-- qualified names are valid.

src/Language/PureScript/Sugar/TypeClasses.hs+11−8

@@ -26,14 +26,14 @@ import Language.PureScript.Values

26import Language.PureScript.CodeGen.JS.AST

27import Language.PureScript.Sugar.CaseDeclarations

28import Language.PureScript.Prim

29−

29+import Language.PureScript.CodeGen.Common (identToJs)

30−import qualified Data.Map as M

32import Control.Applicative

31import Control.Applicative

33import Control.Monad.State

32import Control.Monad.State

34import Control.Arrow (second)

33import Control.Arrow (second)

34+import Data.Maybe (catMaybes)

36−import Language.PureScript.CodeGen.Common (identToJs)

36+import qualified Data.Map as M

38type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])

@@ -47,7 +47,10 @@ desugarTypeClasses :: [Module] -> Either String [Module]

47desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

49desugarModule :: Module -> Desugar Module

50−desugarModule (Module name decls exps) = Module name <$> concat <$> mapM (desugarDecl name) decls <*> pure exps

50+desugarModule (Module name decls (Just exps)) = do

51+ (newExpss, declss) <- unzip <$> mapM (desugarDecl name) decls

52+ return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)

53+desugarModule _ = error "Exports should have been elaborated in name desugaring"

52-- |

55-- |

53-- Desugar type class and type class instance declarations

56-- Desugar type class and type class instance declarations

@@ -87,17 +90,17 @@ desugarModule (Module name decls exps) = Module name <$> concat <$> mapM (desuga

87-- __Test_Foo_array :: forall a. Foo a -> Foo [a]

90-- __Test_Foo_array :: forall a. Foo a -> Foo [a]

88-- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) }

91-- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) }

89--

92--

90−desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]

93+desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])

91desugarDecl mn d@(TypeClassDeclaration name args members) = do

94desugarDecl mn d@(TypeClassDeclaration name args members) = do

92 let tys = map memberToNameAndType members

95 let tys = map memberToNameAndType members

93 modify (M.insert (mn, name) (args, tys))

96 modify (M.insert (mn, name) (args, tys))

94− return $ d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members

97+ return $ (Nothing, d : typeClassDictionaryDeclaration name args members : map (typeClassMemberToDictionaryAccessor mn name args) members)

95desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do

98desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do

96 desugared <- lift $ desugarCases members

99 desugared <- lift $ desugarCases members

97 entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared

100 entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared

98 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared

101 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared

99− return $ d : entries ++ [dictDecl]

102+ return $ (Just $ TypeInstanceRef name className ty, d : entries ++ [dictDecl])

100−desugarDecl _ other = return [other]

103+desugarDecl _ other = return (Nothing, [other])

101

104

102memberToNameAndType :: Declaration -> (String, Type)

105memberToNameAndType :: Declaration -> (String, Type)

103memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)

106memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)