{-|
Module      : IRTS.JavaScript.LangTransforms
Description : The JavaScript LDecl Transformations.

License     : BSD3
Maintainer  : The Idris Community.
-}
{-# 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 :: Map k a -> Set k -> Map k a
restrictKeys m :: Map k a
m s :: Set k
s = (k -> a -> Bool) -> Map k a -> Map k a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\k :: k
k _ -> k
k k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set k
s) Map k a
m

extractGlobs :: Map Name LDecl -> LDecl -> [Name]
extractGlobs :: Map Name LDecl -> LDecl -> [Name]
extractGlobs defs :: Map Name LDecl
defs (LConstructor _ _ _) = []
extractGlobs defs :: Map Name LDecl
defs (LFun _ _ _ e :: LExp
e) =
  let f :: LExp -> Maybe Name
f (LV x :: Name
x) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
x
      f (LLazyApp x :: Name
x _) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
x
      f _ = Maybe Name
forall a. Maybe a
Nothing
  in [Name
x | Just x :: Name
x <- (LExp -> Maybe Name) -> [LExp] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map LExp -> Maybe Name
f ([LExp] -> [Maybe Name]) -> [LExp] -> [Maybe Name]
forall a b. (a -> b) -> a -> b
$ LExp -> [LExp]
forall on. Uniplate on => on -> [on]
universe LExp
e, Name -> Map Name LDecl -> Bool
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 _ _ [] = []
usedFunctions alldefs :: Map Name LDecl
alldefs done :: Set Name
done names :: [Name]
names =
  let decls :: [LDecl]
decls = [Maybe LDecl] -> [LDecl]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe LDecl] -> [LDecl]) -> [Maybe LDecl] -> [LDecl]
forall a b. (a -> b) -> a -> b
$ (Name -> Maybe LDecl) -> [Name] -> [Maybe LDecl]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: Name
x -> Name -> Map Name LDecl -> Maybe LDecl
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 = ([Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> [Name]) -> [[Name]] -> [Name]
forall a b. (a -> b) -> a -> b
$ (LDecl -> [Name]) -> [LDecl] -> [[Name]]
forall a b. (a -> b) -> [a] -> [b]
map (Map Name LDecl -> LDecl -> [Name]
extractGlobs Map Name LDecl
alldefs) [LDecl]
decls) [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
names
      new_names :: [Name]
new_names = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (\x :: Name
x -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Name
x Set Name
done) [Name]
used_names
  in  [Name]
used_names [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Map Name LDecl -> Set Name -> [Name] -> [Name]
usedFunctions Map Name LDecl
alldefs (Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Name
done (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$ [Name] -> Set Name
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 dcls :: Map Name LDecl
dcls start :: [Name]
start =
  let used :: [Name]
used = [Name] -> [Name]
forall a. [a] -> [a]
reverse ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name]
start [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Map Name LDecl -> Set Name -> [Name] -> [Name]
usedFunctions Map Name LDecl
dcls ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name]
start) [Name]
start
  in Map Name LDecl -> Set Name -> Map Name LDecl
forall k a. Ord k => Map k a -> Set k -> Map k a
restrictKeys Map Name LDecl
dcls ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name]
used)

getUsedConstructors :: Map Name LDecl -> Set Name
getUsedConstructors :: Map Name LDecl -> Set Name
getUsedConstructors x :: Map Name LDecl
x = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [ Name
n | LCon _ _ n :: Name
n _ <- Map Name LDecl -> [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 used :: Set Name
used x :: Map Name LDecl
x =
  ([LAlt] -> [LAlt]) -> Map Name LDecl -> Map Name LDecl
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 x :: Int
x n :: Name
n y :: [Name]
y z :: LExp
z):r :: [LAlt]
r) =
      if Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Name
n Set Name
used then ((Int -> Name -> [Name] -> LExp -> LAlt
forall e. Int -> Name -> [Name] -> e -> LAlt' e
LConCase Int
x Name
n [Name]
y LExp
z)LAlt -> [LAlt] -> [LAlt]
forall a. a -> [a] -> [a]
:[LAlt]
r)
        else [LAlt]
r
    f x :: [LAlt]
x = [LAlt]
x

removeDeadCode :: Map Name LDecl -> [Name] -> Map Name LDecl
removeDeadCode :: Map Name LDecl -> [Name] -> Map Name LDecl
removeDeadCode dcls :: Map Name LDecl
dcls start :: [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 Map Name LDecl -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name LDecl
remCons [Name] -> [Name] -> Bool
forall a. Eq a => a -> a -> Bool
== Map Name LDecl -> [Name]
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 x :: Map Name LDecl
x =
  (LExp -> LExp) -> Map Name LDecl -> Map Name LDecl
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 y :: Map Name LDecl
y x :: LExp
x@(LV n :: Name
n) =
      case Name -> Map Name LDecl -> Maybe LDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name LDecl
y of
        Just (LConstructor _ conId :: Int
conId arity :: Int
arity) -> Maybe Name -> Int -> Name -> [LExp] -> LExp
LCon Maybe Name
forall a. Maybe a
Nothing Int
conId Name
n []
        _ -> LExp
x
    f y :: Map Name LDecl
y x :: LExp
x = LExp
x