{-|
Copyright  :  (C) 2016,      University of Twente,
                  2017,      QBayLogic, Google Inc.
                  2017-2019, Myrtle Software Ltd
License    :  BSD2 (see the file LICENSE)
Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>

'XException': An exception for uninitialized values

>>> show (errorX "undefined" :: Integer, 4 :: Int)
"(*** Exception: X: undefined
CallStack (from HasCallStack):
...
>>> showX (errorX "undefined" :: Integer, 4 :: Int)
"(X,4)"
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE Trustworthy #-}

{-# OPTIONS_HADDOCK not-home #-}

module Clash.XException.Internal
  ( XException(..)
    -- * Printing 'XException's as \"X\"
  , showsX, showsPrecXWith
  , showXWith

    -- * Internals
  , GShowX(..), GDeepErrorX(..), GHasUndefined(..), GEnsureSpine(..)
  , GNFDataX(..), Zero, One, ShowType(..), RnfArgs(..), NFDataX1(..)
  , showListX__, genericShowsPrecX
  )
where

import           Prelude             hiding (undefined)

import {-# SOURCE #-} Clash.XException
import           Control.Exception
  (Exception,  catch, evaluate)
import           Data.Either         (isLeft)
import           GHC.Exts
  (Char (C#), Double (D#), Float (F#), Int (I#), Word (W#))
import           GHC.Generics
import           GHC.Show            (appPrec)
import           GHC.Stack           (HasCallStack)
import           System.IO.Unsafe    (unsafeDupablePerformIO)

-- | An exception representing an \"uninitialized\" value.
newtype XException = XException String

instance Show XException where
  show :: XException -> String
show (XException String
s) = String
s

instance Exception XException

-- | Like 'shows', but values that normally throw an 'XException' are
-- converted to \"X\", instead of error'ing out with an exception.
showsX :: ShowX a => a -> ShowS
showsX :: a -> ShowS
showsX = Int -> a -> ShowS
forall a. ShowX a => Int -> a -> ShowS
showsPrecX Int
0

showListX__ :: (a -> ShowS) -> [a] -> ShowS
showListX__ :: (a -> ShowS) -> [a] -> ShowS
showListX__ a -> ShowS
showx = ([a] -> ShowS) -> [a] -> ShowS
forall a. (a -> ShowS) -> a -> ShowS
showXWith [a] -> ShowS
go
  where
    go :: [a] -> ShowS
go []     String
s = String
"[]" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
    go (a
x:[a]
xs) String
s = Char
'[' Char -> ShowS
forall a. a -> [a] -> [a]
: a -> ShowS
showx a
x ([a] -> String
showl [a]
xs)
      where
        showl :: [a] -> String
showl []     = Char
']'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s
        showl (a
y:[a]
ys) = Char
',' Char -> ShowS
forall a. a -> [a] -> [a]
: a -> ShowS
showx a
y ([a] -> String
showl [a]
ys)

genericShowsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS
genericShowsPrecX :: Int -> a -> ShowS
genericShowsPrecX Int
n = ShowType -> Int -> Rep a Any -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
Pref Int
n (Rep a Any -> ShowS) -> (a -> Rep a Any) -> a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

showXWith :: (a -> ShowS) -> a -> ShowS
showXWith :: (a -> ShowS) -> a -> ShowS
showXWith a -> ShowS
f a
x =
  \String
s -> IO String -> String
forall a. IO a -> a
unsafeDupablePerformIO (IO String -> (XException -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (a -> ShowS
f (a -> ShowS) -> IO a -> IO ShowS
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> IO a
forall a. a -> IO a
evaluate a
x IO ShowS -> IO String -> IO String
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> String -> IO String
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure String
s)
                                      (\(XException String
_) -> String -> IO String
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Char
'X'Char -> ShowS
forall a. a -> [a] -> [a]
: String
s)))

-- | Use when you want to create a 'ShowX' instance where:
--
-- - There is no 'Generic' instance for your data type
-- - The 'Generic' derived ShowX method would traverse into the (hidden)
--   implementation details of your data type, and you just want to show the
--   entire value as \"X\".
--
-- Can be used like:
--
-- > data T = ...
-- >
-- > instance Show T where ...
-- >
-- > instance ShowX T where
-- >   showsPrecX = showsPrecXWith showsPrec
showsPrecXWith :: (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith :: (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> a -> ShowS
f Int
n = (a -> ShowS) -> a -> ShowS
forall a. (a -> ShowS) -> a -> ShowS
showXWith (Int -> a -> ShowS
f Int
n)

class GShowX f where
  gshowsPrecX :: ShowType -> Int -> f a -> ShowS
  isNullary   :: f a -> Bool
  isNullary = String -> f a -> Bool
forall a. HasCallStack => String -> a
error String
"generic showX (isNullary): unnecessary case"

data ShowType = Rec        -- Record
              | Tup        -- Tuple
              | Pref       -- Prefix
              | Inf String -- Infix

instance GShowX U1 where
  gshowsPrecX :: ShowType -> Int -> U1 a -> ShowS
gshowsPrecX ShowType
_ Int
_ U1 a
U1 = ShowS
forall a. a -> a
id
  isNullary :: U1 a -> Bool
isNullary U1 a
_ = Bool
True

instance (ShowX c) => GShowX (K1 i c) where
  gshowsPrecX :: ShowType -> Int -> K1 i c a -> ShowS
gshowsPrecX ShowType
_ Int
n (K1 c
a) = Int -> c -> ShowS
forall a. ShowX a => Int -> a -> ShowS
showsPrecX Int
n c
a
  isNullary :: K1 i c a -> Bool
isNullary K1 i c a
_ = Bool
False

instance (GShowX a, Constructor c) => GShowX (M1 C c a) where
  gshowsPrecX :: ShowType -> Int -> M1 C c a a -> ShowS
gshowsPrecX ShowType
_ Int
n c :: M1 C c a a
c@(M1 a a
x) =
    case Fixity
fixity of
      Fixity
Prefix ->
        Bool -> ShowS -> ShowS
showParen (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
appPrec Bool -> Bool -> Bool
&& Bool -> Bool
not (a a -> Bool
forall (f :: Type -> Type) a. GShowX f => f a -> Bool
isNullary a a
x))
          ( (if M1 C c a a -> Bool
forall (f :: Type -> Type) p. C1 c f p -> Bool
conIsTuple M1 C c a a
c then ShowS
forall a. a -> a
id else String -> ShowS
showString (M1 C c a a -> String
forall k (c :: k) k1 (t :: k -> (k1 -> Type) -> k1 -> Type)
       (f :: k1 -> Type) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c a a
c))
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if a a -> Bool
forall (f :: Type -> Type) a. GShowX f => f a -> Bool
isNullary a a
x Bool -> Bool -> Bool
|| M1 C c a a -> Bool
forall (f :: Type -> Type) p. C1 c f p -> Bool
conIsTuple M1 C c a a
c then ShowS
forall a. a -> a
id else String -> ShowS
showString String
" ")
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowType -> ShowS -> ShowS
showBraces ShowType
t (ShowType -> Int -> a a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
appPrec a a
x))
      Infix Associativity
_ Int
m -> Bool -> ShowS -> ShowS
showParen (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
m) (ShowType -> ShowS -> ShowS
showBraces ShowType
t (ShowType -> Int -> a a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
m a a
x))
      where fixity :: Fixity
fixity = M1 C c a a -> Fixity
forall k (c :: k) k1 (t :: k -> (k1 -> Type) -> k1 -> Type)
       (f :: k1 -> Type) (a :: k1).
Constructor c =>
t c f a -> Fixity
conFixity M1 C c a a
c
            t :: ShowType
t = if M1 C c a a -> Bool
forall k (c :: k) k1 (t :: k -> (k1 -> Type) -> k1 -> Type)
       (f :: k1 -> Type) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord M1 C c a a
c then ShowType
Rec else
                  case M1 C c a a -> Bool
forall (f :: Type -> Type) p. C1 c f p -> Bool
conIsTuple M1 C c a a
c of
                    Bool
True -> ShowType
Tup
                    Bool
False -> case Fixity
fixity of
                                Fixity
Prefix    -> ShowType
Pref
                                Infix Associativity
_ Int
_ -> String -> ShowType
Inf (ShowS
forall a. Show a => a -> String
show (M1 C c a a -> String
forall k (c :: k) k1 (t :: k -> (k1 -> Type) -> k1 -> Type)
       (f :: k1 -> Type) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c a a
c))
            showBraces :: ShowType -> ShowS -> ShowS
            showBraces :: ShowType -> ShowS -> ShowS
showBraces ShowType
Rec     ShowS
p = Char -> ShowS
showChar Char
'{' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'}'
            showBraces ShowType
Tup     ShowS
p = Char -> ShowS
showChar Char
'(' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
p ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
')'
            showBraces ShowType
Pref    ShowS
p = ShowS
p
            showBraces (Inf String
_) ShowS
p = ShowS
p

            conIsTuple :: C1 c f p -> Bool
            conIsTuple :: C1 c f p -> Bool
conIsTuple C1 c f p
y = String -> Bool
tupleName (C1 c f p -> String
forall k (c :: k) k1 (t :: k -> (k1 -> Type) -> k1 -> Type)
       (f :: k1 -> Type) (a :: k1).
Constructor c =>
t c f a -> String
conName C1 c f p
y) where
              tupleName :: String -> Bool
tupleName (Char
'(':Char
',':String
_) = Bool
True
              tupleName String
_           = Bool
False

instance (Selector s, GShowX a) => GShowX (M1 S s a) where
  gshowsPrecX :: ShowType -> Int -> M1 S s a a -> ShowS
gshowsPrecX ShowType
t Int
n s :: M1 S s a a
s@(M1 a a
x) | M1 S s a a -> String
forall k (s :: k) k1 (t :: k -> (k1 -> Type) -> k1 -> Type)
       (f :: k1 -> Type) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S s a a
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" =   ShowType -> Int -> a a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n a a
x
                           | Bool
otherwise       =   String -> ShowS
showString (M1 S s a a -> String
forall k (s :: k) k1 (t :: k -> (k1 -> Type) -> k1 -> Type)
       (f :: k1 -> Type) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S s a a
s)
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" = "
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowType -> Int -> a a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
0 a a
x
  isNullary :: M1 S s a a -> Bool
isNullary (M1 a a
x) = a a -> Bool
forall (f :: Type -> Type) a. GShowX f => f a -> Bool
isNullary a a
x

instance (GShowX a) => GShowX (M1 D d a) where
  gshowsPrecX :: ShowType -> Int -> M1 D d a a -> ShowS
gshowsPrecX ShowType
t = (Int -> M1 D d a a -> ShowS) -> Int -> M1 D d a a -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> M1 D d a a -> ShowS
go
    where go :: Int -> M1 D d a a -> ShowS
go Int
n (M1 a a
x) = ShowType -> Int -> a a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n a a
x

instance (GShowX a, GShowX b) => GShowX (a :+: b) where
  gshowsPrecX :: ShowType -> Int -> (:+:) a b a -> ShowS
gshowsPrecX ShowType
t Int
n (L1 a a
x) = ShowType -> Int -> a a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n a a
x
  gshowsPrecX ShowType
t Int
n (R1 b a
x) = ShowType -> Int -> b a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n b a
x

instance (GShowX a, GShowX b) => GShowX (a :*: b) where
  gshowsPrecX :: ShowType -> Int -> (:*:) a b a -> ShowS
gshowsPrecX t :: ShowType
t@ShowType
Rec     Int
n (a a
a :*: b a
b) =
    ShowType -> Int -> a a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n     a a
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
", " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowType -> Int -> b a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n     b a
b
  gshowsPrecX t :: ShowType
t@(Inf String
s) Int
n (a a
a :*: b a
b) =
    ShowType -> Int -> a a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n     a a
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowType -> Int -> b a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n     b a
b
  gshowsPrecX t :: ShowType
t@ShowType
Tup     Int
n (a a
a :*: b a
b) =
    ShowType -> Int -> a a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n     a a
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
','    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowType -> Int -> b a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n     b a
b
  gshowsPrecX t :: ShowType
t@ShowType
Pref    Int
n (a a
a :*: b a
b) =
    ShowType -> Int -> a a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) a a
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowType -> Int -> b a -> ShowS
forall (f :: Type -> Type) a.
GShowX f =>
ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) b a
b

  -- If we have a product then it is not a nullary constructor
  isNullary :: (:*:) a b a -> Bool
isNullary (:*:) a b a
_ = Bool
False

-- Unboxed types
instance GShowX UChar where
  gshowsPrecX :: ShowType -> Int -> UChar a -> ShowS
gshowsPrecX ShowType
_ Int
_ (UChar c)   = Int -> Char -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
0 (Char# -> Char
C# Char#
c) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'#'
instance GShowX UDouble where
  gshowsPrecX :: ShowType -> Int -> UDouble a -> ShowS
gshowsPrecX ShowType
_ Int
_ (UDouble d) = Int -> Double -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
0 (Double# -> Double
D# Double#
d) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"##"
instance GShowX UFloat where
  gshowsPrecX :: ShowType -> Int -> UFloat a -> ShowS
gshowsPrecX ShowType
_ Int
_ (UFloat f)  = Int -> Float -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
0 (Float# -> Float
F# Float#
f) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'#'
instance GShowX UInt where
  gshowsPrecX :: ShowType -> Int -> UInt a -> ShowS
gshowsPrecX ShowType
_ Int
_ (UInt i)    = Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
0 (Int# -> Int
I# Int#
i) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'#'
instance GShowX UWord where
  gshowsPrecX :: ShowType -> Int -> UWord a -> ShowS
gshowsPrecX ShowType
_ Int
_ (UWord w)   = Int -> Word -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
0 (Word# -> Word
W# Word#
w) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"##"

-- | Hidden internal type-class. Adds a generic implementation for the \"NFData\"
-- part of 'NFDataX'
class GNFDataX arity f where
  grnfX :: RnfArgs arity a -> f a -> ()

instance GNFDataX arity V1 where
  grnfX :: RnfArgs arity a -> V1 a -> ()
grnfX RnfArgs arity a
_ V1 a
x = case V1 a
x of {}

data Zero
data One

data RnfArgs arity a where
  RnfArgs0 :: RnfArgs Zero a
  RnfArgs1  :: (a -> ()) -> RnfArgs One a

instance GNFDataX arity U1 where
  grnfX :: RnfArgs arity a -> U1 a -> ()
grnfX RnfArgs arity a
_ U1 a
u = if Either String (U1 a) -> Bool
forall a b. Either a b -> Bool
isLeft (U1 a -> Either String (U1 a)
forall a. a -> Either String a
isX U1 a
u) then () else case U1 a
u of U1 a
U1 -> ()

instance NFDataX a => GNFDataX arity (K1 i a) where
  grnfX :: RnfArgs arity a -> K1 i a a -> ()
grnfX RnfArgs arity a
_ = a -> ()
forall a. NFDataX a => a -> ()
rnfX (a -> ()) -> (K1 i a a -> a) -> K1 i a a -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i a a -> a
forall i c k (p :: k). K1 i c p -> c
unK1
  {-# INLINEABLE grnfX #-}

instance GNFDataX arity a => GNFDataX arity (M1 i c a) where
  grnfX :: RnfArgs arity a -> M1 i c a a -> ()
grnfX RnfArgs arity a
args M1 i c a a
a =
    -- Check for X needed to handle edge-case "data Void"
    if Either String (M1 i c a a) -> Bool
forall a b. Either a b -> Bool
isLeft (M1 i c a a -> Either String (M1 i c a a)
forall a. a -> Either String a
isX M1 i c a a
a) then
      ()
    else
      RnfArgs arity a -> a a -> ()
forall arity (f :: Type -> Type) a.
GNFDataX arity f =>
RnfArgs arity a -> f a -> ()
grnfX RnfArgs arity a
args (M1 i c a a -> a a
forall i (c :: Meta) k (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1 M1 i c a a
a)
  {-# INLINEABLE grnfX #-}

instance (GNFDataX arity a, GNFDataX arity b) => GNFDataX arity (a :*: b) where
  grnfX :: RnfArgs arity a -> (:*:) a b a -> ()
grnfX RnfArgs arity a
args xy :: (:*:) a b a
xy@(~(a a
x :*: b a
y)) =
    if Either String ((:*:) a b a) -> Bool
forall a b. Either a b -> Bool
isLeft ((:*:) a b a -> Either String ((:*:) a b a)
forall a. a -> Either String a
isX (:*:) a b a
xy) then
      ()
    else
      RnfArgs arity a -> a a -> ()
forall arity (f :: Type -> Type) a.
GNFDataX arity f =>
RnfArgs arity a -> f a -> ()
grnfX RnfArgs arity a
args a a
x () -> () -> ()
`seq` RnfArgs arity a -> b a -> ()
forall arity (f :: Type -> Type) a.
GNFDataX arity f =>
RnfArgs arity a -> f a -> ()
grnfX RnfArgs arity a
args b a
y
  {-# INLINEABLE grnfX #-}

instance (GNFDataX arity a, GNFDataX arity b) => GNFDataX arity (a :+: b) where
  grnfX :: RnfArgs arity a -> (:+:) a b a -> ()
grnfX RnfArgs arity a
args (:+:) a b a
lrx =
    if Either String ((:+:) a b a) -> Bool
forall a b. Either a b -> Bool
isLeft ((:+:) a b a -> Either String ((:+:) a b a)
forall a. a -> Either String a
isX (:+:) a b a
lrx) then
      ()
    else
      case (:+:) a b a
lrx of
        L1 a a
x -> RnfArgs arity a -> a a -> ()
forall arity (f :: Type -> Type) a.
GNFDataX arity f =>
RnfArgs arity a -> f a -> ()
grnfX RnfArgs arity a
args a a
x
        R1 b a
x -> RnfArgs arity a -> b a -> ()
forall arity (f :: Type -> Type) a.
GNFDataX arity f =>
RnfArgs arity a -> f a -> ()
grnfX RnfArgs arity a
args b a
x
  {-# INLINEABLE grnfX #-}

instance GNFDataX One Par1 where
  grnfX :: RnfArgs One a -> Par1 a -> ()
grnfX (RnfArgs1 a -> ()
r) = a -> ()
r (a -> ()) -> (Par1 a -> a) -> Par1 a -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Par1 a -> a
forall p. Par1 p -> p
unPar1

instance NFDataX1 f => GNFDataX One (Rec1 f) where
  grnfX :: RnfArgs One a -> Rec1 f a -> ()
grnfX (RnfArgs1 a -> ()
r) = (a -> ()) -> f a -> ()
forall (f :: Type -> Type) a. NFDataX1 f => (a -> ()) -> f a -> ()
liftRnfX a -> ()
r (f a -> ()) -> (Rec1 f a -> f a) -> Rec1 f a -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec1 f a -> f a
forall k (f :: k -> Type) (p :: k). Rec1 f p -> f p
unRec1

instance (NFDataX1 f, GNFDataX One g) => GNFDataX One (f :.: g) where
  grnfX :: RnfArgs One a -> (:.:) f g a -> ()
grnfX RnfArgs One a
args = (g a -> ()) -> f (g a) -> ()
forall (f :: Type -> Type) a. NFDataX1 f => (a -> ()) -> f a -> ()
liftRnfX (RnfArgs One a -> g a -> ()
forall arity (f :: Type -> Type) a.
GNFDataX arity f =>
RnfArgs arity a -> f a -> ()
grnfX RnfArgs One a
args) (f (g a) -> ()) -> ((:.:) f g a -> f (g a)) -> (:.:) f g a -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.:) f g a -> f (g a)
forall k2 (f :: k2 -> Type) k1 (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1

class GEnsureSpine f where
  gEnsureSpine :: f a -> f a

instance GEnsureSpine U1 where
  gEnsureSpine :: U1 a -> U1 a
gEnsureSpine U1 a
_u = U1 a
forall k (p :: k). U1 p
U1

instance NFDataX a => GEnsureSpine (K1 i a) where
  gEnsureSpine :: K1 i a a -> K1 i a a
gEnsureSpine = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a a) -> (K1 i a a -> a) -> K1 i a a -> K1 i a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. NFDataX a => a -> a
ensureSpine (a -> a) -> (K1 i a a -> a) -> K1 i a a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i a a -> a
forall i c k (p :: k). K1 i c p -> c
unK1
  {-# INLINEABLE gEnsureSpine #-}

instance GEnsureSpine a => GEnsureSpine (M1 i c a) where
  gEnsureSpine :: M1 i c a a -> M1 i c a a
gEnsureSpine M1 i c a a
a = a a -> M1 i c a a
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 (a a -> a a
forall (f :: Type -> Type) a. GEnsureSpine f => f a -> f a
gEnsureSpine (M1 i c a a -> a a
forall i (c :: Meta) k (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1 M1 i c a a
a))
  {-# INLINEABLE gEnsureSpine #-}

instance (GEnsureSpine a, GEnsureSpine b) => GEnsureSpine (a :*: b) where
  gEnsureSpine :: (:*:) a b a -> (:*:) a b a
gEnsureSpine ~(a a
x :*: b a
y) = a a -> a a
forall (f :: Type -> Type) a. GEnsureSpine f => f a -> f a
gEnsureSpine a a
x a a -> b a -> (:*:) a b a
forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
f p -> g p -> (:*:) f g p
:*: b a -> b a
forall (f :: Type -> Type) a. GEnsureSpine f => f a -> f a
gEnsureSpine b a
y
  {-# INLINEABLE gEnsureSpine #-}

instance (GEnsureSpine a, GEnsureSpine b) => GEnsureSpine (a :+: b) where
  gEnsureSpine :: (:+:) a b a -> (:+:) a b a
gEnsureSpine (:+:) a b a
lrx =
    case (:+:) a b a
lrx of
      (L1 a a
x) -> a a -> (:+:) a b a
forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
f p -> (:+:) f g p
L1 (a a -> a a
forall (f :: Type -> Type) a. GEnsureSpine f => f a -> f a
gEnsureSpine a a
x)
      (R1 b a
x) -> b a -> (:+:) a b a
forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
g p -> (:+:) f g p
R1 (b a -> b a
forall (f :: Type -> Type) a. GEnsureSpine f => f a -> f a
gEnsureSpine b a
x)
  {-# INLINEABLE gEnsureSpine #-}

instance GEnsureSpine V1 where
  gEnsureSpine :: V1 a -> V1 a
gEnsureSpine V1 a
_ = String -> V1 a
forall a. HasCallStack => String -> a
error String
"Unreachable code?"

-- | A class of functors that can be fully evaluated, according to semantics
-- of NFDataX.
class NFDataX1 f where
  -- | 'liftRnfX' should reduce its argument to normal form (that is, fully
  -- evaluate all sub-components), given an argument to reduce @a@ arguments,
  -- and then return @()@.
  --
  -- See 'rnfX' for the generic deriving.
  liftRnfX :: (a -> ()) -> f a -> ()

  default liftRnfX :: (Generic1 f, GNFDataX One (Rep1 f)) => (a -> ()) -> f a -> ()
  liftRnfX a -> ()
r = RnfArgs One a -> Rep1 f a -> ()
forall arity (f :: Type -> Type) a.
GNFDataX arity f =>
RnfArgs arity a -> f a -> ()
grnfX ((a -> ()) -> RnfArgs One a
forall a. (a -> ()) -> RnfArgs One a
RnfArgs1 a -> ()
r) (Rep1 f a -> ()) -> (f a -> Rep1 f a) -> f a -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Rep1 f a
forall k (f :: k -> Type) (a :: k). Generic1 f => f a -> Rep1 f a
from1


class GHasUndefined f where
  gHasUndefined :: f a -> Bool

instance GHasUndefined U1 where
  gHasUndefined :: U1 a -> Bool
gHasUndefined U1 a
u = if Either String (U1 a) -> Bool
forall a b. Either a b -> Bool
isLeft (U1 a -> Either String (U1 a)
forall a. a -> Either String a
isX U1 a
u) then Bool
True else case U1 a
u of U1 a
U1 -> Bool
False

instance NFDataX a => GHasUndefined (K1 i a) where
  gHasUndefined :: K1 i a a -> Bool
gHasUndefined = a -> Bool
forall a. NFDataX a => a -> Bool
hasUndefined (a -> Bool) -> (K1 i a a -> a) -> K1 i a a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i a a -> a
forall i c k (p :: k). K1 i c p -> c
unK1
  {-# INLINEABLE gHasUndefined #-}

instance GHasUndefined a => GHasUndefined (M1 i c a) where
  gHasUndefined :: M1 i c a a -> Bool
gHasUndefined M1 i c a a
a =
    -- Check for X needed to handle edge-case "data Void"
    if Either String (M1 i c a a) -> Bool
forall a b. Either a b -> Bool
isLeft (M1 i c a a -> Either String (M1 i c a a)
forall a. a -> Either String a
isX M1 i c a a
a) then
      Bool
True
    else
      a a -> Bool
forall (f :: Type -> Type) a. GHasUndefined f => f a -> Bool
gHasUndefined (M1 i c a a -> a a
forall i (c :: Meta) k (f :: k -> Type) (p :: k). M1 i c f p -> f p
unM1 M1 i c a a
a)
  {-# INLINEABLE gHasUndefined #-}

instance (GHasUndefined a, GHasUndefined b) => GHasUndefined (a :*: b) where
  gHasUndefined :: (:*:) a b a -> Bool
gHasUndefined xy :: (:*:) a b a
xy@(~(a a
x :*: b a
y)) =
    if Either String ((:*:) a b a) -> Bool
forall a b. Either a b -> Bool
isLeft ((:*:) a b a -> Either String ((:*:) a b a)
forall a. a -> Either String a
isX (:*:) a b a
xy) then
      Bool
True
    else
      a a -> Bool
forall (f :: Type -> Type) a. GHasUndefined f => f a -> Bool
gHasUndefined a a
x Bool -> Bool -> Bool
|| b a -> Bool
forall (f :: Type -> Type) a. GHasUndefined f => f a -> Bool
gHasUndefined b a
y
  {-# INLINEABLE gHasUndefined #-}

instance (GHasUndefined a, GHasUndefined b) => GHasUndefined (a :+: b) where
  gHasUndefined :: (:+:) a b a -> Bool
gHasUndefined (:+:) a b a
lrx =
    if Either String ((:+:) a b a) -> Bool
forall a b. Either a b -> Bool
isLeft ((:+:) a b a -> Either String ((:+:) a b a)
forall a. a -> Either String a
isX (:+:) a b a
lrx) then
      Bool
True
    else
      case (:+:) a b a
lrx of
        L1 a a
x -> a a -> Bool
forall (f :: Type -> Type) a. GHasUndefined f => f a -> Bool
gHasUndefined a a
x
        R1 b a
x -> b a -> Bool
forall (f :: Type -> Type) a. GHasUndefined f => f a -> Bool
gHasUndefined b a
x
  {-# INLINEABLE gHasUndefined #-}

instance GHasUndefined V1 where
  gHasUndefined :: V1 a -> Bool
gHasUndefined V1 a
_ = String -> Bool
forall a. HasCallStack => String -> a
error String
"Unreachable code?"

class GDeepErrorX f where
  gDeepErrorX :: HasCallStack => String -> f a

instance GDeepErrorX V1 where
  gDeepErrorX :: String -> V1 a
gDeepErrorX = String -> V1 a
forall a. HasCallStack => String -> a
errorX

instance GDeepErrorX U1 where
  gDeepErrorX :: String -> U1 a
gDeepErrorX = U1 a -> String -> U1 a
forall a b. a -> b -> a
const U1 a
forall k (p :: k). U1 p
U1

instance (GDeepErrorX a) => GDeepErrorX (M1 m d a) where
  gDeepErrorX :: String -> M1 m d a a
gDeepErrorX String
e = a a -> M1 m d a a
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 (String -> a a
forall (f :: Type -> Type) a.
(GDeepErrorX f, HasCallStack) =>
String -> f a
gDeepErrorX String
e)

instance (GDeepErrorX f, GDeepErrorX g) => GDeepErrorX (f :*: g) where
  gDeepErrorX :: String -> (:*:) f g a
gDeepErrorX String
e = String -> f a
forall (f :: Type -> Type) a.
(GDeepErrorX f, HasCallStack) =>
String -> f a
gDeepErrorX String
e f a -> g a -> (:*:) f g a
forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
f p -> g p -> (:*:) f g p
:*: String -> g a
forall (f :: Type -> Type) a.
(GDeepErrorX f, HasCallStack) =>
String -> f a
gDeepErrorX String
e

instance NFDataX c => GDeepErrorX (K1 i c) where
  gDeepErrorX :: String -> K1 i c a
gDeepErrorX String
e = c -> K1 i c a
forall k i c (p :: k). c -> K1 i c p
K1 (String -> c
forall a. (NFDataX a, HasCallStack) => String -> a
deepErrorX String
e)

instance GDeepErrorX (f :+: g) where
  gDeepErrorX :: String -> (:+:) f g a
gDeepErrorX = String -> (:+:) f g a
forall a. HasCallStack => String -> a
errorX