{-# 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    = forall s a. State s a -> s -> a
evalState (forall (t :: * -> *).
Traversable t =>
t (Bind Var) -> State TrEnv (t (Bind Var))
transPg (Bind Var -> Bind Var
inlineLoopBreaker 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
  = forall b. [(b, Expr b)] -> Bind b
Rec [(Var
x, forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b. b -> Expr b -> Expr b
Lam (forall a. Subable a => HashMap Var (Expr Var) -> a -> a
sub (forall k v. Hashable k => k -> v -> HashMap k v
M.singleton Var
lbx forall {b}. Expr b
e') Expr Var
lbe) ([Var]
αs 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' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' forall b. Expr b -> Expr b -> Expr b
App (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' forall b. Expr b -> Expr b -> Expr b
App (forall b. Var -> Expr b
Var Var
x) (forall b. Type -> Expr b
Type forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Type
TyVarTy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
αs)) (forall b. Var -> Expr b
Var 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 forall a. Eq a => a -> a -> Bool
== Var
x2 = forall a. a -> Maybe a
Just (Var
x1, Expr Var
e1)
    hasLoopBreaker Expr Var
_                               = forall a. Maybe a
Nothing

    isLoopBreaker :: Var -> Bool
isLoopBreaker =  OccInfo -> Bool
isStrongLoopBreaker forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> OccInfo
occInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => 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 [] 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)    = forall b. [(b, Expr b)] -> Bind b
Rec (forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd ([(Var, Expr Var)] -> Expr Var -> Expr Var
go' [(Var, Expr Var)]
su) 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) = 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 <- 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' (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)      = 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)        = 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)       = 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) = 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 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)       = 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)       = 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)   = 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
&& forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf String
"fail" (forall a. Show a => a -> String
show Var
x)
    getFailExpr :: a -> [(a, b)] -> Maybe b
getFailExpr = 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)forall a. a -> [a] -> [a]
:[(a, Expr b)]
su
    addFailExpr a
_ Expr b
_         [(a, Expr b)]
_  = forall a. Maybe SrcSpan -> String -> a
impossible forall a. Maybe a
Nothing String
"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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Functor f => f (Bind Var) -> f (Bind Var)
innerScTr

outerScTr :: [Bind Id] -> [Bind Id]
outerScTr :: CoreProgram -> CoreProgram
outerScTr = forall b. (b -> [Bind b] -> [Bind b]) -> [Bind b] -> [Bind b]
mapNonRec (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) | forall t. Var -> Bind t -> Bool
isCaseArg Var
x Bind t
xe = [Bind t] -> Var -> [Bind t] -> [Bind t]
go (Bind t
xeforall a. a -> [a] -> [a]
:[Bind t]
ack) Var
x [Bind t]
xes
   go [Bind t]
ack Var
_ [Bind t]
xes        = [Bind t]
ack 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 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 = (forall b. (b -> Expr b -> Expr b) -> Bind b -> Bind b
mapBnd Var -> Expr Var -> Expr Var
scTrans 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 = forall b. (b -> Expr b -> Expr b) -> Expr b -> Expr b
mapExpr Var -> Expr Var -> Expr Var
scTrans forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b. Bind b -> Expr b -> Expr b
Let Expr Var
e0 CoreProgram
bindIds
  where (CoreProgram
bindIds, Expr Var
e0)           = 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)  | forall t. Var -> Bind t -> Bool
isCaseArg Var
x Bind b
b = [Bind b] -> Var -> Expr b -> ([Bind b], Expr b)
go (Bind b
bforall a. a -> [a] -> [a]
:[Bind b]
bs) Var
x Expr b
e
        go [Bind b]
bs Var
x (Tick CoreTickish
t Expr b
e) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t) 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Bind Var -> State TrEnv (Bind Var)
transBd

transBd :: Bind CoreBndr
        -> State TrEnv (Bind CoreBndr)
transBd :: Bind Var -> State TrEnv (Bind Var)
transBd (NonRec Var
x Expr Var
e) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b. b -> Expr b -> Bind b
NonRec Var
x) (Expr Var -> StateT TrEnv Identity (Expr Var)
transExpr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) t a. Monad m => t -> a -> m a
mapBdM Bind Var -> State TrEnv (Bind Var)
transBd Expr Var
e)
transBd (Rec [(Var, Expr Var)]
xes)    = forall b. [(b, Expr b)] -> Bind b
Rec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) b c a.
Applicative m =>
(b -> m c) -> (a, b) -> m (a, c)
mapSndM (forall (m :: * -> *) t a. Monad m => t -> a -> m a
mapBdM Bind Var -> State TrEnv (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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
tvs)
  = 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
  = 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')              = 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
_) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Expr Var -> Bool
nonPoly (forall a b. (a, b) -> b
snd 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 = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Var], Type)
splitForAllTyCoVars forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Var -> Type
exprType

collectNonRecLets :: Expr t -> ([Bind t], Expr t)
collectNonRecLets :: forall t. Expr t -> ([Bind t], Expr t)
collectNonRecLets = 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
bforall a. a -> [a] -> [a]
:[Bind b]
bs) Expr b
e'
        go [Bind b]
bs Expr b
e'                      = (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 = forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Expr b -> [Type] -> Expr b
mkTyApps (forall b. Var -> Expr b
Var Var
x) (forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
TyVarTy [Var]
tvs)) (forall a b. (a -> b) -> [a] -> [b]
map 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)
  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Expr Var -> Expr Var
mkLam 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
ids
        mkLet' :: Expr Var -> Expr Var
mkLet' Expr Var
e = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b. b -> Expr b -> Expr b
Lam Expr Var
e forall a b. (a -> b) -> a -> b
$ [Var]
vs forall a. [a] -> [a] -> [a]
++ [Var]
liveIds
        e' :: Expr Var
e'      = forall b. Bind b -> Expr b -> Expr b
Let (forall b. [(b, Expr b)] -> Bind b
Rec [(Var, Expr Var)]
xes') Expr Var
expr
        xes' :: [(Var, Expr Var)]
xes'    = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Expr Var -> Expr Var
mkLet' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, Expr Var)]
xes

trans [Var]
_ [Var]
_ t (Bind Var)
_ Expr Var
_ = forall a. Maybe SrcSpan -> String -> a
panic forall a. Maybe a
Nothing String
"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    <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Var] -> [Var] -> Var -> State TrEnv ([Var], Var)
mkFreshIds [Var]
vs [Var]
ids) [Var]
xs
      let ([[Var]]
ids', [Var]
ys) = forall a b. [(a, b)] -> ([a], [b])
unzip [([Var], Var)]
fids
      let yes :: [Expr b]
yes  = forall b. [Var] -> [Var] -> Var -> Expr b
appTysAndIds [Var]
vs [Var]
ids forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
ys
      [Var]
ys'     <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Freshable a => a -> TE a
fresh [Var]
xs
      let su :: HashMap Var (Expr b)
su   = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
xs (forall b. Var -> Expr b
Var forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
ys')
      let rs :: [(Var, Expr b)]
rs   = forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
ys' forall {b}. [Expr b]
yes
      let es' :: [Expr Var]
es'  = 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' = forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
ys [Expr Var]
es'
      forall (m :: * -> *) a. Monad m => a -> m a
return   forall a b. (a -> b) -> a -> b
$ forall b. [(b, Expr b)] -> Bind b -> Expr b -> Expr b
mkRecBinds forall {b}. [(Var, Expr b)]
rs (forall b. [(b, Expr b)] -> Bind b
Rec [(Var, Expr Var)]
xes') (forall a. Subable a => HashMap Var (Expr Var) -> a -> a
sub forall {b}. HashMap Var (Expr b)
su Expr Var
e)
 where
   ([Var]
xs, [Expr Var]
es)       = forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Expr Var)]
xes
   mkSu :: [Var] -> [Var] -> HashMap Var (Expr b)
mkSu [Var]
ys [Var]
ids'   = forall k b.
(Eq k, Hashable k) =>
[k] -> [Var] -> [Var] -> [(k, Var)] -> HashMap k (Expr b)
mkSubs [Var]
ids [Var]
vs [Var]
ids' (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 forall a. [a] -> [a] -> [a]
++ [Var]
ids') (forall a. Subable a => HashMap Var (Expr Var) -> a -> a
sub (forall {b}. [Var] -> [Var] -> HashMap Var (Expr b)
mkSu [Var]
ys [Var]
ids') Expr Var
e')

makeTrans [Var]
_ [Var]
_ Expr Var
_ = forall a. Maybe SrcSpan -> String -> a
panic forall a. Maybe a
Nothing String
"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 = forall b. Bind b -> Expr b -> Expr b
Let Bind b
rs (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' 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) = forall b. Bind b -> Expr b -> Expr b
Let (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 = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList forall a b. (a -> b) -> a -> b
$ forall {b}. [(k, Expr b)]
s1 forall a. [a] -> [a] -> [a]
++ forall {b}. [(k, Expr b)]
s2
  where s1 :: [(k, Expr b)]
s1 = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall b. [Var] -> [Var] -> Var -> Expr b
appTysAndIds [Var]
tvs [Var]
xs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(k, Var)]
ys
        s2 :: [(k, Expr b)]
s2 = forall a b. [a] -> [b] -> [(a, b)]
zip [k]
ids (forall b. Var -> Expr b
Var 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 -> State TrEnv ([Var], Var)
mkFreshIds [Var]
tvs [Var]
origIds Var
var
  = do [Var]
ids'  <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Freshable a => a -> TE a
fresh [Var]
origIds
       let ids'' :: [Var]
ids'' = forall a b. (a -> b) -> [a] -> [b]
map Var -> Var
setIdTRecBound [Var]
ids'
       let t :: Type
t  = [TyCoVarBinder] -> Type -> Type
mkForAllTys ((forall var argf. var -> argf -> VarBndr var argf
`Bndr` ArgFlag
Required) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
tvs) forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *}. Foldable t => t Var -> Type -> Type
mkType (forall a. [a] -> [a]
reverse [Var]
ids'') forall a b. (a -> b) -> a -> b
$ Var -> Type
varType Var
var
       let x' :: Var
x' = Var -> Type -> Var
setVarType Var
var Type
t
       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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Type
t Var
x -> AnonArgFlag -> Type -> Type -> Type -> Type
FunTy AnonArgFlag
VisArg Type
Many (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 = HasDebugCallStack => (IdInfo -> IdInfo) -> Var -> Var
modifyIdInfo (IdInfo -> CafInfo -> IdInfo
`setCafInfo` CafInfo
NoCafRefs)

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

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

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

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

instance Freshable Var where
  fresh :: Var -> TE Var
fresh Var
v = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Var -> Unique -> Var
setVarUnique Var
v) 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 <- forall s (m :: * -> *). MonadState s m => m s
get
       let n :: Int
n = TrEnv -> Int
freshIndex TrEnv
s
       forall s (m :: * -> *). MonadState s m => s -> m ()
put TrEnv
s{freshIndex :: Int
freshIndex = Int
nforall a. Num a => a -> a -> a
+Int
1}
       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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> Int -> Unique
mkUnique Char
'X') 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) = forall b. b -> Expr b -> Bind b
NonRec b
x Expr b
xe forall a. a -> [a] -> [a]
: b -> [Bind b] -> [Bind b]
f b
x (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 forall a. a -> [a] -> [a]
: 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)             = forall b. b -> Expr b -> Bind b
NonRec b
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)                 = forall b. [(b, Expr b)] -> Bind b
Rec (forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (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)   = forall b. Bind b -> Expr b -> Expr b
Let (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)             = forall b. Expr b -> Expr b -> Expr b
App  (forall b. (b -> Expr b -> Expr b) -> Expr b -> Expr b
mapExpr b -> Expr b -> Expr b
f Expr b
e1) (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)               = forall b. b -> Expr b -> Expr b
Lam b
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)              = forall b. Bind b -> Expr b -> Expr b
Let (forall b. (b -> Expr b -> Expr b) -> Bind b -> Bind b
mapBnd b -> Expr b -> Expr b
f Bind b
bs) (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)        = forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr b
e b
b Type
t (forall a b. (a -> b) -> [a] -> [b]
map (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)              = forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t (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) = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
d [b]
bs (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
_ = 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)