{-# 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__ >= 908
import GHC.Types.Error (ResolvedDiagnosticReason (..))
#endif

#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  
import GHC.Utils.Logger
import GHC.Plugins
import GHC.Utils.Error
import GHC.Utils.Monad


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')
  | CoreExpr -> Bool
forall {b}. Expr b -> Bool
isType CoreExpr
e' Bool -> Bool -> Bool
|| Bool -> Bool
not  (Kind -> Bool
tcIsLiftedTypeKind ((() :: Constraint) => Kind -> Kind
Kind -> Kind
typeKind ((() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
e'))) = CoreExpr -> Maybe Var
getMaybeVar CoreExpr
e
  | Bool
otherwise = Maybe Var
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) = Var -> Maybe Var
forall a. a -> Maybe a
Just Var
v
getMaybeVar CoreExpr
_ = Maybe Var
forall a. Maybe a
Nothing

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

isVar :: CoreExpr -> Bool
isVar :: CoreExpr -> Bool
isVar = Maybe Var -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Var -> Bool) -> (CoreExpr -> Maybe Var) -> CoreExpr -> Bool
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 :: TyCon -> Bool
isFunTyCon = TyCon -> Bool
isArrowTyCon
repSplitAppTys :: Kind -> (Kind, [Kind])
repSplitAppTys = (() :: Constraint) => Kind -> (Kind, [Kind])
Kind -> (Kind, [Kind])
splitAppTysNoView
#endif
 

printMessage :: (HasDynFlags m, MonadIO m, HasLogger m) =>
                Severity -> SrcSpan -> SDoc -> m ()
printMessage :: forall (m :: * -> *).
(HasDynFlags m, MonadIO m, HasLogger m) =>
Severity -> SrcSpan -> SDoc -> m ()
printMessage Severity
sev SrcSpan
loc SDoc
doc = do
#if __GLASGOW_HASKELL__ >= 908
  logger <- getLogger
  liftIO $ putLogMsg logger (logFlags logger)
    (MCDiagnostic sev (if sev == SevError then ResolvedDiagnosticReason ErrorWithoutFlag else ResolvedDiagnosticReason WarningWithoutFlag) Nothing) loc doc
#elif __GLASGOW_HASKELL__ >= 906
  Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> LogAction
putLogMsg Logger
logger (Logger -> LogFlags
logFlags Logger
logger)
    (Severity
-> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
MCDiagnostic Severity
sev (if Severity
sev Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
== Severity
SevError then DiagnosticReason
ErrorWithoutFlag else DiagnosticReason
WarningWithoutFlag) Maybe DiagnosticCode
forall a. Maybe a
Nothing) SrcSpan
loc SDoc
doc
#elif __GLASGOW_HASKELL__ >= 904
  logger <- getLogger
  liftIO $ putLogMsg logger (logFlags logger)
    (MCDiagnostic sev (if sev == SevError then ErrorWithoutFlag else WarningWithoutFlag)) loc doc
#else
   dflags <- getDynFlags
   logger <- getLogger
   liftIO $ putLogMsg logger dflags NoReason sev loc doc
#endif

instance Ord FastString where
   compare :: FastString -> FastString -> Ordering
compare = FastString -> FastString -> Ordering
uniqCompareFS

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


origNameCache :: CoreM OrigNameCache
origNameCache :: CoreM OrigNameCache
origNameCache = do
  HscEnv
hscEnv <- CoreM HscEnv
getHscEnv
#if __GLASGOW_HASKELL__ >= 904
  let nameCache :: NameCache
nameCache = HscEnv -> NameCache
hsc_NC HscEnv
hscEnv
  IO OrigNameCache -> CoreM OrigNameCache
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO OrigNameCache -> CoreM OrigNameCache)
-> IO OrigNameCache -> CoreM OrigNameCache
forall a b. (a -> b) -> a -> b
$ MVar OrigNameCache -> IO OrigNameCache
forall a. MVar a -> IO a
readMVar (NameCache -> MVar OrigNameCache
nsNames NameCache
nameCache)
#else
  nameCache <- liftIO $ readIORef (hsc_NC hscEnv)
  return $ nsNames 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] = (Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String
moduleName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> (Module -> String) -> Module -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> String
unpackFS (FastString -> String)
-> (Module -> FastString) -> Module -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> FastString
getModuleFS) (OrigNameCache -> [Module]
forall a. ModuleEnv a -> [Module]
moduleEnvKeys OrigNameCache
origNameCache)
  let name :: Name
name = Maybe Name -> Name
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Name -> Name) -> Maybe Name -> Name
forall a b. (a -> b) -> a -> b
$ OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
origNameCache Module
mod OccName
occName
  Name -> CoreM TyThing
forall (m :: * -> *). MonadThings m => Name -> m TyThing
lookupThing Name
name

getVarFromModule :: String -> String -> CoreM Var
getVarFromModule :: String -> String -> CoreM Var
getVarFromModule String
moduleName = (TyThing -> Var) -> CoreM TyThing -> CoreM Var
forall a b. (a -> b) -> CoreM a -> CoreM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() :: Constraint) => TyThing -> Var
TyThing -> Var
tyThingId (CoreM TyThing -> CoreM Var)
-> (String -> CoreM TyThing) -> String -> CoreM Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName -> CoreM TyThing
getNamedThingFromModuleAndOccName String
moduleName (OccName -> CoreM TyThing)
-> (String -> OccName) -> String -> CoreM TyThing
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 = (TyThing -> TyCon) -> CoreM TyThing -> CoreM TyCon
forall a b. (a -> b) -> CoreM a -> CoreM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() :: Constraint) => TyThing -> TyCon
TyThing -> TyCon
tyThingTyCon (CoreM TyThing -> CoreM TyCon)
-> (String -> CoreM TyThing) -> String -> CoreM TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName -> CoreM TyThing
getNamedThingFromModuleAndOccName String
moduleName (OccName -> CoreM TyThing)
-> (String -> OccName) -> String -> CoreM TyThing
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 = [FastString] -> Set FastString
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 (ModuleName -> FastString)
-> (Module -> ModuleName) -> Module -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName

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

isGhcModule :: FastString -> Bool
isGhcModule :: FastString -> Bool
isGhcModule = (FastString -> FastString -> Bool
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 = a -> Name
forall a. NamedThing a => a -> Name
getName a
v
  Module
mod <- Name -> Maybe Module
nameModule_maybe Name
name
  (FastString, FastString) -> Maybe (FastString, FastString)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> FastString
forall a. NamedThing a => a -> FastString
getOccFS Name
name,ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod))


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

isGhcStableType :: FastString -> Bool
isGhcStableType :: FastString -> Bool
isGhcStableType = (FastString -> Set FastString -> Bool
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 Set TypeCmp
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
100 = Bool
False
isTemporalRec Int
_ Set TypeCmp
pr Kind
t | TypeCmp -> Set TypeCmp -> Bool
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' = TypeCmp -> Set TypeCmp -> Set TypeCmp
forall a. Ord a => a -> Set a -> Set a
Set.insert (Kind -> TypeCmp
TC Kind
t) Set TypeCmp
pr
  case (() :: Constraint) => Kind -> Maybe (TyCon, [Kind])
Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe Kind
t of
    Maybe (TyCon, [Kind])
Nothing -> Bool
False
    Just (TyCon
con,[Kind]
args) ->
      case TyCon -> Maybe (FastString, FastString)
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 FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"Box" Bool -> Bool -> Bool
|| FastString
name FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"O") -> Bool
True
          | TyCon -> Bool
isFunTyCon TyCon
con -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((Kind -> Bool) -> [Kind] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Kind -> Bool
isTemporalRec (Int
dInt -> Int -> Int
forall 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} -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((DataCon -> Bool) -> [DataCon] -> [Bool]
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) -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((Kind -> Bool) -> [Kind] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Kind -> Bool
isTemporalRec (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Kind]
tys)
              AlgTyConRhs
_ -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((Kind -> Bool) -> [Kind] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Kind -> Bool
isTemporalRec (Int
dInt -> Int -> Int
forall 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 Set TypeCmp
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
100 = Bool
True
isStableRec Set Var
_ Int
_ Set TypeCmp
pr Kind
t | TypeCmp -> Set TypeCmp -> Bool
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' = TypeCmp -> Set TypeCmp -> Set TypeCmp
forall a. Ord a => a -> Set a -> Set a
Set.insert (Kind -> TypeCmp
TC Kind
t) Set TypeCmp
pr
  case (() :: Constraint) => Kind -> Maybe (TyCon, [Kind])
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 Var -> Set Var -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Var
c
      Maybe Var
Nothing -> Bool
False
    Just (TyCon
con,[Kind]
args) ->
      case TyCon -> Maybe (FastString, FastString)
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 FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"GHC.Num.Integer" Bool -> Bool -> Bool
&& FastString
name FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"Integer" -> Bool
True
          | FastString
mod FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"Data.Text.Internal" Bool -> Bool -> Bool
&& FastString
name FastString -> FastString -> Bool
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 FastString -> FastString -> Bool
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
                | (DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all DataCon -> Bool
hasStrictArgs [DataCon]
cons ->
                  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and  ((DataCon -> Bool) -> [DataCon] -> [Bool]
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) -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Kind -> Bool) -> [Kind] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Set Var -> Int -> Set TypeCmp -> Kind -> Bool
isStableRec Set Var
c (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Kind]
tys)
              TupleTyCon {} -> [Kind] -> Bool
forall a. [a] -> Bool
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 Set TypeCmp
forall a. Set a
Set.empty Kind
t

splitForAllTys' :: Type -> ([TyCoVar], Type)
splitForAllTys' :: Kind -> ([Var], Kind)
splitForAllTys' = Kind -> ([Var], Kind)
splitForAllTyCoVars

-- | 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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
100 = Bool
True
isStrictRec Int
_ Set TypeCmp
pr Kind
t | TypeCmp -> Set TypeCmp -> Bool
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' = TypeCmp -> Set TypeCmp -> Set TypeCmp
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) = Kind -> (Kind, [Kind])
repSplitAppTys Kind
t'
  if Maybe Var -> Bool
forall a. Maybe a -> Bool
isJust (Kind -> Maybe Var
getTyVar_maybe Kind
c) then [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Kind -> Bool) -> [Kind] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Kind -> Bool
isStrictRec (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Kind]
tys)
  else  case (() :: Constraint) => Kind -> Maybe (TyCon, [Kind])
Kind -> Maybe (TyCon, [Kind])
splitTyConApp_maybe Kind
t' of
    Maybe (TyCon, [Kind])
Nothing -> Maybe Var -> Bool
forall a. Maybe a -> Bool
isJust (Kind -> Maybe Var
getTyVar_maybe Kind
t)
    Just (TyCon
con,[Kind]
args) ->
      case TyCon -> Maybe (FastString, FastString)
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 FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"GHC.Num.Integer" Bool -> Bool -> Bool
&& FastString
name FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"Integer" -> Bool
True
          | FastString
mod FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"Data.Text.Internal" Bool -> Bool -> Bool
&& FastString
name FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"Text" -> Bool
True
          | FastString
mod FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"GHC.IORef" Bool -> Bool -> Bool
&& FastString
name FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"IORef" -> Bool
True
          | FastString
mod FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"GHC.MVar" Bool -> Bool -> Bool
&& FastString
name FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"MVar" -> 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 FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"Box" Bool -> Bool -> Bool
|| FastString
name FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
"O" Bool -> Bool -> Bool
|| FastString
name FastString -> FastString -> Bool
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
                | (DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all DataCon -> Bool
hasStrictArgs [DataCon]
cons ->
                  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and  ((DataCon -> Bool) -> [DataCon] -> [Bool]
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) -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Kind -> Bool) -> [Kind] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Kind -> Bool
isStrictRec (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Kind]
tys)
              TupleTyCon {} -> [Kind] -> Bool
forall a. [a] -> Bool
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
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr' Kind
ty
              AlgTyConRhs
_ -> Bool
False
          | Bool
otherwise -> Bool
False





hasStrictArgs :: DataCon -> Bool
hasStrictArgs :: DataCon -> Bool
hasStrictArgs DataCon
con = (HsImplBang -> Bool) -> [HsImplBang] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all HsImplBang -> Bool
isBanged (DataCon -> [HsImplBang]
dataConImplBangs DataCon
con)

userFunction :: Var -> Bool
userFunction :: Var -> Bool
userFunction Var
v
  | Var -> Bool
typeClassFunction Var
v = Bool
True
  | Bool
otherwise = 
    case Name -> String
forall a. NamedThing a => a -> String
getOccString (Var -> Name
forall a. NamedThing a => a -> Name
getName Var
v) of
      (Char
c : String
_)
        | Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'$' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
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 Name -> String
forall a. NamedThing a => a -> String
getOccString (Var -> Name
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
mkSysLocalFromVar :: forall (m :: * -> *). MonadUnique m => FastString -> Var -> m Var
mkSysLocalFromVar FastString
lit Var
v = FastString -> Kind -> Kind -> m Var
forall (m :: * -> *).
MonadUnique m =>
FastString -> Kind -> Kind -> m Var
mkSysLocalM FastString
lit (Var -> Kind
varMult Var
v) (Var -> Kind
varType Var
v)
 
mkSysLocalFromExpr :: MonadUnique m => FastString -> CoreExpr -> m Id
mkSysLocalFromExpr :: forall (m :: * -> *).
MonadUnique m =>
FastString -> CoreExpr -> m Var
mkSysLocalFromExpr FastString
lit CoreExpr
e = FastString -> Kind -> Kind -> m Var
forall (m :: * -> *).
MonadUnique m =>
FastString -> Kind -> Kind -> m Var
mkSysLocalM FastString
lit Kind
oneDataConTy ((() :: Constraint) => CoreExpr -> Kind
CoreExpr -> Kind
exprType CoreExpr
e)
 
 
fromRealSrcSpan :: RealSrcSpan -> SrcSpan
#if __GLASGOW_HASKELL__ >= 904
fromRealSrcSpan :: RealSrcSpan -> SrcSpan
fromRealSrcSpan RealSrcSpan
span = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
span Maybe BufSpan
forall a. Maybe a
Strict.Nothing
#else
fromRealSrcSpan span = RealSrcSpan span Nothing
#endif

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

noLocationInfo :: SrcSpan
noLocationInfo :: SrcSpan
noLocationInfo = UnhelpfulSpanReason -> SrcSpan
UnhelpfulSpan UnhelpfulSpanReason
UnhelpfulNoLocationInfo

mkAlt :: AltCon -> [b] -> Expr b -> Alt b
mkAlt AltCon
c [b]
args Expr b
e = AltCon -> [b] -> Expr b -> Alt b
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)