{-# 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)
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.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 -> b) -> DeepStrictM a -> DeepStrictM b)
-> (forall a b. a -> DeepStrictM b -> DeepStrictM a)
-> Functor DeepStrictM
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
$cfmap :: forall a b. (a -> b) -> DeepStrictM a -> DeepStrictM b
fmap :: forall a b. (a -> b) -> DeepStrictM a -> DeepStrictM b
$c<$ :: forall a b. a -> DeepStrictM b -> DeepStrictM a
<$ :: forall a b. a -> DeepStrictM b -> DeepStrictM a
Functor, Functor DeepStrictM
Functor DeepStrictM =>
(forall a. a -> DeepStrictM a)
-> (forall a b.
    DeepStrictM (a -> b) -> DeepStrictM a -> DeepStrictM b)
-> (forall a b c.
    (a -> b -> c) -> DeepStrictM a -> DeepStrictM b -> DeepStrictM c)
-> (forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM b)
-> (forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM a)
-> Applicative 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
$cpure :: forall a. a -> DeepStrictM a
pure :: forall a. a -> DeepStrictM a
$c<*> :: forall a b. DeepStrictM (a -> b) -> DeepStrictM a -> DeepStrictM b
<*> :: forall a b. DeepStrictM (a -> b) -> DeepStrictM a -> DeepStrictM b
$cliftA2 :: forall a b c.
(a -> b -> c) -> DeepStrictM a -> DeepStrictM b -> DeepStrictM c
liftA2 :: forall a b c.
(a -> b -> c) -> DeepStrictM a -> DeepStrictM b -> DeepStrictM c
$c*> :: forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM b
*> :: forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM b
$c<* :: forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM a
<* :: forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM a
Applicative, Applicative DeepStrictM
Applicative DeepStrictM =>
(forall a b.
 DeepStrictM a -> (a -> DeepStrictM b) -> DeepStrictM b)
-> (forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM b)
-> (forall a. a -> DeepStrictM a)
-> Monad 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
$c>>= :: forall a b. DeepStrictM a -> (a -> DeepStrictM b) -> DeepStrictM b
>>= :: forall a b. DeepStrictM a -> (a -> DeepStrictM b) -> DeepStrictM b
$c>> :: forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM b
>> :: forall a b. DeepStrictM a -> DeepStrictM b -> DeepStrictM b
$creturn :: forall a. a -> DeepStrictM a
return :: forall a. a -> DeepStrictM a
Monad, Monad DeepStrictM
Monad DeepStrictM =>
(forall a. IO a -> DeepStrictM a) -> MonadIO DeepStrictM
forall a. IO a -> DeepStrictM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> DeepStrictM a
liftIO :: forall a. IO a -> DeepStrictM a
MonadIO, Monad DeepStrictM
Monad DeepStrictM =>
(forall a. String -> DeepStrictM a) -> MonadFail DeepStrictM
forall a. String -> DeepStrictM a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall a. String -> DeepStrictM a
fail :: forall a. String -> DeepStrictM a
MonadFail, MonadReader Context)
  deriving (Monad DeepStrictM
Monad DeepStrictM =>
(String -> DeepStrictM Name) -> Quote DeepStrictM
String -> DeepStrictM Name
forall (m :: * -> *). Monad m => (String -> m Name) -> Quote m
$cnewName :: String -> DeepStrictM Name
newName :: String -> DeepStrictM Name
TH.Quote, MonadFail DeepStrictM
MonadIO DeepStrictM
DeepStrictM String
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]
(MonadIO DeepStrictM, MonadFail DeepStrictM) =>
(String -> DeepStrictM Name)
-> (Bool -> String -> DeepStrictM ())
-> (forall a. DeepStrictM a -> DeepStrictM a -> DeepStrictM a)
-> (Bool -> String -> DeepStrictM (Maybe Name))
-> (Name -> DeepStrictM Info)
-> (Name -> DeepStrictM (Maybe Fixity))
-> (Name -> DeepStrictM Type)
-> (Name -> [Type] -> DeepStrictM [Dec])
-> (Name -> DeepStrictM [Role])
-> (forall a. Data a => AnnLookup -> DeepStrictM [a])
-> (Module -> DeepStrictM ModuleInfo)
-> (Name -> DeepStrictM [DecidedStrictness])
-> DeepStrictM Loc
-> (forall a. IO a -> DeepStrictM a)
-> DeepStrictM String
-> (String -> DeepStrictM ())
-> (String -> DeepStrictM String)
-> ([Dec] -> DeepStrictM ())
-> (ForeignSrcLang -> String -> DeepStrictM ())
-> (Q () -> DeepStrictM ())
-> (String -> DeepStrictM ())
-> (forall a. Typeable a => DeepStrictM (Maybe a))
-> (forall a. Typeable a => a -> DeepStrictM ())
-> (Extension -> DeepStrictM Bool)
-> DeepStrictM [Extension]
-> (DocLoc -> String -> DeepStrictM ())
-> (DocLoc -> DeepStrictM (Maybe String))
-> Quasi DeepStrictM
ForeignSrcLang -> String -> DeepStrictM ()
Extension -> DeepStrictM Bool
DocLoc -> DeepStrictM (Maybe String)
DocLoc -> String -> DeepStrictM ()
Module -> DeepStrictM ModuleInfo
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)
-> m String
-> (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
$cqNewName :: String -> DeepStrictM Name
qNewName :: String -> DeepStrictM Name
$cqReport :: Bool -> String -> DeepStrictM ()
qReport :: Bool -> String -> DeepStrictM ()
$cqRecover :: forall a. DeepStrictM a -> DeepStrictM a -> DeepStrictM a
qRecover :: forall a. DeepStrictM a -> DeepStrictM a -> DeepStrictM a
$cqLookupName :: Bool -> String -> DeepStrictM (Maybe Name)
qLookupName :: Bool -> String -> DeepStrictM (Maybe Name)
$cqReify :: Name -> DeepStrictM Info
qReify :: Name -> DeepStrictM Info
$cqReifyFixity :: Name -> DeepStrictM (Maybe Fixity)
qReifyFixity :: Name -> DeepStrictM (Maybe Fixity)
$cqReifyType :: Name -> DeepStrictM Type
qReifyType :: Name -> DeepStrictM Type
$cqReifyInstances :: Name -> [Type] -> DeepStrictM [Dec]
qReifyInstances :: Name -> [Type] -> DeepStrictM [Dec]
$cqReifyRoles :: Name -> DeepStrictM [Role]
qReifyRoles :: Name -> DeepStrictM [Role]
$cqReifyAnnotations :: forall a. Data a => AnnLookup -> DeepStrictM [a]
qReifyAnnotations :: forall a. Data a => AnnLookup -> DeepStrictM [a]
$cqReifyModule :: Module -> DeepStrictM ModuleInfo
qReifyModule :: Module -> DeepStrictM ModuleInfo
$cqReifyConStrictness :: Name -> DeepStrictM [DecidedStrictness]
qReifyConStrictness :: Name -> DeepStrictM [DecidedStrictness]
$cqLocation :: DeepStrictM Loc
qLocation :: DeepStrictM Loc
$cqRunIO :: forall a. IO a -> DeepStrictM a
qRunIO :: forall a. IO a -> DeepStrictM a
$cqGetPackageRoot :: DeepStrictM String
qGetPackageRoot :: DeepStrictM String
$cqAddDependentFile :: String -> DeepStrictM ()
qAddDependentFile :: String -> DeepStrictM ()
$cqAddTempFile :: String -> DeepStrictM String
qAddTempFile :: String -> DeepStrictM String
$cqAddTopDecls :: [Dec] -> DeepStrictM ()
qAddTopDecls :: [Dec] -> DeepStrictM ()
$cqAddForeignFilePath :: ForeignSrcLang -> String -> DeepStrictM ()
qAddForeignFilePath :: ForeignSrcLang -> String -> DeepStrictM ()
$cqAddModFinalizer :: Q () -> DeepStrictM ()
qAddModFinalizer :: Q () -> DeepStrictM ()
$cqAddCorePlugin :: String -> DeepStrictM ()
qAddCorePlugin :: String -> DeepStrictM ()
$cqGetQ :: forall a. Typeable a => DeepStrictM (Maybe a)
qGetQ :: forall a. Typeable a => DeepStrictM (Maybe a)
$cqPutQ :: forall a. Typeable a => a -> DeepStrictM ()
qPutQ :: forall a. Typeable a => a -> DeepStrictM ()
$cqIsExtEnabled :: Extension -> DeepStrictM Bool
qIsExtEnabled :: Extension -> DeepStrictM Bool
$cqExtsEnabled :: DeepStrictM [Extension]
qExtsEnabled :: DeepStrictM [Extension]
$cqPutDoc :: DocLoc -> String -> DeepStrictM ()
qPutDoc :: DocLoc -> String -> DeepStrictM ()
$cqGetDoc :: DocLoc -> DeepStrictM (Maybe String)
qGetDoc :: DocLoc -> DeepStrictM (Maybe String)
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 <- IO (IORef (Map Type DeepStrictWithReason))
-> Q (IORef (Map Type DeepStrictWithReason))
forall a. IO a -> Q a
TH.runIO (IO (IORef (Map Type DeepStrictWithReason))
 -> Q (IORef (Map Type DeepStrictWithReason)))
-> IO (IORef (Map Type DeepStrictWithReason))
-> Q (IORef (Map Type DeepStrictWithReason))
forall a b. (a -> b) -> a -> b
$ Map Type DeepStrictWithReason
-> IO (IORef (Map Type DeepStrictWithReason))
forall a. a -> IO (IORef a)
newIORef Map Type DeepStrictWithReason
forall k a. Map k a
M.empty
  Context -> Q Context
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> Q Context) -> Context -> Q Context
forall a b. (a -> b) -> a -> b
$
    Context
      { contextSpine :: Set Type
contextSpine = Set Type
forall a. Set a
S.empty
      , contextCache :: IORef (Map Type DeepStrictWithReason)
contextCache = IORef (Map Type DeepStrictWithReason)
emptyCache
      , contextOverride :: Map Name (Maybe [Strictness])
contextOverride = Map Name (Maybe [Strictness])
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
(DeepStrict reason -> DeepStrict reason -> Bool)
-> (DeepStrict reason -> DeepStrict reason -> Bool)
-> Eq (DeepStrict reason)
forall reason.
Eq reason =>
DeepStrict reason -> DeepStrict reason -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: DeepStrict reason -> DeepStrict reason -> Bool
Eq, Eq (DeepStrict reason)
Eq (DeepStrict reason) =>
(DeepStrict reason -> DeepStrict reason -> Ordering)
-> (DeepStrict reason -> DeepStrict reason -> Bool)
-> (DeepStrict reason -> DeepStrict reason -> Bool)
-> (DeepStrict reason -> DeepStrict reason -> Bool)
-> (DeepStrict reason -> DeepStrict reason -> Bool)
-> (DeepStrict reason -> DeepStrict reason -> DeepStrict reason)
-> (DeepStrict reason -> DeepStrict reason -> DeepStrict reason)
-> Ord (DeepStrict reason)
DeepStrict reason -> DeepStrict reason -> Bool
DeepStrict reason -> DeepStrict reason -> Ordering
DeepStrict reason -> DeepStrict reason -> DeepStrict reason
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
$ccompare :: forall reason.
Ord reason =>
DeepStrict reason -> DeepStrict reason -> Ordering
compare :: DeepStrict reason -> DeepStrict reason -> Ordering
$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
>= :: DeepStrict reason -> DeepStrict reason -> Bool
$cmax :: forall reason.
Ord reason =>
DeepStrict reason -> DeepStrict reason -> DeepStrict reason
max :: DeepStrict reason -> DeepStrict reason -> DeepStrict reason
$cmin :: forall reason.
Ord reason =>
DeepStrict reason -> DeepStrict reason -> DeepStrict reason
min :: DeepStrict reason -> DeepStrict reason -> DeepStrict reason
Ord, Int -> DeepStrict reason -> ShowS
[DeepStrict reason] -> ShowS
DeepStrict reason -> String
(Int -> DeepStrict reason -> ShowS)
-> (DeepStrict reason -> String)
-> ([DeepStrict reason] -> ShowS)
-> Show (DeepStrict reason)
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
$cshowsPrec :: forall reason. Show reason => Int -> DeepStrict reason -> ShowS
showsPrec :: Int -> DeepStrict reason -> ShowS
$cshow :: forall reason. Show reason => DeepStrict reason -> String
show :: DeepStrict reason -> String
$cshowList :: forall reason. Show reason => [DeepStrict reason] -> ShowS
showList :: [DeepStrict reason] -> ShowS
Show, (forall (m :: * -> *). Quote m => DeepStrict reason -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    DeepStrict reason -> Code m (DeepStrict reason))
-> Lift (DeepStrict reason)
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)
$clift :: forall reason (m :: * -> *).
(Lift reason, Quote m) =>
DeepStrict reason -> m Exp
lift :: forall (m :: * -> *). Quote m => DeepStrict reason -> m Exp
$cliftTyped :: forall reason (m :: * -> *).
(Lift reason, Quote m) =>
DeepStrict reason -> Code m (DeepStrict reason)
liftTyped :: forall (m :: * -> *).
Quote m =>
DeepStrict reason -> Code m (DeepStrict reason)
TH.Lift, (forall a b. (a -> b) -> DeepStrict a -> DeepStrict b)
-> (forall a b. a -> DeepStrict b -> DeepStrict a)
-> Functor DeepStrict
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
$cfmap :: forall a b. (a -> b) -> DeepStrict a -> DeepStrict b
fmap :: forall a b. (a -> b) -> DeepStrict a -> DeepStrict b
$c<$ :: forall a b. a -> DeepStrict b -> DeepStrict a
<$ :: forall a b. a -> DeepStrict b -> DeepStrict a
Functor)

type DeepStrictWithReason = DeepStrict [DeepStrictReason]

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

instance Semigroup reason => Monoid (DeepStrict reason) where
  mempty :: DeepStrict reason
mempty = DeepStrict reason
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
(DeepStrictReason -> DeepStrictReason -> Bool)
-> (DeepStrictReason -> DeepStrictReason -> Bool)
-> Eq DeepStrictReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DeepStrictReason -> DeepStrictReason -> Bool
== :: DeepStrictReason -> DeepStrictReason -> Bool
$c/= :: DeepStrictReason -> DeepStrictReason -> Bool
/= :: DeepStrictReason -> DeepStrictReason -> Bool
Eq, Eq DeepStrictReason
Eq DeepStrictReason =>
(DeepStrictReason -> DeepStrictReason -> Ordering)
-> (DeepStrictReason -> DeepStrictReason -> Bool)
-> (DeepStrictReason -> DeepStrictReason -> Bool)
-> (DeepStrictReason -> DeepStrictReason -> Bool)
-> (DeepStrictReason -> DeepStrictReason -> Bool)
-> (DeepStrictReason -> DeepStrictReason -> DeepStrictReason)
-> (DeepStrictReason -> DeepStrictReason -> DeepStrictReason)
-> Ord 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
$ccompare :: DeepStrictReason -> DeepStrictReason -> Ordering
compare :: DeepStrictReason -> DeepStrictReason -> Ordering
$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
>= :: DeepStrictReason -> DeepStrictReason -> Bool
$cmax :: DeepStrictReason -> DeepStrictReason -> DeepStrictReason
max :: DeepStrictReason -> DeepStrictReason -> DeepStrictReason
$cmin :: DeepStrictReason -> DeepStrictReason -> DeepStrictReason
min :: DeepStrictReason -> DeepStrictReason -> DeepStrictReason
Ord, Int -> DeepStrictReason -> ShowS
[DeepStrictReason] -> ShowS
DeepStrictReason -> String
(Int -> DeepStrictReason -> ShowS)
-> (DeepStrictReason -> String)
-> ([DeepStrictReason] -> ShowS)
-> Show DeepStrictReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DeepStrictReason -> ShowS
showsPrec :: Int -> DeepStrictReason -> ShowS
$cshow :: DeepStrictReason -> String
show :: DeepStrictReason -> String
$cshowList :: [DeepStrictReason] -> ShowS
showList :: [DeepStrictReason] -> ShowS
Show, (forall (m :: * -> *). Quote m => DeepStrictReason -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    DeepStrictReason -> Code m DeepStrictReason)
-> Lift DeepStrictReason
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
$clift :: forall (m :: * -> *). Quote m => DeepStrictReason -> m Exp
lift :: forall (m :: * -> *). Quote m => DeepStrictReason -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
DeepStrictReason -> Code m DeepStrictReason
liftTyped :: forall (m :: * -> *).
Quote m =>
DeepStrictReason -> Code m DeepStrictReason
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.$$ reason -> Doc
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 (Type -> Doc
forall a. Ppr a => a -> Doc
Ppr.ppr Type
typ) Int
2 ([Doc] -> Doc
Ppr.vcat ((DeepStrictReason -> Doc) -> [DeepStrictReason] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DeepStrictReason -> Doc
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.<+> Name -> Doc
forall a. Ppr a => a -> Doc
Ppr.ppr Name
name) Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
Ppr.vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (DeepStrictReason -> Doc) -> [DeepStrictReason] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DeepStrictReason -> Doc
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  (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
Ppr.vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (DeepStrictReason -> Doc) -> [DeepStrictReason] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DeepStrictReason -> Doc
forall a. Ppr a => a -> Doc
Ppr.ppr [DeepStrictReason]
rest
  ppr (FieldReason (Right Name
name) [DeepStrictReason]
rest) = Doc -> Int -> Doc -> Doc
Ppr.hang (Name -> Doc
forall a. Ppr a => a -> Doc
Ppr.ppr Name
name) Int
2  (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
Ppr.vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (DeepStrictReason -> Doc) -> [DeepStrictReason] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DeepStrictReason -> Doc
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.<+>  Name -> Doc
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 =  ([DeepStrictReason] -> [DeepStrictReason])
-> DeepStrictWithReason -> DeepStrictWithReason
forall a b. (a -> b) -> DeepStrict a -> DeepStrict b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DeepStrictReason -> [DeepStrictReason]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DeepStrictReason -> [DeepStrictReason])
-> ([DeepStrictReason] -> DeepStrictReason)
-> [DeepStrictReason]
-> [DeepStrictReason]
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 = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
context String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> x -> String
forall a. Ppr a => a -> String
Ppr.pprint x
x

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

data HasBang = HasBang | NoBang
  deriving (HasBang -> HasBang -> Bool
(HasBang -> HasBang -> Bool)
-> (HasBang -> HasBang -> Bool) -> Eq HasBang
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HasBang -> HasBang -> Bool
== :: HasBang -> HasBang -> Bool
$c/= :: HasBang -> HasBang -> Bool
/= :: HasBang -> HasBang -> Bool
Eq, Eq HasBang
Eq HasBang =>
(HasBang -> HasBang -> Ordering)
-> (HasBang -> HasBang -> Bool)
-> (HasBang -> HasBang -> Bool)
-> (HasBang -> HasBang -> Bool)
-> (HasBang -> HasBang -> Bool)
-> (HasBang -> HasBang -> HasBang)
-> (HasBang -> HasBang -> HasBang)
-> Ord 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
$ccompare :: HasBang -> HasBang -> Ordering
compare :: HasBang -> HasBang -> Ordering
$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
>= :: HasBang -> HasBang -> Bool
$cmax :: HasBang -> HasBang -> HasBang
max :: HasBang -> HasBang -> HasBang
$cmin :: HasBang -> HasBang -> HasBang
min :: HasBang -> HasBang -> HasBang
Ord, Int -> HasBang -> ShowS
[HasBang] -> ShowS
HasBang -> String
(Int -> HasBang -> ShowS)
-> (HasBang -> String) -> ([HasBang] -> ShowS) -> Show HasBang
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HasBang -> ShowS
showsPrec :: Int -> HasBang -> ShowS
$cshow :: HasBang -> String
show :: HasBang -> String
$cshowList :: [HasBang] -> ShowS
showList :: [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
(FieldInfo -> FieldInfo -> Bool)
-> (FieldInfo -> FieldInfo -> Bool) -> Eq FieldInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldInfo -> FieldInfo -> Bool
== :: FieldInfo -> FieldInfo -> Bool
$c/= :: FieldInfo -> FieldInfo -> Bool
/= :: FieldInfo -> FieldInfo -> Bool
Eq, Eq FieldInfo
Eq FieldInfo =>
(FieldInfo -> FieldInfo -> Ordering)
-> (FieldInfo -> FieldInfo -> Bool)
-> (FieldInfo -> FieldInfo -> Bool)
-> (FieldInfo -> FieldInfo -> Bool)
-> (FieldInfo -> FieldInfo -> Bool)
-> (FieldInfo -> FieldInfo -> FieldInfo)
-> (FieldInfo -> FieldInfo -> FieldInfo)
-> Ord 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
$ccompare :: FieldInfo -> FieldInfo -> Ordering
compare :: FieldInfo -> FieldInfo -> Ordering
$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
>= :: FieldInfo -> FieldInfo -> Bool
$cmax :: FieldInfo -> FieldInfo -> FieldInfo
max :: FieldInfo -> FieldInfo -> FieldInfo
$cmin :: FieldInfo -> FieldInfo -> FieldInfo
min :: FieldInfo -> FieldInfo -> FieldInfo
Ord, Int -> FieldInfo -> ShowS
[FieldInfo] -> ShowS
FieldInfo -> String
(Int -> FieldInfo -> ShowS)
-> (FieldInfo -> String)
-> ([FieldInfo] -> ShowS)
-> Show FieldInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldInfo -> ShowS
showsPrec :: Int -> FieldInfo -> ShowS
$cshow :: FieldInfo -> String
show :: FieldInfo -> String
$cshowList :: [FieldInfo] -> ShowS
showList :: [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 = ([Type] -> Env) -> ([Type], [Type]) -> (Env, [Type])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Type] -> Env
forall {a}. [a] -> Map Name a
makeEnv (([Type], [Type]) -> (Env, [Type]))
-> ([Type], [Type]) -> (Env, [Type])
forall a b. (a -> b) -> a -> b
$ Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
argNames) [Type]
args
  where
    makeEnv :: [a] -> Map Name a
makeEnv = [(Name, a)] -> Map Name a
forall k a. Ord k => [(k, a)] -> Map k a
ML.fromList ([(Name, a)] -> Map Name a)
-> ([a] -> [(Name, a)]) -> [a] -> Map Name a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> [a] -> [(Name, a)]
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 { TH.datatypeCons = TH.applySubstitution env (TH.datatypeCons 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) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
v
    getVariable Type
_ = Maybe Name
forall a. Maybe a
Nothing
    freeVars :: [Name]
freeVars = (Type -> Maybe Name) -> [Type] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Type -> Maybe Name
getVariable ([Type] -> [Name]) -> [Type] -> [Name]
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> [Type]
TH.datatypeInstTypes DatatypeInfo
datatypeInfo
    (Env
env, [Type]
typeArgs') = HasCallStack => [Type] -> [Name] -> (Env, [Type])
[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
Name -> DeepStrictM Levity
reifyLevityName Name
name
reifyLevityType (TH.AppT Type
x Type
_)  = HasCallStack => Type -> DeepStrictM Levity
Type -> DeepStrictM Levity
reifyLevityType Type
x
reifyLevityType (TH.ListT{})   = Levity -> DeepStrictM Levity
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Levity
Lifted
reifyLevityType (TH.TupleT{})  = Levity -> DeepStrictM Levity
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Levity
Lifted
reifyLevityType (TH.ArrowT{})  = Levity -> DeepStrictM Levity
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Levity
Lifted
reifyLevityType (TH.UnboxedTupleT{})  = Levity -> DeepStrictM Levity
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Levity
Unlifted
reifyLevityType (TH.UnboxedSumT{})  = Levity -> DeepStrictM Levity
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Levity
Unlifted
reifyLevityType Type
typ            = String -> Type -> DeepStrictM Levity
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 <- Name -> DeepStrictM Type
forall (m :: * -> *). Quasi m => Name -> m Type
TH.qReifyType Name
name
  Levity -> DeepStrictM Levity
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Levity -> DeepStrictM Levity) -> Levity -> DeepStrictM Levity
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
DatatypeInfo -> [Type] -> DeepStrictM DeepStrictWithReason
isDatatypeDeepStrict' DatatypeInfo
dt' [Type]
args'
  where
    (DatatypeInfo
dt', [Type]
args') = HasCallStack => [Type] -> DatatypeInfo -> (DatatypeInfo, [Type])
[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 <- (ConstructorInfo -> DeepStrictM DeepStrictWithReason)
-> [ConstructorInfo] -> DeepStrictM [DeepStrictWithReason]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\ConstructorInfo
c -> HasCallStack =>
ConstructorInfo
-> DatatypeVariant -> [Type] -> DeepStrictM DeepStrictWithReason
ConstructorInfo
-> DatatypeVariant -> [Type] -> DeepStrictM DeepStrictWithReason
isConDeepStrict ConstructorInfo
c (DatatypeInfo -> DatatypeVariant
TH.datatypeVariant DatatypeInfo
datatypeInfo) [Type]
args) ([ConstructorInfo] -> DeepStrictM [DeepStrictWithReason])
-> [ConstructorInfo] -> DeepStrictM [DeepStrictWithReason]
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> [ConstructorInfo]
TH.datatypeCons DatatypeInfo
datatypeInfo
  DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DeepStrictWithReason -> DeepStrictM DeepStrictWithReason)
-> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a b. (a -> b) -> a -> b
$ [DeepStrictWithReason] -> DeepStrictWithReason
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) = (Name -> FieldKey) -> [Name] -> [FieldKey]
forall a b. (a -> b) -> [a] -> [b]
map Name -> FieldKey
forall a b. b -> Either a b
Right [Name]
fieldNames
extractFieldNames ConstructorVariant
_                                 = (Int -> FieldKey) -> [Int] -> [FieldKey]
forall a b. (a -> b) -> [a] -> [b]
map Int -> FieldKey
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 [WeakStrictness] -> DeepStrictM [WeakStrictness]
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([WeakStrictness] -> DeepStrictM [WeakStrictness])
-> [WeakStrictness] -> DeepStrictM [WeakStrictness]
forall a b. (a -> b) -> a -> b
$ WeakStrictness -> [WeakStrictness]
forall a. a -> [a]
repeat WeakStrictness
WeakStrict -- newtypes are strict
    else (DecidedStrictness -> WeakStrictness)
-> [DecidedStrictness] -> [WeakStrictness]
forall a b. (a -> b) -> [a] -> [b]
map DecidedStrictness -> WeakStrictness
decodeDecidedStrictness ([DecidedStrictness] -> [WeakStrictness])
-> DeepStrictM [DecidedStrictness] -> DeepStrictM [WeakStrictness]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> DeepStrictM [DecidedStrictness]
forall (m :: * -> *). Quasi m => Name -> m [DecidedStrictness]
TH.qReifyConStrictness Name
conName
  let fieldNames :: [FieldKey]
fieldNames = ConstructorVariant -> [FieldKey]
extractFieldNames (ConstructorVariant -> [FieldKey])
-> ConstructorVariant -> [FieldKey]
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> ConstructorVariant
TH.constructorVariant ConstructorInfo
conInfo
  let conFields :: [FieldInfo]
conFields = (FieldKey -> WeakStrictness -> Type -> FieldInfo)
-> [FieldKey] -> [WeakStrictness] -> [Type] -> [FieldInfo]
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 <- (FieldInfo -> DeepStrictM DeepStrictWithReason)
-> [FieldInfo] -> DeepStrictM [DeepStrictWithReason]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (HasCallStack =>
FieldInfo -> [Type] -> DeepStrictM DeepStrictWithReason
FieldInfo -> [Type] -> DeepStrictM DeepStrictWithReason
`isFieldDeepStrict` [Type]
args) [FieldInfo]
conFields
  DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DeepStrictWithReason -> DeepStrictM DeepStrictWithReason)
-> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a b. (a -> b) -> a -> b
$ ([DeepStrictReason] -> DeepStrictReason)
-> DeepStrictWithReason -> DeepStrictWithReason
giveReasonContext (Name -> [DeepStrictReason] -> DeepStrictReason
LazyConstructor Name
conName) (DeepStrictWithReason -> DeepStrictWithReason)
-> DeepStrictWithReason -> DeepStrictWithReason
forall a b. (a -> b) -> a -> b
$ [DeepStrictWithReason] -> DeepStrictWithReason
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
Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict Type
fieldType [Type]
args
  Levity
fieldLevity <- HasCallStack => Type -> DeepStrictM Levity
Type -> DeepStrictM Levity
reifyLevityType Type
fieldType
  case (WeakStrictness
fieldWeakStrictness, DeepStrictWithReason
fieldTypeRecStrict, Levity
fieldLevity) of
    (WeakStrictness
WeakStrict, DeepStrictWithReason
DeepStrict, Levity
_) -> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DeepStrictWithReason
forall reason. DeepStrict reason
DeepStrict
    (WeakStrictness
WeakLazy, DeepStrictWithReason
DeepStrict, Levity
Unlifted) -> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DeepStrictWithReason
forall reason. DeepStrict reason
DeepStrict
    (WeakStrictness
WeakLazy, DeepStrictWithReason
strictness, Levity
Lifted) -> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DeepStrictWithReason -> DeepStrictM DeepStrictWithReason)
-> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a b. (a -> b) -> a -> b
$ [DeepStrictReason] -> DeepStrictWithReason
forall reason. reason -> DeepStrict reason
NotDeepStrict [FieldKey -> DeepStrictReason
LazyField FieldKey
fieldName] DeepStrictWithReason
-> DeepStrictWithReason -> DeepStrictWithReason
forall a. Semigroup a => a -> a -> a
<> DeepStrictWithReason -> DeepStrictWithReason
inField DeepStrictWithReason
strictness
    (WeakStrictness
_, DeepStrictWithReason
strictness, Levity
_) -> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DeepStrictWithReason -> DeepStrictM DeepStrictWithReason)
-> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
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 <- (Context -> IORef (Map Type DeepStrictWithReason))
-> DeepStrictM (IORef (Map Type DeepStrictWithReason))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> IORef (Map Type DeepStrictWithReason)
contextCache
  Map Type DeepStrictWithReason
cache <- IO (Map Type DeepStrictWithReason)
-> DeepStrictM (Map Type DeepStrictWithReason)
forall a. IO a -> DeepStrictM a
forall (m :: * -> *) a. Quasi m => IO a -> m a
TH.qRunIO (IO (Map Type DeepStrictWithReason)
 -> DeepStrictM (Map Type DeepStrictWithReason))
-> IO (Map Type DeepStrictWithReason)
-> DeepStrictM (Map Type DeepStrictWithReason)
forall a b. (a -> b) -> a -> b
$ IORef (Map Type DeepStrictWithReason)
-> IO (Map Type DeepStrictWithReason)
forall a. IORef a -> IO a
readIORef IORef (Map Type DeepStrictWithReason)
cacheRef
  Maybe DeepStrictWithReason
-> DeepStrictM (Maybe DeepStrictWithReason)
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DeepStrictWithReason
 -> DeepStrictM (Maybe DeepStrictWithReason))
-> Maybe DeepStrictWithReason
-> DeepStrictM (Maybe DeepStrictWithReason)
forall a b. (a -> b) -> a -> b
$ Type -> Map Type DeepStrictWithReason -> Maybe DeepStrictWithReason
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 <- (Context -> IORef (Map Type DeepStrictWithReason))
-> DeepStrictM (IORef (Map Type DeepStrictWithReason))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> IORef (Map Type DeepStrictWithReason)
contextCache
  IO () -> DeepStrictM ()
forall a. IO a -> DeepStrictM a
forall (m :: * -> *) a. Quasi m => IO a -> m a
TH.qRunIO (IO () -> DeepStrictM ())
-> ((Map Type DeepStrictWithReason
     -> Map Type DeepStrictWithReason)
    -> IO ())
-> (Map Type DeepStrictWithReason -> Map Type DeepStrictWithReason)
-> DeepStrictM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Map Type DeepStrictWithReason)
-> (Map Type DeepStrictWithReason -> Map Type DeepStrictWithReason)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map Type DeepStrictWithReason)
cacheRef ((Map Type DeepStrictWithReason -> Map Type DeepStrictWithReason)
 -> DeepStrictM ())
-> (Map Type DeepStrictWithReason -> Map Type DeepStrictWithReason)
-> DeepStrictM ()
forall a b. (a -> b) -> a -> b
$ Type
-> DeepStrictWithReason
-> Map Type DeepStrictWithReason
-> Map Type DeepStrictWithReason
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Type
typ ([DeepStrictReason] -> [DeepStrictReason] -> [DeepStrictReason]
forall a b. a -> b -> a
const [String -> DeepStrictReason
LazyOther (String -> DeepStrictReason) -> String -> DeepStrictReason
forall a b. (a -> b) -> a -> b
$ Type -> String
forall a. Ppr a => a -> String
Ppr.pprint Type
typ String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is lazy see above"] ([DeepStrictReason] -> [DeepStrictReason])
-> DeepStrictWithReason -> DeepStrictWithReason
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 <- DeepStrictM Context
forall r (m :: * -> *). MonadReader r m => m r
ask
  Maybe DeepStrictWithReason
cachedVal <- HasCallStack => Type -> DeepStrictM (Maybe DeepStrictWithReason)
Type -> DeepStrictM (Maybe DeepStrictWithReason)
getCachedDeepStrict Type
typ
  Bool -> DeepStrictM () -> DeepStrictM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Int
contextRecursionDepth Context
ctxt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0) (DeepStrictM () -> DeepStrictM ())
-> (String -> DeepStrictM ()) -> String -> DeepStrictM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DeepStrictM ()
forall a. String -> DeepStrictM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> DeepStrictM ()) -> String -> DeepStrictM ()
forall a b. (a -> b) -> a -> b
$ String
"Recursion depth reached. Try adding an override for this type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
1000 (Type -> String
forall a. Show a => a -> String
show Type
typ)
  case (Maybe DeepStrictWithReason
cachedVal, Type -> Set Type -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Type
typ (Set Type -> Bool) -> Set Type -> Bool
forall a b. (a -> b) -> a -> b
$ Context -> Set Type
contextSpine Context
ctxt) of
    (Just DeepStrictWithReason
val, Bool
_) -> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DeepStrictWithReason
val
    (Maybe DeepStrictWithReason
_, Bool
True) -> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DeepStrictWithReason
forall reason. DeepStrict reason
DeepStrict -- by inductive hypothesis
    (Maybe DeepStrictWithReason, Bool)
_ ->
      (Context -> Context)
-> DeepStrictM DeepStrictWithReason
-> DeepStrictM DeepStrictWithReason
forall a. (Context -> Context) -> DeepStrictM a -> DeepStrictM a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Context
_ctxt ->
        Context
ctxt {contextSpine = S.insert typ (contextSpine ctxt), contextRecursionDepth = contextRecursionDepth ctxt - 1}) (DeepStrictM DeepStrictWithReason
 -> DeepStrictM DeepStrictWithReason)
-> DeepStrictM DeepStrictWithReason
-> DeepStrictM DeepStrictWithReason
forall a b. (a -> b) -> a -> b
$ do
          DeepStrictWithReason
ret <- DeepStrictWithReason -> DeepStrictWithReason
inType (DeepStrictWithReason -> DeepStrictWithReason)
-> DeepStrictM DeepStrictWithReason
-> DeepStrictM DeepStrictWithReason
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict' Type
typ [Type]
args
          HasCallStack => Type -> DeepStrictWithReason -> DeepStrictM ()
Type -> DeepStrictWithReason -> DeepStrictM ()
putCachedDeepStrict Type
typ DeepStrictWithReason
ret
          DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a. a -> DeepStrictM a
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
Name -> [Type] -> DeepStrictM DeepStrictWithReason
isNameDeepStrict Name
typeName [Type]
args
isTypeDeepStrict' (TH.AppT Type
func Type
arg) [Type]
args = HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict' Type
func (Type
argType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
args)
isTypeDeepStrict' (TH.TupleT Int
0) [Type]
_         = DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DeepStrictWithReason
forall reason. DeepStrict reason
DeepStrict -- () is DeepStrict
isTypeDeepStrict' (TH.TupleT Int
n) [Type]
args      = HasCallStack => Name -> [Type] -> DeepStrictM DeepStrictWithReason
Name -> [Type] -> DeepStrictM DeepStrictWithReason
isNameDeepStrict (Int -> Name
TH.tupleTypeName Int
n) [Type]
args
isTypeDeepStrict' (TH.ArrowT{}) [Type]
_         = DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DeepStrictWithReason -> DeepStrictM DeepStrictWithReason)
-> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a b. (a -> b) -> a -> b
$ [DeepStrictReason] -> DeepStrictWithReason
forall reason. reason -> DeepStrict reason
NotDeepStrict [String -> DeepStrictReason
LazyOther String
"Functions are lazy"]
isTypeDeepStrict' (TH.ListT{}) [Type]
args       = HasCallStack => Name -> [Type] -> DeepStrictM DeepStrictWithReason
Name -> [Type] -> DeepStrictM DeepStrictWithReason
isNameDeepStrict ''[] [Type]
args
isTypeDeepStrict' (TH.UnboxedTupleT Int
arity) [Type]
args = HasCallStack => Name -> [Type] -> DeepStrictM DeepStrictWithReason
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
Name -> [Type] -> DeepStrictM DeepStrictWithReason
isNameDeepStrict (Int -> Name
TH.unboxedSumTypeName Int
arity) [Type]
args
isTypeDeepStrict' Type
typ [Type]
_                   = String -> Type -> DeepStrictM DeepStrictWithReason
forall x a. (HasCallStack, Ppr x, Show x) => String -> x -> a
prettyPanic String
"Unexpected type" Type
typ

-- | 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 <- DeepStrictM Context
forall r (m :: * -> *). MonadReader r m => m r
ask
  case Name -> Map Name (Maybe [Strictness]) -> Maybe (Maybe [Strictness])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
typeName (Map Name (Maybe [Strictness]) -> Maybe (Maybe [Strictness]))
-> Map Name (Maybe [Strictness]) -> Maybe (Maybe [Strictness])
forall a b. (a -> b) -> a -> b
$ Context -> Map Name (Maybe [Strictness])
contextOverride Context
ctxt of
    Maybe (Maybe [Strictness])
Nothing -> do
      Info
info <- ReaderT Context Q Info -> DeepStrictM Info
forall a. ReaderT Context Q a -> DeepStrictM a
DeepStrictM (ReaderT Context Q Info -> DeepStrictM Info)
-> ReaderT Context Q Info -> DeepStrictM Info
forall a b. (a -> b) -> a -> b
$ Q Info -> ReaderT Context Q Info
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Info -> ReaderT Context Q Info)
-> Q Info -> ReaderT Context Q Info
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 BndrVis]
tyvarbndrs Type
rhs) -> do
          let (Env
env, [Type]
args') = HasCallStack => [Type] -> [Name] -> (Env, [Type])
[Type] -> [Name] -> (Env, [Type])
prepareDatatypeInfoEnv [Type]
args ((TyVarBndr BndrVis -> Name) -> [TyVarBndr BndrVis] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> Name
forall flag. TyVarBndr_ flag -> Name
TH.tvName [TyVarBndr BndrVis]
tyvarbndrs)
          HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict (Env -> Type -> Type
forall a. TypeSubstitution a => Env -> a -> a
TH.applySubstitution Env
env Type
rhs) [Type]
args'
        -- th-abstraction doesn't handle type/data families
        TH.FamilyI{} -> do
          [Dec]
instances <- ReaderT Context Q [Dec] -> DeepStrictM [Dec]
forall a. ReaderT Context Q a -> DeepStrictM a
DeepStrictM (ReaderT Context Q [Dec] -> DeepStrictM [Dec])
-> ReaderT Context Q [Dec] -> DeepStrictM [Dec]
forall a b. (a -> b) -> a -> b
$ Q [Dec] -> ReaderT Context Q [Dec]
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q [Dec] -> ReaderT Context Q [Dec])
-> Q [Dec] -> ReaderT Context Q [Dec]
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])
[Type] -> [Name] -> (Env, [Type])
prepareDatatypeInfoEnv [Type]
args (Type -> [Name]
forall a. TypeSubstitution a => a -> [Name]
TH.freeVariables Type
lhs)
              HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
Type -> [Type] -> DeepStrictM DeepStrictWithReason
isTypeDeepStrict (Env -> Type -> Type
forall a. TypeSubstitution a => Env -> a -> a
TH.applySubstitution Env
env Type
rhs) [Type]
args'
            [Dec]
_ -> String -> DeepStrictM DeepStrictWithReason
forall a. HasCallStack => String -> a
error String
"The majority of data/type families are currently not supported"
        Info
_ -> do
          DatatypeInfo
datatypeInfo <- ReaderT Context Q DatatypeInfo -> DeepStrictM DatatypeInfo
forall a. ReaderT Context Q a -> DeepStrictM a
DeepStrictM (ReaderT Context Q DatatypeInfo -> DeepStrictM DatatypeInfo)
-> ReaderT Context Q DatatypeInfo -> DeepStrictM DatatypeInfo
forall a b. (a -> b) -> a -> b
$ Q DatatypeInfo -> ReaderT Context Q DatatypeInfo
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q DatatypeInfo -> ReaderT Context Q DatatypeInfo)
-> Q DatatypeInfo -> ReaderT Context Q DatatypeInfo
forall a b. (a -> b) -> a -> b
$ Info -> Q DatatypeInfo
TH.normalizeInfo Info
info
          HasCallStack =>
DatatypeInfo -> [Type] -> DeepStrictM DeepStrictWithReason
DatatypeInfo -> [Type] -> DeepStrictM DeepStrictWithReason
isDatatypeDeepStrict DatatypeInfo
datatypeInfo [Type]
args
    Just Maybe [Strictness]
Nothing -> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DeepStrictWithReason -> DeepStrictM DeepStrictWithReason)
-> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a b. (a -> b) -> a -> b
$ [DeepStrictReason] -> DeepStrictWithReason
forall reason. reason -> DeepStrict reason
NotDeepStrict [String -> DeepStrictReason
LazyOther String
"This type is marked as lazy"]
    Just (Just [Strictness]
strictnessReqs) ->
      ([DeepStrictWithReason] -> DeepStrictWithReason)
-> DeepStrictM [DeepStrictWithReason]
-> DeepStrictM DeepStrictWithReason
forall a b. (a -> b) -> DeepStrictM a -> DeepStrictM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [DeepStrictWithReason] -> DeepStrictWithReason
forall a. Monoid a => [a] -> a
mconcat (DeepStrictM [DeepStrictWithReason]
 -> DeepStrictM DeepStrictWithReason)
-> (((Strictness, Type) -> DeepStrictM DeepStrictWithReason)
    -> DeepStrictM [DeepStrictWithReason])
-> ((Strictness, Type) -> DeepStrictM DeepStrictWithReason)
-> DeepStrictM DeepStrictWithReason
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Strictness, Type)]
-> ((Strictness, Type) -> DeepStrictM DeepStrictWithReason)
-> DeepStrictM [DeepStrictWithReason]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([Strictness] -> [Type] -> [(Strictness, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Strictness]
strictnessReqs [Type]
args) (((Strictness, Type) -> DeepStrictM DeepStrictWithReason)
 -> DeepStrictM DeepStrictWithReason)
-> ((Strictness, Type) -> DeepStrictM DeepStrictWithReason)
-> DeepStrictM DeepStrictWithReason
forall a b. (a -> b) -> a -> b
$ \case
        (Strictness
Lazy, Type
_)     -> DeepStrictWithReason -> DeepStrictM DeepStrictWithReason
forall a. a -> DeepStrictM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DeepStrictWithReason
forall reason. DeepStrict reason
DeepStrict
        (Strictness
Strict, Type
typ) -> HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
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
  ReaderT Context Q DeepStrictWithReason
-> Context -> Q DeepStrictWithReason
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (DeepStrictM DeepStrictWithReason
-> ReaderT Context Q DeepStrictWithReason
forall a. DeepStrictM a -> ReaderT Context Q a
runDeepStrictM (DeepStrictM DeepStrictWithReason
 -> ReaderT Context Q DeepStrictWithReason)
-> DeepStrictM DeepStrictWithReason
-> ReaderT Context Q DeepStrictWithReason
forall a b. (a -> b) -> a -> b
$ HasCallStack => Type -> [Type] -> DeepStrictM DeepStrictWithReason
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) =
   Type -> Doc
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.$$ [DeepStrictReason] -> Doc
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 -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    NotDeepStrict [DeepStrictReason]
reason ->
      String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ DeepStrictAssertionFailed -> String
forall a. Ppr a => a -> String
Ppr.pprint (DeepStrictAssertionFailed -> String)
-> DeepStrictAssertionFailed -> String
forall a b. (a -> b) -> a -> b
$ Type -> [DeepStrictReason] -> DeepStrictAssertionFailed
DeepStrictAssertionFailed Type
typ [DeepStrictReason]
reason