git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #263 from garyb/master

Fix JS modules to only include exported items

commit18ba0fb110bc508e7596ae91e445f97a9bb23825 authorPhil Freeman <paf31@cantab.net> dateSat 8 Mar 2014, 11:49 (13 years ago) parent62b500a820fbac
5 files changed+82−32
compare with golang
unifiedsplit
src/Language/PureScript/CodeGen/JS.hs+24−15 src/Language/PureScript/DeadCodeElimination.hs+27−5 src/Language/PureScript/Declarations.hs+6−1 src/Language/PureScript/Sugar/Names.hs+14−3 src/Language/PureScript/Sugar/TypeClasses.hs+11−8
src/Language/PureScript/CodeGen/JS.hs+24−15
@@ -49,28 +49,29 @@ import qualified Language.PureScript.Constants as C
4949-- module.
5050--
5151moduleToJs :: Options -> Module -> Environment -> Maybe JS
52−moduleToJs opts (Module name decls _) env =
52+moduleToJs opts (Module name decls (Just exps)) env =
5353 case jsDecls of
5454 [] -> Nothing
5555 _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar C._ps)) $
5656 JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))
5757 [JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar C._ps)) (JSObjectLiteral [])]
5858 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"
6062
6163-- |
6264-- Generate code in the simplified Javascript intermediate representation for a declaration
6365--
6466declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]
6567declToJs 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))]
6769declToJs opts mp (BindingGroupDeclaration vals) e =
68− Just $ concatMap (\(ident, _, val) ->
69− export ident $ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))
70− ) vals
70+ Just $ flip concatMap vals $ \(ident, _, val) ->
71+ [JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))]
7172declToJs _ mp (DataDeclaration _ _ ctors) _ =
7273 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 []))]
7475 where
7576 go :: ProperName -> Integer -> [Type] -> [JS] -> JS
7677 go pn _ [] values =
@@ -78,18 +79,26 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =
7879 go pn index (_ : tys') values =
7980 JSFunction Nothing ["value" ++ show index]
8081 (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])
81−declToJs opts mp (DataBindingGroupDeclaration ds) e =
82− Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
83−declToJs _ _ (ExternDeclaration _ ident (Just js) _) _ =
84− Just $ export ident js
82+declToJs opts mp (DataBindingGroupDeclaration ds) e = Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds
83+declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = Just [js]
8584declToJs _ _ _ _ = Nothing
8685
8786-- |
88−-- Generate code in the simplified Javascript intermediate representation for exporting a
89−-- declaration from a module.
87+-- Generate code in the simplified Javascript intermediate representation for an export from a
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.
9099--
91−export :: Ident -> JS -> [JS]
92−export ident value = [ value, JSAssignment (accessor ident (JSVar "module")) (var ident) ]
100+export :: Ident -> JS
101+export ident = JSAssignment (accessor ident (JSVar "module")) (var ident)
93102
94103-- |
95104-- 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
3030-- Eliminate all declarations which are not a transitive dependency of the entry point module
3131--
3232eliminateDeadCode :: [ModuleName] -> [Module] -> [Module]
33−eliminateDeadCode entryPoints ms =
34− let declarations = concatMap declarationsByModule ms
35− (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
36− 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
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"
40+ declarations = concatMap declarationsByModule ms
41+ (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
42+ entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
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
3860
3961type Key = (ModuleName, Either Ident ProperName)
4062
src/Language/PureScript/Declarations.hs+6−1
@@ -61,6 +61,10 @@ data DeclarationRef
6161 -- A type class
6262 --
6363 | TypeClassRef ProperName
64+ -- |
65+ -- A type class instance, created during typeclass desugaring (name, class name, instance types)
66+ --
67+ | TypeInstanceRef Ident (Qualified ProperName) [Type]
6468 deriving (Show, Eq, D.Data, D.Typeable)
6569
6670-- |
@@ -112,7 +116,8 @@ data Declaration
112116 --
113117 | TypeClassDeclaration ProperName [String] [Declaration]
114118 -- |
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)
116121 --
117122 | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]
118123 deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/Sugar/Names.hs+14−3
@@ -147,9 +147,10 @@ desugarImports modules = do
147147 -- the module has access to an unfiltered list of its own members.
148148 renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either String Module
149149 renameInModule' unfilteredExports exports m@(Module mn _ _) = rethrowForModule m $ do
150− let exports' = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
151− imports <- resolveImports exports' m
152− renameInModule imports exports' m
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
152+ imports <- resolveImports env m
153+ renameInModule imports env (elaborateExports exps m)
153154
154155-- |
155156-- Rethrow an error with the name of the current module in the case of a failure
@@ -157,6 +158,16 @@ desugarImports modules = do
157158rethrowForModule :: Module -> Either String a -> Either String a
158159rethrowForModule (Module mn _ _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)
159160
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+
160171-- |
161172-- Replaces all local names with qualified names within a module and checks that all existing
162173-- qualified names are valid.
src/Language/PureScript/Sugar/TypeClasses.hs+11−8
@@ -26,14 +26,14 @@ import Language.PureScript.Values
2626import Language.PureScript.CodeGen.JS.AST
2727import Language.PureScript.Sugar.CaseDeclarations
2828import Language.PureScript.Prim
29−
30−import qualified Data.Map as M
29+import Language.PureScript.CodeGen.Common (identToJs)
3130
3231import Control.Applicative
3332import Control.Monad.State
3433import Control.Arrow (second)
34+import Data.Maybe (catMaybes)
3535
36−import Language.PureScript.CodeGen.Common (identToJs)
36+import qualified Data.Map as M
3737
3838type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])
3939
@@ -47,7 +47,10 @@ desugarTypeClasses :: [Module] -> Either String [Module]
4747desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
4848
4949desugarModule :: 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"
5154
5255-- |
5356-- Desugar type class and type class instance declarations
@@ -87,17 +90,17 @@ desugarModule (Module name decls exps) = Module name <$> concat <$> mapM (desuga
8790-- __Test_Foo_array :: forall a. Foo a -> Foo [a]
8891-- __Test_Foo_array _1 = { foo: __Test_Foo_array_foo _1 :: [a] -> [a] (unchecked) }
8992--
90−desugarDecl :: ModuleName -> Declaration -> Desugar [Declaration]
93+desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
9194desugarDecl mn d@(TypeClassDeclaration name args members) = do
9295 let tys = map memberToNameAndType members
9396 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)
9598desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do
9699 desugared <- lift $ desugarCases members
97100 entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared
98101 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared
99− return $ d : entries ++ [dictDecl]
100−desugarDecl _ other = return [other]
102+ return $ (Just $ TypeInstanceRef name className ty, d : entries ++ [dictDecl])
103+desugarDecl _ other = return (Nothing, [other])
101104
102105memberToNameAndType :: Declaration -> (String, Type)
103106memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)