--------------------------------------------------------------------------------
-- | Convert GHC Core into Administrative Normal Form (ANF) --------------------
--------------------------------------------------------------------------------

{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE NoMonomorphismRestriction  #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}


module Language.Haskell.Liquid.Transforms.ANF (anormalize) where

import           Prelude                          hiding (error)
import           CoreSyn                          hiding (mkTyArg)
import           CoreUtils                        (exprType)
import qualified DsMonad
import           DsMonad                          (initDsWithModGuts)
import           GHC                              hiding (exprType)
import           HscTypes
import           Literal
import           MkCore                           (mkCoreLets)
import           Outputable                       (trace)
import           Language.Haskell.Liquid.GHC.TypeRep
import           Language.Haskell.Liquid.GHC.API  hiding (exprType, mkTyArg)
import           VarEnv                           (VarEnv, emptyVarEnv, extendVarEnv, lookupWithDefaultVarEnv)
import           UniqSupply                       (MonadUnique, getUniqueM)
import           Control.Monad.State.Lazy
import           System.Console.CmdArgs.Verbosity (whenLoud)
import qualified Language.Fixpoint.Misc     as F
import qualified Language.Fixpoint.Types    as F

import           Language.Haskell.Liquid.UX.Config  as UX
import qualified Language.Haskell.Liquid.Misc       as Misc 
import           Language.Haskell.Liquid.GHC.Misc   as GM
import           Language.Haskell.Liquid.Transforms.Rec
import           Language.Haskell.Liquid.Transforms.Rewrite
import           Language.Haskell.Liquid.Types.Errors

import qualified Language.Haskell.Liquid.GHC.SpanStack as Sp
import qualified Language.Haskell.Liquid.GHC.Resugar   as Rs
import           Data.Maybe                       (fromMaybe)
import           Data.List                        (sortBy, (\\))
import           Data.Function                    (on)
import qualified Text.Printf as Printf 

--------------------------------------------------------------------------------
-- | A-Normalize a module ------------------------------------------------------
--------------------------------------------------------------------------------
anormalize :: UX.Config -> HscEnv -> ModGuts -> IO [CoreBind]
--------------------------------------------------------------------------------
anormalize :: Config -> HscEnv -> ModGuts -> IO [CoreBind]
anormalize Config
cfg HscEnv
hscEnv ModGuts
modGuts = do
  IO () -> IO ()
whenLoud (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
putStrLn String
"***************************** GHC CoreBinds ***************************"
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> [CoreBind] -> String
GM.showCBs Bool
untidy (ModGuts -> [CoreBind]
mg_binds ModGuts
modGuts)
    String -> IO ()
putStrLn String
"***************************** REC CoreBinds ***************************"
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> [CoreBind] -> String
GM.showCBs Bool
untidy [CoreBind]
orig_cbs
    String -> IO ()
putStrLn String
"***************************** RWR CoreBinds ***************************"
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> [CoreBind] -> String
GM.showCBs Bool
untidy [CoreBind]
rwr_cbs
  ([CoreBind] -> Maybe [CoreBind] -> [CoreBind]
forall a. a -> Maybe a -> a
fromMaybe [CoreBind]
forall a. a
err (Maybe [CoreBind] -> [CoreBind])
-> ((Messages, Maybe [CoreBind]) -> Maybe [CoreBind])
-> (Messages, Maybe [CoreBind])
-> [CoreBind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Messages, Maybe [CoreBind]) -> Maybe [CoreBind]
forall a b. (a, b) -> b
snd) ((Messages, Maybe [CoreBind]) -> [CoreBind])
-> IO (Messages, Maybe [CoreBind]) -> IO [CoreBind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv
-> ModGuts -> DsM [CoreBind] -> IO (Messages, Maybe [CoreBind])
forall a. HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
initDsWithModGuts HscEnv
hscEnv ModGuts
modGuts DsM [CoreBind]
act -- hscEnv m grEnv tEnv emptyFamInstEnv act
    where
      err :: a
err      = Maybe SrcSpan -> String -> a
forall a. Maybe SrcSpan -> String -> a
panic Maybe SrcSpan
forall a. Maybe a
Nothing String
"Oops, cannot A-Normalize GHC Core!"
      act :: DsM [CoreBind]
act      = (CoreBind -> DsM [CoreBind]) -> [CoreBind] -> DsM [CoreBind]
forall (m :: * -> *) (t :: * -> *) a b.
(Monad m, Traversable t) =>
(a -> m [b]) -> t a -> m [b]
Misc.concatMapM (AnfEnv -> CoreBind -> DsM [CoreBind]
normalizeTopBind AnfEnv
γ0) [CoreBind]
rwr_cbs
      γ0 :: AnfEnv
γ0       = Config -> AnfEnv
emptyAnfEnv Config
cfg
      rwr_cbs :: [CoreBind]
rwr_cbs  = Config -> [CoreBind] -> [CoreBind]
rewriteBinds Config
cfg [CoreBind]
orig_cbs
      orig_cbs :: [CoreBind]
orig_cbs = [CoreBind] -> [CoreBind]
transformRecExpr ([CoreBind] -> [CoreBind]) -> [CoreBind] -> [CoreBind]
forall a b. (a -> b) -> a -> b
$ ModGuts -> [CoreBind]
mg_binds ModGuts
modGuts
      untidy :: Bool
untidy   = Config -> Bool
UX.untidyCore Config
cfg

{-
      m        = mgi_module modGuts
      grEnv    = mgi_rdr_env modGuts
      tEnv     = modGutsTypeEnv modGuts

modGutsTypeEnv :: MGIModGuts -> TypeEnv
modGutsTypeEnv mg  = typeEnvFromEntities ids tcs fis
  where
    ids            = bindersOfBinds (mgi_binds mg)
    tcs            = mgi_tcs mg
    fis            = mgi_fam_insts mg
-}

--------------------------------------------------------------------------------
-- | A-Normalize a @CoreBind@ --------------------------------------------------
--------------------------------------------------------------------------------

-- Can't make the below default for normalizeBind as it
-- fails tests/pos/lets.hs due to GHCs odd let-bindings

normalizeTopBind :: AnfEnv -> Bind CoreBndr -> DsMonad.DsM [CoreBind]
normalizeTopBind :: AnfEnv -> CoreBind -> DsM [CoreBind]
normalizeTopBind AnfEnv
γ (NonRec CoreBndr
x Expr CoreBndr
e)
  = do Expr CoreBndr
e' <- DsM (Expr CoreBndr) -> DsM (Expr CoreBndr)
forall a. DsM a -> DsM a
runDsM (DsM (Expr CoreBndr) -> DsM (Expr CoreBndr))
-> DsM (Expr CoreBndr) -> DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ StateT DsST DsM (Expr CoreBndr) -> DsST -> DsM (Expr CoreBndr)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
stitch AnfEnv
γ Expr CoreBndr
e) ([CoreBind] -> DsST
DsST [])
       [CoreBind] -> DsM [CoreBind]
forall (m :: * -> *) a. Monad m => a -> m a
return [CoreBind -> CoreBind
normalizeTyVars (CoreBind -> CoreBind) -> CoreBind -> CoreBind
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
x Expr CoreBndr
e']

normalizeTopBind AnfEnv
γ (Rec [(CoreBndr, Expr CoreBndr)]
xes)
  = do DsST
xes' <- DsM DsST -> DsM DsST
forall a. DsM a -> DsM a
runDsM (DsM DsST -> DsM DsST) -> DsM DsST -> DsM DsST
forall a b. (a -> b) -> a -> b
$ StateT DsST DsM () -> DsST -> DsM DsST
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (AnfEnv -> CoreBind -> StateT DsST DsM ()
normalizeBind AnfEnv
γ ([(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr, Expr CoreBndr)]
xes)) ([CoreBind] -> DsST
DsST [])
       [CoreBind] -> DsM [CoreBind]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreBind] -> DsM [CoreBind]) -> [CoreBind] -> DsM [CoreBind]
forall a b. (a -> b) -> a -> b
$ (CoreBind -> CoreBind) -> [CoreBind] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map CoreBind -> CoreBind
normalizeTyVars (DsST -> [CoreBind]
st_binds DsST
xes')

normalizeTyVars :: Bind Id -> Bind Id
normalizeTyVars :: CoreBind -> CoreBind
normalizeTyVars (NonRec CoreBndr
x Expr CoreBndr
e) = CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec (CoreBndr -> Type -> CoreBndr
setVarType CoreBndr
x Type
t') (Expr CoreBndr -> CoreBind) -> Expr CoreBndr -> CoreBind
forall a b. (a -> b) -> a -> b
$ Expr CoreBndr -> Expr CoreBndr
normalizeForAllTys Expr CoreBndr
e
  where 
    t' :: Type
t'       = String -> [CoreBndr] -> [CoreBndr] -> Type -> Type
subst String
msg [CoreBndr]
as [CoreBndr]
as' Type
bt
    msg :: String
msg      = String
"WARNING: unable to renameVars on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CoreBndr -> String
forall a. Outputable a => a -> String
GM.showPpr CoreBndr
x
    as' :: [CoreBndr]
as'      = ([CoreBndr], Type) -> [CoreBndr]
forall a b. (a, b) -> a
fst (([CoreBndr], Type) -> [CoreBndr])
-> ([CoreBndr], Type) -> [CoreBndr]
forall a b. (a -> b) -> a -> b
$ Type -> ([CoreBndr], Type)
splitForAllTys (Type -> ([CoreBndr], Type)) -> Type -> ([CoreBndr], Type)
forall a b. (a -> b) -> a -> b
$ Expr CoreBndr -> Type
exprType Expr CoreBndr
e
    ([CoreBndr]
as, Type
bt) = Type -> ([CoreBndr], Type)
splitForAllTys (CoreBndr -> Type
varType CoreBndr
x)
normalizeTyVars (Rec [(CoreBndr, Expr CoreBndr)]
xes)    = [(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr, Expr CoreBndr)]
xes'
  where 
    nrec :: [CoreBind]
nrec     = CoreBind -> CoreBind
normalizeTyVars (CoreBind -> CoreBind) -> [CoreBind] -> [CoreBind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((\(CoreBndr
x, Expr CoreBndr
e) -> CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
x Expr CoreBndr
e) ((CoreBndr, Expr CoreBndr) -> CoreBind)
-> [(CoreBndr, Expr CoreBndr)] -> [CoreBind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(CoreBndr, Expr CoreBndr)]
xes)
    xes' :: [(CoreBndr, Expr CoreBndr)]
xes'     = (\(NonRec CoreBndr
x Expr CoreBndr
e) -> (CoreBndr
x, Expr CoreBndr
e)) (CoreBind -> (CoreBndr, Expr CoreBndr))
-> [CoreBind] -> [(CoreBndr, Expr CoreBndr)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CoreBind]
nrec

subst :: String -> [TyVar] -> [TyVar] -> Type -> Type
subst :: String -> [CoreBndr] -> [CoreBndr] -> Type -> Type
subst String
msg [CoreBndr]
as [CoreBndr]
as' Type
bt
  | [CoreBndr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreBndr]
as Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [CoreBndr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreBndr]
as'
  = [TyCoVarBinder] -> Type -> Type
mkForAllTys (CoreBndr -> TyCoVarBinder
mkTyArg (CoreBndr -> TyCoVarBinder) -> [CoreBndr] -> [TyCoVarBinder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CoreBndr]
as') (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
su Type
bt
  | Bool
otherwise
  = String -> Type -> Type
forall a. String -> a -> a
trace String
msg (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [TyCoVarBinder] -> Type -> Type
mkForAllTys (CoreBndr -> TyCoVarBinder
mkTyArg (CoreBndr -> TyCoVarBinder) -> [CoreBndr] -> [TyCoVarBinder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CoreBndr]
as) Type
bt
  where su :: TCvSubst
su = [(CoreBndr, Type)] -> TCvSubst
mkTvSubstPrs ([(CoreBndr, Type)] -> TCvSubst) -> [(CoreBndr, Type)] -> TCvSubst
forall a b. (a -> b) -> a -> b
$ [CoreBndr] -> [Type] -> [(CoreBndr, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CoreBndr]
as ([CoreBndr] -> [Type]
mkTyVarTys [CoreBndr]
as')

-- | eta-expand CoreBinds with quantified types
normalizeForAllTys :: CoreExpr -> CoreExpr
normalizeForAllTys :: Expr CoreBndr -> Expr CoreBndr
normalizeForAllTys Expr CoreBndr
e = case Expr CoreBndr
e of
  Lam CoreBndr
b Expr CoreBndr
_ | CoreBndr -> Bool
isTyVar CoreBndr
b
    -> Expr CoreBndr
e
  Expr CoreBndr
_ -> [CoreBndr] -> Expr CoreBndr -> Expr CoreBndr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
tvs (Expr CoreBndr -> [Type] -> Expr CoreBndr
forall b. Expr b -> [Type] -> Expr b
mkTyApps Expr CoreBndr
e ((CoreBndr -> Type) -> [CoreBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> Type
mkTyVarTy [CoreBndr]
tvs))
  where
  ([CoreBndr]
tvs, Type
_) = Type -> ([CoreBndr], Type)
splitForAllTys (Expr CoreBndr -> Type
exprType Expr CoreBndr
e)


newtype DsM a = DsM {DsM a -> DsM a
runDsM :: DsMonad.DsM a}
   deriving (a -> DsM b -> DsM a
(a -> b) -> DsM a -> DsM b
(forall a b. (a -> b) -> DsM a -> DsM b)
-> (forall a b. a -> DsM b -> DsM a) -> Functor DsM
forall a b. a -> DsM b -> DsM a
forall a b. (a -> b) -> DsM a -> DsM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> DsM b -> DsM a
$c<$ :: forall a b. a -> DsM b -> DsM a
fmap :: (a -> b) -> DsM a -> DsM b
$cfmap :: forall a b. (a -> b) -> DsM a -> DsM b
Functor, Applicative DsM
a -> DsM a
Applicative DsM
-> (forall a b. DsM a -> (a -> DsM b) -> DsM b)
-> (forall a b. DsM a -> DsM b -> DsM b)
-> (forall a. a -> DsM a)
-> Monad DsM
DsM a -> (a -> DsM b) -> DsM b
DsM a -> DsM b -> DsM b
forall a. a -> DsM a
forall a b. DsM a -> DsM b -> DsM b
forall a b. DsM a -> (a -> DsM b) -> DsM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> DsM a
$creturn :: forall a. a -> DsM a
>> :: DsM a -> DsM b -> DsM b
$c>> :: forall a b. DsM a -> DsM b -> DsM b
>>= :: DsM a -> (a -> DsM b) -> DsM b
$c>>= :: forall a b. DsM a -> (a -> DsM b) -> DsM b
$cp1Monad :: Applicative DsM
Monad, Monad DsM
DsM [Unique]
DsM UniqSupply
DsM Unique
Monad DsM
-> DsM UniqSupply -> DsM Unique -> DsM [Unique] -> MonadUnique DsM
forall (m :: * -> *).
Monad m -> m UniqSupply -> m Unique -> m [Unique] -> MonadUnique m
getUniquesM :: DsM [Unique]
$cgetUniquesM :: DsM [Unique]
getUniqueM :: DsM Unique
$cgetUniqueM :: DsM Unique
getUniqueSupplyM :: DsM UniqSupply
$cgetUniqueSupplyM :: DsM UniqSupply
$cp1MonadUnique :: Monad DsM
MonadUnique, Functor DsM
a -> DsM a
Functor DsM
-> (forall a. a -> DsM a)
-> (forall a b. DsM (a -> b) -> DsM a -> DsM b)
-> (forall a b c. (a -> b -> c) -> DsM a -> DsM b -> DsM c)
-> (forall a b. DsM a -> DsM b -> DsM b)
-> (forall a b. DsM a -> DsM b -> DsM a)
-> Applicative DsM
DsM a -> DsM b -> DsM b
DsM a -> DsM b -> DsM a
DsM (a -> b) -> DsM a -> DsM b
(a -> b -> c) -> DsM a -> DsM b -> DsM c
forall a. a -> DsM a
forall a b. DsM a -> DsM b -> DsM a
forall a b. DsM a -> DsM b -> DsM b
forall a b. DsM (a -> b) -> DsM a -> DsM b
forall a b c. (a -> b -> c) -> DsM a -> DsM b -> DsM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: DsM a -> DsM b -> DsM a
$c<* :: forall a b. DsM a -> DsM b -> DsM a
*> :: DsM a -> DsM b -> DsM b
$c*> :: forall a b. DsM a -> DsM b -> DsM b
liftA2 :: (a -> b -> c) -> DsM a -> DsM b -> DsM c
$cliftA2 :: forall a b c. (a -> b -> c) -> DsM a -> DsM b -> DsM c
<*> :: DsM (a -> b) -> DsM a -> DsM b
$c<*> :: forall a b. DsM (a -> b) -> DsM a -> DsM b
pure :: a -> DsM a
$cpure :: forall a. a -> DsM a
$cp1Applicative :: Functor DsM
Applicative)

data DsST = DsST { DsST -> [CoreBind]
st_binds :: [CoreBind] }

type DsMW = StateT DsST DsM

------------------------------------------------------------------
normalizeBind :: AnfEnv -> CoreBind -> DsMW ()
------------------------------------------------------------------
normalizeBind :: AnfEnv -> CoreBind -> StateT DsST DsM ()
normalizeBind AnfEnv
γ (NonRec CoreBndr
x Expr CoreBndr
e)
  = do Expr CoreBndr
e' <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize AnfEnv
γ Expr CoreBndr
e
       [CoreBind] -> StateT DsST DsM ()
add [CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
x Expr CoreBndr
e']

normalizeBind AnfEnv
γ (Rec [(CoreBndr, Expr CoreBndr)]
xes)
  = do [Expr CoreBndr]
es' <- (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> [Expr CoreBndr] -> StateT DsST DsM [Expr CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
stitch AnfEnv
γ) [Expr CoreBndr]
es
       [CoreBind] -> StateT DsST DsM ()
add [[(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([CoreBndr] -> [Expr CoreBndr] -> [(CoreBndr, Expr CoreBndr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CoreBndr]
xs [Expr CoreBndr]
es')]
    where
       ([CoreBndr]
xs, [Expr CoreBndr]
es) = [(CoreBndr, Expr CoreBndr)] -> ([CoreBndr], [Expr CoreBndr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CoreBndr, Expr CoreBndr)]
xes

--------------------------------------------------------------------
normalizeName :: AnfEnv -> CoreExpr -> DsMW CoreExpr
--------------------------------------------------------------------

-- normalizeNameDebug γ e
--   = liftM (tracePpr ("normalizeName" ++ showPpr e)) $ normalizeName γ e

normalizeName :: AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalizeName AnfEnv
γ e :: Expr CoreBndr
e@(Lit Literal
l)
  | Literal -> Bool
shouldNormalize Literal
l
  = AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalizeLiteral AnfEnv
γ Expr CoreBndr
e
  | Bool
otherwise
  = Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
e

normalizeName AnfEnv
γ (Var CoreBndr
x)
  = Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr
forall b. CoreBndr -> Expr b
Var (AnfEnv -> CoreBndr -> CoreBndr -> CoreBndr
lookupAnfEnv AnfEnv
γ CoreBndr
x CoreBndr
x)

normalizeName AnfEnv
_ e :: Expr CoreBndr
e@(Type Type
_)
  = Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
e

normalizeName AnfEnv
γ e :: Expr CoreBndr
e@(Coercion Coercion
_)
  = do CoreBndr
x     <- DsM CoreBndr -> StateT DsST DsM CoreBndr
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DsM CoreBndr -> StateT DsST DsM CoreBndr)
-> DsM CoreBndr -> StateT DsST DsM CoreBndr
forall a b. (a -> b) -> a -> b
$ AnfEnv -> Type -> DsM CoreBndr
freshNormalVar AnfEnv
γ (Type -> DsM CoreBndr) -> Type -> DsM CoreBndr
forall a b. (a -> b) -> a -> b
$ Expr CoreBndr -> Type
exprType Expr CoreBndr
e
       [CoreBind] -> StateT DsST DsM ()
add  [CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
x Expr CoreBndr
e]
       Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr
forall b. CoreBndr -> Expr b
Var CoreBndr
x

normalizeName AnfEnv
γ (Tick Tickish CoreBndr
tt Expr CoreBndr
e)
  = do Expr CoreBndr
e'    <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalizeName (AnfEnv
γ AnfEnv -> Tickish CoreBndr -> AnfEnv
`at` Tickish CoreBndr
tt) Expr CoreBndr
e
       Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ Tickish CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Tickish CoreBndr -> Expr b -> Expr b
Tick Tickish CoreBndr
tt Expr CoreBndr
e'

normalizeName AnfEnv
γ Expr CoreBndr
e
  = do Expr CoreBndr
e'   <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize AnfEnv
γ Expr CoreBndr
e
       CoreBndr
x    <- DsM CoreBndr -> StateT DsST DsM CoreBndr
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DsM CoreBndr -> StateT DsST DsM CoreBndr)
-> DsM CoreBndr -> StateT DsST DsM CoreBndr
forall a b. (a -> b) -> a -> b
$ AnfEnv -> Type -> DsM CoreBndr
freshNormalVar AnfEnv
γ (Type -> DsM CoreBndr) -> Type -> DsM CoreBndr
forall a b. (a -> b) -> a -> b
$ Expr CoreBndr -> Type
exprType Expr CoreBndr
e
       [CoreBind] -> StateT DsST DsM ()
add [CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
x Expr CoreBndr
e']
       Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr
forall b. CoreBndr -> Expr b
Var CoreBndr
x

shouldNormalize :: Literal -> Bool
shouldNormalize :: Literal -> Bool
shouldNormalize (LitNumber {})  = Bool
True 
shouldNormalize (LitString {})    = Bool
True 
shouldNormalize Literal
_               = Bool
False

add :: [CoreBind] -> DsMW ()
add :: [CoreBind] -> StateT DsST DsM ()
add [CoreBind]
w = (DsST -> DsST) -> StateT DsST DsM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((DsST -> DsST) -> StateT DsST DsM ())
-> (DsST -> DsST) -> StateT DsST DsM ()
forall a b. (a -> b) -> a -> b
$ \DsST
s -> DsST
s { st_binds :: [CoreBind]
st_binds = DsST -> [CoreBind]
st_binds DsST
s [CoreBind] -> [CoreBind] -> [CoreBind]
forall a. [a] -> [a] -> [a]
++ [CoreBind]
w}

--------------------------------------------------------------------------------
normalizeLiteral :: AnfEnv -> CoreExpr -> DsMW CoreExpr
--------------------------------------------------------------------------------
normalizeLiteral :: AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalizeLiteral AnfEnv
γ Expr CoreBndr
e =
  do CoreBndr
x <- DsM CoreBndr -> StateT DsST DsM CoreBndr
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DsM CoreBndr -> StateT DsST DsM CoreBndr)
-> DsM CoreBndr -> StateT DsST DsM CoreBndr
forall a b. (a -> b) -> a -> b
$ AnfEnv -> Type -> DsM CoreBndr
freshNormalVar AnfEnv
γ (Type -> DsM CoreBndr) -> Type -> DsM CoreBndr
forall a b. (a -> b) -> a -> b
$ Expr CoreBndr -> Type
exprType Expr CoreBndr
e
     [CoreBind] -> StateT DsST DsM ()
add [CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
x Expr CoreBndr
e]
     Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr
forall b. CoreBndr -> Expr b
Var CoreBndr
x

--------------------------------------------------------------------------------
normalize :: AnfEnv -> CoreExpr -> DsMW CoreExpr
--------------------------------------------------------------------------------
normalize :: AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize AnfEnv
γ Expr CoreBndr
e
  | AnfEnv -> Bool
forall t. HasConfig t => t -> Bool
UX.patternFlag AnfEnv
γ
  , Just Pattern
p <- Expr CoreBndr -> Maybe Pattern
Rs.lift Expr CoreBndr
e
  = AnfEnv -> Pattern -> StateT DsST DsM (Expr CoreBndr)
normalizePattern AnfEnv
γ Pattern
p

normalize AnfEnv
γ (Lam CoreBndr
x Expr CoreBndr
e) | CoreBndr -> Bool
isTyVar CoreBndr
x 
  = do Expr CoreBndr
e' <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize AnfEnv
γ Expr CoreBndr
e
       Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x Expr CoreBndr
e'

normalize AnfEnv
γ (Lam CoreBndr
x Expr CoreBndr
e)
  = do Expr CoreBndr
e' <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
stitch AnfEnv
γ Expr CoreBndr
e
       Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
x Expr CoreBndr
e'

normalize AnfEnv
γ (Let CoreBind
b Expr CoreBndr
e)
  = do AnfEnv -> CoreBind -> StateT DsST DsM ()
normalizeBind AnfEnv
γ CoreBind
b
       AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize AnfEnv
γ Expr CoreBndr
e
       -- Need to float bindings all the way up to the top
       -- Due to GHCs odd let-bindings (see tests/pos/lets.hs)

normalize AnfEnv
γ (Case Expr CoreBndr
e CoreBndr
x Type
t [Alt CoreBndr]
as)
  = do Expr CoreBndr
n     <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalizeName AnfEnv
γ Expr CoreBndr
e
       CoreBndr
x'    <- DsM CoreBndr -> StateT DsST DsM CoreBndr
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DsM CoreBndr -> StateT DsST DsM CoreBndr)
-> DsM CoreBndr -> StateT DsST DsM CoreBndr
forall a b. (a -> b) -> a -> b
$ AnfEnv -> Type -> DsM CoreBndr
freshNormalVar AnfEnv
γ Type
τx -- rename "wild" to avoid shadowing
       let γ' :: AnfEnv
γ' = AnfEnv -> CoreBndr -> CoreBndr -> AnfEnv
extendAnfEnv AnfEnv
γ CoreBndr
x CoreBndr
x'
       [Alt CoreBndr]
as'   <- [Alt CoreBndr]
-> (Alt CoreBndr -> StateT DsST DsM (Alt CoreBndr))
-> StateT DsST DsM [Alt CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Alt CoreBndr]
as ((Alt CoreBndr -> StateT DsST DsM (Alt CoreBndr))
 -> StateT DsST DsM [Alt CoreBndr])
-> (Alt CoreBndr -> StateT DsST DsM (Alt CoreBndr))
-> StateT DsST DsM [Alt CoreBndr]
forall a b. (a -> b) -> a -> b
$ \(AltCon
c, [CoreBndr]
xs, Expr CoreBndr
e') -> (Expr CoreBndr -> Alt CoreBndr)
-> StateT DsST DsM (Expr CoreBndr)
-> StateT DsST DsM (Alt CoreBndr)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (AltCon
c, [CoreBndr]
xs,) (AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
stitch (AltCon -> AnfEnv -> AnfEnv
incrCaseDepth AltCon
c AnfEnv
γ') Expr CoreBndr
e')
       [Alt CoreBndr]
as''  <- DsM [Alt CoreBndr] -> StateT DsST DsM [Alt CoreBndr]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DsM [Alt CoreBndr] -> StateT DsST DsM [Alt CoreBndr])
-> DsM [Alt CoreBndr] -> StateT DsST DsM [Alt CoreBndr]
forall a b. (a -> b) -> a -> b
$ AnfEnv -> Type -> [Alt CoreBndr] -> DsM [Alt CoreBndr]
expandDefaultCase AnfEnv
γ Type
τx [Alt CoreBndr]
as'
       Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ Expr CoreBndr
-> CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr CoreBndr
n CoreBndr
x' Type
t [Alt CoreBndr]
as''
    where τx :: Type
τx = CoreBndr -> Type
GM.expandVarType CoreBndr
x

normalize AnfEnv
γ (Var CoreBndr
x)
  = Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Expr CoreBndr
forall b. CoreBndr -> Expr b
Var (AnfEnv -> CoreBndr -> CoreBndr -> CoreBndr
lookupAnfEnv AnfEnv
γ CoreBndr
x CoreBndr
x)

normalize AnfEnv
_ e :: Expr CoreBndr
e@(Lit Literal
_)
  = Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
e

normalize AnfEnv
_ e :: Expr CoreBndr
e@(Type Type
_)
  = Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return Expr CoreBndr
e

normalize AnfEnv
γ (Cast Expr CoreBndr
e Coercion
τ)
  = do Expr CoreBndr
e' <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalizeName AnfEnv
γ Expr CoreBndr
e
       Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ Expr CoreBndr -> Coercion -> Expr CoreBndr
forall b. Expr b -> Coercion -> Expr b
Cast Expr CoreBndr
e' Coercion
τ

normalize AnfEnv
γ (App Expr CoreBndr
e1 e2 :: Expr CoreBndr
e2@(Type Type
_))
  = do Expr CoreBndr
e1' <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize AnfEnv
γ Expr CoreBndr
e1
       Expr CoreBndr
e2' <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize AnfEnv
γ Expr CoreBndr
e2
       Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
App Expr CoreBndr
e1' Expr CoreBndr
e2'

normalize AnfEnv
γ (App Expr CoreBndr
e1 Expr CoreBndr
e2)
  = do Expr CoreBndr
e1' <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize AnfEnv
γ Expr CoreBndr
e1
       Expr CoreBndr
n2  <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalizeName AnfEnv
γ Expr CoreBndr
e2
       Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
App Expr CoreBndr
e1' Expr CoreBndr
n2

normalize AnfEnv
γ (Tick Tickish CoreBndr
tt Expr CoreBndr
e)
  = do Expr CoreBndr
e' <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize (AnfEnv
γ AnfEnv -> Tickish CoreBndr -> AnfEnv
`at` Tickish CoreBndr
tt) Expr CoreBndr
e
       Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ Tickish CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Tickish CoreBndr -> Expr b -> Expr b
Tick Tickish CoreBndr
tt Expr CoreBndr
e'

normalize AnfEnv
_ (Coercion Coercion
c)
  = Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ Coercion -> Expr CoreBndr
forall b. Coercion -> Expr b
Coercion Coercion
c

--------------------------------------------------------------------------------
stitch :: AnfEnv -> CoreExpr -> DsMW CoreExpr
--------------------------------------------------------------------------------
stitch :: AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
stitch AnfEnv
γ Expr CoreBndr
e
  = do DsST
bs'   <- StateT DsST DsM DsST
forall s (m :: * -> *). MonadState s m => m s
get
       (DsST -> DsST) -> StateT DsST DsM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((DsST -> DsST) -> StateT DsST DsM ())
-> (DsST -> DsST) -> StateT DsST DsM ()
forall a b. (a -> b) -> a -> b
$ \DsST
s -> DsST
s { st_binds :: [CoreBind]
st_binds = [] }
       Expr CoreBndr
e'    <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize AnfEnv
γ Expr CoreBndr
e
       [CoreBind]
bs    <- DsST -> [CoreBind]
st_binds (DsST -> [CoreBind])
-> StateT DsST DsM DsST -> StateT DsST DsM [CoreBind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT DsST DsM DsST
forall s (m :: * -> *). MonadState s m => m s
get
       DsST -> StateT DsST DsM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put DsST
bs'
       Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ [CoreBind] -> Expr CoreBndr -> Expr CoreBndr
mkCoreLets [CoreBind]
bs Expr CoreBndr
e'

_mkCoreLets' :: [CoreBind] -> CoreExpr -> CoreExpr
_mkCoreLets' :: [CoreBind] -> Expr CoreBndr -> Expr CoreBndr
_mkCoreLets' [CoreBind]
bs Expr CoreBndr
e = [CoreBind] -> Expr CoreBndr -> Expr CoreBndr
mkCoreLets [CoreBind]
bs1 Expr CoreBndr
e1
  where
    (Expr CoreBndr
e1, [CoreBind]
bs1)    = String
-> (Expr CoreBndr, [CoreBind]) -> (Expr CoreBndr, [CoreBind])
forall a. Outputable a => String -> a -> a
GM.tracePpr String
"MKCORELETS" (Expr CoreBndr
e, [CoreBind]
bs)

--------------------------------------------------------------------------------
normalizePattern :: AnfEnv -> Rs.Pattern -> DsMW CoreExpr
--------------------------------------------------------------------------------
normalizePattern :: AnfEnv -> Pattern -> StateT DsST DsM (Expr CoreBndr)
normalizePattern AnfEnv
γ p :: Pattern
p@(Rs.PatBind {}) = do
  -- don't normalize the >>= itself, we have a special typing rule for it
  Expr CoreBndr
e1'   <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize AnfEnv
γ (Pattern -> Expr CoreBndr
Rs.patE1 Pattern
p)
  Expr CoreBndr
e2'   <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
stitch    AnfEnv
γ (Pattern -> Expr CoreBndr
Rs.patE2 Pattern
p)
  Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ Pattern -> Expr CoreBndr
Rs.lower Pattern
p { patE1 :: Expr CoreBndr
Rs.patE1 = Expr CoreBndr
e1', patE2 :: Expr CoreBndr
Rs.patE2 = Expr CoreBndr
e2' }

normalizePattern AnfEnv
γ p :: Pattern
p@(Rs.PatReturn {}) = do
  Expr CoreBndr
e'    <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize AnfEnv
γ (Pattern -> Expr CoreBndr
Rs.patE Pattern
p)
  Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ Pattern -> Expr CoreBndr
Rs.lower Pattern
p { patE :: Expr CoreBndr
Rs.patE = Expr CoreBndr
e' }

normalizePattern AnfEnv
_ p :: Pattern
p@(Rs.PatProject {}) =
  Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern -> Expr CoreBndr
Rs.lower Pattern
p)

normalizePattern AnfEnv
γ p :: Pattern
p@(Rs.PatSelfBind {}) = do
  AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize AnfEnv
γ (Pattern -> Expr CoreBndr
Rs.patE Pattern
p)

normalizePattern AnfEnv
γ p :: Pattern
p@(Rs.PatSelfRecBind {}) = do
  Expr CoreBndr
e'    <- AnfEnv -> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
normalize AnfEnv
γ (Pattern -> Expr CoreBndr
Rs.patE Pattern
p)
  Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr))
-> Expr CoreBndr -> StateT DsST DsM (Expr CoreBndr)
forall a b. (a -> b) -> a -> b
$ Pattern -> Expr CoreBndr
Rs.lower Pattern
p { patE :: Expr CoreBndr
Rs.patE = Expr CoreBndr
e' }


--------------------------------------------------------------------------------
expandDefault :: AnfEnv -> Bool 
--------------------------------------------------------------------------------
expandDefault :: AnfEnv -> Bool
expandDefault AnfEnv
γ = AnfEnv -> Int
aeCaseDepth AnfEnv
γ Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= AnfEnv -> Int
forall t. HasConfig t => t -> Int
maxCaseExpand AnfEnv
γ 

--------------------------------------------------------------------------------
expandDefaultCase :: AnfEnv
                  -> Type
                  -> [(AltCon, [Id], CoreExpr)]
                  -> DsM [(AltCon, [Id], CoreExpr)]
--------------------------------------------------------------------------------
expandDefaultCase :: AnfEnv -> Type -> [Alt CoreBndr] -> DsM [Alt CoreBndr]
expandDefaultCase AnfEnv
γ Type
tyapp zs :: [Alt CoreBndr]
zs@((AltCon
DEFAULT, [CoreBndr]
_ ,Expr CoreBndr
_) : [Alt CoreBndr]
_) | AnfEnv -> Bool
expandDefault AnfEnv
γ
  = AnfEnv -> Type -> [Alt CoreBndr] -> DsM [Alt CoreBndr]
forall c.
AnfEnv
-> Type
-> [(AltCon, [CoreBndr], c)]
-> DsM [(AltCon, [CoreBndr], c)]
expandDefaultCase' AnfEnv
γ Type
tyapp [Alt CoreBndr]
zs

expandDefaultCase AnfEnv
γ tyapp :: Type
tyapp@(TyConApp TyCon
tc [Type]
_) z :: [Alt CoreBndr]
z@((AltCon
DEFAULT, [CoreBndr]
_ ,Expr CoreBndr
_):[Alt CoreBndr]
dcs)
  = case TyCon -> Maybe [DataCon]
tyConDataCons_maybe TyCon
tc of
       Just [DataCon]
ds -> do let ds' :: [DataCon]
ds' = [DataCon]
ds [DataCon] -> [DataCon] -> [DataCon]
forall a. Eq a => [a] -> [a] -> [a]
\\ [ DataCon
d | (DataAlt DataCon
d, [CoreBndr]
_ , Expr CoreBndr
_) <- [Alt CoreBndr]
dcs]
                     let n :: Int
n   = [DataCon] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataCon]
ds'
                     if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
                       then AnfEnv -> Type -> [Alt CoreBndr] -> DsM [Alt CoreBndr]
forall c.
AnfEnv
-> Type
-> [(AltCon, [CoreBndr], c)]
-> DsM [(AltCon, [CoreBndr], c)]
expandDefaultCase' AnfEnv
γ Type
tyapp [Alt CoreBndr]
z
                       else if AnfEnv -> Int
forall t. HasConfig t => t -> Int
maxCaseExpand AnfEnv
γ Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
2 
                            then [Alt CoreBndr] -> DsM [Alt CoreBndr]
forall (m :: * -> *) a. Monad m => a -> m a
return [Alt CoreBndr]
z 
                            else [Alt CoreBndr] -> DsM [Alt CoreBndr]
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [Alt CoreBndr] -> [Alt CoreBndr]
forall a. String -> a -> a
trace (Bool -> AnfEnv -> Int -> String
expandMessage Bool
False AnfEnv
γ Int
n) [Alt CoreBndr]
z) 
       Maybe [DataCon]
Nothing -> [Alt CoreBndr] -> DsM [Alt CoreBndr]
forall (m :: * -> *) a. Monad m => a -> m a
return [Alt CoreBndr]
z --

expandDefaultCase AnfEnv
_ Type
_ [Alt CoreBndr]
z
   = [Alt CoreBndr] -> DsM [Alt CoreBndr]
forall (m :: * -> *) a. Monad m => a -> m a
return [Alt CoreBndr]
z

expandDefaultCase' 
  :: AnfEnv -> Type -> [(AltCon, [Id], c)] -> DsM [(AltCon, [Id], c)]
expandDefaultCase' :: AnfEnv
-> Type
-> [(AltCon, [CoreBndr], c)]
-> DsM [(AltCon, [CoreBndr], c)]
expandDefaultCase' AnfEnv
γ Type
t ((AltCon
DEFAULT, [CoreBndr]
_, c
e) : [(AltCon, [CoreBndr], c)]
dcs)
  | Just [(DataCon, [CoreBndr], [Type])]
dtss <- Type -> [AltCon] -> Maybe [(DataCon, [CoreBndr], [Type])]
GM.defaultDataCons Type
t ((AltCon, [CoreBndr], c) -> AltCon
forall a b c. (a, b, c) -> a
F.fst3 ((AltCon, [CoreBndr], c) -> AltCon)
-> [(AltCon, [CoreBndr], c)] -> [AltCon]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(AltCon, [CoreBndr], c)]
dcs) = do 
      [(AltCon, [CoreBndr], c)]
dcs'    <- AnfEnv -> [(AltCon, [CoreBndr], c)] -> [(AltCon, [CoreBndr], c)]
forall a. AnfEnv -> [a] -> [a]
warnCaseExpand AnfEnv
γ ([(AltCon, [CoreBndr], c)] -> [(AltCon, [CoreBndr], c)])
-> DsM [(AltCon, [CoreBndr], c)] -> DsM [(AltCon, [CoreBndr], c)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(DataCon, [CoreBndr], [Type])]
-> ((DataCon, [CoreBndr], [Type]) -> DsM (AltCon, [CoreBndr], c))
-> DsM [(AltCon, [CoreBndr], c)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(DataCon, [CoreBndr], [Type])]
dtss (AnfEnv
-> c
-> (DataCon, [CoreBndr], [Type])
-> DsM (AltCon, [CoreBndr], c)
forall e.
AnfEnv
-> e
-> (DataCon, [CoreBndr], [Type])
-> DsM (AltCon, [CoreBndr], e)
cloneCase AnfEnv
γ c
e)
      [(AltCon, [CoreBndr], c)] -> DsM [(AltCon, [CoreBndr], c)]
forall (m :: * -> *) a. Monad m => a -> m a
return   ([(AltCon, [CoreBndr], c)] -> DsM [(AltCon, [CoreBndr], c)])
-> [(AltCon, [CoreBndr], c)] -> DsM [(AltCon, [CoreBndr], c)]
forall a b. (a -> b) -> a -> b
$ [(AltCon, [CoreBndr], c)] -> [(AltCon, [CoreBndr], c)]
forall b c. [(AltCon, b, c)] -> [(AltCon, b, c)]
sortCases ([(AltCon, [CoreBndr], c)]
dcs' [(AltCon, [CoreBndr], c)]
-> [(AltCon, [CoreBndr], c)] -> [(AltCon, [CoreBndr], c)]
forall a. [a] -> [a] -> [a]
++ [(AltCon, [CoreBndr], c)]
dcs)
expandDefaultCase' AnfEnv
_ Type
_ [(AltCon, [CoreBndr], c)]
z
   = [(AltCon, [CoreBndr], c)] -> DsM [(AltCon, [CoreBndr], c)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(AltCon, [CoreBndr], c)]
z 

cloneCase :: AnfEnv -> e -> (DataCon, [TyVar], [Type]) -> DsM (AltCon, [Id], e)
cloneCase :: AnfEnv
-> e
-> (DataCon, [CoreBndr], [Type])
-> DsM (AltCon, [CoreBndr], e)
cloneCase AnfEnv
γ e
e (DataCon
d, [CoreBndr]
as, [Type]
ts) = do 
  [CoreBndr]
xs  <- (Type -> DsM CoreBndr) -> [Type] -> DsM [CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (AnfEnv -> Type -> DsM CoreBndr
freshNormalVar AnfEnv
γ) [Type]
ts 
  (AltCon, [CoreBndr], e) -> DsM (AltCon, [CoreBndr], e)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataCon -> AltCon
DataAlt DataCon
d, [CoreBndr]
as [CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. [a] -> [a] -> [a]
++ [CoreBndr]
xs, e
e)

sortCases :: [(AltCon, b, c)] -> [(AltCon, b, c)]
sortCases :: [(AltCon, b, c)] -> [(AltCon, b, c)]
sortCases = ((AltCon, b, c) -> (AltCon, b, c) -> Ordering)
-> [(AltCon, b, c)] -> [(AltCon, b, c)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (AltCon -> AltCon -> Ordering
cmpAltCon (AltCon -> AltCon -> Ordering)
-> ((AltCon, b, c) -> AltCon)
-> (AltCon, b, c)
-> (AltCon, b, c)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (AltCon, b, c) -> AltCon
forall a b c. (a, b, c) -> a
F.fst3) 

warnCaseExpand :: AnfEnv -> [a] -> [a] 
warnCaseExpand :: AnfEnv -> [a] -> [a]
warnCaseExpand AnfEnv
γ [a]
xs  
  | Int
10 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n          = String -> [a] -> [a]
forall a. String -> a -> a
trace (Bool -> AnfEnv -> Int -> String
expandMessage Bool
True AnfEnv
γ Int
n) [a]
xs 
  | Bool
otherwise       = [a]
xs
  where 
   n :: Int
n                = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs 

expandMessage :: Bool -> AnfEnv -> Int -> String 
expandMessage :: Bool -> AnfEnv -> Int -> String
expandMessage Bool
expand AnfEnv
γ Int
n = [String] -> String
unlines [String
forall t. PrintfType t => t
msg1, String
forall t. PrintfType t => t
msg2]   
  where 
    msg1 :: t
msg1            = String -> String -> String -> Int -> Int -> t
forall r. PrintfType r => String -> r
Printf.printf String
"WARNING: (%s) %s DEFAULT with %d cases at depth %d" (SrcSpan -> String
forall a. Outputable a => a -> String
showPpr SrcSpan
sp) String
v1 Int
n Int
d 
    msg2 :: t
msg2            = String -> String -> Int -> t
forall r. PrintfType r => String -> r
Printf.printf String
"%s expansion with --max-case-expand=%d" String
v2 Int
d' 
    (String
v1, String
v2, Int
d') 
      | Bool
expand      = (String
"Expanding"    , String
"Disable", Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) :: (String, String, Int)
      | Bool
otherwise   = (String
"Not expanding", String
"Enable" , Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) 
    d :: Int
d               = AnfEnv -> Int
aeCaseDepth AnfEnv
γ
    sp :: SrcSpan
sp              = SpanStack -> SrcSpan
Sp.srcSpan (AnfEnv -> SpanStack
aeSrcSpan AnfEnv
γ)

--------------------------------------------------------------------------------
-- | ANF Environments ----------------------------------------------------------
--------------------------------------------------------------------------------
freshNormalVar :: AnfEnv -> Type -> DsM Id
freshNormalVar :: AnfEnv -> Type -> DsM CoreBndr
freshNormalVar AnfEnv
γ Type
t = do
  Unique
u     <- DsM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
  let i :: Int
i  = Unique -> Int
getKey Unique
u
  let sp :: SrcSpan
sp = SpanStack -> SrcSpan
Sp.srcSpan (AnfEnv -> SpanStack
aeSrcSpan AnfEnv
γ)
  CoreBndr -> DsM CoreBndr
forall (m :: * -> *) a. Monad m => a -> m a
return (OccName -> Unique -> Type -> SrcSpan -> CoreBndr
mkUserLocal (Int -> OccName
anfOcc Int
i) Unique
u Type
t SrcSpan
sp)

anfOcc :: Int -> OccName
anfOcc :: Int -> OccName
anfOcc = FastString -> OccName
mkVarOccFS (FastString -> OccName) -> (Int -> FastString) -> Int -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> FastString
GM.symbolFastString (Symbol -> FastString) -> (Int -> Symbol) -> Int -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Int -> Symbol
forall a. Show a => Symbol -> a -> Symbol
F.intSymbol Symbol
F.anfPrefix

data AnfEnv = AnfEnv
  { AnfEnv -> VarEnv CoreBndr
aeVarEnv    :: VarEnv Id
  , AnfEnv -> SpanStack
aeSrcSpan   :: Sp.SpanStack
  , AnfEnv -> Config
aeCfg       :: UX.Config
  , AnfEnv -> Int
aeCaseDepth :: !Int
  }

instance UX.HasConfig AnfEnv where
  getConfig :: AnfEnv -> Config
getConfig = AnfEnv -> Config
aeCfg

emptyAnfEnv :: UX.Config -> AnfEnv
emptyAnfEnv :: Config -> AnfEnv
emptyAnfEnv Config
cfg = AnfEnv :: VarEnv CoreBndr -> SpanStack -> Config -> Int -> AnfEnv
AnfEnv 
  { aeVarEnv :: VarEnv CoreBndr
aeVarEnv    = VarEnv CoreBndr
forall a. VarEnv a
emptyVarEnv 
  , aeSrcSpan :: SpanStack
aeSrcSpan   = SpanStack
Sp.empty 
  , aeCfg :: Config
aeCfg       = Config
cfg 
  , aeCaseDepth :: Int
aeCaseDepth = Int
1
  }

lookupAnfEnv :: AnfEnv -> Id -> Id -> Id
lookupAnfEnv :: AnfEnv -> CoreBndr -> CoreBndr -> CoreBndr
lookupAnfEnv AnfEnv
γ CoreBndr
x CoreBndr
y = VarEnv CoreBndr -> CoreBndr -> CoreBndr -> CoreBndr
forall a. VarEnv a -> a -> CoreBndr -> a
lookupWithDefaultVarEnv (AnfEnv -> VarEnv CoreBndr
aeVarEnv AnfEnv
γ) CoreBndr
x CoreBndr
y

extendAnfEnv :: AnfEnv -> Id -> Id -> AnfEnv
extendAnfEnv :: AnfEnv -> CoreBndr -> CoreBndr -> AnfEnv
extendAnfEnv AnfEnv
γ CoreBndr
x CoreBndr
y = AnfEnv
γ { aeVarEnv :: VarEnv CoreBndr
aeVarEnv = VarEnv CoreBndr -> CoreBndr -> CoreBndr -> VarEnv CoreBndr
forall a. VarEnv a -> CoreBndr -> a -> VarEnv a
extendVarEnv (AnfEnv -> VarEnv CoreBndr
aeVarEnv AnfEnv
γ) CoreBndr
x CoreBndr
y }

incrCaseDepth :: AltCon -> AnfEnv -> AnfEnv 
incrCaseDepth :: AltCon -> AnfEnv -> AnfEnv
incrCaseDepth AltCon
DEFAULT AnfEnv
γ = AnfEnv
γ { aeCaseDepth :: Int
aeCaseDepth = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ AnfEnv -> Int
aeCaseDepth AnfEnv
γ }
incrCaseDepth AltCon
_       AnfEnv
γ = AnfEnv
γ 

at :: AnfEnv -> Tickish Id -> AnfEnv
at :: AnfEnv -> Tickish CoreBndr -> AnfEnv
at AnfEnv
γ Tickish CoreBndr
tt = AnfEnv
γ { aeSrcSpan :: SpanStack
aeSrcSpan = Span -> SpanStack -> SpanStack
Sp.push (Tickish CoreBndr -> Span
Sp.Tick Tickish CoreBndr
tt) (AnfEnv -> SpanStack
aeSrcSpan AnfEnv
γ)}