{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveLift                 #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MagicHash                  #-}
{-# LANGUAGE TemplateHaskellQuotes      #-}
{-# LANGUAGE TupleSections              #-}

-- | Check that a datatype is deeply strict, ie, it recursively only has strict fields.
module Language.Haskell.TH.DeepStrict
  (
  -- * DeepStrict
    DeepStrict(..)
  , DeepStrictReason(..)
  , DeepStrictWithReason
  -- * Checking data types
  , isDeepStrict
  , isDeepStrictWith
  , assertDeepStrict
  , assertDeepStrictWith
  -- * Context
  , Context(..)
  , Strictness(..)
  , emptyContext
  , FieldKey
  ) where

import Data.Maybe                    (mapMaybe, fromMaybe)
import Data.List                     (foldl')
import Control.Monad                 (when)
import Control.Monad.IO.Class        (MonadIO)
import Control.Monad.Reader          (MonadReader (ask, local), ReaderT (..), asks)
import Control.Monad.Trans           (lift)
import Data.Bifunctor                (first)
import Data.IORef                    (IORef, modifyIORef', newIORef, readIORef)
import Data.Traversable              (for)
import GHC.Stack                     (HasCallStack)
import Language.Haskell.TH           (Q)
import Language.Haskell.TH.Instances ()

import qualified Data.Map                     as ML
import qualified Data.Set                     as S
import qualified Data.Map.Strict              as M
import qualified Language.Haskell.TH          as TH
import qualified Language.Haskell.TH.Datatype as TH
import qualified Language.Haskell.TH.Datatype.TyVarBndr as TH
import qualified Language.Haskell.TH.Ppr      as Ppr
import qualified Language.Haskell.TH.PprLib   as Ppr
import qualified Language.Haskell.TH.Syntax   as TH

newtype DeepStrictM a = DeepStrictM { forall a. DeepStrictM a -> ReaderT Context Q a
runDeepStrictM :: ReaderT Context Q a }
  deriving newtype (forall a b. a -> DeepStrictM b -> DeepStrictM a
forall a b. (a -> b) -> DeepStrictM a -> DeepStrictM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> DeepStrictM b -> DeepStrictM a
$c<$ :: forall a b. a -> DeepStrictM b -> DeepStrictM a
fmap :: forall a b. (a -> b) -> DeepStrictM a -> DeepStrictM b
$cfmap :: forall a b. (a -> b) -> DeepStrictM a -> DeepStrictM b
Functor, Functor DeepStrictM
forall a. a -> DeepStrictM a
forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM a
forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM b
forall a b. DeepStrictM (a -> b) -> DeepStrictM a -> DeepStrictM b
forall a b c.
(a -> b -> c) -> DeepStrictM a -> DeepStrictM b -> DeepStrictM 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
<* :: forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM a
$c<* :: forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM a
*> :: forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM b
$c*> :: forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM b
liftA2 :: forall a b c.
(a -> b -> c) -> DeepStrictM a -> DeepStrictM b -> DeepStrictM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> DeepStrictM a -> DeepStrictM b -> DeepStrictM c
<*> :: forall a b. DeepStrictM (a -> b) -> DeepStrictM a -> DeepStrictM b
$c<*> :: forall a b. DeepStrictM (a -> b) -> DeepStrictM a -> DeepStrictM b
pure :: forall a. a -> DeepStrictM a
$cpure :: forall a. a -> DeepStrictM a
Applicative, Applicative DeepStrictM
forall a. a -> DeepStrictM a
forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM b
forall a b. DeepStrictM a -> (a -> DeepStrictM b) -> DeepStrictM 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 :: forall a. a -> DeepStrictM a
$creturn :: forall a. a -> DeepStrictM a
>> :: forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM b
$c>> :: forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM b
>>= :: forall a b. DeepStrictM a -> (a -> DeepStrictM b) -> DeepStrictM b
$c>>= :: forall a b. DeepStrictM a -> (a -> DeepStrictM b) -> DeepStrictM b
Monad, Monad DeepStrictM
forall a. IO a -> DeepStrictM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> DeepStrictM a
$cliftIO :: forall a. IO a -> DeepStrictM a
MonadIO, Monad DeepStrictM
forall a. String -> DeepStrictM a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> DeepStrictM a
$cfail :: forall a. String -> DeepStrictM a
MonadFail, MonadReader Context)
  deriving (Monad DeepStrictM
String -> DeepStrictM Name
forall (m :: * -> *). Monad m -> (String -> m Name) -> Quote m
newName :: String -> DeepStrictM Name
$cnewName :: String -> DeepStrictM Name
TH.Quote, MonadFail DeepStrictM
MonadIO DeepStrictM
DeepStrictM [Extension]
DeepStrictM Loc
Bool -> String -> DeepStrictM (Maybe Name)
Bool -> String -> DeepStrictM ()
String -> DeepStrictM String
String -> DeepStrictM Name
String -> DeepStrictM ()
[Dec] -> DeepStrictM ()
Q () -> DeepStrictM ()
Name -> DeepStrictM [Role]
Name -> DeepStrictM [DecidedStrictness]
Name -> DeepStrictM (Maybe Fixity)
Name -> DeepStrictM Type
Name -> DeepStrictM Info
Name -> [Type] -> DeepStrictM [Dec]
Extension -> DeepStrictM Bool
ForeignSrcLang -> String -> DeepStrictM ()
Module -> DeepStrictM ModuleInfo
DocLoc -> DeepStrictM (Maybe String)
DocLoc -> String -> DeepStrictM ()
forall a. Data a => AnnLookup -> DeepStrictM [a]
forall a. Typeable a => DeepStrictM (Maybe a)
forall a. Typeable a => a -> DeepStrictM ()
forall a. IO a -> DeepStrictM a
forall a. DeepStrictM a -> DeepStrictM a -> DeepStrictM a
forall (m :: * -> *).
MonadIO m
-> MonadFail m
-> (String -> m Name)
-> (Bool -> String -> m ())
-> (forall a. m a -> m a -> m a)
-> (Bool -> String -> m (Maybe Name))
-> (Name -> m Info)
-> (Name -> m (Maybe Fixity))
-> (Name -> m Type)
-> (Name -> [Type] -> m [Dec])
-> (Name -> m [Role])
-> (forall a. Data a => AnnLookup -> m [a])
-> (Module -> m ModuleInfo)
-> (Name -> m [DecidedStrictness])
-> m Loc
-> (forall a. IO a -> m a)
-> (String -> m ())
-> (String -> m String)
-> ([Dec] -> m ())
-> (ForeignSrcLang -> String -> m ())
-> (Q () -> m ())
-> (String -> m ())
-> (forall a. Typeable a => m (Maybe a))
-> (forall a. Typeable a => a -> m ())
-> (Extension -> m Bool)
-> m [Extension]
-> (DocLoc -> String -> m ())
-> (DocLoc -> m (Maybe String))
-> Quasi m
qGetDoc :: DocLoc -> DeepStrictM (Maybe String)
$cqGetDoc :: DocLoc -> DeepStrictM (Maybe String)
qPutDoc :: DocLoc -> String -> DeepStrictM ()
$cqPutDoc :: DocLoc -> String -> DeepStrictM ()
qExtsEnabled :: DeepStrictM [Extension]
$cqExtsEnabled :: DeepStrictM [Extension]
qIsExtEnabled :: Extension -> DeepStrictM Bool
$cqIsExtEnabled :: Extension -> DeepStrictM Bool
qPutQ :: forall a. Typeable a => a -> DeepStrictM ()
$cqPutQ :: forall a. Typeable a => a -> DeepStrictM ()
qGetQ :: forall a. Typeable a => DeepStrictM (Maybe a)
$cqGetQ :: forall a. Typeable a => DeepStrictM (Maybe a)
qAddCorePlugin :: String -> DeepStrictM ()
$cqAddCorePlugin :: String -> DeepStrictM ()
qAddModFinalizer :: Q () -> DeepStrictM ()
$cqAddModFinalizer :: Q () -> DeepStrictM ()
qAddForeignFilePath :: ForeignSrcLang -> String -> DeepStrictM ()
$cqAddForeignFilePath :: ForeignSrcLang -> String -> DeepStrictM ()
qAddTopDecls :: [Dec] -> DeepStrictM ()
$cqAddTopDecls :: [Dec] -> DeepStrictM ()
qAddTempFile :: String -> DeepStrictM String
$cqAddTempFile :: String -> DeepStrictM String
qAddDependentFile :: String -> DeepStrictM ()
$cqAddDependentFile :: String -> DeepStrictM ()
qRunIO :: forall a. IO a -> DeepStrictM a
$cqRunIO :: forall a. IO a -> DeepStrictM a
qLocation :: DeepStrictM Loc
$cqLocation :: DeepStrictM Loc
qReifyConStrictness :: Name -> DeepStrictM [DecidedStrictness]
$cqReifyConStrictness :: Name -> DeepStrictM [DecidedStrictness]
qReifyModule :: Module -> DeepStrictM ModuleInfo
$cqReifyModule :: Module -> DeepStrictM ModuleInfo
qReifyAnnotations :: forall a. Data a => AnnLookup -> DeepStrictM [a]
$cqReifyAnnotations :: forall a. Data a => AnnLookup -> DeepStrictM [a]
qReifyRoles :: Name -> DeepStrictM [Role]
$cqReifyRoles :: Name -> DeepStrictM [Role]
qReifyInstances :: Name -> [Type] -> DeepStrictM [Dec]
$cqReifyInstances :: Name -> [Type] -> DeepStrictM [Dec]
qReifyType :: Name -> DeepStrictM Type
$cqReifyType :: Name -> DeepStrictM Type
qReifyFixity :: Name -> DeepStrictM (Maybe Fixity)
$cqReifyFixity :: Name -> DeepStrictM (Maybe Fixity)
qReify :: Name -> DeepStrictM Info
$cqReify :: Name -> DeepStrictM Info
qLookupName :: Bool -> String -> DeepStrictM (Maybe Name)
$cqLookupName :: Bool -> String -> DeepStrictM (Maybe Name)
qRecover :: forall a. DeepStrictM a -> DeepStrictM a -> DeepStrictM a
$cqRecover :: forall a. DeepStrictM a -> DeepStrictM a -> DeepStrictM a
qReport :: Bool -> String -> DeepStrictM ()
$cqReport :: Bool -> String -> DeepStrictM ()
qNewName :: String -> DeepStrictM Name
$cqNewName :: String -> DeepStrictM Name
TH.Quasi) via (ReaderT Context Q)

-- | Allow overriding various setting that determine what types we consider deep strict.
data Context = Context
  { Context -> Set Type
contextSpine          :: !(S.Set TH.Type) -- ^ The types we are recursively checking. By the inductive hypothesis, we assume they are DeepStrict.
  , Context -> IORef (Map Type DeepStrictWithReason)
contextCache          :: !(IORef (M.Map TH.Type DeepStrictWithReason))
  , Context -> Map Name (Maybe [Strictness])
contextOverride       :: !(M.Map TH.Name (Maybe [Strictness])) -- ^ Maps names of types to whether they can be deep strict and if they can which arguments need to be strict
  , Context -> Int
contextRecursionDepth :: !Int -- ^ A recursion depth to avoid infinite loops.
  }

-- | The default t'Context'.
emptyContext :: Q Context
emptyContext :: Q Context
emptyContext = do
  IORef (Map Type DeepStrictWithReason)
emptyCache <- forall a. IO a -> Q a
TH.runIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall k a. Map k a
M.empty
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Context
      { contextSpine :: Set Type
contextSpine = forall a. Set a
S.empty
      , contextCache :: IORef (Map Type DeepStrictWithReason)
contextCache = IORef (Map Type DeepStrictWithReason)
emptyCache
      , contextOverride :: Map Name (Maybe [Strictness])
contextOverride = forall k a. Map k a
M.empty
      , contextRecursionDepth :: Int
contextRecursionDepth = Int
1000
      }

-- | A type is deep strict if and only if for each constructor:
--
--   - All of its fields are strict, ie, they have a @!@ if possible.
--   - The type of of each field is deep strict.
--
-- The Monoid instance allows us to gather up reasons why a type fails to be deep strict.
--
-- === Examples
--
-- @()@ is deep strict because its single constructor doesn't have any fields so it is vacuously deep strict.
--
-- 'Int', 'Char', etc are all deep strict because they are wrappers around unlifted types that cannot be lazy.
--
-- @Maybe Int@ is not deep strict.
-- It has a 'Nothing' constructor, which is fine.
-- But, the 'Just' constructor has a lazy field, which means it's not deep strict.
data DeepStrict reason =
    DeepStrict
  | NotDeepStrict !reason
  deriving (DeepStrict reason -> DeepStrict reason -> Bool
forall reason.
Eq reason =>
DeepStrict reason -> DeepStrict reason -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeepStrict reason -> DeepStrict reason -> Bool
$c/= :: forall reason.
Eq reason =>
DeepStrict reason -> DeepStrict reason -> Bool
== :: DeepStrict reason -> DeepStrict reason -> Bool
$c== :: forall reason.
Eq reason =>
DeepStrict reason -> DeepStrict reason -> Bool
Eq, DeepStrict reason -> DeepStrict reason -> Bool
DeepStrict reason -> DeepStrict reason -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {reason}. Ord reason => Eq (DeepStrict reason)
forall reason.
Ord reason =>
DeepStrict reason -> DeepStrict reason -> Bool
forall reason.
Ord reason =>
DeepStrict reason -> DeepStrict reason -> Ordering
forall reason.
Ord reason =>
DeepStrict reason -> DeepStrict reason -> DeepStrict reason
min :: DeepStrict reason -> DeepStrict reason -> DeepStrict reason
$cmin :: forall reason.
Ord reason =>
DeepStrict reason -> DeepStrict reason -> DeepStrict reason
max :: DeepStrict reason -> DeepStrict reason -> DeepStrict reason
$cmax :: forall reason.
Ord reason =>
DeepStrict reason -> DeepStrict reason -> DeepStrict reason
>= :: DeepStrict reason -> DeepStrict reason -> Bool
$c>= :: forall reason.
Ord reason =>
DeepStrict reason -> DeepStrict reason -> Bool
> :: DeepStrict reason -> DeepStrict reason -> Bool
$c> :: forall reason.
Ord reason =>
DeepStrict reason -> DeepStrict reason -> Bool
<= :: DeepStrict reason -> DeepStrict reason -> Bool
$c<= :: forall reason.
Ord reason =>
DeepStrict reason -> DeepStrict reason -> Bool
< :: DeepStrict reason -> DeepStrict reason -> Bool
$c< :: forall reason.
Ord reason =>
DeepStrict reason -> DeepStrict reason -> Bool
compare :: DeepStrict reason -> DeepStrict reason -> Ordering
$ccompare :: forall reason.
Ord reason =>
DeepStrict reason -> DeepStrict reason -> Ordering
Ord, Int -> DeepStrict reason -> ShowS
forall reason. Show reason => Int -> DeepStrict reason -> ShowS
forall reason. Show reason => [DeepStrict reason] -> ShowS
forall reason. Show reason => DeepStrict reason -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeepStrict reason] -> ShowS
$cshowList :: forall reason. Show reason => [DeepStrict reason] -> ShowS
show :: DeepStrict reason -> String
$cshow :: forall reason. Show reason => DeepStrict reason -> String
showsPrec :: Int -> DeepStrict reason -> ShowS
$cshowsPrec :: forall reason. Show reason => Int -> DeepStrict reason -> ShowS
Show, forall reason (m :: * -> *).
(Lift reason, Quote m) =>
DeepStrict reason -> m Exp
forall reason (m :: * -> *).
(Lift reason, Quote m) =>
DeepStrict reason -> Code m (DeepStrict reason)
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => DeepStrict reason -> m Exp
forall (m :: * -> *).
Quote m =>
DeepStrict reason -> Code m (DeepStrict reason)
liftTyped :: forall (m :: * -> *).
Quote m =>
DeepStrict reason -> Code m (DeepStrict reason)
$cliftTyped :: forall reason (m :: * -> *).
(Lift reason, Quote m) =>
DeepStrict reason -> Code m (DeepStrict reason)
lift :: forall (m :: * -> *). Quote m => DeepStrict reason -> m Exp
$clift :: forall reason (m :: * -> *).
(Lift reason, Quote m) =>
DeepStrict reason -> m Exp
TH.Lift, forall a b. a -> DeepStrict b -> DeepStrict a
forall a b. (a -> b) -> DeepStrict a -> DeepStrict b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> DeepStrict b -> DeepStrict a
$c<$ :: forall a b. a -> DeepStrict b -> DeepStrict a
fmap :: forall a b. (a -> b) -> DeepStrict a -> DeepStrict b
$cfmap :: forall a b. (a -> b) -> DeepStrict a -> DeepStrict b
Functor)

type DeepStrictWithReason = DeepStrict [DeepStrictReason]

instance Semigroup reason => Semigroup (DeepStrict reason) where
  DeepStrict reason
DeepStrict <> :: DeepStrict reason -> DeepStrict reason -> DeepStrict reason
<> DeepStrict reason
DeepStrict                       = forall reason. DeepStrict reason
DeepStrict
  NotDeepStrict reason
reason <> DeepStrict reason
DeepStrict             = forall reason. reason -> DeepStrict reason
NotDeepStrict reason
reason
  DeepStrict reason
DeepStrict <> NotDeepStrict reason
reason             = forall reason. reason -> DeepStrict reason
NotDeepStrict reason
reason
  NotDeepStrict reason
reason1 <> NotDeepStrict reason
reason2 = forall reason. reason -> DeepStrict reason
NotDeepStrict forall a b. (a -> b) -> a -> b
$ reason
reason1 forall a. Semigroup a => a -> a -> a
<> reason
reason2

instance Semigroup reason => Monoid (DeepStrict reason) where
  mempty :: DeepStrict reason
mempty = forall reason. DeepStrict reason
DeepStrict

-- | Reasons why a type fails to be deep strict.
data DeepStrictReason =
    LazyType !TH.Type ![DeepStrictReason]
  -- ^ The type is lazy.
  | LazyConstructor !TH.Name ![DeepStrictReason]
  -- ^ The type has a lazy constructor.
  | FieldReason !FieldKey ![DeepStrictReason]
  -- ^ One of the fields of the constructor fails to be deep strict.
  | LazyField !FieldKey
  -- ^ One of the fields of the constructor is lazy, ie, doesn't have a @!@.
  | LazyOther !String
  deriving (DeepStrictReason -> DeepStrictReason -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeepStrictReason -> DeepStrictReason -> Bool
$c/= :: DeepStrictReason -> DeepStrictReason -> Bool
== :: DeepStrictReason -> DeepStrictReason -> Bool
$c== :: DeepStrictReason -> DeepStrictReason -> Bool
Eq, Eq DeepStrictReason
DeepStrictReason -> DeepStrictReason -> Bool
DeepStrictReason -> DeepStrictReason -> Ordering
DeepStrictReason -> DeepStrictReason -> DeepStrictReason
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DeepStrictReason -> DeepStrictReason -> DeepStrictReason
$cmin :: DeepStrictReason -> DeepStrictReason -> DeepStrictReason
max :: DeepStrictReason -> DeepStrictReason -> DeepStrictReason
$cmax :: DeepStrictReason -> DeepStrictReason -> DeepStrictReason
>= :: DeepStrictReason -> DeepStrictReason -> Bool
$c>= :: DeepStrictReason -> DeepStrictReason -> Bool
> :: DeepStrictReason -> DeepStrictReason -> Bool
$c> :: DeepStrictReason -> DeepStrictReason -> Bool
<= :: DeepStrictReason -> DeepStrictReason -> Bool
$c<= :: DeepStrictReason -> DeepStrictReason -> Bool
< :: DeepStrictReason -> DeepStrictReason -> Bool
$c< :: DeepStrictReason -> DeepStrictReason -> Bool
compare :: DeepStrictReason -> DeepStrictReason -> Ordering
$ccompare :: DeepStrictReason -> DeepStrictReason -> Ordering
Ord, Int -> DeepStrictReason -> ShowS
[DeepStrictReason] -> ShowS
DeepStrictReason -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeepStrictReason] -> ShowS
$cshowList :: [DeepStrictReason] -> ShowS
show :: DeepStrictReason -> String
$cshow :: DeepStrictReason -> String
showsPrec :: Int -> DeepStrictReason -> ShowS
$cshowsPrec :: Int -> DeepStrictReason -> ShowS
Show, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => DeepStrictReason -> m Exp
forall (m :: * -> *).
Quote m =>
DeepStrictReason -> Code m DeepStrictReason
liftTyped :: forall (m :: * -> *).
Quote m =>
DeepStrictReason -> Code m DeepStrictReason
$cliftTyped :: forall (m :: * -> *).
Quote m =>
DeepStrictReason -> Code m DeepStrictReason
lift :: forall (m :: * -> *). Quote m => DeepStrictReason -> m Exp
$clift :: forall (m :: * -> *). Quote m => DeepStrictReason -> m Exp
TH.Lift)

instance Ppr.Ppr reason => Ppr.Ppr (DeepStrict reason) where
  ppr :: DeepStrict reason -> Doc
ppr DeepStrict reason
DeepStrict             = String -> Doc
Ppr.text String
"DeepStrict" Doc -> Doc -> Doc
Ppr.$+$ String -> Doc
Ppr.text String
""
  ppr (NotDeepStrict reason
reason) = String -> Doc
Ppr.text String
"NotDeepStrict" Doc -> Doc -> Doc
Ppr.$$ forall a. Ppr a => a -> Doc
Ppr.ppr reason
reason Doc -> Doc -> Doc
Ppr.$+$ String -> Doc
Ppr.text String
""

instance Ppr.Ppr DeepStrictReason where
  ppr :: DeepStrictReason -> Doc
ppr (LazyType Type
typ [DeepStrictReason]
rest) = Doc -> Int -> Doc -> Doc
Ppr.hang (forall a. Ppr a => a -> Doc
Ppr.ppr Type
typ) Int
2 ([Doc] -> Doc
Ppr.vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Ppr a => a -> Doc
Ppr.ppr [DeepStrictReason]
rest))
  ppr (LazyConstructor Name
name [DeepStrictReason]
rest) = Doc -> Int -> Doc -> Doc
Ppr.hang (String -> Doc
Ppr.text String
"con" Doc -> Doc -> Doc
Ppr.<+> forall a. Ppr a => a -> Doc
Ppr.ppr Name
name) Int
2 forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
Ppr.vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Ppr a => a -> Doc
Ppr.ppr [DeepStrictReason]
rest
  ppr (FieldReason (Left Int
ix) [DeepStrictReason]
rest) = Doc -> Int -> Doc -> Doc
Ppr.hang (String -> Doc
Ppr.text String
"field" Doc -> Doc -> Doc
Ppr.<+> Int -> Doc
Ppr.int Int
ix) Int
2  forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
Ppr.vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Ppr a => a -> Doc
Ppr.ppr [DeepStrictReason]
rest
  ppr (FieldReason (Right Name
name) [DeepStrictReason]
rest) = Doc -> Int -> Doc -> Doc
Ppr.hang (forall a. Ppr a => a -> Doc
Ppr.ppr Name
name) Int
2  forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
Ppr.vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Ppr a => a -> Doc
Ppr.ppr [DeepStrictReason]
rest
  ppr (LazyField (Left Int
ix)) = String -> Doc
Ppr.text String
"field" Doc -> Doc -> Doc
Ppr.<+> Int -> Doc
Ppr.int Int
ix Doc -> Doc -> Doc
Ppr.<+> String -> Doc
Ppr.text String
"is lazy"
  ppr (LazyField (Right Name
name)) = String -> Doc
Ppr.text String
"field" Doc -> Doc -> Doc
Ppr.<+>  forall a. Ppr a => a -> Doc
Ppr.ppr Name
name Doc -> Doc -> Doc
Ppr.<+> String -> Doc
Ppr.text String
"is lazy"
  ppr (LazyOther String
txt) = String -> Doc
Ppr.text String
txt

giveReasonContext :: ([DeepStrictReason] -> DeepStrictReason) -> DeepStrictWithReason  -> DeepStrictWithReason
giveReasonContext :: ([DeepStrictReason] -> DeepStrictReason)
-> DeepStrictWithReason -> DeepStrictWithReason
giveReasonContext [DeepStrictReason] -> DeepStrictReason
f =  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DeepStrictReason] -> DeepStrictReason
f)

prettyPanic :: (HasCallStack, Ppr.Ppr x, Show x) => String -> x -> a
prettyPanic :: forall x a. (HasCallStack, Ppr x, Show x) => String -> x -> a
prettyPanic String
context x
x = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
context forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Ppr a => a -> String
Ppr.pprint x
x

data Levity = Lifted | Unlifted
  deriving (Levity -> Levity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Levity -> Levity -> Bool
$c/= :: Levity -> Levity -> Bool
== :: Levity -> Levity -> Bool
$c== :: Levity -> Levity -> Bool
Eq, Eq Levity
Levity -> Levity -> Bool
Levity -> Levity -> Ordering
Levity -> Levity -> Levity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Levity -> Levity -> Levity
$cmin :: Levity -> Levity -> Levity
max :: Levity -> Levity -> Levity
$cmax :: Levity -> Levity -> Levity
>= :: Levity -> Levity -> Bool
$c>= :: Levity -> Levity -> Bool
> :: Levity -> Levity -> Bool
$c> :: Levity -> Levity -> Bool
<= :: Levity -> Levity -> Bool
$c<= :: Levity -> Levity -> Bool
< :: Levity -> Levity -> Bool
$c< :: Levity -> Levity -> Bool
compare :: Levity -> Levity -> Ordering
$ccompare :: Levity -> Levity -> Ordering
Ord, Int -> Levity -> ShowS
[Levity] -> ShowS
Levity -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Levity] -> ShowS
$cshowList :: [Levity] -> ShowS
show :: Levity -> String
$cshow :: Levity -> String
showsPrec :: Int -> Levity -> ShowS
$cshowsPrec :: Int -> Levity -> ShowS
Show)

-- | Whether a type is used strictly by a data type.
-- We use these to annotate types with deep strictness overrides.
-- Types that have fields labelled as 'Language.Haskell.TH.DeepStrict.Strict' require those types to be deep strict.
-- Types that have fields labelled as 'Language.Haskell.TH.DeepStrict.Lazy' will never be deep strict, but this can be helpful for nicer messages.
data Strictness = Strict | Lazy
  deriving (Strictness -> Strictness -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Strictness -> Strictness -> Bool
$c/= :: Strictness -> Strictness -> Bool
== :: Strictness -> Strictness -> Bool
$c== :: Strictness -> Strictness -> Bool
Eq, Eq Strictness
Strictness -> Strictness -> Bool
Strictness -> Strictness -> Ordering
Strictness -> Strictness -> Strictness
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Strictness -> Strictness -> Strictness
$cmin :: Strictness -> Strictness -> Strictness
max :: Strictness -> Strictness -> Strictness
$cmax :: Strictness -> Strictness -> Strictness
>= :: Strictness -> Strictness -> Bool
$c>= :: Strictness -> Strictness -> Bool
> :: Strictness -> Strictness -> Bool
$c> :: Strictness -> Strictness -> Bool
<= :: Strictness -> Strictness -> Bool
$c<= :: Strictness -> Strictness -> Bool
< :: Strictness -> Strictness -> Bool
$c< :: Strictness -> Strictness -> Bool
compare :: Strictness -> Strictness -> Ordering
$ccompare :: Strictness -> Strictness -> Ordering
Ord, Int -> Strictness -> ShowS
[Strictness] -> ShowS
Strictness -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Strictness] -> ShowS
$cshowList :: [Strictness] -> ShowS
show :: Strictness -> String
$cshow :: Strictness -> String
showsPrec :: Int -> Strictness -> ShowS
$cshowsPrec :: Int -> Strictness -> ShowS
Show)

-- | A function/constructor is weak strict either iff it is strict and the argument isn't unlifted
-- So, it is like strictness but functions/constructors with unlifted/newtype args are WeakLazy
-- See: https://gitlab.haskell.org/ghc/ghc/-/issues/21380
data WeakStrictness = WeakStrict | WeakLazy
  deriving (WeakStrictness -> WeakStrictness -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WeakStrictness -> WeakStrictness -> Bool
$c/= :: WeakStrictness -> WeakStrictness -> Bool
== :: WeakStrictness -> WeakStrictness -> Bool
$c== :: WeakStrictness -> WeakStrictness -> Bool
Eq, Eq WeakStrictness
WeakStrictness -> WeakStrictness -> Bool
WeakStrictness -> WeakStrictness -> Ordering
WeakStrictness -> WeakStrictness -> WeakStrictness
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: WeakStrictness -> WeakStrictness -> WeakStrictness
$cmin :: WeakStrictness -> WeakStrictness -> WeakStrictness
max :: WeakStrictness -> WeakStrictness -> WeakStrictness
$cmax :: WeakStrictness -> WeakStrictness -> WeakStrictness
>= :: WeakStrictness -> WeakStrictness -> Bool
$c>= :: WeakStrictness -> WeakStrictness -> Bool
> :: WeakStrictness -> WeakStrictness -> Bool
$c> :: WeakStrictness -> WeakStrictness -> Bool
<= :: WeakStrictness -> WeakStrictness -> Bool
$c<= :: WeakStrictness -> WeakStrictness -> Bool
< :: WeakStrictness -> WeakStrictness -> Bool
$c< :: WeakStrictness -> WeakStrictness -> Bool
compare :: WeakStrictness -> WeakStrictness -> Ordering
$ccompare :: WeakStrictness -> WeakStrictness -> Ordering
Ord, Int -> WeakStrictness -> ShowS
[WeakStrictness] -> ShowS
WeakStrictness -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WeakStrictness] -> ShowS
$cshowList :: [WeakStrictness] -> ShowS
show :: WeakStrictness -> String
$cshow :: WeakStrictness -> String
showsPrec :: Int -> WeakStrictness -> ShowS
$cshowsPrec :: Int -> WeakStrictness -> ShowS
Show)

data HasBang = HasBang | NoBang
  deriving (HasBang -> HasBang -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HasBang -> HasBang -> Bool
$c/= :: HasBang -> HasBang -> Bool
== :: HasBang -> HasBang -> Bool
$c== :: HasBang -> HasBang -> Bool
Eq, Eq HasBang
HasBang -> HasBang -> Bool
HasBang -> HasBang -> Ordering
HasBang -> HasBang -> HasBang
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HasBang -> HasBang -> HasBang
$cmin :: HasBang -> HasBang -> HasBang
max :: HasBang -> HasBang -> HasBang
$cmax :: HasBang -> HasBang -> HasBang
>= :: HasBang -> HasBang -> Bool
$c>= :: HasBang -> HasBang -> Bool
> :: HasBang -> HasBang -> Bool
$c> :: HasBang -> HasBang -> Bool
<= :: HasBang -> HasBang -> Bool
$c<= :: HasBang -> HasBang -> Bool
< :: HasBang -> HasBang -> Bool
$c< :: HasBang -> HasBang -> Bool
compare :: HasBang -> HasBang -> Ordering
$ccompare :: HasBang -> HasBang -> Ordering
Ord, Int -> HasBang -> ShowS
[HasBang] -> ShowS
HasBang -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HasBang] -> ShowS
$cshowList :: [HasBang] -> ShowS
show :: HasBang -> String
$cshow :: HasBang -> String
showsPrec :: Int -> HasBang -> ShowS
$cshowsPrec :: Int -> HasBang -> ShowS
Show)

type FieldKey = Either Int TH.Name

data FieldInfo =
  FieldInfo
  { FieldInfo -> FieldKey
fieldInfoName :: FieldKey -- ^ either the index of the field or the name
  , FieldInfo -> WeakStrictness
fieldInfoBang :: WeakStrictness
  , FieldInfo -> Type
fieldInfoType :: TH.Type -- ^ May contain variables bound by datatype args
  } deriving (FieldInfo -> FieldInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldInfo -> FieldInfo -> Bool
$c/= :: FieldInfo -> FieldInfo -> Bool
== :: FieldInfo -> FieldInfo -> Bool
$c== :: FieldInfo -> FieldInfo -> Bool
Eq, Eq FieldInfo
FieldInfo -> FieldInfo -> Bool
FieldInfo -> FieldInfo -> Ordering
FieldInfo -> FieldInfo -> FieldInfo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FieldInfo -> FieldInfo -> FieldInfo
$cmin :: FieldInfo -> FieldInfo -> FieldInfo
max :: FieldInfo -> FieldInfo -> FieldInfo
$cmax :: FieldInfo -> FieldInfo -> FieldInfo
>= :: FieldInfo -> FieldInfo -> Bool
$c>= :: FieldInfo -> FieldInfo -> Bool
> :: FieldInfo -> FieldInfo -> Bool
$c> :: FieldInfo -> FieldInfo -> Bool
<= :: FieldInfo -> FieldInfo -> Bool
$c<= :: FieldInfo -> FieldInfo -> Bool
< :: FieldInfo -> FieldInfo -> Bool
$c< :: FieldInfo -> FieldInfo -> Bool
compare :: FieldInfo -> FieldInfo -> Ordering
$ccompare :: FieldInfo -> FieldInfo -> Ordering
Ord, Int -> FieldInfo -> ShowS
[FieldInfo] -> ShowS
FieldInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldInfo] -> ShowS
$cshowList :: [FieldInfo] -> ShowS
show :: FieldInfo -> String
$cshow :: FieldInfo -> String
showsPrec :: Int -> FieldInfo -> ShowS
$cshowsPrec :: Int -> FieldInfo -> ShowS
Show)

type Env = ML.Map TH.Name TH.Type

prepareDatatypeInfoEnv :: HasCallStack => [TH.Type] -> [TH.Name] -> (Env, [TH.Type])
prepareDatatypeInfoEnv :: HasCallStack => [Type] -> [Name] -> (Env, [Type])
prepareDatatypeInfoEnv [Type]
args [Name]
argNames = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall {a}. [a] -> Map Name a
makeEnv forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
argNames) [Type]
args
  where
    makeEnv :: [a] -> Map Name a
makeEnv = forall k a. Ord k => [(k, a)] -> Map k a
ML.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
argNames

substituteDatatypeInfoEnv :: HasCallStack => [TH.Type] -> TH.DatatypeInfo -> (TH.DatatypeInfo, [TH.Type])
substituteDatatypeInfoEnv :: HasCallStack => [Type] -> DatatypeInfo -> (DatatypeInfo, [Type])
substituteDatatypeInfoEnv [Type]
typeArgs DatatypeInfo
datatypeInfo =
  (DatatypeInfo
datatypeInfo { datatypeCons :: [ConstructorInfo]
TH.datatypeCons = forall a. TypeSubstitution a => Env -> a -> a
TH.applySubstitution Env
env (DatatypeInfo -> [ConstructorInfo]
TH.datatypeCons DatatypeInfo
datatypeInfo)
                }
  , [Type]
typeArgs')
  where
    getVariable :: TH.Type -> Maybe TH.Name
    getVariable :: Type -> Maybe Name
getVariable (TH.SigT Type
t Type
_k) = Type -> Maybe Name
getVariable Type
t
    getVariable (TH.VarT Name
v) = forall a. a -> Maybe a
Just Name
v
    getVariable Type
_ = forall a. Maybe a
Nothing
    freeVars :: [Name]
freeVars = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Type -> Maybe Name
getVariable forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> [Type]
TH.datatypeInstTypes DatatypeInfo
datatypeInfo
    (Env
env, [Type]
typeArgs') = HasCallStack => [Type] -> [Name] -> (Env, [Type])
prepareDatatypeInfoEnv [Type]
typeArgs [Name]
freeVars

decodeDecidedStrictness :: TH.DecidedStrictness -> WeakStrictness
decodeDecidedStrictness :: DecidedStrictness -> WeakStrictness
decodeDecidedStrictness DecidedStrictness
TH.DecidedStrict = WeakStrictness
WeakStrict
decodeDecidedStrictness DecidedStrictness
TH.DecidedUnpack = WeakStrictness
WeakStrict
decodeDecidedStrictness DecidedStrictness
TH.DecidedLazy   = WeakStrictness
WeakLazy

reifyLevityType :: HasCallStack => TH.Type -> DeepStrictM Levity
reifyLevityType :: HasCallStack => Type -> DeepStrictM Levity
reifyLevityType (TH.ConT Name
name) = HasCallStack => Name -> DeepStrictM Levity
reifyLevityName Name
name
reifyLevityType (TH.AppT Type
x Type
_)  = HasCallStack => Type -> DeepStrictM Levity
reifyLevityType Type
x
reifyLevityType (TH.ListT{})   = forall (f :: * -> *) a. Applicative f => a -> f a
pure Levity
Lifted
reifyLevityType (TH.TupleT{})  = forall (f :: * -> *) a. Applicative f => a -> f a
pure Levity
Lifted
reifyLevityType (TH.ArrowT{})  = forall (f :: * -> *) a. Applicative f => a -> f a
pure Levity
Lifted
reifyLevityType (TH.UnboxedTupleT{})  = forall (f :: * -> *) a. Applicative f => a -> f a
pure Levity
Unlifted
reifyLevityType (TH.UnboxedSumT{})  = forall (f :: * -> *) a. Applicative f => a -> f a
pure Levity
Unlifted
reifyLevityType Type
typ            = forall x a. (HasCallStack, Ppr x, Show x) => String -> x -> a
prettyPanic String
"unexpected type" Type
typ

-- | precondtion: name is a type
reifyLevityName :: HasCallStack => TH.Name -> DeepStrictM Levity
reifyLevityName :: HasCallStack => Name -> DeepStrictM Levity
reifyLevityName Name
name = do
  Type
kind <- forall (m :: * -> *). Quasi m => Name -> m Type
TH.qReifyType Name
name
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Type -> Levity
classifyKindLevity Type
kind

-- | Figure out the levity of a type from its kind.
--   If it has type arguments the kind will have arrows, we want to know the final return type.
--   Eg, for (x -> (y -> z)), we care about z
classifyKindLevity :: TH.Kind -> Levity
classifyKindLevity :: Type -> Levity
classifyKindLevity (TH.AppT Type
_ Type
x) = Type -> Levity
classifyKindLevity Type
x
classifyKindLevity Type
TH.StarT      = Levity
Lifted
classifyKindLevity Type
_             = Levity
Unlifted


isDatatypeDeepStrict :: HasCallStack => TH.DatatypeInfo -> [TH.Type] -> DeepStrictM DeepStrictWithReason
isDatatypeDeepStrict :: HasCallStack =>
DatatypeInfo -> [Type] -> DeepStrictM DeepStrictWithReason
isDatatypeDeepStrict DatatypeInfo
dt [Type]
args = HasCallStack =>
DatatypeInfo -> [Type] -> DeepStrictM DeepStrictWithReason
isDatatypeDeepStrict' DatatypeInfo
dt' [Type]
args'
  where
    (DatatypeInfo
dt', [Type]
args') = HasCallStack => [Type] -> DatatypeInfo -> (DatatypeInfo, [Type])
substituteDatatypeInfoEnv [Type]
args DatatypeInfo
dt

isDatatypeDeepStrict' :: HasCallStack => TH.DatatypeInfo -> [TH.Type] -> DeepStrictM DeepStrictWithReason
isDatatypeDeepStrict' :: HasCallStack =>
DatatypeInfo -> [Type] -> DeepStrictM DeepStrictWithReason
isDatatypeDeepStrict' DatatypeInfo
datatypeInfo [Type]
args = do
  [DeepStrictWithReason]
consDeepStrict <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\ConstructorInfo
c -> HasCallStack =>
ConstructorInfo
-> DatatypeVariant -> [Type] -> DeepStrictM DeepStrictWithReason
isConDeepStrict ConstructorInfo
c (DatatypeInfo -> DatatypeVariant
TH.datatypeVariant DatatypeInfo
datatypeInfo) [Type]
args) forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> [ConstructorInfo]
TH.datatypeCons DatatypeInfo
datatypeInfo
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [DeepStrictWithReason]
consDeepStrict

-- | Figure out the field names for a constructor.
-- We have names for records, we use indices for everything else.
extractFieldNames :: TH.ConstructorVariant -> [FieldKey]
extractFieldNames :: ConstructorVariant -> [FieldKey]
extractFieldNames (TH.RecordConstructor [Name]
fieldNames) = forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right [Name]
fieldNames
extractFieldNames ConstructorVariant
_                                 = forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left [Int
0..]

isConDeepStrict :: HasCallStack => TH.ConstructorInfo -> TH.DatatypeVariant -> [TH.Type] -> DeepStrictM DeepStrictWithReason
isConDeepStrict :: HasCallStack =>
ConstructorInfo
-> DatatypeVariant -> [Type] -> DeepStrictM DeepStrictWithReason
isConDeepStrict conInfo :: ConstructorInfo
conInfo@(TH.ConstructorInfo { constructorName :: ConstructorInfo -> Name
TH.constructorName = Name
conName, constructorFields :: ConstructorInfo -> [Type]
TH.constructorFields = [Type]
fieldTypes }) DatatypeVariant
variant [Type]
args = do
  [WeakStrictness]
fieldBangs <-
    if DatatypeVariant -> Bool
isNewtype DatatypeVariant
variant
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
repeat WeakStrictness
WeakStrict -- newtypes are strict
    else forall a b. (a -> b) -> [a] -> [b]
map DecidedStrictness -> WeakStrictness
decodeDecidedStrictness forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quasi m => Name -> m [DecidedStrictness]
TH.qReifyConStrictness Name
conName
  let fieldNames :: [FieldKey]
fieldNames = ConstructorVariant -> [FieldKey]
extractFieldNames forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> ConstructorVariant
TH.constructorVariant ConstructorInfo
conInfo
  let conFields :: [FieldInfo]
conFields = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 FieldKey -> WeakStrictness -> Type -> FieldInfo
FieldInfo [FieldKey]
fieldNames [WeakStrictness]
fieldBangs [Type]
fieldTypes
  [DeepStrictWithReason]
fieldDeepStrict <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (HasCallStack =>
FieldInfo -> [Type] -> DeepStrictM DeepStrictWithReason
`isFieldDeepStrict` [Type]
args) [FieldInfo]
conFields
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ([DeepStrictReason] -> DeepStrictReason)
-> DeepStrictWithReason -> DeepStrictWithReason
giveReasonContext (Name -> [DeepStrictReason] -> DeepStrictReason
LazyConstructor Name
conName) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [DeepStrictWithReason]
fieldDeepStrict

isNewtype :: TH.DatatypeVariant -> Bool
isNewtype :: DatatypeVariant -> Bool
isNewtype DatatypeVariant
TH.Newtype         = Bool
True
isNewtype DatatypeVariant
TH.NewtypeInstance = Bool
True
isNewtype DatatypeVariant
_                  = Bool
False

isFieldDeepStrict :: HasCallStack => FieldInfo -> [TH.Type] -> DeepStrictM DeepStrictWithReason
isFieldDeepStrict :: HasCallStack =>
FieldInfo -> [Type] -> DeepStrictM DeepStrictWithReason
isFieldDeepStrict (FieldInfo FieldKey
fieldName WeakStrictness
fieldWeakStrictness Type
fieldType) [Type]
args = do
  DeepStrictWithReason
fieldTypeRecStrict <- HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict Type
fieldType [Type]
args
  Levity
fieldLevity <- HasCallStack => Type -> DeepStrictM Levity
reifyLevityType Type
fieldType
  case (WeakStrictness
fieldWeakStrictness, DeepStrictWithReason
fieldTypeRecStrict, Levity
fieldLevity) of
    (WeakStrictness
WeakStrict, DeepStrictWithReason
DeepStrict, Levity
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall reason. DeepStrict reason
DeepStrict
    (WeakStrictness
WeakLazy, DeepStrictWithReason
DeepStrict, Levity
Unlifted) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall reason. DeepStrict reason
DeepStrict
    (WeakStrictness
WeakLazy, DeepStrictWithReason
strictness, Levity
Lifted) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall reason. reason -> DeepStrict reason
NotDeepStrict [FieldKey -> DeepStrictReason
LazyField FieldKey
fieldName] forall a. Semigroup a => a -> a -> a
<> DeepStrictWithReason -> DeepStrictWithReason
inField DeepStrictWithReason
strictness
    (WeakStrictness
_, DeepStrictWithReason
strictness, Levity
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ DeepStrictWithReason -> DeepStrictWithReason
inField DeepStrictWithReason
strictness
  where
    inField :: DeepStrictWithReason -> DeepStrictWithReason
inField = ([DeepStrictReason] -> DeepStrictReason)
-> DeepStrictWithReason -> DeepStrictWithReason
giveReasonContext (FieldKey -> [DeepStrictReason] -> DeepStrictReason
FieldReason FieldKey
fieldName)

getCachedDeepStrict :: HasCallStack => TH.Type -> DeepStrictM (Maybe DeepStrictWithReason)
getCachedDeepStrict :: HasCallStack => Type -> DeepStrictM (Maybe DeepStrictWithReason)
getCachedDeepStrict Type
typ = do
  IORef (Map Type DeepStrictWithReason)
cacheRef <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> IORef (Map Type DeepStrictWithReason)
contextCache
  Map Type DeepStrictWithReason
cache <- forall (m :: * -> *) a. Quasi m => IO a -> m a
TH.qRunIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (Map Type DeepStrictWithReason)
cacheRef
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Type
typ Map Type DeepStrictWithReason
cache

putCachedDeepStrict :: HasCallStack => TH.Type -> DeepStrictWithReason  -> DeepStrictM ()
putCachedDeepStrict :: HasCallStack => Type -> DeepStrictWithReason -> DeepStrictM ()
putCachedDeepStrict Type
typ DeepStrictWithReason
val = do
  IORef (Map Type DeepStrictWithReason)
cacheRef <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> IORef (Map Type DeepStrictWithReason)
contextCache
  forall (m :: * -> *) a. Quasi m => IO a -> m a
TH.qRunIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map Type DeepStrictWithReason)
cacheRef forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Type
typ (forall a b. a -> b -> a
const [String -> DeepStrictReason
LazyOther forall a b. (a -> b) -> a -> b
$ forall a. Ppr a => a -> String
Ppr.pprint Type
typ forall a. Semigroup a => a -> a -> a
<> String
" is lazy see above"] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DeepStrictWithReason
val)

isTypeDeepStrict :: HasCallStack => TH.Type -> [TH.Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict :: HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict Type
typ [Type]
args = do
  Context
ctxt <- forall r (m :: * -> *). MonadReader r m => m r
ask
  Maybe DeepStrictWithReason
cachedVal <- HasCallStack => Type -> DeepStrictM (Maybe DeepStrictWithReason)
getCachedDeepStrict Type
typ
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Int
contextRecursionDepth Context
ctxt forall a. Ord a => a -> a -> Bool
<= Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Recursion depth reached. Try adding an override for this type: " forall a. Semigroup a => a -> a -> a
<> forall a. Int -> [a] -> [a]
take Int
1000 (forall a. Show a => a -> String
show Type
typ)
  case (Maybe DeepStrictWithReason
cachedVal, forall a. Ord a => a -> Set a -> Bool
S.member Type
typ forall a b. (a -> b) -> a -> b
$ Context -> Set Type
contextSpine Context
ctxt) of
    (Just DeepStrictWithReason
val, Bool
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DeepStrictWithReason
val
    (Maybe DeepStrictWithReason
_, Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall reason. DeepStrict reason
DeepStrict -- by inductive hypothesis
    (Maybe DeepStrictWithReason, Bool)
_ ->
      forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Context
_ctxt ->
        Context
ctxt {contextSpine :: Set Type
contextSpine = forall a. Ord a => a -> Set a -> Set a
S.insert Type
typ (Context -> Set Type
contextSpine Context
ctxt), contextRecursionDepth :: Int
contextRecursionDepth = Context -> Int
contextRecursionDepth Context
ctxt forall a. Num a => a -> a -> a
- Int
1}) forall a b. (a -> b) -> a -> b
$ do
          DeepStrictWithReason
ret <- DeepStrictWithReason -> DeepStrictWithReason
inType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict' Type
typ [Type]
args
          HasCallStack => Type -> DeepStrictWithReason -> DeepStrictM ()
putCachedDeepStrict Type
typ DeepStrictWithReason
ret
          forall (f :: * -> *) a. Applicative f => a -> f a
pure DeepStrictWithReason
ret
  where
    inType :: DeepStrictWithReason -> DeepStrictWithReason
inType = ([DeepStrictReason] -> DeepStrictReason)
-> DeepStrictWithReason -> DeepStrictWithReason
giveReasonContext (Type -> [DeepStrictReason] -> DeepStrictReason
LazyType Type
typ)

isTypeDeepStrict' :: HasCallStack => TH.Type -> [TH.Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict' :: HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict' (TH.ConT Name
typeName) [Type]
args = HasCallStack => Name -> [Type] -> DeepStrictM DeepStrictWithReason
isNameDeepStrict Name
typeName [Type]
args
isTypeDeepStrict' (TH.AppT Type
func Type
arg) [Type]
args = HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict' Type
func (Type
argforall a. a -> [a] -> [a]
:[Type]
args)
isTypeDeepStrict' (TH.TupleT Int
0) [Type]
_         = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall reason. DeepStrict reason
DeepStrict -- () is DeepStrict
isTypeDeepStrict' (TH.TupleT Int
n) [Type]
args      = HasCallStack => Name -> [Type] -> DeepStrictM DeepStrictWithReason
isNameDeepStrict (Int -> Name
TH.tupleTypeName Int
n) [Type]
args
isTypeDeepStrict' (TH.ArrowT{}) [Type]
_         = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall reason. reason -> DeepStrict reason
NotDeepStrict [String -> DeepStrictReason
LazyOther String
"Functions are lazy"]
isTypeDeepStrict' (TH.ListT{}) [Type]
args       = HasCallStack => Name -> [Type] -> DeepStrictM DeepStrictWithReason
isNameDeepStrict ''[] [Type]
args
isTypeDeepStrict' (TH.UnboxedTupleT Int
arity) [Type]
args = HasCallStack => Name -> [Type] -> DeepStrictM DeepStrictWithReason
isNameDeepStrict (Int -> Name
TH.unboxedTupleTypeName Int
arity) [Type]
args
isTypeDeepStrict' (TH.UnboxedSumT Int
arity) [Type]
args  = HasCallStack => Name -> [Type] -> DeepStrictM DeepStrictWithReason
isNameDeepStrict (Int -> Name
TH.unboxedSumTypeName Int
arity) [Type]
args
isTypeDeepStrict' Type
typ [Type]
_                   = forall x a. (HasCallStack, Ppr x, Show x) => String -> x -> a
prettyPanic String
"Unexpected type" Type
typ

-- | figure out whether a newtype/data family is deep strict
isDataFamilyDeepStrict
  :: (p1 -> TH.Name -> [TH.TyVarBndr TH.BndrVis] -> p2 -> p3 -> p4 -> TH.Dec)
  -> TH.Name
  -> [TH.Type]
  -> p1
  -> Maybe [TH.TyVarBndr ()]
  -> TH.Type
  -> p2
  -> p3
  -> p4
  -> DeepStrictM DeepStrictWithReason
isDataFamilyDeepStrict :: forall p1 p2 p3 p4.
(p1 -> Name -> [TyVarBndr ()] -> p2 -> p3 -> p4 -> Dec)
-> Name
-> [Type]
-> p1
-> Maybe [TyVarBndr ()]
-> Type
-> p2
-> p3
-> p4
-> DeepStrictM DeepStrictWithReason
isDataFamilyDeepStrict p1 -> Name -> [TyVarBndr ()] -> p2 -> p3 -> p4 -> Dec
dConstr Name
typeName [Type]
args p1
cxt Maybe [TyVarBndr ()]
mTyVarBndrs Type
typ p2
kind p3
con p4
deriv =  do
  let tyVarBndrs :: [TyVarBndr ()]
tyVarBndrs = forall a. a -> Maybe a -> a
fromMaybe [] Maybe [TyVarBndr ()]
mTyVarBndrs
  let
    mkRequiredVis :: TyVarBndr flag -> TyVarBndr ()
mkRequiredVis (TH.PlainTV Name
x flag
_) = forall flag. Name -> flag -> TyVarBndr_ flag
TH.plainTVFlag Name
x ()
TH.BndrReq
    mkRequiredVis (TH.KindedTV Name
x flag
_ Type
k) = forall flag. Name -> flag -> Type -> TyVarBndr_ flag
TH.kindedTVFlag Name
x ()
TH.BndrReq Type
k
  let appliedArgs :: Type
appliedArgs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
TH.AppT (Name -> Type
TH.ConT Name
typeName) [Type]
args
  let d :: Dec
d = p1 -> Name -> [TyVarBndr ()] -> p2 -> p3 -> p4 -> Dec
dConstr p1
cxt (String -> Name
TH.mkName forall a b. (a -> b) -> a -> b
$ forall a. Ppr a => a -> String
TH.pprint forall a b. (a -> b) -> a -> b
$ Type
appliedArgs)  (forall a b. (a -> b) -> [a] -> [b]
map forall {flag}. TyVarBndr flag -> TyVarBndr ()
mkRequiredVis [TyVarBndr ()]
tyVarBndrs) p2
kind p3
con p4
deriv
  DatatypeInfo
datatypeInfo <- forall a. ReaderT Context Q a -> DeepStrictM a
DeepStrictM forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Dec -> Q DatatypeInfo
TH.normalizeDec Dec
d
  -- figure out the mapping from the input to the free variables in the family instance
  Env
unified <- forall a. ReaderT Context Q a -> DeepStrictM a
DeepStrictM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ [Type] -> Q Env
TH.unifyTypes [Type
appliedArgs, Type
typ]
  let tyVarNotFound :: a
tyVarNotFound = forall a. HasCallStack => String -> a
error String
"unmatched type variable in a data family definition"
  -- now our args are those free variables with the mapping
  let args' :: [Type]
args' = forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
tyVarNotFound forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Env
unified forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall flag. TyVarBndr_ flag -> Name
TH.tvName) [TyVarBndr ()]
tyVarBndrs
  HasCallStack =>
DatatypeInfo -> [Type] -> DeepStrictM DeepStrictWithReason
isDatatypeDeepStrict DatatypeInfo
datatypeInfo [Type]
args'

-- | Is this type constructor applied to these arguments deep strict
isNameDeepStrict :: HasCallStack => TH.Name -> [TH.Type] -> DeepStrictM DeepStrictWithReason
isNameDeepStrict :: HasCallStack => Name -> [Type] -> DeepStrictM DeepStrictWithReason
isNameDeepStrict Name
typeName [Type]
args = do
  Context
ctxt <- forall r (m :: * -> *). MonadReader r m => m r
ask
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
typeName forall a b. (a -> b) -> a -> b
$ Context -> Map Name (Maybe [Strictness])
contextOverride Context
ctxt of
    Maybe (Maybe [Strictness])
Nothing -> do
      Info
info <- forall a. ReaderT Context Q a -> DeepStrictM a
DeepStrictM forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Name -> Q Info
TH.reify Name
typeName
      case Info
info of
        -- th-abstraction can't handle type synonyms.
        -- let's treat a type synonym as just the RHS
        TH.TyConI (TH.TySynD Name
_name [TyVarBndr ()]
tyvarbndrs Type
rhs) -> do
          let (Env
env, [Type]
args') = HasCallStack => [Type] -> [Name] -> (Env, [Type])
prepareDatatypeInfoEnv [Type]
args (forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
TH.tvName [TyVarBndr ()]
tyvarbndrs)
          HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict (forall a. TypeSubstitution a => Env -> a -> a
TH.applySubstitution Env
env Type
rhs) [Type]
args'
        -- handle type/data families
        TH.FamilyI{} -> do
          [Dec]
instances <- forall a. ReaderT Context Q a -> DeepStrictM a
DeepStrictM forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Q [Dec]
TH.reifyInstances Name
typeName [Type]
args
          case [Dec]
instances of
            -- a type synonym instance is handled like a type synonym:
            -- just treat it as the RHS.
            (TH.TySynInstD (TH.TySynEqn Maybe [TyVarBndr ()]
_ Type
lhs Type
rhs)):[Dec]
_ -> do
              let (Env
env, [Type]
args') = HasCallStack => [Type] -> [Name] -> (Env, [Type])
prepareDatatypeInfoEnv [Type]
args (forall a. TypeSubstitution a => a -> [Name]
TH.freeVariables Type
lhs)
              HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict (forall a. TypeSubstitution a => Env -> a -> a
TH.applySubstitution Env
env Type
rhs) [Type]
args'
            -- let's construct a dummy datatype decleration
            (TH.DataInstD [Type]
cxt Maybe [TyVarBndr ()]
mTyVarBndrs Type
typ Maybe Type
kind [Con]
con [DerivClause]
deriv):[Dec]
_ -> do
              forall p1 p2 p3 p4.
(p1 -> Name -> [TyVarBndr ()] -> p2 -> p3 -> p4 -> Dec)
-> Name
-> [Type]
-> p1
-> Maybe [TyVarBndr ()]
-> Type
-> p2
-> p3
-> p4
-> DeepStrictM DeepStrictWithReason
isDataFamilyDeepStrict [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD Name
typeName [Type]
args [Type]
cxt Maybe [TyVarBndr ()]
mTyVarBndrs Type
typ Maybe Type
kind [Con]
con [DerivClause]
deriv
            (TH.NewtypeInstD [Type]
cxt Maybe [TyVarBndr ()]
mTyVarBndrs Type
typ Maybe Type
kind Con
con [DerivClause]
deriv):[Dec]
_ -> do
              forall p1 p2 p3 p4.
(p1 -> Name -> [TyVarBndr ()] -> p2 -> p3 -> p4 -> Dec)
-> Name
-> [Type]
-> p1
-> Maybe [TyVarBndr ()]
-> Type
-> p2
-> p3
-> p4
-> DeepStrictM DeepStrictWithReason
isDataFamilyDeepStrict [Type]
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
TH.NewtypeD Name
typeName [Type]
args [Type]
cxt Maybe [TyVarBndr ()]
mTyVarBndrs Type
typ Maybe Type
kind Con
con [DerivClause]
deriv
            [Dec]
_ -> forall a. HasCallStack => String -> a
error String
"Unsupported/ambiguous data/type family"
        Info
_ -> do
          DatatypeInfo
datatypeInfo <- forall a. ReaderT Context Q a -> DeepStrictM a
DeepStrictM forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Info -> Q DatatypeInfo
TH.normalizeInfo Info
info
          HasCallStack =>
DatatypeInfo -> [Type] -> DeepStrictM DeepStrictWithReason
isDatatypeDeepStrict DatatypeInfo
datatypeInfo [Type]
args
    Just Maybe [Strictness]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall reason. reason -> DeepStrict reason
NotDeepStrict [String -> DeepStrictReason
LazyOther String
"This type is marked as lazy"]
    Just (Just [Strictness]
strictnessReqs) ->
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall a b. [a] -> [b] -> [(a, b)]
zip [Strictness]
strictnessReqs [Type]
args) forall a b. (a -> b) -> a -> b
$ \case
        (Strictness
Lazy, Type
_)     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall reason. DeepStrict reason
DeepStrict
        (Strictness
Strict, Type
typ) -> HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict Type
typ []

-- | Determine if a type is deep strict
-- Invariant: The type doesn't contain any free variables, eg, @Maybe a@ will fail.
isDeepStrict :: TH.Type -> Q DeepStrictWithReason
isDeepStrict :: Type -> Q DeepStrictWithReason
isDeepStrict Type
typ = do
  Context
emptyC <- Q Context
emptyContext
  Context -> Type -> Q DeepStrictWithReason
isDeepStrictWith Context
emptyC Type
typ

isDeepStrictWith :: Context -> TH.Type -> Q DeepStrictWithReason
isDeepStrictWith :: Context -> Type -> Q DeepStrictWithReason
isDeepStrictWith Context
context Type
typ = do
  Type
typRes <- Type -> Q Type
TH.resolveTypeSynonyms Type
typ
  forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. DeepStrictM a -> ReaderT Context Q a
runDeepStrictM forall a b. (a -> b) -> a -> b
$ HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict Type
typRes []) Context
context


-- | Assert that a type is deep strict.
-- If the type isn't deep strict then this will produce an error with the reasons why.
assertDeepStrict :: TH.Type -> Q [TH.Dec]
assertDeepStrict :: Type -> Q [Dec]
assertDeepStrict Type
typ = do
  Context
emptyC <- Q Context
emptyContext
  Context -> Type -> Q [Dec]
assertDeepStrictWith Context
emptyC Type
typ

data DeepStrictAssertionFailed = DeepStrictAssertionFailed TH.Type [DeepStrictReason]

instance Ppr.Ppr DeepStrictAssertionFailed where
  ppr :: DeepStrictAssertionFailed -> Doc
ppr (DeepStrictAssertionFailed Type
typ [DeepStrictReason]
reason) =
   forall a. Ppr a => a -> Doc
Ppr.ppr Type
typ Doc -> Doc -> Doc
Ppr.$+$ String -> Doc
Ppr.text String
"is not Deep Strict, because: "
   Doc -> Doc -> Doc
Ppr.$$ forall a. Ppr a => a -> Doc
Ppr.ppr [DeepStrictReason]
reason

assertDeepStrictWith :: Context -> TH.Type -> Q [TH.Dec]
assertDeepStrictWith :: Context -> Type -> Q [Dec]
assertDeepStrictWith Context
context Type
typ = do
  DeepStrictWithReason
result <- Context -> Type -> Q DeepStrictWithReason
isDeepStrictWith Context
context Type
typ
  case DeepStrictWithReason
result of
    DeepStrictWithReason
DeepStrict -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    NotDeepStrict [DeepStrictReason]
reason ->
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Ppr a => a -> String
Ppr.pprint forall a b. (a -> b) -> a -> b
$ Type -> [DeepStrictReason] -> DeepStrictAssertionFailed
DeepStrictAssertionFailed Type
typ [DeepStrictReason]
reason