{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-}
module IRTS.JavaScript.LangTransforms( removeDeadCode
, globlToCon
) where
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Idris.Core.CaseTree
import Idris.Core.TT
import IRTS.Lang
import Data.Data
import Data.Generics.Uniplate.Data
deriving instance Typeable FDesc
deriving instance Data FDesc
deriving instance Typeable LVar
deriving instance Data LVar
deriving instance Typeable PrimFn
deriving instance Data PrimFn
deriving instance Typeable CaseType
deriving instance Data CaseType
deriving instance Typeable LExp
deriving instance Data LExp
deriving instance Typeable LDecl
deriving instance Data LDecl
deriving instance Typeable LOpt
deriving instance Data LOpt
restrictKeys :: Ord k => Map k a -> Set k -> Map k a
restrictKeys :: forall k a. Ord k => Map k a -> Set k -> Map k a
restrictKeys Map k a
m Set k
s = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\k
k a
_ -> k
k forall a. Ord a => a -> Set a -> Bool
`Set.member` Set k
s) Map k a
m
extractGlobs :: Map Name LDecl -> LDecl -> [Name]
Map Name LDecl
defs (LConstructor Name
_ Int
_ Int
_) = []
extractGlobs Map Name LDecl
defs (LFun [LOpt]
_ Name
_ [Name]
_ LExp
e) =
let f :: LExp -> Maybe Name
f (LV Name
x) = forall a. a -> Maybe a
Just Name
x
f (LLazyApp Name
x [LExp]
_) = forall a. a -> Maybe a
Just Name
x
f LExp
_ = forall a. Maybe a
Nothing
in [Name
x | Just Name
x <- forall a b. (a -> b) -> [a] -> [b]
map LExp -> Maybe Name
f forall a b. (a -> b) -> a -> b
$ forall on. Uniplate on => on -> [on]
universe LExp
e, forall k a. Ord k => k -> Map k a -> Bool
Map.member Name
x Map Name LDecl
defs]
usedFunctions :: Map Name LDecl -> Set Name -> [Name] -> [Name]
usedFunctions :: Map Name LDecl -> Set Name -> [Name] -> [Name]
usedFunctions Map Name LDecl
_ Set Name
_ [] = []
usedFunctions Map Name LDecl
alldefs Set Name
done [Name]
names =
let decls :: [LDecl]
decls = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Name
x -> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
x Map Name LDecl
alldefs) [Name]
names
used_names :: [Name]
used_names = (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Map Name LDecl -> LDecl -> [Name]
extractGlobs Map Name LDecl
alldefs) [LDecl]
decls) forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
names
new_names :: [Name]
new_names = forall a. (a -> Bool) -> [a] -> [a]
filter (\Name
x -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Bool
Set.member Name
x Set Name
done) [Name]
used_names
in [Name]
used_names forall a. [a] -> [a] -> [a]
++ Map Name LDecl -> Set Name -> [Name] -> [Name]
usedFunctions Map Name LDecl
alldefs (forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Name
done forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Name]
new_names) [Name]
new_names
usedDecls :: Map Name LDecl -> [Name] -> Map Name LDecl
usedDecls :: Map Name LDecl -> [Name] -> Map Name LDecl
usedDecls Map Name LDecl
dcls [Name]
start =
let used :: [Name]
used = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ [Name]
start forall a. [a] -> [a] -> [a]
++ Map Name LDecl -> Set Name -> [Name] -> [Name]
usedFunctions Map Name LDecl
dcls (forall a. Ord a => [a] -> Set a
Set.fromList [Name]
start) [Name]
start
in forall k a. Ord k => Map k a -> Set k -> Map k a
restrictKeys Map Name LDecl
dcls (forall a. Ord a => [a] -> Set a
Set.fromList [Name]
used)
getUsedConstructors :: Map Name LDecl -> Set Name
getUsedConstructors :: Map Name LDecl -> Set Name
getUsedConstructors Map Name LDecl
x = forall a. Ord a => [a] -> Set a
Set.fromList [ Name
n | LCon Maybe Name
_ Int
_ Name
n [LExp]
_ <- forall from to. Biplate from to => from -> [to]
universeBi Map Name LDecl
x]
removeUnusedBranches :: Set Name -> Map Name LDecl -> Map Name LDecl
removeUnusedBranches :: Set Name -> Map Name LDecl -> Map Name LDecl
removeUnusedBranches Set Name
used Map Name LDecl
x =
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi [LAlt] -> [LAlt]
f Map Name LDecl
x
where
f :: [LAlt] -> [LAlt]
f :: [LAlt] -> [LAlt]
f ((LConCase Int
x Name
n [Name]
y LExp
z):[LAlt]
r) =
if forall a. Ord a => a -> Set a -> Bool
Set.member Name
n Set Name
used then ((forall e. Int -> Name -> [Name] -> e -> LAlt' e
LConCase Int
x Name
n [Name]
y LExp
z)forall a. a -> [a] -> [a]
:[LAlt]
r)
else [LAlt]
r
f [LAlt]
x = [LAlt]
x
removeDeadCode :: Map Name LDecl -> [Name] -> Map Name LDecl
removeDeadCode :: Map Name LDecl -> [Name] -> Map Name LDecl
removeDeadCode Map Name LDecl
dcls [Name]
start =
let used :: Map Name LDecl
used = Map Name LDecl -> [Name] -> Map Name LDecl
usedDecls Map Name LDecl
dcls [Name]
start
remCons :: Map Name LDecl
remCons = Set Name -> Map Name LDecl -> Map Name LDecl
removeUnusedBranches (Map Name LDecl -> Set Name
getUsedConstructors Map Name LDecl
used) Map Name LDecl
used
in if forall k a. Map k a -> [k]
Map.keys Map Name LDecl
remCons forall a. Eq a => a -> a -> Bool
== forall k a. Map k a -> [k]
Map.keys Map Name LDecl
dcls then Map Name LDecl
remCons
else Map Name LDecl -> [Name] -> Map Name LDecl
removeDeadCode Map Name LDecl
remCons [Name]
start
globlToCon :: Map Name LDecl -> Map Name LDecl
globlToCon :: Map Name LDecl -> Map Name LDecl
globlToCon Map Name LDecl
x =
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (Map Name LDecl -> LExp -> LExp
f Map Name LDecl
x) Map Name LDecl
x
where
f :: Map Name LDecl -> LExp -> LExp
f :: Map Name LDecl -> LExp -> LExp
f Map Name LDecl
y x :: LExp
x@(LV Name
n) =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name LDecl
y of
Just (LConstructor Name
_ Int
conId Int
arity) -> Maybe Name -> Int -> Name -> [LExp] -> LExp
LCon forall a. Maybe a
Nothing Int
conId Name
n []
Maybe LDecl
_ -> LExp
x
f Map Name LDecl
y LExp
x = LExp
x