{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Rattus.Plugin.Utils (
  printMessage,
  Severity(..),
  isRattModule,
  isGhcModule,
  getNameModule,
  isStable,
  isStrict,
  isTemporal,
  userFunction,
  isType)
  where

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

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 Coercion
_) = Expr b -> Bool
isType Expr b
e
isType (Tick Tickish Id
_ Expr b
e) = Expr b -> Bool
isType Expr b
e
isType Expr b
_ = Bool
False

printMessage :: (HasDynFlags m, MonadIO m) =>
                Severity -> SrcSpan -> MsgDoc -> m ()
printMessage :: Severity -> SrcSpan -> MsgDoc -> m ()
printMessage Severity
sev SrcSpan
loc MsgDoc
doc = do
  DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let sty :: PprStyle
sty = case Severity
sev of
                     Severity
SevError   -> DynFlags -> PprStyle
defaultErrStyle DynFlags
dflags
                     Severity
SevWarning -> DynFlags -> PprStyle
defaultErrStyle DynFlags
dflags
                     Severity
SevDump    -> DynFlags -> PprStyle
defaultDumpStyle DynFlags
dflags
                     Severity
_          -> DynFlags -> PprStyle
defaultUserStyle DynFlags
dflags
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
putLogMsg DynFlags
dflags WarnReason
NoReason Severity
sev SrcSpan
loc PprStyle
sty MsgDoc
doc



rattModules :: Set FastString
rattModules :: Set FastString
rattModules = [FastString] -> Set FastString
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 = (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return (Name -> FastString
forall a. NamedThing a => a -> FastString
getOccFS Name
name,ModuleName -> FastString
moduleNameFS (Module -> 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
"Int",FastString
"Bool",FastString
"Float",FastString
"Double",FastString
"Char", FastString
"IO"]


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 Set TypeCmp
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
100 = Bool
False
isTemporalRec Int
_ Set TypeCmp
pr Type
t | TypeCmp -> Set TypeCmp -> Bool
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' = TypeCmp -> Set TypeCmp -> Set TypeCmp
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])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t of
    Maybe (TyCon, [Type])
Nothing -> Bool
False
    Just (TyCon
con,[Type]
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 ((Type -> Bool) -> [Type] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Type -> Bool
isTemporalRec (Int
dInt -> Int -> Int
forall 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} -> [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 -> [Type] -> ([Id], [Type], [Type])
dataConInstSig DataCon
con [Type]
args of
                        ([Id]
_, [Type]
_,[Type]
tys) -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((Type -> Bool) -> [Type] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Type -> Bool
isTemporalRec (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Type]
tys)
              AlgTyConRhs
_ -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((Type -> Bool) -> [Type] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Type -> Bool
isTemporalRec (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Type]
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 Id -> Type -> Bool
isStable Set Id
c Type
t = Set Id -> Int -> Set TypeCmp -> Type -> Bool
isStableRec Set Id
c Int
0 Set TypeCmp
forall a. Set a
Set.empty Type
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 Id -> Int -> Set TypeCmp -> Type -> Bool
isStableRec Set Id
_ Int
d Set TypeCmp
_ Type
_ | Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
100 = Bool
True
isStableRec Set Id
_ Int
_ Set TypeCmp
pr Type
t | TypeCmp -> Set TypeCmp -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Type -> TypeCmp
TC Type
t) Set TypeCmp
pr = Bool
True
isStableRec Set Id
c Int
d Set TypeCmp
pr Type
t = do
  let pr' :: Set TypeCmp
pr' = TypeCmp -> Set TypeCmp -> Set TypeCmp
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])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t of
    Maybe (TyCon, [Type])
Nothing -> case Type -> Maybe Id
getTyVar_maybe Type
t of
      Just Id
v -> -- if it's a type variable, check the context
        Id
v Id -> Set Id -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Id
c
      Maybe Id
Nothing -> Bool
False
    Just (TyCon
con,[Type]
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
True
            -- If its a built-in type check the set of stable built-in types
          | FastString -> Bool
isGhcModule FastString
mod -> FastString
name FastString -> Set FastString -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FastString
ghcStableTypes
          {- 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
                | [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (DataCon -> [Bool]) -> [DataCon] -> [Bool]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((HsSrcBang -> Bool) -> [HsSrcBang] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map HsSrcBang -> Bool
isSrcStrict'
                                   ([HsSrcBang] -> [Bool])
-> (DataCon -> [HsSrcBang]) -> DataCon -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> [HsSrcBang]
dataConSrcBangs) ([DataCon] -> [Bool]) -> [DataCon] -> [Bool]
forall a b. (a -> b) -> a -> b
$ [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 -> [Type] -> ([Id], [Type], [Type])
dataConInstSig DataCon
con [Type]
args of
                        ([Id]
_, [Type]
_,[Type]
tys) -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Type -> Bool) -> [Type] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Set Id -> Int -> Set TypeCmp -> Type -> Bool
isStableRec Set Id
c (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Type]
tys)
              TupleTyCon {} -> [Type] -> Bool
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 Set TypeCmp
forall a. Set a
Set.empty Type
t

-- | 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 -> Type -> Bool
isStrictRec Int
d Set TypeCmp
_ Type
_ | Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
100 = Bool
True
isStrictRec Int
_ Set TypeCmp
pr Type
t | TypeCmp -> Set TypeCmp -> Bool
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' = TypeCmp -> Set TypeCmp -> Set TypeCmp
forall a. Ord a => a -> Set a -> Set a
Set.insert (Type -> TypeCmp
TC Type
t) Set TypeCmp
pr
  let ([Id]
_,Type
t') = Type -> ([Id], Type)
splitForAllTys Type
t
  let (Type
c, [Type]
tys) = HasDebugCallStack => Type -> (Type, [Type])
Type -> (Type, [Type])
repSplitAppTys Type
t'
  if Maybe Id -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Maybe Id
getTyVar_maybe Type
c) then [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Type -> Bool) -> [Type] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Type -> Bool
isStrictRec (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Type]
tys)
  else  case HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t' of
    Maybe (TyCon, [Type])
Nothing -> Maybe Id -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Maybe Id
getTyVar_maybe Type
t)
    Just (TyCon
con,[Type]
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
            -- If its a built-in type check the set of stable built-in types
          | FastString -> Bool
isGhcModule FastString
mod -> FastString
name FastString -> Set FastString -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FastString
ghcStableTypes
          {- 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
                | [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ ((DataCon -> Bool) -> [DataCon] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map ([Type] -> DataCon -> Bool
areSrcStrict [Type]
args)) ([DataCon] -> [Bool]) -> [DataCon] -> [Bool]
forall a b. (a -> b) -> a -> b
$ [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 -> [Type] -> ([Id], [Type], [Type])
dataConInstSig DataCon
con [Type]
args of
                        ([Id]
_, [Type]
_,[Type]
tys) -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Type -> Bool) -> [Type] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Set TypeCmp -> Type -> Bool
isStrictRec (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Set TypeCmp
pr') [Type]
tys)
              TupleTyCon {} -> [Type] -> Bool
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 = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Type -> HsSrcBang -> Bool) -> [Type] -> [HsSrcBang] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> HsSrcBang -> Bool
forall p. p -> HsSrcBang -> Bool
check [Type]
tys (DataCon -> [HsSrcBang]
dataConSrcBangs DataCon
con))
  where ([Id]
_, [Type]
_,[Type]
tys) = DataCon -> [Type] -> ([Id], [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 :: Id -> Bool
userFunction Id
v =
  case Name -> String
forall a. NamedThing a => a -> String
getOccString (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
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