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