git.iko.soy/rowtype-yoga/purescript-native
on 1b46a84 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/DeadCodeElimination.hs
113 lines 5.7 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Language.PureScript.DeadCodeElimination
4-- Copyright : (c) 2014 Phil Freeman
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15module Language.PureScript.DeadCodeElimination (
16 eliminateDeadCode
17) where
19import Data.List
20import Data.Graph
21import Data.Maybe (mapMaybe)
23import Language.PureScript.Names
24import Language.PureScript.Declarations
26-- |
27-- Eliminate all declarations which are not a transitive dependency of the entry point module
28--
29eliminateDeadCode :: [ModuleName] -> [Module] -> [Module]
30eliminateDeadCode entryPoints ms = map go ms
31 where
32 go (Module moduleName ds (Just exps)) = Module moduleName ds' (Just exps')
33 where
34 ds' = filter (isUsed moduleName graph vertexFor entryPointVertices) ds
35 exps' = mapMaybe (filterExport ds') exps
36 go _ = error "Exports should have been elaborated in name desugaring"
37 declarations = concatMap declarationsByModule ms
38 (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
39 entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
41 filterExport :: [Declaration] -> DeclarationRef -> Maybe DeclarationRef
42 filterExport decls r@(TypeRef name _) | (any $ typeOrClassExists name) decls = Just r
43 filterExport decls r@(TypeClassRef name) | (any $ typeOrClassExists name) decls = Just r
44 filterExport decls r@(ValueRef name) | (any $ valueExists name) decls = Just r
45 filterExport decls r@(TypeInstanceRef name) | (any $ valueExists name) decls = Just r
46 filterExport _ _ = Nothing
48 valueExists :: Ident -> Declaration -> Bool
49 valueExists name (ValueDeclaration name' _ _ _ _) = name == name'
50 valueExists name (ExternDeclaration _ name' _ _) = name == name'
51 valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls
52 valueExists name (PositionedDeclaration _ d) = valueExists name d
53 valueExists _ _ = False
55 typeOrClassExists :: ProperName -> Declaration -> Bool
56 typeOrClassExists name (DataDeclaration _ name' _ _) = name == name'
57 typeOrClassExists name (TypeClassDeclaration name' _ _ _) = name == name'
58 typeOrClassExists name (DataBindingGroupDeclaration decls) = any (typeOrClassExists name) decls
59 typeOrClassExists name (PositionedDeclaration _ d) = typeOrClassExists name d
60 typeOrClassExists _ _ = False
62type Key = (ModuleName, Either Ident ProperName)
64declarationsByModule :: Module -> [(Key, [Key])]
65declarationsByModule (Module moduleName ds _) = concatMap go ds
66 where
67 go :: Declaration -> [(Key, [Key])]
68 go d@(ValueDeclaration name _ _ _ _) = [((moduleName, Left name), dependencies moduleName d)]
69 go (DataDeclaration _ _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors
70 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]
71 go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'
72 go (DataBindingGroupDeclaration ds') = concatMap go ds'
73 go (TypeClassDeclaration name _ _ _) = [((moduleName, Right name), [])]
74 go (PositionedDeclaration _ d) = go d
75 go _ = []
77dependencies :: ModuleName -> Declaration -> [Key]
78dependencies moduleName =
79 let (f, _, _, _, _) = everythingOnValues (++) (const []) values (const []) (const []) (const [])
80 in nub . f
81 where
82 values :: Expr -> [Key]
83 values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]
84 values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]
85 values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"
86 values (TypeClassDictionaryConstructorApp (Qualified (Just mn) name) _) = [(mn, Right name)]
87 values (TypeClassDictionaryConstructorApp (Qualified Nothing _) _) = error "Found unqualified class dictionary constructor"
88 values _ = []
90isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool
91isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _ _) =
92 let Just v' = vertexFor (moduleName, Left name)
93 in any (\v -> path graph v v') entryPointVertices
94isUsed moduleName graph vertexFor entryPointVertices (FixityDeclaration _ name) =
95 let Just v' = vertexFor (moduleName, Left $ Op name)
96 in any (\v -> path graph v v') entryPointVertices
97isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ _ dctors) =
98 any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)
99 in any (\v -> path graph v v') entryPointVertices) dctors
100isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =
101 let Just v' = vertexFor (moduleName, Left name)
102 in any (\v -> path graph v v') entryPointVertices
103isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =
104 any (\(name, _, _) -> let Just v' = vertexFor (moduleName, Left name)
105 in any (\v -> path graph v v') entryPointVertices) ds
106isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =
107 any (isUsed moduleName graph vertexFor entryPointVertices) ds
108isUsed moduleName graph vertexFor entryPointVertices (TypeClassDeclaration name _ _ _) =
109 let Just v' = vertexFor (moduleName, Right name)
110 in any (\v -> path graph v v') entryPointVertices
111isUsed moduleName graph vertexFor entryPointVertices (PositionedDeclaration _ d) =
112 isUsed moduleName graph vertexFor entryPointVertices d
113isUsed _ _ _ _ _ = True