{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}

module Language.Haskell.Liquid.Transforms.Rec (
     transformRecExpr, transformScope
     , outerScTr , innerScTr
     , isIdTRecBound, setIdTRecBound
     ) where

import           Control.Arrow                        (second)
import           Control.Monad.State
import qualified Data.HashMap.Strict                  as M
import           Data.Hashable
import           Liquid.GHC.API      as Ghc hiding (panic)
import           Language.Haskell.Liquid.GHC.Misc
import           Language.Haskell.Liquid.GHC.Play
import           Language.Haskell.Liquid.Misc         (mapSndM)
import           Language.Fixpoint.Misc               (mapSnd) -- , traceShow)
import           Language.Haskell.Liquid.Types.Errors
import           Prelude                              hiding (error)

import qualified Data.List                            as L


transformRecExpr :: CoreProgram -> CoreProgram
transformRecExpr :: CoreProgram -> CoreProgram
transformRecExpr CoreProgram
cbs = CoreProgram
pg
  -- TODO-REBARE weird GHC crash on Data/Text/Array.hs | isEmptyBag $ filterBag isTypeError e
  -- TODO-REBARE weird GHC crash on Data/Text/Array.hs = pg
  -- TODO-REBARE weird GHC crash on Data/Text/Array.hs | otherwise
  -- TODO-REBARE weird GHC crash on Data/Text/Array.hs = panic Nothing ("Type-check" ++ showSDoc (pprMessageBag e))
  where
    pg :: CoreProgram
pg     = CoreProgram -> CoreProgram
inlineFailCases CoreProgram
pg0
    pg0 :: CoreProgram
pg0    = State TrEnv CoreProgram -> TrEnv -> CoreProgram
forall s a. State s a -> s -> a
evalState (CoreProgram -> State TrEnv CoreProgram
forall (t :: * -> *).
Traversable t =>
t (Bind Var) -> State TrEnv (t (Bind Var))
transPg (Bind Var -> Bind Var
inlineLoopBreaker (Bind Var -> Bind Var) -> CoreProgram -> CoreProgram
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreProgram
cbs)) TrEnv
initEnv
    -- (_, e) = lintCoreBindings [] pg




inlineLoopBreaker :: Bind Id -> Bind Id
inlineLoopBreaker :: Bind Var -> Bind Var
inlineLoopBreaker (NonRec Var
x Expr Var
e) | Just (Var
lbx, Expr Var
lbe) <- Expr Var -> Maybe (Var, Expr Var)
hasLoopBreaker Expr Var
be
  = [(Var, Expr Var)] -> Bind Var
forall b. [(b, Expr b)] -> Bind b
Rec [(Var
x, (Var -> Expr Var -> Expr Var) -> Expr Var -> [Var] -> Expr Var
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Var -> Expr Var -> Expr Var
forall b. b -> Expr b -> Expr b
Lam (HashMap Var (Expr Var) -> Expr Var -> Expr Var
forall a. Subable a => HashMap Var (Expr Var) -> a -> a
sub (Var -> Expr Var -> HashMap Var (Expr Var)
forall k v. Hashable k => k -> v -> HashMap k v
M.singleton Var
lbx Expr Var
forall {b}. Expr b
e') Expr Var
lbe) ([Var]
αs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
as))]
  where
    ([Var]
αs, [Var]
as, Expr Var
be) = Expr Var -> ([Var], [Var], Expr Var)
collectTyAndValBinders Expr Var
e

    e' :: Expr b
e' = (Expr b -> Expr b -> Expr b) -> Expr b -> [Expr b] -> Expr b
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' Expr b -> Expr b -> Expr b
forall b. Expr b -> Expr b -> Expr b
App ((Expr b -> Expr b -> Expr b) -> Expr b -> [Expr b] -> Expr b
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' Expr b -> Expr b -> Expr b
forall b. Expr b -> Expr b -> Expr b
App (Var -> Expr b
forall b. Var -> Expr b
Var Var
x) (Type -> Expr b
forall b. Type -> Expr b
Type (Type -> Expr b) -> (Var -> Type) -> Var -> Expr b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Type
TyVarTy (Var -> Expr b) -> [Var] -> [Expr b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
αs)) (Var -> Expr b
forall b. Var -> Expr b
Var (Var -> Expr b) -> [Var] -> [Expr b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
as)

    hasLoopBreaker :: Expr Var -> Maybe (Var, Expr Var)
hasLoopBreaker (Let (Rec [(Var
x1, Expr Var
e1)]) (Var Var
x2)) | Var -> Bool
isLoopBreaker Var
x1 Bool -> Bool -> Bool
&& Var
x1 Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
x2 = (Var, Expr Var) -> Maybe (Var, Expr Var)
forall a. a -> Maybe a
Just (Var
x1, Expr Var
e1)
    hasLoopBreaker Expr Var
_                               = Maybe (Var, Expr Var)
forall a. Maybe a
Nothing

    isLoopBreaker :: Var -> Bool
isLoopBreaker =  OccInfo -> Bool
isStrongLoopBreaker (OccInfo -> Bool) -> (Var -> OccInfo) -> Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> OccInfo
occInfo (IdInfo -> OccInfo) -> (Var -> IdInfo) -> Var -> OccInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => Var -> IdInfo
Var -> IdInfo
idInfo

inlineLoopBreaker Bind Var
bs
  = Bind Var
bs

inlineFailCases :: CoreProgram -> CoreProgram
inlineFailCases :: CoreProgram -> CoreProgram
inlineFailCases = ([(Var, Expr Var)] -> Bind Var -> Bind Var
go [] (Bind Var -> Bind Var) -> CoreProgram -> CoreProgram
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
  where
    go :: [(Var, Expr Var)] -> Bind Var -> Bind Var
go [(Var, Expr Var)]
su (Rec [(Var, Expr Var)]
xes)    = [(Var, Expr Var)] -> Bind Var
forall b. [(b, Expr b)] -> Bind b
Rec ((Expr Var -> Expr Var) -> (Var, Expr Var) -> (Var, Expr Var)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd ([(Var, Expr Var)] -> Expr Var -> Expr Var
go' [(Var, Expr Var)]
su) ((Var, Expr Var) -> (Var, Expr Var))
-> [(Var, Expr Var)] -> [(Var, Expr Var)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, Expr Var)]
xes)
    go [(Var, Expr Var)]
su (NonRec Var
x Expr Var
e) = Var -> Expr Var -> Bind Var
forall b. b -> Expr b -> Bind b
NonRec Var
x ([(Var, Expr Var)] -> Expr Var -> Expr Var
go' [(Var, Expr Var)]
su Expr Var
e)

    go' :: [(Var, Expr Var)] -> Expr Var -> Expr Var
go' [(Var, Expr Var)]
su (App (Var Var
x) Expr Var
_)       | Var -> Bool
isFailId Var
x, Just Expr Var
e <- Var -> [(Var, Expr Var)] -> Maybe (Expr Var)
forall {a} {b}. Eq a => a -> [(a, b)] -> Maybe b
getFailExpr Var
x [(Var, Expr Var)]
su = Expr Var
e
    go' [(Var, Expr Var)]
su (Let (NonRec Var
x Expr Var
ex) Expr Var
e) | Var -> Bool
isFailId Var
x   = [(Var, Expr Var)] -> Expr Var -> Expr Var
go' (Var -> Expr Var -> [(Var, Expr Var)] -> [(Var, Expr Var)]
forall {a} {b}. a -> Expr b -> [(a, Expr b)] -> [(a, Expr b)]
addFailExpr Var
x ([(Var, Expr Var)] -> Expr Var -> Expr Var
go' [(Var, Expr Var)]
su Expr Var
ex) [(Var, Expr Var)]
su) Expr Var
e

    go' [(Var, Expr Var)]
su (App Expr Var
e1 Expr Var
e2)      = Expr Var -> Expr Var -> Expr Var
forall b. Expr b -> Expr b -> Expr b
App ([(Var, Expr Var)] -> Expr Var -> Expr Var
go' [(Var, Expr Var)]
su Expr Var
e1) ([(Var, Expr Var)] -> Expr Var -> Expr Var
go' [(Var, Expr Var)]
su Expr Var
e2)
    go' [(Var, Expr Var)]
su (Lam Var
x Expr Var
e)        = Var -> Expr Var -> Expr Var
forall b. b -> Expr b -> Expr b
Lam Var
x ([(Var, Expr Var)] -> Expr Var -> Expr Var
go' [(Var, Expr Var)]
su Expr Var
e)
    go' [(Var, Expr Var)]
su (Let Bind Var
xs Expr Var
e)       = Bind Var -> Expr Var -> Expr Var
forall b. Bind b -> Expr b -> Expr b
Let ([(Var, Expr Var)] -> Bind Var -> Bind Var
go [(Var, Expr Var)]
su Bind Var
xs) ([(Var, Expr Var)] -> Expr Var -> Expr Var
go' [(Var, Expr Var)]
su Expr Var
e)
    go' [(Var, Expr Var)]
su (Case Expr Var
e Var
x Type
t [Alt Var]
alt) = Expr Var -> Var -> Type -> [Alt Var] -> Expr Var
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case ([(Var, Expr Var)] -> Expr Var -> Expr Var
go' [(Var, Expr Var)]
su Expr Var
e) Var
x Type
t ([(Var, Expr Var)] -> Alt Var -> Alt Var
goalt [(Var, Expr Var)]
su (Alt Var -> Alt Var) -> [Alt Var] -> [Alt Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Alt Var]
alt)
    go' [(Var, Expr Var)]
su (Cast Expr Var
e CoercionR
c)       = Expr Var -> CoercionR -> Expr Var
forall b. Expr b -> CoercionR -> Expr b
Cast ([(Var, Expr Var)] -> Expr Var -> Expr Var
go' [(Var, Expr Var)]
su Expr Var
e) CoercionR
c
    go' [(Var, Expr Var)]
su (Tick CoreTickish
t Expr Var
e)       = CoreTickish -> Expr Var -> Expr Var
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t ([(Var, Expr Var)] -> Expr Var -> Expr Var
go' [(Var, Expr Var)]
su Expr Var
e)
    go' [(Var, Expr Var)]
_  Expr Var
e                = Expr Var
e

    goalt :: [(Var, Expr Var)] -> Alt Var -> Alt Var
goalt [(Var, Expr Var)]
su (Alt AltCon
c [Var]
xs Expr Var
e)   = AltCon -> [Var] -> Expr Var -> Alt Var
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
c [Var]
xs ([(Var, Expr Var)] -> Expr Var -> Expr Var
go' [(Var, Expr Var)]
su Expr Var
e)

    isFailId :: Var -> Bool
isFailId Var
x  = Var -> Bool
isLocalId Var
x Bool -> Bool -> Bool
&& Name -> Bool
isSystemName (Var -> Name
varName Var
x) Bool -> Bool -> Bool
&& [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf [Char]
"fail" (Var -> [Char]
forall a. Show a => a -> [Char]
show Var
x)
    getFailExpr :: a -> [(a, b)] -> Maybe b
getFailExpr = a -> [(a, b)] -> Maybe b
forall {a} {b}. Eq a => a -> [(a, b)] -> Maybe b
L.lookup

    addFailExpr :: a -> Expr b -> [(a, Expr b)] -> [(a, Expr b)]
addFailExpr a
x (Lam b
_ Expr b
e) [(a, Expr b)]
su = (a
x, Expr b
e)(a, Expr b) -> [(a, Expr b)] -> [(a, Expr b)]
forall a. a -> [a] -> [a]
:[(a, Expr b)]
su
    addFailExpr a
_ Expr b
_         [(a, Expr b)]
_  = Maybe SrcSpan -> [Char] -> [(a, Expr b)]
forall a. Maybe SrcSpan -> [Char] -> a
impossible Maybe SrcSpan
forall a. Maybe a
Nothing [Char]
"internal error" -- this cannot happen

-- isTypeError :: SDoc -> Bool
-- isTypeError s | isInfixOf "Non term variable" (showSDoc s) = False
-- isTypeError _ = True

-- No need for this transformation after ghc-8!!!
transformScope :: [Bind Id] -> [Bind Id]
transformScope :: CoreProgram -> CoreProgram
transformScope = CoreProgram -> CoreProgram
outerScTr (CoreProgram -> CoreProgram)
-> (CoreProgram -> CoreProgram) -> CoreProgram -> CoreProgram
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreProgram -> CoreProgram
forall (f :: * -> *). Functor f => f (Bind Var) -> f (Bind Var)
innerScTr

outerScTr :: [Bind Id] -> [Bind Id]
outerScTr :: CoreProgram -> CoreProgram
outerScTr = (Var -> CoreProgram -> CoreProgram) -> CoreProgram -> CoreProgram
forall b. (b -> [Bind b] -> [Bind b]) -> [Bind b] -> [Bind b]
mapNonRec (CoreProgram -> Var -> CoreProgram -> CoreProgram
forall {t}. [Bind t] -> Var -> [Bind t] -> [Bind t]
go [])
  where
   go :: [Bind t] -> Var -> [Bind t] -> [Bind t]
go [Bind t]
ack Var
x (Bind t
xe : [Bind t]
xes) | Var -> Bind t -> Bool
forall t. Var -> Bind t -> Bool
isCaseArg Var
x Bind t
xe = [Bind t] -> Var -> [Bind t] -> [Bind t]
go (Bind t
xeBind t -> [Bind t] -> [Bind t]
forall a. a -> [a] -> [a]
:[Bind t]
ack) Var
x [Bind t]
xes
   go [Bind t]
ack Var
_ [Bind t]
xes        = [Bind t]
ack [Bind t] -> [Bind t] -> [Bind t]
forall a. [a] -> [a] -> [a]
++ [Bind t]
xes

isCaseArg :: Id -> Bind t -> Bool
isCaseArg :: forall t. Var -> Bind t -> Bool
isCaseArg Var
x (NonRec t
_ (Case (Var Var
z) t
_ Type
_ [Alt t]
_)) = Var
z Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
x
isCaseArg Var
_ Bind t
_                               = Bool
False

innerScTr :: Functor f => f (Bind Id) -> f (Bind Id)
innerScTr :: forall (f :: * -> *). Functor f => f (Bind Var) -> f (Bind Var)
innerScTr = ((Var -> Expr Var -> Expr Var) -> Bind Var -> Bind Var
forall b. (b -> Expr b -> Expr b) -> Bind b -> Bind b
mapBnd Var -> Expr Var -> Expr Var
scTrans (Bind Var -> Bind Var) -> f (Bind Var) -> f (Bind Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

scTrans :: Id -> Expr Id -> Expr Id
scTrans :: Var -> Expr Var -> Expr Var
scTrans Var
id' Expr Var
expr = (Var -> Expr Var -> Expr Var) -> Expr Var -> Expr Var
forall b. (b -> Expr b -> Expr b) -> Expr b -> Expr b
mapExpr Var -> Expr Var -> Expr Var
scTrans (Expr Var -> Expr Var) -> Expr Var -> Expr Var
forall a b. (a -> b) -> a -> b
$ (Bind Var -> Expr Var -> Expr Var)
-> Expr Var -> CoreProgram -> Expr Var
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Bind Var -> Expr Var -> Expr Var
forall b. Bind b -> Expr b -> Expr b
Let Expr Var
e0 CoreProgram
bindIds
  where (CoreProgram
bindIds, Expr Var
e0)           = CoreProgram -> Var -> Expr Var -> (CoreProgram, Expr Var)
forall {b}. [Bind b] -> Var -> Expr b -> ([Bind b], Expr b)
go [] Var
id' Expr Var
expr
        go :: [Bind b] -> Var -> Expr b -> ([Bind b], Expr b)
go [Bind b]
bs Var
x (Let Bind b
b Expr b
e)  | Var -> Bind b -> Bool
forall t. Var -> Bind t -> Bool
isCaseArg Var
x Bind b
b = [Bind b] -> Var -> Expr b -> ([Bind b], Expr b)
go (Bind b
bBind b -> [Bind b] -> [Bind b]
forall a. a -> [a] -> [a]
:[Bind b]
bs) Var
x Expr b
e
        go [Bind b]
bs Var
x (Tick CoreTickish
t Expr b
e) = (Expr b -> Expr b) -> ([Bind b], Expr b) -> ([Bind b], Expr b)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (CoreTickish -> Expr b -> Expr b
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t) (([Bind b], Expr b) -> ([Bind b], Expr b))
-> ([Bind b], Expr b) -> ([Bind b], Expr b)
forall a b. (a -> b) -> a -> b
$ [Bind b] -> Var -> Expr b -> ([Bind b], Expr b)
go [Bind b]
bs Var
x Expr b
e
        go [Bind b]
bs Var
_ Expr b
e          = ([Bind b]
bs, Expr b
e)

type TE = State TrEnv

data TrEnv = Tr { TrEnv -> Int
freshIndex  :: !Int
                , TrEnv -> SrcSpan
_loc        :: SrcSpan
                }

initEnv :: TrEnv
initEnv :: TrEnv
initEnv = Int -> SrcSpan -> TrEnv
Tr Int
0 SrcSpan
noSrcSpan

transPg :: Traversable t
        => t (Bind CoreBndr)
        -> State TrEnv (t (Bind CoreBndr))
transPg :: forall (t :: * -> *).
Traversable t =>
t (Bind Var) -> State TrEnv (t (Bind Var))
transPg = (Bind Var -> StateT TrEnv Identity (Bind Var))
-> t (Bind Var) -> StateT TrEnv Identity (t (Bind Var))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM Bind Var -> StateT TrEnv Identity (Bind Var)
transBd

transBd :: Bind CoreBndr
        -> State TrEnv (Bind CoreBndr)
transBd :: Bind Var -> StateT TrEnv Identity (Bind Var)
transBd (NonRec Var
x Expr Var
e) = (Expr Var -> Bind Var)
-> StateT TrEnv Identity (Expr Var)
-> StateT TrEnv Identity (Bind Var)
forall a b.
(a -> b) -> StateT TrEnv Identity a -> StateT TrEnv Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Var -> Expr Var -> Bind Var
forall b. b -> Expr b -> Bind b
NonRec Var
x) (Expr Var -> StateT TrEnv Identity (Expr Var)
transExpr (Expr Var -> StateT TrEnv Identity (Expr Var))
-> StateT TrEnv Identity (Expr Var)
-> StateT TrEnv Identity (Expr Var)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Bind Var -> StateT TrEnv Identity (Bind Var))
-> Expr Var -> StateT TrEnv Identity (Expr Var)
forall (m :: * -> *) t a. Monad m => t -> a -> m a
mapBdM Bind Var -> StateT TrEnv Identity (Bind Var)
transBd Expr Var
e)
transBd (Rec [(Var, Expr Var)]
xes)    = [(Var, Expr Var)] -> Bind Var
forall b. [(b, Expr b)] -> Bind b
Rec ([(Var, Expr Var)] -> Bind Var)
-> StateT TrEnv Identity [(Var, Expr Var)]
-> StateT TrEnv Identity (Bind Var)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Var, Expr Var) -> StateT TrEnv Identity (Var, Expr Var))
-> [(Var, Expr Var)] -> StateT TrEnv Identity [(Var, Expr Var)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Expr Var -> StateT TrEnv Identity (Expr Var))
-> (Var, Expr Var) -> StateT TrEnv Identity (Var, Expr Var)
forall (m :: * -> *) b c a.
Applicative m =>
(b -> m c) -> (a, b) -> m (a, c)
mapSndM ((Bind Var -> StateT TrEnv Identity (Bind Var))
-> Expr Var -> StateT TrEnv Identity (Expr Var)
forall (m :: * -> *) t a. Monad m => t -> a -> m a
mapBdM Bind Var -> StateT TrEnv Identity (Bind Var)
transBd)) [(Var, Expr Var)]
xes

transExpr :: CoreExpr -> TE CoreExpr
transExpr :: Expr Var -> StateT TrEnv Identity (Expr Var)
transExpr Expr Var
e
  | Expr Var -> Bool
isNonPolyRec Expr Var
e' Bool -> Bool -> Bool
&& Bool -> Bool
not ([Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
tvs)
  = [Var]
-> [Var]
-> CoreProgram
-> Expr Var
-> StateT TrEnv Identity (Expr Var)
forall (t :: * -> *).
Foldable t =>
[Var]
-> [Var]
-> t (Bind Var)
-> Expr Var
-> StateT TrEnv Identity (Expr Var)
trans [Var]
tvs [Var]
ids CoreProgram
bs Expr Var
e'
  | Bool
otherwise
  = Expr Var -> StateT TrEnv Identity (Expr Var)
forall a. a -> StateT TrEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr Var
e
  where ([Var]
tvs, [Var]
ids, Expr Var
e'')       = Expr Var -> ([Var], [Var], Expr Var)
collectTyAndValBinders Expr Var
e
        (CoreProgram
bs, Expr Var
e')              = Expr Var -> (CoreProgram, Expr Var)
forall t. Expr t -> ([Bind t], Expr t)
collectNonRecLets Expr Var
e''

isNonPolyRec :: Expr CoreBndr -> Bool
isNonPolyRec :: Expr Var -> Bool
isNonPolyRec (Let (Rec [(Var, Expr Var)]
xes) Expr Var
_) = (Expr Var -> Bool) -> [Expr Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Expr Var -> Bool
nonPoly ((Var, Expr Var) -> Expr Var
forall a b. (a, b) -> b
snd ((Var, Expr Var) -> Expr Var) -> [(Var, Expr Var)] -> [Expr Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, Expr Var)]
xes)
isNonPolyRec Expr Var
_                 = Bool
False

nonPoly :: CoreExpr -> Bool
nonPoly :: Expr Var -> Bool
nonPoly = [Var] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Var] -> Bool) -> (Expr Var -> [Var]) -> Expr Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Var], Type) -> [Var]
forall a b. (a, b) -> a
fst (([Var], Type) -> [Var])
-> (Expr Var -> ([Var], Type)) -> Expr Var -> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Var], Type)
splitForAllTyCoVars (Type -> ([Var], Type))
-> (Expr Var -> Type) -> Expr Var -> ([Var], Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => Expr Var -> Type
Expr Var -> Type
exprType

collectNonRecLets :: Expr t -> ([Bind t], Expr t)
collectNonRecLets :: forall t. Expr t -> ([Bind t], Expr t)
collectNonRecLets = [Bind t] -> Expr t -> ([Bind t], Expr t)
forall {b}. [Bind b] -> Expr b -> ([Bind b], Expr b)
go []
  where go :: [Bind b] -> Expr b -> ([Bind b], Expr b)
go [Bind b]
bs (Let b :: Bind b
b@(NonRec b
_ Expr b
_) Expr b
e') = [Bind b] -> Expr b -> ([Bind b], Expr b)
go (Bind b
bBind b -> [Bind b] -> [Bind b]
forall a. a -> [a] -> [a]
:[Bind b]
bs) Expr b
e'
        go [Bind b]
bs Expr b
e'                      = ([Bind b] -> [Bind b]
forall a. [a] -> [a]
reverse [Bind b]
bs, Expr b
e')

appTysAndIds :: [Var] -> [Id] -> Id -> Expr b
appTysAndIds :: forall b. [Var] -> [Var] -> Var -> Expr b
appTysAndIds [Var]
tvs [Var]
ids Var
x = Expr b -> [Expr b] -> Expr b
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Expr b -> [Type] -> Expr b
forall b. Expr b -> [Type] -> Expr b
mkTyApps (Var -> Expr b
forall b. Var -> Expr b
Var Var
x) ((Var -> Type) -> [Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
TyVarTy [Var]
tvs)) ((Var -> Expr b) -> [Var] -> [Expr b]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Expr b
forall b. Var -> Expr b
Var [Var]
ids)

trans :: Foldable t
      => [TyVar]
      -> [Var]
      -> t (Bind Id)
      -> Expr Var
      -> State TrEnv (Expr Id)
trans :: forall (t :: * -> *).
Foldable t =>
[Var]
-> [Var]
-> t (Bind Var)
-> Expr Var
-> StateT TrEnv Identity (Expr Var)
trans [Var]
vs [Var]
ids t (Bind Var)
bs (Let (Rec [(Var, Expr Var)]
xes) Expr Var
expr)
  = (Expr Var -> Expr Var)
-> StateT TrEnv Identity (Expr Var)
-> StateT TrEnv Identity (Expr Var)
forall a b.
(a -> b) -> StateT TrEnv Identity a -> StateT TrEnv Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Expr Var -> Expr Var
mkLam (Expr Var -> Expr Var)
-> (Expr Var -> Expr Var) -> Expr Var -> Expr Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Var -> Expr Var
mkLet') ([Var] -> [Var] -> Expr Var -> StateT TrEnv Identity (Expr Var)
makeTrans [Var]
vs [Var]
liveIds Expr Var
e')
  where liveIds :: [Var]
liveIds = Var -> Var
mkAlive (Var -> Var) -> [Var] -> [Var]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
ids
        mkLet' :: Expr Var -> Expr Var
mkLet' Expr Var
e = (Bind Var -> Expr Var -> Expr Var)
-> Expr Var -> t (Bind Var) -> Expr Var
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Bind Var -> Expr Var -> Expr Var
forall b. Bind b -> Expr b -> Expr b
Let Expr Var
e t (Bind Var)
bs
        mkLam :: Expr Var -> Expr Var
mkLam Expr Var
e = (Var -> Expr Var -> Expr Var) -> Expr Var -> [Var] -> Expr Var
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Var -> Expr Var -> Expr Var
forall b. b -> Expr b -> Expr b
Lam Expr Var
e ([Var] -> Expr Var) -> [Var] -> Expr Var
forall a b. (a -> b) -> a -> b
$ [Var]
vs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
liveIds
        e' :: Expr Var
e'      = Bind Var -> Expr Var -> Expr Var
forall b. Bind b -> Expr b -> Expr b
Let ([(Var, Expr Var)] -> Bind Var
forall b. [(b, Expr b)] -> Bind b
Rec [(Var, Expr Var)]
xes') Expr Var
expr
        xes' :: [(Var, Expr Var)]
xes'    = (Expr Var -> Expr Var) -> (Var, Expr Var) -> (Var, Expr Var)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Expr Var -> Expr Var
mkLet' ((Var, Expr Var) -> (Var, Expr Var))
-> [(Var, Expr Var)] -> [(Var, Expr Var)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, Expr Var)]
xes

trans [Var]
_ [Var]
_ t (Bind Var)
_ Expr Var
_ = Maybe SrcSpan -> [Char] -> StateT TrEnv Identity (Expr Var)
forall a. Maybe SrcSpan -> [Char] -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing [Char]
"TransformRec.trans called with invalid input"

makeTrans :: [TyVar]
          -> [Var]
          -> Expr Var
          -> State TrEnv (Expr Var)
makeTrans :: [Var] -> [Var] -> Expr Var -> StateT TrEnv Identity (Expr Var)
makeTrans [Var]
vs [Var]
ids (Let (Rec [(Var, Expr Var)]
xes) Expr Var
e)
 = do [([Var], Var)]
fids    <- (Var -> StateT TrEnv Identity ([Var], Var))
-> [Var] -> StateT TrEnv Identity [([Var], Var)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Var] -> [Var] -> Var -> StateT TrEnv Identity ([Var], Var)
mkFreshIds [Var]
vs [Var]
ids) [Var]
xs
      let ([[Var]]
ids', [Var]
ys) = [([Var], Var)] -> ([[Var]], [Var])
forall a b. [(a, b)] -> ([a], [b])
unzip [([Var], Var)]
fids
      let yes :: [Expr b]
yes  = [Var] -> [Var] -> Var -> Expr b
forall b. [Var] -> [Var] -> Var -> Expr b
appTysAndIds [Var]
vs [Var]
ids (Var -> Expr b) -> [Var] -> [Expr b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
ys
      [Var]
ys'     <- (Var -> StateT TrEnv Identity Var)
-> [Var] -> StateT TrEnv Identity [Var]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Var -> StateT TrEnv Identity Var
forall a. Freshable a => a -> TE a
fresh [Var]
xs
      let su :: HashMap Var (Expr b)
su   = [(Var, Expr b)] -> HashMap Var (Expr b)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(Var, Expr b)] -> HashMap Var (Expr b))
-> [(Var, Expr b)] -> HashMap Var (Expr b)
forall a b. (a -> b) -> a -> b
$ [Var] -> [Expr b] -> [(Var, Expr b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
xs (Var -> Expr b
forall b. Var -> Expr b
Var (Var -> Expr b) -> [Var] -> [Expr b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
ys')
      let rs :: [(Var, Expr b)]
rs   = [Var] -> [Expr b] -> [(Var, Expr b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
ys' [Expr b]
forall {b}. [Expr b]
yes
      let es' :: [Expr Var]
es'  = ([Var] -> Expr Var -> Expr Var)
-> [[Var]] -> [Expr Var] -> [Expr Var]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ([Var] -> [Var] -> Expr Var -> Expr Var
mkE [Var]
ys) [[Var]]
ids' [Expr Var]
es
      let xes' :: [(Var, Expr Var)]
xes' = [Var] -> [Expr Var] -> [(Var, Expr Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
ys [Expr Var]
es'
      Expr Var -> StateT TrEnv Identity (Expr Var)
forall a. a -> StateT TrEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return   (Expr Var -> StateT TrEnv Identity (Expr Var))
-> Expr Var -> StateT TrEnv Identity (Expr Var)
forall a b. (a -> b) -> a -> b
$ [(Var, Expr Var)] -> Bind Var -> Expr Var -> Expr Var
forall b. [(b, Expr b)] -> Bind b -> Expr b -> Expr b
mkRecBinds [(Var, Expr Var)]
forall {b}. [(Var, Expr b)]
rs ([(Var, Expr Var)] -> Bind Var
forall b. [(b, Expr b)] -> Bind b
Rec [(Var, Expr Var)]
xes') (HashMap Var (Expr Var) -> Expr Var -> Expr Var
forall a. Subable a => HashMap Var (Expr Var) -> a -> a
sub HashMap Var (Expr Var)
forall {b}. HashMap Var (Expr b)
su Expr Var
e)
 where
   ([Var]
xs, [Expr Var]
es)       = [(Var, Expr Var)] -> ([Var], [Expr Var])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Expr Var)]
xes
   mkSu :: [Var] -> [Var] -> HashMap Var (Expr b)
mkSu [Var]
ys [Var]
ids'   = [Var] -> [Var] -> [Var] -> [(Var, Var)] -> HashMap Var (Expr b)
forall k b.
(Eq k, Hashable k) =>
[k] -> [Var] -> [Var] -> [(k, Var)] -> HashMap k (Expr b)
mkSubs [Var]
ids [Var]
vs [Var]
ids' ([Var] -> [Var] -> [(Var, Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
xs [Var]
ys)
   mkE :: [Var] -> [Var] -> Expr Var -> Expr Var
mkE [Var]
ys [Var]
ids' Expr Var
e' = [Var] -> Expr Var -> Expr Var
mkCoreLams ([Var]
vs [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
ids') (HashMap Var (Expr Var) -> Expr Var -> Expr Var
forall a. Subable a => HashMap Var (Expr Var) -> a -> a
sub ([Var] -> [Var] -> HashMap Var (Expr Var)
forall {b}. [Var] -> [Var] -> HashMap Var (Expr b)
mkSu [Var]
ys [Var]
ids') Expr Var
e')

makeTrans [Var]
_ [Var]
_ Expr Var
_ = Maybe SrcSpan -> [Char] -> StateT TrEnv Identity (Expr Var)
forall a. Maybe SrcSpan -> [Char] -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing [Char]
"TransformRec.makeTrans called with invalid input"

mkRecBinds :: [(b, Expr b)] -> Bind b -> Expr b -> Expr b
mkRecBinds :: forall b. [(b, Expr b)] -> Bind b -> Expr b -> Expr b
mkRecBinds [(b, Expr b)]
xes Bind b
rs Expr b
expr = Bind b -> Expr b -> Expr b
forall b. Bind b -> Expr b -> Expr b
Let Bind b
rs ((Expr b -> (b, Expr b) -> Expr b)
-> Expr b -> [(b, Expr b)] -> Expr b
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' Expr b -> (b, Expr b) -> Expr b
forall {b}. Expr b -> (b, Expr b) -> Expr b
f Expr b
expr [(b, Expr b)]
xes)
  where f :: Expr b -> (b, Expr b) -> Expr b
f Expr b
e (b
x, Expr b
xe) = Bind b -> Expr b -> Expr b
forall b. Bind b -> Expr b -> Expr b
Let (b -> Expr b -> Bind b
forall b. b -> Expr b -> Bind b
NonRec b
x Expr b
xe) Expr b
e

mkSubs :: (Eq k, Hashable k)
       => [k] -> [Var] -> [Id] -> [(k, Id)] -> M.HashMap k (Expr b)
mkSubs :: forall k b.
(Eq k, Hashable k) =>
[k] -> [Var] -> [Var] -> [(k, Var)] -> HashMap k (Expr b)
mkSubs [k]
ids [Var]
tvs [Var]
xs [(k, Var)]
ys = [(k, Expr b)] -> HashMap k (Expr b)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(k, Expr b)] -> HashMap k (Expr b))
-> [(k, Expr b)] -> HashMap k (Expr b)
forall a b. (a -> b) -> a -> b
$ [(k, Expr b)]
forall {b}. [(k, Expr b)]
s1 [(k, Expr b)] -> [(k, Expr b)] -> [(k, Expr b)]
forall a. [a] -> [a] -> [a]
++ [(k, Expr b)]
forall {b}. [(k, Expr b)]
s2
  where s1 :: [(k, Expr b)]
s1 = (Var -> Expr b) -> (k, Var) -> (k, Expr b)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ([Var] -> [Var] -> Var -> Expr b
forall b. [Var] -> [Var] -> Var -> Expr b
appTysAndIds [Var]
tvs [Var]
xs) ((k, Var) -> (k, Expr b)) -> [(k, Var)] -> [(k, Expr b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(k, Var)]
ys
        s2 :: [(k, Expr b)]
s2 = [k] -> [Expr b] -> [(k, Expr b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [k]
ids (Var -> Expr b
forall b. Var -> Expr b
Var (Var -> Expr b) -> [Var] -> [Expr b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
xs)

mkFreshIds :: [TyVar]
           -> [Var]
           -> Var
           -> State TrEnv ([Var], Id)
mkFreshIds :: [Var] -> [Var] -> Var -> StateT TrEnv Identity ([Var], Var)
mkFreshIds [Var]
tvs [Var]
origIds Var
var
  = do [Var]
ids'  <- (Var -> StateT TrEnv Identity Var)
-> [Var] -> StateT TrEnv Identity [Var]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Var -> StateT TrEnv Identity Var
forall a. Freshable a => a -> TE a
fresh [Var]
origIds
       let ids'' :: [Var]
ids'' = (Var -> Var) -> [Var] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Var
setIdTRecBound [Var]
ids'
       let t :: Type
t  = [ForAllTyBinder] -> Type -> Type
mkForAllTys ((Var -> ForAllTyFlag -> ForAllTyBinder
forall var argf. var -> argf -> VarBndr var argf
`Bndr` ForAllTyFlag
Required) (Var -> ForAllTyBinder) -> [Var] -> [ForAllTyBinder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
tvs) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Var] -> Type -> Type
forall {t :: * -> *}. Foldable t => t Var -> Type -> Type
mkType ([Var] -> [Var]
forall a. [a] -> [a]
reverse [Var]
ids'') (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
var
       let x' :: Var
x' = Var -> Type -> Var
setVarType Var
var Type
t
       ([Var], Var) -> StateT TrEnv Identity ([Var], Var)
forall a. a -> StateT TrEnv Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Var]
ids'', Var
x')
  where
    mkType :: t Var -> Type -> Type
mkType t Var
ids Type
ty = (Type -> Var -> Type) -> Type -> t Var -> Type
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Type
t Var
x -> FunTyFlag -> Type -> Type -> Type -> Type
FunTy FunTyFlag
FTF_T_T Type
ManyTy (Var -> Type
varType Var
x) Type
t) Type
ty t Var
ids -- FIXME(adinapoli): Is 'VisArg' OK here?

-- NOTE [Don't choose transform-rec binders as decreasing params]
-- --------------------------------------------------------------
--
-- We don't want to select a binder created by TransformRec as the
-- decreasing parameter, since the user didn't write it. Furthermore,
-- consider T1065. There we have an inner loop that decreases on the
-- sole list parameter. But TransformRec prepends the parameters to the
-- outer `groupByFB` to the inner `groupByFBCore`, and now the first
-- decreasing parameter is the constant `xs0`. Disaster!
--
-- So we need a way to signal to L.H.L.Constraint.Generate that we
-- should ignore these copied Vars. The easiest way to do that is to set
-- a flag on the Var that we know won't be set, and it just so happens
-- GHC has a bunch of optional flags that can be set by various Core
-- analyses that we don't run...
setIdTRecBound :: Id -> Id
-- This is an ugly hack..
setIdTRecBound :: Var -> Var
setIdTRecBound = (() :: Constraint) => (IdInfo -> IdInfo) -> Var -> Var
(IdInfo -> IdInfo) -> Var -> Var
modifyIdInfo (IdInfo -> CafInfo -> IdInfo
`setCafInfo` CafInfo
NoCafRefs)

isIdTRecBound :: Id -> Bool
isIdTRecBound :: Var -> Bool
isIdTRecBound = Bool -> Bool
not (Bool -> Bool) -> (Var -> Bool) -> Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CafInfo -> Bool
mayHaveCafRefs (CafInfo -> Bool) -> (Var -> CafInfo) -> Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> CafInfo
cafInfo (IdInfo -> CafInfo) -> (Var -> IdInfo) -> Var -> CafInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => Var -> IdInfo
Var -> IdInfo
idInfo

class Freshable a where
  fresh :: a -> TE a

instance Freshable Int where
  fresh :: Int -> TE Int
fresh Int
_ = TE Int
forall (m :: * -> *). MonadState TrEnv m => m Int
freshInt

instance Freshable Unique where
  fresh :: Unique -> TE Unique
fresh Unique
_ = TE Unique
forall (m :: * -> *). MonadState TrEnv m => m Unique
freshUnique

instance Freshable Var where
  fresh :: Var -> StateT TrEnv Identity Var
fresh Var
v = (Unique -> Var) -> TE Unique -> StateT TrEnv Identity Var
forall a b.
(a -> b) -> StateT TrEnv Identity a -> StateT TrEnv Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Var -> Unique -> Var
setVarUnique Var
v) TE Unique
forall (m :: * -> *). MonadState TrEnv m => m Unique
freshUnique

freshInt :: MonadState TrEnv m => m Int
freshInt :: forall (m :: * -> *). MonadState TrEnv m => m Int
freshInt
  = do TrEnv
s <- m TrEnv
forall s (m :: * -> *). MonadState s m => m s
get
       let n :: Int
n = TrEnv -> Int
freshIndex TrEnv
s
       TrEnv -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put TrEnv
s{freshIndex = n+1}
       Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n

freshUnique :: MonadState TrEnv m => m Unique
freshUnique :: forall (m :: * -> *). MonadState TrEnv m => m Unique
freshUnique = (Int -> Unique) -> m Int -> m Unique
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> Int -> Unique
mkUnique Char
'X') m Int
forall (m :: * -> *). MonadState TrEnv m => m Int
freshInt


mapNonRec :: (b -> [Bind b] -> [Bind b]) -> [Bind b] -> [Bind b]
mapNonRec :: forall b. (b -> [Bind b] -> [Bind b]) -> [Bind b] -> [Bind b]
mapNonRec b -> [Bind b] -> [Bind b]
f (NonRec b
x Expr b
xe:[Bind b]
xes) = b -> Expr b -> Bind b
forall b. b -> Expr b -> Bind b
NonRec b
x Expr b
xe Bind b -> [Bind b] -> [Bind b]
forall a. a -> [a] -> [a]
: b -> [Bind b] -> [Bind b]
f b
x ((b -> [Bind b] -> [Bind b]) -> [Bind b] -> [Bind b]
forall b. (b -> [Bind b] -> [Bind b]) -> [Bind b] -> [Bind b]
mapNonRec b -> [Bind b] -> [Bind b]
f [Bind b]
xes)
mapNonRec b -> [Bind b] -> [Bind b]
f (Bind b
xe:[Bind b]
xes)          = Bind b
xe Bind b -> [Bind b] -> [Bind b]
forall a. a -> [a] -> [a]
: (b -> [Bind b] -> [Bind b]) -> [Bind b] -> [Bind b]
forall b. (b -> [Bind b] -> [Bind b]) -> [Bind b] -> [Bind b]
mapNonRec b -> [Bind b] -> [Bind b]
f [Bind b]
xes
mapNonRec b -> [Bind b] -> [Bind b]
_ []                = []

mapBnd :: (b -> Expr b -> Expr b) -> Bind b -> Bind b
mapBnd :: forall b. (b -> Expr b -> Expr b) -> Bind b -> Bind b
mapBnd b -> Expr b -> Expr b
f (NonRec b
b Expr b
e)             = b -> Expr b -> Bind b
forall b. b -> Expr b -> Bind b
NonRec b
b ((b -> Expr b -> Expr b) -> Expr b -> Expr b
forall b. (b -> Expr b -> Expr b) -> Expr b -> Expr b
mapExpr b -> Expr b -> Expr b
f  Expr b
e)
mapBnd b -> Expr b -> Expr b
f (Rec [(b, Expr b)]
bs)                 = [(b, Expr b)] -> Bind b
forall b. [(b, Expr b)] -> Bind b
Rec (((b, Expr b) -> (b, Expr b)) -> [(b, Expr b)] -> [(b, Expr b)]
forall a b. (a -> b) -> [a] -> [b]
map ((Expr b -> Expr b) -> (b, Expr b) -> (b, Expr b)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((b -> Expr b -> Expr b) -> Expr b -> Expr b
forall b. (b -> Expr b -> Expr b) -> Expr b -> Expr b
mapExpr b -> Expr b -> Expr b
f)) [(b, Expr b)]
bs)

mapExpr :: (b -> Expr b -> Expr b) -> Expr b -> Expr b
mapExpr :: forall b. (b -> Expr b -> Expr b) -> Expr b -> Expr b
mapExpr b -> Expr b -> Expr b
f (Let (NonRec b
x Expr b
ex) Expr b
e)   = Bind b -> Expr b -> Expr b
forall b. Bind b -> Expr b -> Expr b
Let (b -> Expr b -> Bind b
forall b. b -> Expr b -> Bind b
NonRec b
x (b -> Expr b -> Expr b
f b
x Expr b
ex) ) (b -> Expr b -> Expr b
f b
x Expr b
e)
mapExpr b -> Expr b -> Expr b
f (App Expr b
e1 Expr b
e2)             = Expr b -> Expr b -> Expr b
forall b. Expr b -> Expr b -> Expr b
App  ((b -> Expr b -> Expr b) -> Expr b -> Expr b
forall b. (b -> Expr b -> Expr b) -> Expr b -> Expr b
mapExpr b -> Expr b -> Expr b
f Expr b
e1) ((b -> Expr b -> Expr b) -> Expr b -> Expr b
forall b. (b -> Expr b -> Expr b) -> Expr b -> Expr b
mapExpr b -> Expr b -> Expr b
f Expr b
e2)
mapExpr b -> Expr b -> Expr b
f (Lam b
b Expr b
e)               = b -> Expr b -> Expr b
forall b. b -> Expr b -> Expr b
Lam b
b ((b -> Expr b -> Expr b) -> Expr b -> Expr b
forall b. (b -> Expr b -> Expr b) -> Expr b -> Expr b
mapExpr b -> Expr b -> Expr b
f Expr b
e)
mapExpr b -> Expr b -> Expr b
f (Let Bind b
bs Expr b
e)              = Bind b -> Expr b -> Expr b
forall b. Bind b -> Expr b -> Expr b
Let ((b -> Expr b -> Expr b) -> Bind b -> Bind b
forall b. (b -> Expr b -> Expr b) -> Bind b -> Bind b
mapBnd b -> Expr b -> Expr b
f Bind b
bs) ((b -> Expr b -> Expr b) -> Expr b -> Expr b
forall b. (b -> Expr b -> Expr b) -> Expr b -> Expr b
mapExpr b -> Expr b -> Expr b
f Expr b
e)
mapExpr b -> Expr b -> Expr b
f (Case Expr b
e b
b Type
t [Alt b]
alt)        = Expr b -> b -> Type -> [Alt b] -> Expr b
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr b
e b
b Type
t ((Alt b -> Alt b) -> [Alt b] -> [Alt b]
forall a b. (a -> b) -> [a] -> [b]
map ((b -> Expr b -> Expr b) -> Alt b -> Alt b
forall b. (b -> Expr b -> Expr b) -> Alt b -> Alt b
mapAlt b -> Expr b -> Expr b
f) [Alt b]
alt)
mapExpr b -> Expr b -> Expr b
f (Tick CoreTickish
t Expr b
e)              = CoreTickish -> Expr b -> Expr b
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t ((b -> Expr b -> Expr b) -> Expr b -> Expr b
forall b. (b -> Expr b -> Expr b) -> Expr b -> Expr b
mapExpr b -> Expr b -> Expr b
f Expr b
e)
mapExpr b -> Expr b -> Expr b
_  Expr b
e                      = Expr b
e

mapAlt :: (b -> Expr b -> Expr b) -> Alt b -> Alt b
mapAlt :: forall b. (b -> Expr b -> Expr b) -> Alt b -> Alt b
mapAlt b -> Expr b -> Expr b
f (Alt AltCon
d [b]
bs Expr b
e) = AltCon -> [b] -> Expr b -> Alt b
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
d [b]
bs ((b -> Expr b -> Expr b) -> Expr b -> Expr b
forall b. (b -> Expr b -> Expr b) -> Expr b -> Expr b
mapExpr b -> Expr b -> Expr b
f Expr b
e)

-- Do not apply transformations to inner code

mapBdM :: Monad m => t -> a -> m a
mapBdM :: forall (m :: * -> *) t a. Monad m => t -> a -> m a
mapBdM t
_ = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- mapBdM f (Let b e)        = liftM2 Let (f b) (mapBdM f e)
-- mapBdM f (App e1 e2)      = liftM2 App (mapBdM f e1) (mapBdM f e2)
-- mapBdM f (Lam b e)        = liftM (Lam b) (mapBdM f e)
-- mapBdM f (Case e b t alt) = liftM (Case e b t) (mapM (mapBdAltM f) alt)
-- mapBdM f (Tick t e)       = liftM (Tick t) (mapBdM f e)
-- mapBdM _  e               = return  e
--
-- mapBdAltM f (d, bs, e) = liftM ((,,) d bs) (mapBdM f e)