git.iko.soy/Idris-dev
on 96086d2 help sign in
Idris-dev/src/IRTS/JavaScript/LangTransforms.hs
109 lines 3.4 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 , globlToCon
12 ) where
15import Control.DeepSeq
16import Control.Monad.Trans.State
17import Data.List
18import Data.Map.Strict (Map)
19import qualified Data.Map.Strict as Map
20import Data.Maybe
21import Data.Set (Set)
22import qualified Data.Set as Set
23import Data.Text (Text)
24import qualified Data.Text as T
25import Idris.Core.CaseTree
26import Idris.Core.TT
27import IRTS.Lang
29import Data.Data
30import Data.Generics.Uniplate.Data
31import GHC.Generics (Generic)
33deriving instance Typeable FDesc
34deriving instance Data FDesc
35deriving instance Typeable LVar
36deriving instance Data LVar
37deriving instance Typeable PrimFn
38deriving instance Data PrimFn
39deriving instance Typeable CaseType
40deriving instance Data CaseType
41deriving instance Typeable LExp
42deriving instance Data LExp
43deriving instance Typeable LDecl
44deriving instance Data LDecl
45deriving instance Typeable LOpt
46deriving instance Data LOpt
49restrictKeys :: Ord k => Map k a -> Set k -> Map k a
50restrictKeys m s = Map.filterWithKey (\k _ -> k `Set.member` s) m
52mapMapListKeys :: Ord k => (a->a) -> [k] -> Map k a -> Map k a
53mapMapListKeys _ [] x = x
54mapMapListKeys f (t:r) x = mapMapListKeys f r $ Map.adjust f t x
57extractGlobs :: Map Name LDecl -> LDecl -> [Name]
58extractGlobs defs (LConstructor _ _ _) = []
59extractGlobs defs (LFun _ _ _ e) =
60 let f (LV x) = Just x
61 f (LLazyApp x _) = Just x
62 f _ = Nothing
63 in [x | Just x <- map f $ universe e, Map.member x defs]
65usedFunctions :: Map Name LDecl -> Set Name -> [Name] -> [Name]
66usedFunctions _ _ [] = []
67usedFunctions alldefs done names =
68 let decls = catMaybes $ map (\x -> Map.lookup x alldefs) names
69 used_names = (nub $ concat $ map (extractGlobs alldefs) decls) \\ names
70 new_names = filter (\x -> not $ Set.member x done) used_names
71 in used_names ++ usedFunctions alldefs (Set.union done $ Set.fromList new_names) new_names
74usedDecls :: Map Name LDecl -> [Name] -> Map Name LDecl
75usedDecls dcls start =
76 let used = reverse $ start ++ usedFunctions dcls (Set.fromList start) start
77 in restrictKeys dcls (Set.fromList used)
79getUsedConstructors :: Map Name LDecl -> Set Name
80getUsedConstructors x = Set.fromList [ n | LCon _ _ n _ <- universeBi x]
82removeUnusedBranches :: Set Name -> Map Name LDecl -> Map Name LDecl
83removeUnusedBranches used x =
84 transformBi f x
85 where
86 f :: [LAlt] -> [LAlt]
87 f ((LConCase x n y z):r) =
88 if Set.member n used then ((LConCase x n y z):r)
89 else r
90 f x = x
92removeDeadCode :: Map Name LDecl -> [Name] -> Map Name LDecl
93removeDeadCode dcls start =
94 let used = usedDecls dcls start
95 remCons = removeUnusedBranches (getUsedConstructors used) used
96 in if Map.keys remCons == Map.keys dcls then remCons
97 else removeDeadCode remCons start
100globlToCon :: Map Name LDecl -> Map Name LDecl
101globlToCon x =
102 transformBi (f x) x
103 where
104 f :: Map Name LDecl -> LExp -> LExp
105 f y x@(LV n) =
106 case Map.lookup n y of
107 Just (LConstructor _ conId arity) -> LCon Nothing conId n []
108 _ -> x
109 f y x = x