git.iko.soy/Idris-dev
on ea65347 help sign in
Idris-dev/src/IRTS/JavaScript/LangTransforms.hs
96 lines 3.1 kB history raw
1{-|
2Module : IRTS.JavaScript.LangTransforms
3Description : The JavaScript LDecl Transformations.
4Copyright :
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-}
10module IRTS.JavaScript.LangTransforms( removeDeadCode
11 ) where
14import Control.DeepSeq
15import Control.Monad.Trans.State
16import Data.List
17import Data.Map.Strict (Map)
18import qualified Data.Map.Strict as Map
19import Data.Maybe
20import Data.Set (Set)
21import qualified Data.Set as Set
22import Data.Text (Text)
23import qualified Data.Text as T
24import Idris.Core.CaseTree
25import Idris.Core.TT
26import IRTS.Lang
28import Data.Data
29import Data.Generics.Uniplate.Data
30import GHC.Generics (Generic)
32deriving instance Typeable FDesc
33deriving instance Data FDesc
34deriving instance Typeable LVar
35deriving instance Data LVar
36deriving instance Typeable PrimFn
37deriving instance Data PrimFn
38deriving instance Typeable CaseType
39deriving instance Data CaseType
40deriving instance Typeable LExp
41deriving instance Data LExp
42deriving instance Typeable LDecl
43deriving instance Data LDecl
44deriving instance Typeable LOpt
45deriving instance Data LOpt
48restrictKeys :: Ord k => Map k a -> Set k -> Map k a
49restrictKeys m s = Map.filterWithKey (\k _ -> k `Set.member` s) m
51mapMapListKeys :: Ord k => (a->a) -> [k] -> Map k a -> Map k a
52mapMapListKeys _ [] x = x
53mapMapListKeys f (t:r) x = mapMapListKeys f r $ Map.adjust f t x
56extractGlobs :: Map Name LDecl -> LDecl -> [Name]
57extractGlobs defs (LConstructor _ _ _) = []
58extractGlobs defs (LFun _ _ _ e) =
59 let f (LV (Glob x)) = Just x
60 f (LLazyApp x _) = Just x
61 f _ = Nothing
62 in [x | Just x <- map f $ universe e, Map.member x defs]
64usedFunctions :: Map Name LDecl -> Set Name -> [Name] -> [Name]
65usedFunctions _ _ [] = []
66usedFunctions alldefs done names =
67 let decls = catMaybes $ map (\x -> Map.lookup x alldefs) names
68 used_names = (nub $ concat $ map (extractGlobs alldefs) decls) \\ names
69 new_names = filter (\x -> not $ Set.member x done) used_names
70 in used_names ++ usedFunctions alldefs (Set.union done $ Set.fromList new_names) new_names
73usedDecls :: Map Name LDecl -> [Name] -> Map Name LDecl
74usedDecls dcls start =
75 let used = reverse $ start ++ usedFunctions dcls (Set.fromList start) start
76 in restrictKeys dcls (Set.fromList used)
78getUsedConstructors :: Map Name LDecl -> Set Name
79getUsedConstructors x = Set.fromList [ n | LCon _ _ n _ <- universeBi x]
81removeUnusedBranches :: Set Name -> Map Name LDecl -> Map Name LDecl
82removeUnusedBranches used x =
83 transformBi f x
84 where
85 f :: [LAlt] -> [LAlt]
86 f ((LConCase x n y z):r) =
87 if Set.member n used then ((LConCase x n y z):r)
88 else r
89 f x = x
91removeDeadCode :: Map Name LDecl -> [Name] -> Map Name LDecl
92removeDeadCode dcls start =
93 let used = usedDecls dcls start
94 remCons = removeUnusedBranches (getUsedConstructors used) used
95 in if Map.keys remCons == Map.keys dcls then remCons
96 else removeDeadCode remCons start