{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}

module AsyncRattus.Plugin.Utils (
  printMessage,
  Severity(..),
  isRattModule,
  adv'Var,
  select'Var,
  bigDelay,
  inputValueVar,
  extractClockVar,
  unionVar,
  isGhcModule,
  getNameModule,
  isStable,
  isStrict,
  isTemporal,
  userFunction,
  typeClassFunction,
  getVar,
  getMaybeVar,
  getModuleFS,
  isVar,
  isType,
  mkSysLocalFromVar,
  mkSysLocalFromExpr,
  fromRealSrcSpan,
  noLocationInfo,
  mkAlt,
  getAlt,
  splitForAllTys')
  where
#if __GLASGOW_HASKELL__ >= 906
import GHC.Builtin.Types.Prim
import GHC.Tc.Utils.TcType
#endif
#if __GLASGOW_HASKELL__ >= 904
import qualified GHC.Data.Strict as Strict
import Control.Concurrent.MVar (readMVar)
#else
import Data.IORef (readIORef)
#endif  
#if __GLASGOW_HASKELL__ >= 902

import GHC.Utils.Logger
#endif

#if __GLASGOW_HASKELL__ >= 900
import GHC.Plugins
import GHC.Utils.Error
import GHC.Utils.Monad
#else
import GhcPlugins
import ErrUtils
import MonadUtils
#endif


import GHC.Types.Name.Cache (NameCache(nsNames), lookupOrigNameCache, OrigNameCache)
import qualified GHC.Types.Name.Occurrence as Occurrence
import GHC.Types.TyThing

import Prelude hiding ((<>))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Char
import Data.Maybe


getMaybeVar :: CoreExpr -> Maybe Var
getMaybeVar :: CoreExpr -> Maybe Var
getMaybeVar (App CoreExpr
e CoreExpr
e')
  | forall {b}. Expr b -> Bool
isType CoreExpr
e' Bool -> Bool -> Bool
|| Bool -> Bool
not  (Kind -> Bool
tcIsLiftedTypeKind (HasDebugCallStack => Kind -> Kind
typeKind (CoreExpr -> Kind
exprType CoreExpr
e'))) = CoreExpr -> Maybe Var
getMaybeVar CoreExpr
e
  | Bool
otherwise = forall a. Maybe a
Nothing
getMaybeVar (Cast CoreExpr
e CoercionR
_) = CoreExpr -> Maybe Var
getMaybeVar CoreExpr
e
getMaybeVar (Tick CoreTickish
_ CoreExpr
e) = CoreExpr -> Maybe Var
getMaybeVar CoreExpr
e
getMaybeVar (Var Var
v) = forall a. a -> Maybe a
Just Var
v
getMaybeVar CoreExpr
_ = forall a. Maybe a
Nothing

getVar :: CoreExpr -> Var
getVar :: CoreExpr -> Var
getVar = forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Maybe Var
getMaybeVar

isVar :: CoreExpr -> Bool
isVar :: CoreExpr -> Bool
isVar = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> Maybe Var
getMaybeVar

isType :: Expr b -> Bool
isType Type {} = Bool
True
isType (App Expr b
e Expr b
_) = Expr b -> Bool
isType Expr b
e
isType (Cast Expr b
e CoercionR
_) = Expr b -> Bool
isType Expr b
e
isType (Tick CoreTickish
_ Expr b
e) = Expr b -> Bool
isType Expr b
e
isType Expr b
_ = Bool
False

#if __GLASGOW_HASKELL__ >= 906
isFunTyCon = isArrowTyCon
repSplitAppTys = splitAppTysNoView
#endif
 
#if __GLASGOW_HASKELL__ >= 902
printMessage :: (HasDynFlags m, MonadIO m, HasLogger m) =>
                Severity -> SrcSpan -> SDoc -> m ()
#else
printMessage :: (HasDynFlags m, MonadIO m) =>
                Severity -> SrcSpan -> MsgDoc -> m ()
#endif

printMessage :: forall (m :: * -> *).
(HasDynFlags m, MonadIO m, HasLogger m) =>
Severity -> SrcSpan -> SDoc -> m ()
printMessage Severity
sev SrcSpan
loc SDoc
doc = do
#if __GLASGOW_HASKELL__ >= 906
  logger <- getLogger
  liftIO $ putLogMsg logger (logFlags logger)
    (MCDiagnostic sev (if sev == SevError then ErrorWithoutFlag else WarningWithoutFlag) Nothing) loc doc
#elif __GLASGOW_HASKELL__ >= 904
  logger <- getLogger
  liftIO $ putLogMsg logger (logFlags logger)
    (MCDiagnostic sev (if sev == SevError then ErrorWithoutFlag else WarningWithoutFlag)) loc doc
#elif __GLASGOW_HASKELL__ >= 902
   DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
   Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
   forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
NoReason Severity
sev SrcSpan
loc SDoc
doc
#elif __GLASGOW_HASKELL__ >= 900  
  dflags <- getDynFlags
  liftIO $ putLogMsg dflags NoReason sev loc doc
#else
  dflags <- getDynFlags
  let sty = case sev of
              SevError   -> defaultErrStyle dflags
              SevWarning -> defaultErrStyle dflags
              SevDump    -> defaultDumpStyle dflags
              _          -> defaultUserStyle dflags
  liftIO $ putLogMsg dflags NoReason sev loc sty doc
#endif

#if __GLASGOW_HASKELL__ >= 902
instance Ord FastString where
   compare :: FastString -> FastString -> Ordering
compare = FastString -> FastString -> Ordering
uniqCompareFS
#endif

{-
******************************************************
*             Extracting variables                   *
******************************************************
-}


origNameCache :: CoreM OrigNameCache
origNameCache :: CoreM OrigNameCache
origNameCache = do
  HscEnv
hscEnv <- CoreM HscEnv
getHscEnv
#if __GLASGOW_HASKELL__ >= 904
  let nameCache = hsc_NC hscEnv
  liftIO $ readMVar (nsNames nameCache)
#else
  NameCache
nameCache <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (HscEnv -> IORef NameCache
hsc_NC HscEnv
hscEnv)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ NameCache -> OrigNameCache
nsNames NameCache
nameCache
#endif


getNamedThingFromModuleAndOccName :: String -> OccName -> CoreM TyThing
getNamedThingFromModuleAndOccName :: String -> OccName -> CoreM TyThing
getNamedThingFromModuleAndOccName String
moduleName OccName
occName = do
  OrigNameCache
origNameCache <- CoreM OrigNameCache
origNameCache
  let [Module
mod] = forall a. (a -> Bool) -> [a] -> [a]
filter ((String
moduleName forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> String
unpackFS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> FastString
getModuleFS) (forall a. ModuleEnv a -> [Module]
moduleEnvKeys OrigNameCache
origNameCache)
  let name :: Name
name = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
origNameCache Module
mod OccName
occName
  forall (m :: * -> *). MonadThings m => Name -> m TyThing
lookupThing Name
name

getVarFromModule :: String -> String -> CoreM Var
getVarFromModule :: String -> String -> CoreM Var
getVarFromModule String
moduleName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HasDebugCallStack => TyThing -> Var
tyThingId forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName -> CoreM TyThing
getNamedThingFromModuleAndOccName String
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpace -> String -> OccName
mkOccName NameSpace
Occurrence.varName

getTyConFromModule :: String -> String -> CoreM TyCon
getTyConFromModule :: String -> String -> CoreM TyCon
getTyConFromModule String
moduleName = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HasDebugCallStack => TyThing -> TyCon
tyThingTyCon forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName -> CoreM TyThing
getNamedThingFromModuleAndOccName String
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpace -> String -> OccName
mkOccName NameSpace
Occurrence.tcName

adv'Var :: CoreM Var
adv'Var :: CoreM Var
adv'Var = String -> String -> CoreM Var
getVarFromModule String
"AsyncRattus.InternalPrimitives" String
"adv'"

select'Var :: CoreM Var
select'Var :: CoreM Var
select'Var = String -> String -> CoreM Var
getVarFromModule String
"AsyncRattus.InternalPrimitives" String
"select'"

bigDelay :: CoreM Var
bigDelay :: CoreM Var
bigDelay = String -> String -> CoreM Var
getVarFromModule String
"AsyncRattus.InternalPrimitives" String
"Delay"

inputValueVar :: CoreM TyCon
inputValueVar :: CoreM TyCon
inputValueVar = String -> String -> CoreM TyCon
getTyConFromModule String
"AsyncRattus.InternalPrimitives" String
"InputValue"

extractClockVar :: CoreM Var
extractClockVar :: CoreM Var
extractClockVar = String -> String -> CoreM Var
getVarFromModule String
"AsyncRattus.InternalPrimitives" String
"extractClock"

unionVar :: CoreM Var
unionVar :: CoreM Var
unionVar = String -> String -> CoreM Var
getVarFromModule String
"AsyncRattus.InternalPrimitives" String
"clockUnion"

rattModules :: Set FastString
rattModules :: Set FastString
rattModules = forall a. Ord a => [a] -> Set a
Set.fromList [FastString
"AsyncRattus.InternalPrimitives",FastString
"AsyncRattus.Channels"]

getModuleFS :: Module -> FastString
getModuleFS :: Module -> FastString
getModuleFS = ModuleName -> FastString
moduleNameFS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
moduleName

isRattModule :: FastString -> Bool
isRattModule :: FastString -> Bool
isRattModule = (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FastString
rattModules)

isGhcModule :: FastString -> Bool
isGhcModule :: FastString -> Bool
isGhcModule = (forall a. Eq a => a -> a -> Bool
== FastString
"GHC.Types")

getNameModule :: NamedThing a => a -> Maybe (FastString, FastString)
getNameModule :: forall a. NamedThing a => a -> Maybe (FastString, FastString)
getNameModule a
v = do
  let name :: Name
name = forall a. NamedThing a => a -> Name
getName a
v
  Module
mod <- Name -> Maybe Module
nameModule_maybe Name
name
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. NamedThing a => a -> FastString
getOccFS Name
name,ModuleName -> FastString
moduleNameFS (forall unit. GenModule unit -> ModuleName
moduleName Module
mod))


-- | The set of stable built-in types.
ghcStableTypes :: Set FastString
ghcStableTypes :: Set FastString
ghcStableTypes = forall a. Ord a => [a] -> Set a
Set.fromList [FastString
"Int",FastString
"Bool",FastString
"Float",FastString
"Double",FastString
"Char", FastString
"IO"]

isGhcStableType :: FastString -> Bool
isGhcStableType :: FastString -> Bool
isGhcStableType = (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FastString
ghcStableTypes)


newtype TypeCmp = TC Type

instance Eq TypeCmp where
  (TC Kind
t1) == :: TypeCmp -> TypeCmp -> Bool
== (TC Kind
t2) = Kind -> Kind -> Bool
eqType Kind
t1 Kind
t2

instance Ord TypeCmp where
  compare :: TypeCmp -> TypeCmp -> Ordering
compare (TC Kind
t1) (TC Kind
t2) = Kind -> Kind -> Ordering
nonDetCmpType Kind
t1 Kind
t2

isTemporal :: Type -> Bool
isTemporal :: Kind -> Bool
isTemporal Kind
t = Int -> Set TypeCmp -> Kind -> Bool
isTemporalRec Int
0 forall a. Set a
Set.empty Kind
t


isTemporalRec :: Int -> Set TypeCmp -> Type -> Bool
isTemporalRec :: Int -> Set TypeCmp -> Kind -> Bool
isTemporalRec Int
d Set TypeCmp
_ Kind
_ | Int
d forall a. Eq a => a -> a -> Bool
== Int
100 = Bool
False
isTemporalRec Int
_ Set TypeCmp
pr Kind
t | forall a. Ord a => a -> Set a -> Bool
Set.member (Kind -> TypeCmp
TC Kind
t) Set TypeCmp
pr = Bool
False
isTemporalRec Int
d Set TypeCmp
pr Kind
t = do
  let pr' :: Set TypeCmp
pr' = forall a. Ord a => a -> Set a -> Set a
Set.insert (Kind -> TypeCmp
TC Kind
t) Set TypeCmp
pr
  case HasDebugCallStack => Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe Kind
t of
    Maybe (TyCon, [Kind])
Nothing -> Bool
False
    Just (TyCon
con,[Kind]
args) ->
      case forall a. NamedThing a => a -> Maybe (FastString, FastString)
getNameModule TyCon
con of
        Maybe (FastString, FastString)
Nothing -> Bool
False
        Just (FastString
name,FastString
mod)
          -- If it's a Rattus type constructor check if it's a box
          | FastString -> Bool
isRattModule FastString
mod Bool -> Bool -> Bool
&& (FastString
name forall a. Eq a => a -> a -> Bool
== FastString
"Box" Bool -> Bool -> Bool
|| FastString
name forall a. Eq a => a -> a -> Bool
== FastString
"O") -> Bool
True
          | TyCon -> Bool
isFunTyCon TyCon
con -> forall (t :: * -> *). Foldable t => t Bool -> Bool
or (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Kind -> Bool
isTemporalRec (Int
dforall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Kind]
args)
          | TyCon -> Bool
isAlgTyCon TyCon
con ->
            case TyCon -> AlgTyConRhs
algTyConRhs TyCon
con of
              DataTyCon {data_cons :: AlgTyConRhs -> [DataCon]
data_cons = [DataCon]
cons} -> forall (t :: * -> *). Foldable t => t Bool -> Bool
or (forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Bool
check [DataCon]
cons)
                where check :: DataCon -> Bool
check DataCon
con = case DataCon -> [Kind] -> ([Var], [Kind], [Kind])
dataConInstSig DataCon
con [Kind]
args of
                        ([Var]
_, [Kind]
_,[Kind]
tys) -> forall (t :: * -> *). Foldable t => t Bool -> Bool
or (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Kind -> Bool
isTemporalRec (Int
dforall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Kind]
tys)
              AlgTyConRhs
_ -> forall (t :: * -> *). Foldable t => t Bool -> Bool
or (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Kind -> Bool
isTemporalRec (Int
dforall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Kind]
args)
        Maybe (FastString, FastString)
_ -> Bool
False


-- | Check whether the given type is stable. This check may use
-- 'Stable' constraints from the context.

isStable :: Set Var -> Type -> Bool
isStable :: Set Var -> Kind -> Bool
isStable Set Var
c Kind
t = Set Var -> Int -> Set TypeCmp -> Kind -> Bool
isStableRec Set Var
c Int
0 forall a. Set a
Set.empty Kind
t

-- | Check whether the given type is stable. This check may use
-- 'Stable' constraints from the context.

isStableRec :: Set Var -> Int -> Set TypeCmp -> Type -> Bool
-- To prevent infinite recursion (when checking recursive types) we
-- keep track of previously checked types. This, however, is not
-- enough for non-regular data types. Hence we also have a counter.
isStableRec :: Set Var -> Int -> Set TypeCmp -> Kind -> Bool
isStableRec Set Var
_ Int
d Set TypeCmp
_ Kind
_ | Int
d forall a. Eq a => a -> a -> Bool
== Int
100 = Bool
True
isStableRec Set Var
_ Int
_ Set TypeCmp
pr Kind
t | forall a. Ord a => a -> Set a -> Bool
Set.member (Kind -> TypeCmp
TC Kind
t) Set TypeCmp
pr = Bool
True
isStableRec Set Var
c Int
d Set TypeCmp
pr Kind
t = do
  let pr' :: Set TypeCmp
pr' = forall a. Ord a => a -> Set a -> Set a
Set.insert (Kind -> TypeCmp
TC Kind
t) Set TypeCmp
pr
  case HasDebugCallStack => Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe Kind
t of
    Maybe (TyCon, [Kind])
Nothing -> case Kind -> Maybe Var
getTyVar_maybe Kind
t of
      Just Var
v -> -- if it's a type variable, check the context
        Var
v forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Var
c
      Maybe Var
Nothing -> Bool
False
    Just (TyCon
con,[Kind]
args) ->
      case forall a. NamedThing a => a -> Maybe (FastString, FastString)
getNameModule TyCon
con of
        Maybe (FastString, FastString)
Nothing -> Bool
False
        Just (FastString
name,FastString
mod)
          -- If it's a Rattus type constructor check if it's a box
          | FastString -> Bool
isRattModule FastString
mod Bool -> Bool -> Bool
&& FastString
name forall a. Eq a => a -> a -> Bool
== FastString
"Box" -> Bool
True
            -- If its a built-in type check the set of stable built-in types
          | FastString -> Bool
isGhcModule FastString
mod -> FastString -> Bool
isGhcStableType FastString
name
          {- deal with type synonyms (does not seem to be necessary (??))
           | Just (subst,ty,[]) <- expandSynTyCon_maybe con args ->
             isStableRec c (d+1) pr' (substTy (extendTvSubstList emptySubst subst) ty) -}
          | TyCon -> Bool
isAlgTyCon TyCon
con ->
            case TyCon -> AlgTyConRhs
algTyConRhs TyCon
con of
              DataTyCon {data_cons :: AlgTyConRhs -> [DataCon]
data_cons = [DataCon]
cons, is_enum :: AlgTyConRhs -> Bool
is_enum = Bool
enum}
                | Bool
enum -> Bool
True
                | forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map HsSrcBang -> Bool
isSrcStrict'
                                   forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> [HsSrcBang]
dataConSrcBangs) forall a b. (a -> b) -> a -> b
$ [DataCon]
cons ->
                  forall (t :: * -> *). Foldable t => t Bool -> Bool
and  (forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Bool
check [DataCon]
cons)
                | Bool
otherwise -> Bool
False
                where check :: DataCon -> Bool
check DataCon
con = case DataCon -> [Kind] -> ([Var], [Kind], [Kind])
dataConInstSig DataCon
con [Kind]
args of
                        ([Var]
_, [Kind]
_,[Kind]
tys) -> forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b. (a -> b) -> [a] -> [b]
map (Set Var -> Int -> Set TypeCmp -> Kind -> Bool
isStableRec Set Var
c (Int
dforall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Kind]
tys)
              TupleTyCon {} -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Kind]
args
              AlgTyConRhs
_ -> Bool
False
        Maybe (FastString, FastString)
_ -> Bool
False



isStrict :: Type -> Bool
isStrict :: Kind -> Bool
isStrict Kind
t = Int -> Set TypeCmp -> Kind -> Bool
isStrictRec Int
0 forall a. Set a
Set.empty Kind
t

#if __GLASGOW_HASKELL__ >= 902
splitForAllTys' :: Type -> ([TyCoVar], Type)
splitForAllTys' :: Kind -> ([Var], Kind)
splitForAllTys' = Kind -> ([Var], Kind)
splitForAllTyCoVars
#else
splitForAllTys' = splitForAllTys
#endif

-- | Check whether the given type is stable. This check may use
-- 'Stable' constraints from the context.

isStrictRec :: Int -> Set TypeCmp -> Type -> Bool
-- To prevent infinite recursion (when checking recursive types) we
-- keep track of previously checked types. This, however, is not
-- enough for non-regular data types. Hence we also have a counter.
isStrictRec :: Int -> Set TypeCmp -> Kind -> Bool
isStrictRec Int
d Set TypeCmp
_ Kind
_ | Int
d forall a. Eq a => a -> a -> Bool
== Int
100 = Bool
True
isStrictRec Int
_ Set TypeCmp
pr Kind
t | forall a. Ord a => a -> Set a -> Bool
Set.member (Kind -> TypeCmp
TC Kind
t) Set TypeCmp
pr = Bool
True
isStrictRec Int
d Set TypeCmp
pr Kind
t = do
  let pr' :: Set TypeCmp
pr' = forall a. Ord a => a -> Set a -> Set a
Set.insert (Kind -> TypeCmp
TC Kind
t) Set TypeCmp
pr
  let ([Var]
_,Kind
t') = Kind -> ([Var], Kind)
splitForAllTys' Kind
t
  let (Kind
c, [Kind]
tys) = HasDebugCallStack => Kind -> (Kind, [Kind])
repSplitAppTys Kind
t'
  if forall a. Maybe a -> Bool
isJust (Kind -> Maybe Var
getTyVar_maybe Kind
c) then forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Kind -> Bool
isStrictRec (Int
dforall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Kind]
tys)
  else  case HasDebugCallStack => Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe Kind
t' of
    Maybe (TyCon, [Kind])
Nothing -> forall a. Maybe a -> Bool
isJust (Kind -> Maybe Var
getTyVar_maybe Kind
t)
    Just (TyCon
con,[Kind]
args) ->
      case forall a. NamedThing a => a -> Maybe (FastString, FastString)
getNameModule TyCon
con of
        Maybe (FastString, FastString)
Nothing -> Bool
False
        Just (FastString
name,FastString
mod)
          | FastString
mod forall a. Eq a => a -> a -> Bool
== FastString
"GHC.Num.Integer" Bool -> Bool -> Bool
&& FastString
name forall a. Eq a => a -> a -> Bool
== FastString
"Integer" -> Bool
True
          | FastString
mod forall a. Eq a => a -> a -> Bool
== FastString
"Data.Text.Internal" Bool -> Bool -> Bool
&& FastString
name forall a. Eq a => a -> a -> Bool
== FastString
"Text" -> Bool
True
          -- If it's a Rattus type constructor check if it's a box
          | FastString -> Bool
isRattModule FastString
mod Bool -> Bool -> Bool
&& (FastString
name forall a. Eq a => a -> a -> Bool
== FastString
"Box" Bool -> Bool -> Bool
|| FastString
name forall a. Eq a => a -> a -> Bool
== FastString
"O" Bool -> Bool -> Bool
|| FastString
name forall a. Eq a => a -> a -> Bool
== FastString
"Output") -> Bool
True
            -- If its a built-in type check the set of stable built-in types
          | FastString -> Bool
isGhcModule FastString
mod -> FastString -> Bool
isGhcStableType FastString
name
          {- deal with type synonyms (does not seem to be necessary (??))
           | Just (subst,ty,[]) <- expandSynTyCon_maybe con args ->
             isStrictRec c (d+1) pr' (substTy (extendTvSubstList emptySubst subst) ty) -}
          | TyCon -> Bool
isFunTyCon TyCon
con -> Bool
True
          | TyCon -> Bool
isAlgTyCon TyCon
con ->
            case TyCon -> AlgTyConRhs
algTyConRhs TyCon
con of
              DataTyCon {data_cons :: AlgTyConRhs -> [DataCon]
data_cons = [DataCon]
cons, is_enum :: AlgTyConRhs -> Bool
is_enum = Bool
enum}
                | Bool
enum -> Bool
True
                | forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ (forall a b. (a -> b) -> [a] -> [b]
map ([Kind] -> DataCon -> Bool
areSrcStrict [Kind]
args)) forall a b. (a -> b) -> a -> b
$ [DataCon]
cons ->
                  forall (t :: * -> *). Foldable t => t Bool -> Bool
and  (forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Bool
check [DataCon]
cons)
                | Bool
otherwise -> Bool
False
                where check :: DataCon -> Bool
check DataCon
con = case DataCon -> [Kind] -> ([Var], [Kind], [Kind])
dataConInstSig DataCon
con [Kind]
args of
                        ([Var]
_, [Kind]
_,[Kind]
tys) -> forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Kind -> Bool
isStrictRec (Int
dforall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Kind]
tys)
              TupleTyCon {} -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Kind]
args
              NewTyCon {nt_rhs :: AlgTyConRhs -> Kind
nt_rhs = Kind
ty} -> Int -> Set TypeCmp -> Kind -> Bool
isStrictRec (Int
dforall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr' Kind
ty
              AlgTyConRhs
_ -> Bool
False
          | Bool
otherwise -> Bool
False





areSrcStrict :: [Type] -> DataCon -> Bool
areSrcStrict :: [Kind] -> DataCon -> Bool
areSrcStrict [Kind]
args DataCon
con = forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {p}. p -> HsSrcBang -> Bool
check [Kind]
tys (DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
con))
  where ([Var]
_, [Kind]
_,[Kind]
tys) = DataCon -> [Kind] -> ([Var], [Kind], [Kind])
dataConInstSig DataCon
con [Kind]
args
        check :: p -> HsSrcBang -> Bool
check p
_ HsSrcBang
b = HsSrcBang -> Bool
isSrcStrict' HsSrcBang
b

isSrcStrict' :: HsSrcBang -> Bool
isSrcStrict' :: HsSrcBang -> Bool
isSrcStrict' (HsSrcBang SourceText
_ SrcUnpackedness
_ SrcStrictness
SrcStrict) = Bool
True
isSrcStrict' (HsSrcBang SourceText
_ SrcUnpackedness
SrcUnpack SrcStrictness
_) = Bool
True
isSrcStrict' HsSrcBang
_ =  Bool
False


userFunction :: Var -> Bool
userFunction :: Var -> Bool
userFunction Var
v
  | Var -> Bool
typeClassFunction Var
v = Bool
True
  | Bool
otherwise = 
    case forall a. NamedThing a => a -> String
getOccString (forall a. NamedThing a => a -> Name
getName Var
v) of
      (Char
c : String
_)
        | Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'$' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
':' -> Bool
False
        | Bool
otherwise -> Bool
True
      String
_ -> Bool
False

typeClassFunction :: Var -> Bool
typeClassFunction :: Var -> Bool
typeClassFunction Var
v =
  case forall a. NamedThing a => a -> String
getOccString (forall a. NamedThing a => a -> Name
getName Var
v) of
    (Char
'$' : Char
'c' : String
_) -> Bool
True
    (Char
'$' : Char
'f' : String
_) -> Bool
True
    String
_ -> Bool
False

mkSysLocalFromVar :: MonadUnique m => FastString -> Var -> m Id
#if __GLASGOW_HASKELL__ >= 900

mkSysLocalFromVar :: forall (m :: * -> *). MonadUnique m => FastString -> Var -> m Var
mkSysLocalFromVar FastString
lit Var
v = forall (m :: * -> *).
MonadUnique m =>
FastString -> Kind -> Kind -> m Var
mkSysLocalM FastString
lit (Var -> Kind
varMult Var
v) (Var -> Kind
varType Var
v)
#else
mkSysLocalFromVar lit v = mkSysLocalM lit (varType v)
#endif
 
mkSysLocalFromExpr :: MonadUnique m => FastString -> CoreExpr -> m Id
#if __GLASGOW_HASKELL__ >= 900
mkSysLocalFromExpr :: forall (m :: * -> *).
MonadUnique m =>
FastString -> CoreExpr -> m Var
mkSysLocalFromExpr FastString
lit CoreExpr
e = forall (m :: * -> *).
MonadUnique m =>
FastString -> Kind -> Kind -> m Var
mkSysLocalM FastString
lit Kind
oneDataConTy (CoreExpr -> Kind
exprType CoreExpr
e)
#else
mkSysLocalFromExpr lit e = mkSysLocalM lit (exprType e)
#endif
 
 
fromRealSrcSpan :: RealSrcSpan -> SrcSpan
#if __GLASGOW_HASKELL__ >= 904
fromRealSrcSpan span = RealSrcSpan span Strict.Nothing
#elif __GLASGOW_HASKELL__ >= 900
fromRealSrcSpan :: RealSrcSpan -> SrcSpan
fromRealSrcSpan RealSrcSpan
span = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
span forall a. Maybe a
Nothing
#else
fromRealSrcSpan span = RealSrcSpan span
#endif

#if __GLASGOW_HASKELL__ >= 900
instance Ord SrcSpan where
  compare :: SrcSpan -> SrcSpan -> Ordering
compare (RealSrcSpan RealSrcSpan
s Maybe BufSpan
_) (RealSrcSpan RealSrcSpan
t Maybe BufSpan
_) = forall a. Ord a => a -> a -> Ordering
compare RealSrcSpan
s RealSrcSpan
t
  compare RealSrcSpan{} SrcSpan
_ = Ordering
LT
  compare SrcSpan
_ SrcSpan
_ = Ordering
GT
#endif

noLocationInfo :: SrcSpan
#if __GLASGOW_HASKELL__ >= 900
noLocationInfo :: SrcSpan
noLocationInfo = UnhelpfulSpanReason -> SrcSpan
UnhelpfulSpan UnhelpfulSpanReason
UnhelpfulNoLocationInfo
#else         
noLocationInfo = UnhelpfulSpan "<no location info>"
#endif

#if __GLASGOW_HASKELL__ >= 902
mkAlt :: AltCon -> [b] -> Expr b -> Alt b
mkAlt AltCon
c [b]
args Expr b
e = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
c [b]
args Expr b
e
getAlt :: Alt b -> (AltCon, [b], Expr b)
getAlt (Alt AltCon
c [b]
args Expr b
e) = (AltCon
c, [b]
args, Expr b
e)
#else
mkAlt c args e = (c, args, e)
getAlt alt = alt
#endif