{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
module Rattus.Plugin.Utils (
printMessage,
Severity(..),
isRattModule,
isGhcModule,
getNameModule,
isStable,
isStrict,
isTemporal,
userFunction,
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
#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 Prelude hiding ((<>))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Char
import Data.Maybe
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
rattModules :: Set FastString
rattModules :: Set FastString
rattModules = forall a. Ord a => [a] -> Set a
Set.fromList [FastString
"Rattus.Internal",FastString
"Rattus.Primitives"
,FastString
"Rattus.Stable", FastString
"Rattus.Arrow"]
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))
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 Type
t1) == :: TypeCmp -> TypeCmp -> Bool
== (TC Type
t2) = Type -> Type -> Bool
eqType Type
t1 Type
t2
instance Ord TypeCmp where
compare :: TypeCmp -> TypeCmp -> Ordering
compare (TC Type
t1) (TC Type
t2) = Type -> Type -> Ordering
nonDetCmpType Type
t1 Type
t2
isTemporal :: Type -> Bool
isTemporal :: Type -> Bool
isTemporal Type
t = Int -> Set TypeCmp -> Type -> Bool
isTemporalRec Int
0 forall a. Set a
Set.empty Type
t
isTemporalRec :: Int -> Set TypeCmp -> Type -> Bool
isTemporalRec :: Int -> Set TypeCmp -> Type -> Bool
isTemporalRec Int
d Set TypeCmp
_ Type
_ | Int
d forall a. Eq a => a -> a -> Bool
== Int
100 = Bool
False
isTemporalRec Int
_ Set TypeCmp
pr Type
t | forall a. Ord a => a -> Set a -> Bool
Set.member (Type -> TypeCmp
TC Type
t) Set TypeCmp
pr = Bool
False
isTemporalRec Int
d Set TypeCmp
pr Type
t = do
let pr' :: Set TypeCmp
pr' = forall a. Ord a => a -> Set a -> Set a
Set.insert (Type -> TypeCmp
TC Type
t) Set TypeCmp
pr
case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t of
Maybe (TyCon, [Type])
Nothing -> Bool
False
Just (TyCon
con,[Type]
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 -> 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 -> Type -> Bool
isTemporalRec (Int
dforall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Type]
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 -> [Type] -> ([Var], [Type], [Type])
dataConInstSig DataCon
con [Type]
args of
([Var]
_, [Type]
_,[Type]
tys) -> forall (t :: * -> *). Foldable t => t Bool -> Bool
or (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Type -> Bool
isTemporalRec (Int
dforall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Type]
tys)
AlgTyConRhs
_ -> forall (t :: * -> *). Foldable t => t Bool -> Bool
or (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Type -> Bool
isTemporalRec (Int
dforall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Type]
args)
Maybe (FastString, FastString)
_ -> Bool
False
isStable :: Set Var -> Type -> Bool
isStable :: Set Var -> Type -> Bool
isStable Set Var
c Type
t = Set Var -> Int -> Set TypeCmp -> Type -> Bool
isStableRec Set Var
c Int
0 forall a. Set a
Set.empty Type
t
isStableRec :: Set Var -> Int -> Set TypeCmp -> Type -> Bool
isStableRec :: Set Var -> Int -> Set TypeCmp -> Type -> Bool
isStableRec Set Var
_ Int
d Set TypeCmp
_ Type
_ | Int
d forall a. Eq a => a -> a -> Bool
== Int
100 = Bool
True
isStableRec Set Var
_ Int
_ Set TypeCmp
pr Type
t | forall a. Ord a => a -> Set a -> Bool
Set.member (Type -> TypeCmp
TC Type
t) Set TypeCmp
pr = Bool
True
isStableRec Set Var
c Int
d Set TypeCmp
pr Type
t = do
let pr' :: Set TypeCmp
pr' = forall a. Ord a => a -> Set a -> Set a
Set.insert (Type -> TypeCmp
TC Type
t) Set TypeCmp
pr
case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t of
Maybe (TyCon, [Type])
Nothing -> case Type -> Maybe Var
getTyVar_maybe Type
t of
Just Var
v ->
Var
v forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Var
c
Maybe Var
Nothing -> Bool
False
Just (TyCon
con,[Type]
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 -> Bool
isRattModule FastString
mod Bool -> Bool -> Bool
&& FastString
name forall a. Eq a => a -> a -> Bool
== FastString
"Box" -> Bool
True
| FastString -> Bool
isGhcModule FastString
mod -> FastString -> Bool
isGhcStableType FastString
name
| 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 -> [Type] -> ([Var], [Type], [Type])
dataConInstSig DataCon
con [Type]
args of
([Var]
_, [Type]
_,[Type]
tys) -> forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b. (a -> b) -> [a] -> [b]
map (Set Var -> Int -> Set TypeCmp -> Type -> Bool
isStableRec Set Var
c (Int
dforall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Type]
tys)
TupleTyCon {} -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
args
AlgTyConRhs
_ -> Bool
False
Maybe (FastString, FastString)
_ -> Bool
False
isStrict :: Type -> Bool
isStrict :: Type -> Bool
isStrict Type
t = Int -> Set TypeCmp -> Type -> Bool
isStrictRec Int
0 forall a. Set a
Set.empty Type
t
#if __GLASGOW_HASKELL__ >= 902
splitForAllTys' :: Type -> ([TyCoVar], Type)
splitForAllTys' :: Type -> ([Var], Type)
splitForAllTys' = Type -> ([Var], Type)
splitForAllTyCoVars
#else
splitForAllTys' = splitForAllTys
#endif
isStrictRec :: Int -> Set TypeCmp -> Type -> Bool
isStrictRec :: Int -> Set TypeCmp -> Type -> Bool
isStrictRec Int
d Set TypeCmp
_ Type
_ | Int
d forall a. Eq a => a -> a -> Bool
== Int
100 = Bool
True
isStrictRec Int
_ Set TypeCmp
pr Type
t | forall a. Ord a => a -> Set a -> Bool
Set.member (Type -> TypeCmp
TC Type
t) Set TypeCmp
pr = Bool
True
isStrictRec Int
d Set TypeCmp
pr Type
t = do
let pr' :: Set TypeCmp
pr' = forall a. Ord a => a -> Set a -> Set a
Set.insert (Type -> TypeCmp
TC Type
t) Set TypeCmp
pr
let ([Var]
_,Type
t') = Type -> ([Var], Type)
splitForAllTys' Type
t
let (Type
c, [Type]
tys) = HasDebugCallStack => Type -> (Type, [Type])
repSplitAppTys Type
t'
if forall a. Maybe a -> Bool
isJust (Type -> Maybe Var
getTyVar_maybe Type
c) then forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Type -> Bool
isStrictRec (Int
dforall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Type]
tys)
else case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t' of
Maybe (TyCon, [Type])
Nothing -> forall a. Maybe a -> Bool
isJust (Type -> Maybe Var
getTyVar_maybe Type
t)
Just (TyCon
con,[Type]
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 -> 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
| FastString -> Bool
isGhcModule FastString
mod -> FastString -> Bool
isGhcStableType FastString
name
| 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 ([Type] -> DataCon -> Bool
areSrcStrict [Type]
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 -> [Type] -> ([Var], [Type], [Type])
dataConInstSig DataCon
con [Type]
args of
([Var]
_, [Type]
_,[Type]
tys) -> forall (t :: * -> *). Foldable t => t Bool -> Bool
and (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Type -> Bool
isStrictRec (Int
dforall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Type]
tys)
TupleTyCon {} -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
args
AlgTyConRhs
_ -> Bool
False
| Bool
otherwise -> Bool
False
areSrcStrict :: [Type] -> DataCon -> Bool
areSrcStrict :: [Type] -> DataCon -> Bool
areSrcStrict [Type]
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 [Type]
tys (DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
con))
where ([Var]
_, [Type]
_,[Type]
tys) = DataCon -> [Type] -> ([Var], [Type], [Type])
dataConInstSig DataCon
con [Type]
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
_ = Bool
False
userFunction :: Var -> Bool
userFunction :: Var -> Bool
userFunction Var
v =
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
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 -> Type -> Type -> m Var
mkSysLocalM FastString
lit (Var -> Type
varMult Var
v) (Var -> Type
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 -> Type -> Type -> m Var
mkSysLocalM FastString
lit Type
oneDataConTy (CoreExpr -> Type
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