git.iko.soy/rowtype-yoga/purescript-native
on 6661c03 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/DeadCodeElimination.hs
76 lines 3.5 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.Data
20import Data.List
21import Data.Graph
22import Data.Generics
23import Data.Maybe (mapMaybe)
25import Language.PureScript.Names
26import Language.PureScript.Values
27import Language.PureScript.Declarations
29-- |
30-- Eliminate all declarations which are not a transitive dependency of the entry point module
31--
32eliminateDeadCode :: [ModuleName] -> [Module] -> [Module]
33eliminateDeadCode 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
39type Key = (ModuleName, Either Ident ProperName)
41declarationsByModule :: Module -> [(Key, [Key])]
42declarationsByModule (Module moduleName ds _) = concatMap go ds
43 where
44 go :: Declaration -> [(Key, [Key])]
45 go d@(ValueDeclaration name _ _ _ _) = [((moduleName, Left name), dependencies moduleName d)]
46 go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors
47 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]
48 go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'
49 go (DataBindingGroupDeclaration ds') = concatMap go ds'
50 go _ = []
52dependencies :: (Data d) => ModuleName -> d -> [Key]
53dependencies moduleName = nub . everything (++) (mkQ [] values)
54 where
55 values :: Value -> [Key]
56 values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]
57 values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]
58 values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"
59 values _ = []
61isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool
62isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _ _) =
63 let Just v' = vertexFor (moduleName, Left name)
64 in any (\v -> path graph v v') entryPointVertices
65isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ dctors) =
66 any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)
67 in any (\v -> path graph v v') entryPointVertices) dctors
68isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =
69 let Just v' = vertexFor (moduleName, Left name)
70 in any (\v -> path graph v v') entryPointVertices
71isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =
72 any (\(name, _, _) -> let Just v' = vertexFor (moduleName, Left name)
73 in any (\v -> path graph v v') entryPointVertices) ds
74isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =
75 any (isUsed moduleName graph vertexFor entryPointVertices) ds
76isUsed _ _ _ _ _ = True