-- |
-- Helper module for dead call elimination.
module Language.PureScript.DCE.Utils where

import           Control.Arrow (first, second, (***), (+++))
import           Language.PureScript.CoreFn
import           Language.PureScript.Names

bindIdents :: Bind Ann -> [Ident]
bindIdents :: Bind Ann -> [Ident]
bindIdents (NonRec Ann
_ Ident
i Expr Ann
_) = [Ident
i]
bindIdents (Rec [((Ann, Ident), Expr Ann)]
bs) = (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> [a] -> [b]
`map` [((Ann, Ident), Expr Ann)]
bs

bindExprs :: Bind Ann -> [Expr Ann]
bindExprs :: Bind Ann -> [Expr Ann]
bindExprs (NonRec Ann
_ Ident
_ Expr Ann
e) = [Expr Ann
e]
bindExprs (Rec [((Ann, Ident), Expr Ann)]
bs) = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> [a] -> [b]
`map` [((Ann, Ident), Expr Ann)]
bs

unBind :: Bind Ann -> [(Ident, Expr Ann)]
unBind :: Bind Ann -> [(Ident, Expr Ann)]
unBind (NonRec Ann
_ Ident
i Expr Ann
e) = [(Ident
i, Expr Ann
e)]
unBind (Rec [((Ann, Ident), Expr Ann)]
bs) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a, b) -> b
snd forall a b. (a -> b) -> [a] -> [b]
`map` [((Ann, Ident), Expr Ann)]
bs

everywhereOnValuesM
  :: forall m a
   . (Monad m)
  => (Bind a -> m (Bind a))
  -> (Expr a -> m (Expr a))
  -> ([Expr a] -> [Binder a] -> m [Binder a])
  -> m ()
  -- ^ monadic computation fired after handling case alternative
  -> (Bind a -> m (Bind a), Expr a -> m (Expr a))
everywhereOnValuesM :: forall (m :: * -> *) a.
Monad m =>
(Bind a -> m (Bind a))
-> (Expr a -> m (Expr a))
-> ([Expr a] -> [Binder a] -> m [Binder a])
-> m ()
-> (Bind a -> m (Bind a), Expr a -> m (Expr a))
everywhereOnValuesM Bind a -> m (Bind a)
f Expr a -> m (Expr a)
g [Expr a] -> [Binder a] -> m [Binder a]
h m ()
mh = (Bind a -> m (Bind a)
f', Expr a -> m (Expr a)
g')
  where
  f' :: Bind a -> m (Bind a)
f' (NonRec a
a Ident
name Expr a
e) = forall a. a -> Ident -> Expr a -> Bind a
NonRec a
a Ident
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr a -> m (Expr a)
g' Expr a
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bind a -> m (Bind a)
f
  f' (Rec [((a, Ident), Expr a)]
es) = forall a. [((a, Ident), Expr a)] -> Bind a
Rec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr a -> m (Expr a)
g) [((a, Ident), Expr a)]
es forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bind a -> m (Bind a)
f
     
  g' :: Expr a -> m (Expr a)
g' (Literal a
ann Literal (Expr a)
e) = forall a. a -> Literal (Expr a) -> Expr a
Literal a
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b. (b -> m b) -> Literal b -> m (Literal b)
handleLiteral Expr a -> m (Expr a)
g' Literal (Expr a)
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr a -> m (Expr a)
g
  g' (Accessor a
ann PSString
prop Expr a
e) = forall a. a -> PSString -> Expr a -> Expr a
Accessor a
ann PSString
prop forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr a -> m (Expr a)
g' Expr a
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr a -> m (Expr a)
g
  g' (ObjectUpdate a
ann Expr a
obj [(PSString, Expr a)]
vs) = forall a. a -> Expr a -> [(PSString, Expr a)] -> Expr a
ObjectUpdate a
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr a -> m (Expr a)
g' Expr a
obj forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr a -> m (Expr a)
g') [(PSString, Expr a)]
vs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr a -> m (Expr a)
g
  g' (Abs a
ann Ident
name Expr a
e) = forall a. a -> Ident -> Expr a -> Expr a
Abs a
ann Ident
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr a -> m (Expr a)
g' Expr a
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr a -> m (Expr a)
g
  g' (App a
ann Expr a
v1 Expr a
v2) = forall a. a -> Expr a -> Expr a -> Expr a
App a
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr a -> m (Expr a)
g' Expr a
v1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr a -> m (Expr a)
g' Expr a
v2 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr a -> m (Expr a)
g
  g' (Case a
ann [Expr a]
vs [CaseAlternative a]
alts) = do
    [Expr a]
vs' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr a -> m (Expr a)
g' [Expr a]
vs
    [CaseAlternative a]
alts' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Expr a] -> CaseAlternative a -> m (CaseAlternative a)
handleCaseAlternative [Expr a]
vs') [CaseAlternative a]
alts
    Expr a -> m (Expr a)
g (forall a. a -> [Expr a] -> [CaseAlternative a] -> Expr a
Case a
ann [Expr a]
vs' [CaseAlternative a]
alts')
  g' (Let a
ann [Bind a]
ds Expr a
e) = forall a. a -> [Bind a] -> Expr a -> Expr a
Let a
ann forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Bind a -> m (Bind a)
f' [Bind a]
ds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr a -> m (Expr a)
g' Expr a
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr a -> m (Expr a)
g
  g' Expr a
e = Expr a -> m (Expr a)
g Expr a
e

  handleCaseAlternative :: [Expr a] -> CaseAlternative a -> m (CaseAlternative a)
  handleCaseAlternative :: [Expr a] -> CaseAlternative a -> m (CaseAlternative a)
handleCaseAlternative [Expr a]
es (CaseAlternative [Binder a]
bs Either [(Expr a, Expr a)] (Expr a)
r) = do
    [Binder a]
bs' <- [Expr a] -> [Binder a] -> m [Binder a]
h [Expr a]
es [Binder a]
bs
    Either [(Expr a, Expr a)] (Expr a)
rs <- Either [(Expr a, Expr a)] (Expr a)
-> m (Either [(Expr a, Expr a)] (Expr a))
g'' Either [(Expr a, Expr a)] (Expr a)
r
    m ()
mh
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
[Binder a]
-> Either [(Guard a, Guard a)] (Guard a) -> CaseAlternative a
CaseAlternative [Binder a]
bs' Either [(Expr a, Expr a)] (Expr a)
rs)
    where
    g'' :: Either [(Guard a, Expr a)] (Expr a) -> m (Either [(Guard a, Expr a)] (Expr a))
    g'' :: Either [(Expr a, Expr a)] (Expr a)
-> m (Either [(Expr a, Expr a)] (Expr a))
g'' (Left [(Expr a, Expr a)]
es') = forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Expr a, Expr a) -> m (Expr a, Expr a)
gn [(Expr a, Expr a)]
es'
    g'' (Right Expr a
e) = forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr a -> m (Expr a)
g' Expr a
e

    gn :: (Expr a, Expr a) -> m (Expr a, Expr a)
gn (Expr a
e1, Expr a
e2) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr a -> m (Expr a)
g' Expr a
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expr a -> m (Expr a)
g' Expr a
e2

  handleLiteral :: (b -> m b) -> Literal b -> m (Literal b)
  handleLiteral :: forall b. (b -> m b) -> Literal b -> m (Literal b)
handleLiteral b -> m b
i (ArrayLiteral [b]
ls) = forall a. [a] -> Literal a
ArrayLiteral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse b -> m b
i [b]
ls
  handleLiteral b -> m b
i (ObjectLiteral [(PSString, b)]
ls) = forall a. [(PSString, a)] -> Literal a
ObjectLiteral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse b -> m b
i) [(PSString, b)]
ls
  handleLiteral b -> m b
_ Literal b
other = forall (m :: * -> *) a. Monad m => a -> m a
return Literal b
other

unAnn :: Expr a -> Expr ()
unAnn :: forall a. Expr a -> Expr ()
unAnn (Literal a
_ Literal (Expr a)
l) = forall a. a -> Literal (Expr a) -> Expr a
Literal () (forall a. Expr a -> Expr ()
unAnn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Literal (Expr a)
l)
unAnn (Constructor a
_ ProperName 'TypeName
n ProperName 'ConstructorName
cn [Ident]
is) = forall a.
a
-> ProperName 'TypeName
-> ProperName 'ConstructorName
-> [Ident]
-> Expr a
Constructor () ProperName 'TypeName
n ProperName 'ConstructorName
cn [Ident]
is
unAnn (Accessor a
_ PSString
s Expr a
e) = forall a. a -> PSString -> Expr a -> Expr a
Accessor () PSString
s (forall a. Expr a -> Expr ()
unAnn Expr a
e)
unAnn (ObjectUpdate a
_ Expr a
e [(PSString, Expr a)]
es) = forall a. a -> Expr a -> [(PSString, Expr a)] -> Expr a
ObjectUpdate () (forall a. Expr a -> Expr ()
unAnn Expr a
e) (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. Expr a -> Expr ()
unAnn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PSString, Expr a)]
es)
unAnn (Abs a
_ Ident
i Expr a
e) = forall a. a -> Ident -> Expr a -> Expr a
Abs () Ident
i (forall a. Expr a -> Expr ()
unAnn Expr a
e)
unAnn (App a
_ Expr a
e1 Expr a
e2) = forall a. a -> Expr a -> Expr a -> Expr a
App () (forall a. Expr a -> Expr ()
unAnn Expr a
e1) (forall a. Expr a -> Expr ()
unAnn Expr a
e2)
unAnn (Var a
_ Qualified Ident
i) = forall a. a -> Qualified Ident -> Expr a
Var () Qualified Ident
i
unAnn (Case a
_ [Expr a]
es [CaseAlternative a]
cs) = forall a. a -> [Expr a] -> [CaseAlternative a] -> Expr a
Case () (forall a. Expr a -> Expr ()
unAnn forall a b. (a -> b) -> [a] -> [b]
`map` [Expr a]
es) (forall a. CaseAlternative a -> CaseAlternative ()
gn forall a b. (a -> b) -> [a] -> [b]
`map` [CaseAlternative a]
cs)
  where
  gn :: CaseAlternative a -> CaseAlternative ()
  gn :: forall a. CaseAlternative a -> CaseAlternative ()
gn (CaseAlternative [Binder a]
bs Either [(Guard a, Guard a)] (Guard a)
es') = forall a.
[Binder a]
-> Either [(Guard a, Guard a)] (Guard a) -> CaseAlternative a
CaseAlternative (forall a. Binder a -> Binder ()
unAnnBinder forall a b. (a -> b) -> [a] -> [b]
`map` [Binder a]
bs) (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Expr a -> Expr ()
unAnn forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a. Expr a -> Expr ()
unAnn) forall (a :: * -> * -> *) b c b' c'.
ArrowChoice a =>
a b c -> a b' c' -> a (Either b b') (Either c c')
+++ forall a. Expr a -> Expr ()
unAnn forall a b. (a -> b) -> a -> b
$ Either [(Guard a, Guard a)] (Guard a)
es')

  unAnnBinder :: Binder a -> Binder ()
  unAnnBinder :: forall a. Binder a -> Binder ()
unAnnBinder (NullBinder a
_) = forall a. a -> Binder a
NullBinder ()
  unAnnBinder (LiteralBinder a
_ Literal (Binder a)
l) = forall a. a -> Literal (Binder a) -> Binder a
LiteralBinder () (forall a. Binder a -> Binder ()
unAnnBinder forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Literal (Binder a)
l)
  unAnnBinder (VarBinder a
_ Ident
i) = forall a. a -> Ident -> Binder a
VarBinder () Ident
i
  unAnnBinder (ConstructorBinder a
_ Qualified (ProperName 'TypeName)
n Qualified (ProperName 'ConstructorName)
cn [Binder a]
bs) = forall a.
a
-> Qualified (ProperName 'TypeName)
-> Qualified (ProperName 'ConstructorName)
-> [Binder a]
-> Binder a
ConstructorBinder () Qualified (ProperName 'TypeName)
n Qualified (ProperName 'ConstructorName)
cn (forall a. Binder a -> Binder ()
unAnnBinder forall a b. (a -> b) -> [a] -> [b]
`map` [Binder a]
bs)
  unAnnBinder (NamedBinder a
_ Ident
i Binder a
b) = forall a. a -> Ident -> Binder a -> Binder a
NamedBinder () Ident
i (forall a. Binder a -> Binder ()
unAnnBinder Binder a
b)
unAnn (Let a
_ [Bind a]
bs Expr a
e) = forall a. a -> [Bind a] -> Expr a -> Expr a
Let () (forall {a}. Bind a -> Bind ()
unAnnBind forall a b. (a -> b) -> [a] -> [b]
`map` [Bind a]
bs) (forall a. Expr a -> Expr ()
unAnn Expr a
e)
  where
  unAnnBind :: Bind a -> Bind ()
unAnnBind (NonRec a
_ Ident
i Expr a
e') = forall a. a -> Ident -> Expr a -> Bind a
NonRec () Ident
i (forall a. Expr a -> Expr ()
unAnn Expr a
e')
  unAnnBind (Rec [((a, Ident), Expr a)]
bs') = forall a. [((a, Ident), Expr a)] -> Bind a
Rec ((forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall a b. a -> b -> a
const ()) forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a. Expr a -> Expr ()
unAnn) forall a b. (a -> b) -> [a] -> [b]
`map` [((a, Ident), Expr a)]
bs')

-- |
-- Helper function for pretty printing errors in tests.
showExpr :: Expr a -> String
showExpr :: forall a. Expr a -> String
showExpr = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Expr a -> Expr ()
unAnn