{-|
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>

'X': 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 DefaultSignatures     #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE EmptyCase             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeOperators         #-}

{-# LANGUAGE Trustworthy #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Clash.XException
  ( -- * 'X': An exception for uninitialized values
    XException(..), errorX, isX, hasX, maybeIsX, maybeHasX
    -- * Printing 'X' exceptions as \"X\"
  , ShowX (..), showsX, printX, showsPrecXWith
    -- * Strict evaluation
  , seqX, forceX, deepseqX, rwhnfX, defaultSeqX
    -- * Structured undefined / deep evaluation with undefined values
  , Undefined (rnfX, deepErrorX)
  )
where

import Control.Exception (Exception, catch, evaluate, throw)
import Control.DeepSeq   (NFData, rnf)
import Data.Complex      (Complex)
import Data.Either       (isLeft)
import Data.Foldable     (toList)
import Data.Int          (Int8,Int16,Int32,Int64)
import Data.Ord          (Down (Down))
import Data.Ratio        (Ratio, numerator, denominator)
import qualified Data.Semigroup as SG
import Data.Sequence     (Seq(Empty, (:<|)))
import Data.Word         (Word8,Word16,Word32,Word64)
import GHC.Exts          (Char (C#), Double (D#), Float (F#), Int (I#), Word (W#))
import GHC.Generics
import GHC.Natural       (Natural)
import GHC.Show          (appPrec)
import GHC.Stack         (HasCallStack, callStack, prettyCallStack, withFrozenCallStack)
import Numeric.Half      (Half)
import System.IO.Unsafe  (unsafeDupablePerformIO)

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

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

instance Exception XException

-- | Either 'seqX' or 'deepSeqX' depending on the value of the cabal flag
-- '-fsuper-strict'. If enabled, 'defaultSeqX' will be 'deepseqX', otherwise
-- 'seqX'. Flag defaults to /false/ and thus 'seqX'.
defaultSeqX :: Undefined a => a -> b -> b
#ifdef CLASH_SUPER_STRICT
defaultSeqX = deepseqX
#else
defaultSeqX :: a -> b -> b
defaultSeqX = a -> b -> b
forall a b. a -> b -> b
seqX
#endif
{-# INLINE defaultSeqX #-}

-- | Like 'error', but throwing an 'XException' instead of an 'ErrorCall'
--
-- The 'ShowX' methods print these error-values as \"X\"; instead of error'ing
-- out with an exception.
errorX :: HasCallStack => String -> a
errorX :: String -> a
errorX msg :: String
msg = XException -> a
forall a e. Exception e => e -> a
throw (String -> XException
XException ("X: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack))

-- | Like 'seq', however, whereas 'seq' will always do:
--
-- > seq  _|_              b = _|_
--
-- 'seqX' will do:
--
-- > seqX (XException msg) b = b
-- > seqX _|_              b = _|_
seqX :: a -> b -> b
seqX :: a -> b -> b
seqX a :: a
a b :: b
b = IO b -> b
forall a. IO a -> a
unsafeDupablePerformIO
  (IO b -> (XException -> IO b) -> IO b
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (a -> IO a
forall a. a -> IO a
evaluate a
a IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b) (\(XException _) -> b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b))
{-# NOINLINE seqX #-}
infixr 0 `seqX`

-- | Evaluate a value with given function, returning 'Nothing' if it throws
-- 'XException'.
--
-- > maybeX hasX 42                  = Just 42
-- > maybeX hasX (XException msg)    = Nothing
-- > maybeX hasX (3, XException msg) = Nothing
-- > maybeX hasX (3, _|_)            = _|_
-- > maybeX hasX _|_                 = _|_
-- >
-- > maybeX isX 42                  = Just 42
-- > maybeX isX (XException msg)    = Nothing
-- > maybeX isX (3, XException msg) = Just (3, XException msg)
-- > maybeX isX (3, _|_)            = Just (3, _|_)
-- > maybeX isX _|_                 = _|_
--
maybeX :: NFData a => (a -> Either String a) -> a -> Maybe a
maybeX :: (a -> Either String a) -> a -> Maybe a
maybeX f :: a -> Either String a
f a :: a
a = (String -> Maybe a) -> (a -> Maybe a) -> Either String a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> String -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (a -> Either String a
f a
a)

-- | Fully evaluate a value, returning 'Nothing' if it throws 'XException'.
--
-- > maybeX 42                  = Just 42
-- > maybeX (XException msg)    = Nothing
-- > maybeX (3, XException msg) = Nothing
-- > maybeX (3, _|_)            = _|_
-- > maybeX _|_                 = _|_
--
maybeHasX :: NFData a => a -> Maybe a
maybeHasX :: a -> Maybe a
maybeHasX = (a -> Either String a) -> a -> Maybe a
forall a. NFData a => (a -> Either String a) -> a -> Maybe a
maybeX a -> Either String a
forall a. NFData a => a -> Either String a
hasX

-- | Evaluate a value to WHNF, returning 'Nothing' if it throws 'XException'.
--
-- > maybeIsX 42                  = Just 42
-- > maybeIsX (XException msg)    = Nothing
-- > maybeIsX (3, XException msg) = Just (3, XException msg)
-- > maybeIsX (3, _|_)            = Just (3, _|_)
-- > maybeIsX _|_                 = _|_
maybeIsX :: NFData a => a -> Maybe a
maybeIsX :: a -> Maybe a
maybeIsX = (a -> Either String a) -> a -> Maybe a
forall a. NFData a => (a -> Either String a) -> a -> Maybe a
maybeX a -> Either String a
forall a. a -> Either String a
isX

-- | Fully evaluate a value, returning @'Left' msg@ if it throws 'XException'.
--
-- > hasX 42                  = Right 42
-- > hasX (XException msg)    = Left msg
-- > hasX (3, XException msg) = Left msg
-- > hasX (3, _|_)            = _|_
-- > hasX _|_                 = _|_
--
-- If a data structure contains multiple 'XException's, the "first" message is
-- picked according to the implementation of 'rnf'.
hasX :: NFData a => a -> Either String a
hasX :: a -> Either String a
hasX a :: a
a =
  IO (Either String a) -> Either String a
forall a. IO a -> a
unsafeDupablePerformIO
    (IO (Either String a)
-> (XException -> IO (Either String a)) -> IO (Either String a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
      (() -> IO ()
forall a. a -> IO a
evaluate (a -> ()
forall a. NFData a => a -> ()
rnf a
a) IO () -> IO (Either String a) -> IO (Either String a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either String a
forall a b. b -> Either a b
Right a
a))
      (\(XException msg :: String
msg) -> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left String
msg)))
{-# NOINLINE hasX #-}

-- | Evaluate a value to WHNF, returning @'Left' msg@ if is a 'XException'.
--
-- > isX 42                  = Right 42
-- > isX (XException msg)    = Left msg
-- > isX (3, XException msg) = Right (3, XException msg)
-- > isX (3, _|_)            = (3, _|_)
-- > isX _|_                 = _|_
isX :: a -> Either String a
isX :: a -> Either String a
isX a :: a
a =
  IO (Either String a) -> Either String a
forall a. IO a -> a
unsafeDupablePerformIO
    (IO (Either String a)
-> (XException -> IO (Either String a)) -> IO (Either String a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
      (a -> IO a
forall a. a -> IO a
evaluate a
a IO a -> IO (Either String a) -> IO (Either String a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either String a
forall a b. b -> Either a b
Right a
a))
      (\(XException msg :: String
msg) -> Either String a -> IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left String
msg)))
{-# NOINLINE isX #-}

showXWith :: (a -> ShowS) -> a -> ShowS
showXWith :: (a -> ShowS) -> a -> ShowS
showXWith f :: a -> ShowS
f x :: a
x =
  \s :: 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 :: * -> *) 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 :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
s)
                                      (\(XException _) -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ('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 f :: Int -> a -> ShowS
f n :: Int
n = (a -> ShowS) -> a -> ShowS
forall a. (a -> ShowS) -> a -> ShowS
showXWith (Int -> a -> ShowS
f Int
n)

-- | Like 'shows', but values that normally throw an 'X' exception 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 0

-- | Like 'print', but values that normally throw an 'X' exception are
-- converted to \"X\", instead of error'ing out with an exception
printX :: ShowX a => a -> IO ()
printX :: a -> IO ()
printX x :: a
x = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. ShowX a => a -> String
showX a
x

-- | Like the 'Show' class, but values that normally throw an 'X' exception are
-- converted to \"X\", instead of error'ing out with an exception.
--
-- >>> show (errorX "undefined" :: Integer, 4 :: Int)
-- "(*** Exception: X: undefined
-- CallStack (from HasCallStack):
-- ...
-- >>> showX (errorX "undefined" :: Integer, 4 :: Int)
-- "(X,4)"
--
-- Can be derived using 'GHC.Generics':
--
-- > {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
-- >
-- > import Clash.Prelude
-- > import GHC.Generics
-- >
-- > data T = MkTA Int | MkTB Bool
-- >   deriving (Show,Generic,ShowX)
class ShowX a where
  -- | Like 'showsPrec', but values that normally throw an 'X' exception are
  -- converted to \"X\", instead of error'ing out with an exception.
  showsPrecX :: Int -> a -> ShowS

  -- | Like 'show', but values that normally throw an 'X' exception are
  -- converted to \"X\", instead of error'ing out with an exception.
  showX :: a -> String
  showX x :: a
x = a -> ShowS
forall a. ShowX a => a -> ShowS
showsX a
x ""

  -- | Like 'showList', but values that normally throw an 'X' exception are
  -- converted to \"X\", instead of error'ing out with an exception.
  showListX :: [a] -> ShowS
  showListX ls :: [a]
ls s :: String
s = (a -> ShowS) -> [a] -> ShowS
forall a. (a -> ShowS) -> [a] -> ShowS
showListX__ a -> ShowS
forall a. ShowX a => a -> ShowS
showsX [a]
ls String
s

  default showsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS
  showsPrecX = Int -> a -> ShowS
forall a. (Generic a, GShowX (Rep a)) => Int -> a -> ShowS
genericShowsPrecX

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

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

genericShowsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS
genericShowsPrecX :: Int -> a -> ShowS
genericShowsPrecX n :: Int
n = ShowType -> Int -> Rep a Any -> ShowS
forall (f :: * -> *) 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

instance ShowX ()
instance (ShowX a, ShowX b) => ShowX (a,b)
instance (ShowX a, ShowX b, ShowX c) => ShowX (a,b,c)
instance (ShowX a, ShowX b, ShowX c, ShowX d) => ShowX (a,b,c,d)
instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e) => ShowX (a,b,c,d,e)
instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f) => ShowX (a,b,c,d,e,f)
instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g) => ShowX (a,b,c,d,e,f,g)

-- Show is defined up to 15-tuples, but GHC.Generics only has Generic instances
-- up to 7-tuples, hence we need these orphan instances.
deriving instance Generic ((,,,,,,,) a b c d e f g h)
deriving instance Generic ((,,,,,,,,) a b c d e f g h i)
deriving instance Generic ((,,,,,,,,,) a b c d e f g h i j)
deriving instance Generic ((,,,,,,,,,,) a b c d e f g h i j k)
deriving instance Generic ((,,,,,,,,,,,) a b c d e f g h i j k l)
deriving instance Generic ((,,,,,,,,,,,,) a b c d e f g h i j k l m)
deriving instance Generic ((,,,,,,,,,,,,,) a b c d e f g h i j k l m n)
deriving instance Generic ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o)

instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h) => ShowX (a,b,c,d,e,f,g,h)
instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i) => ShowX (a,b,c,d,e,f,g,h,i)
instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j)
  => ShowX (a,b,c,d,e,f,g,h,i,j)
instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k)
  => ShowX (a,b,c,d,e,f,g,h,i,j,k)
instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l)
  => ShowX (a,b,c,d,e,f,g,h,i,j,k,l)
instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l
         ,ShowX m)
  => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m)
instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l
         ,ShowX m, ShowX n)
  => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l
         ,ShowX m, ShowX n, ShowX o)
  => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)

instance {-# OVERLAPPABLE #-} ShowX a => ShowX [a] where
  showsPrecX :: Int -> [a] -> ShowS
showsPrecX _ = [a] -> ShowS
forall a. ShowX a => [a] -> ShowS
showListX

instance ShowX Char where
  showsPrecX :: Int -> Char -> ShowS
showsPrecX = (Int -> Char -> ShowS) -> Int -> Char -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Char -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX Bool

instance ShowX Double where
  showsPrecX :: Int -> Double -> ShowS
showsPrecX = (Int -> Double -> ShowS) -> Int -> Double -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Double -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX a => ShowX (Down a) where
  showsPrecX :: Int -> Down a -> ShowS
showsPrecX = (Int -> Down a -> ShowS) -> Int -> Down a -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Down a -> ShowS
forall a. ShowX a => Int -> a -> ShowS
showsPrecX

instance (ShowX a, ShowX b) => ShowX (Either a b)

instance ShowX Float where
  showsPrecX :: Int -> Float -> ShowS
showsPrecX = (Int -> Float -> ShowS) -> Int -> Float -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Float -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX Int where
  showsPrecX :: Int -> Int -> ShowS
showsPrecX = (Int -> Int -> ShowS) -> Int -> Int -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX Int8 where
  showsPrecX :: Int -> Int8 -> ShowS
showsPrecX = (Int -> Int8 -> ShowS) -> Int -> Int8 -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Int8 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX Int16 where
  showsPrecX :: Int -> Int16 -> ShowS
showsPrecX = (Int -> Int16 -> ShowS) -> Int -> Int16 -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Int16 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX Int32 where
  showsPrecX :: Int -> Int32 -> ShowS
showsPrecX = (Int -> Int32 -> ShowS) -> Int -> Int32 -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Int32 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX Int64 where
  showsPrecX :: Int -> Int64 -> ShowS
showsPrecX = (Int -> Int64 -> ShowS) -> Int -> Int64 -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Int64 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX Integer where
  showsPrecX :: Int -> Integer -> ShowS
showsPrecX = (Int -> Integer -> ShowS) -> Int -> Integer -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Integer -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX Natural where
  showsPrecX :: Int -> Natural -> ShowS
showsPrecX = (Int -> Natural -> ShowS) -> Int -> Natural -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Natural -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX a => ShowX (Seq a) where
  showsPrecX :: Int -> Seq a -> ShowS
showsPrecX _ = [a] -> ShowS
forall a. ShowX a => [a] -> ShowS
showListX ([a] -> ShowS) -> (Seq a -> [a]) -> Seq a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance ShowX Word where
  showsPrecX :: Int -> Word -> ShowS
showsPrecX = (Int -> Word -> ShowS) -> Int -> Word -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Word -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX Word8 where
  showsPrecX :: Int -> Word8 -> ShowS
showsPrecX = (Int -> Word8 -> ShowS) -> Int -> Word8 -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Word8 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX Word16 where
  showsPrecX :: Int -> Word16 -> ShowS
showsPrecX = (Int -> Word16 -> ShowS) -> Int -> Word16 -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Word16 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX Word32 where
  showsPrecX :: Int -> Word32 -> ShowS
showsPrecX = (Int -> Word32 -> ShowS) -> Int -> Word32 -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Word32 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX Word64 where
  showsPrecX :: Int -> Word64 -> ShowS
showsPrecX = (Int -> Word64 -> ShowS) -> Int -> Word64 -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Word64 -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

instance ShowX a => ShowX (Maybe a)

instance ShowX a => ShowX (Ratio a) where
  showsPrecX :: Int -> Ratio a -> ShowS
showsPrecX = (Int -> Ratio a -> ShowS) -> Int -> Ratio a -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> Ratio a -> ShowS
forall a. ShowX a => Int -> a -> ShowS
showsPrecX

instance ShowX a => ShowX (Complex a)

instance {-# OVERLAPPING #-} ShowX String where
  showsPrecX :: Int -> String -> ShowS
showsPrecX = (Int -> String -> ShowS) -> Int -> String -> ShowS
forall a. (Int -> a -> ShowS) -> Int -> a -> ShowS
showsPrecXWith Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

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 "generic showX (isNullary): unnecessary case"

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

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

instance (GShowX a, Constructor c) => GShowX (M1 C c a) where
  gshowsPrecX :: ShowType -> Int -> M1 C c a a -> ShowS
gshowsPrecX _ n :: Int
n c :: M1 C c a a
c@(M1 x :: a a
x) =
    case Fixity
fixity of
      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 :: * -> *) a. GShowX f => f a -> Bool
isNullary a a
x))
          ( (if M1 C c a a -> Bool
forall (f :: * -> *) 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 -> *) -> k1 -> *)
       (f :: k1 -> *) (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 :: * -> *) a. GShowX f => f a -> Bool
isNullary a a
x Bool -> Bool -> Bool
|| M1 C c a a -> Bool
forall (f :: * -> *) p. C1 c f p -> Bool
conIsTuple M1 C c a a
c then ShowS
forall a. a -> a
id else String -> ShowS
showString " ")
          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 :: * -> *) a. GShowX f => ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
appPrec a a
x))
      Infix _ m :: 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 :: * -> *) 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 -> *) -> k1 -> *)
       (f :: k1 -> *) (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 -> *) -> k1 -> *)
       (f :: k1 -> *) (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 :: * -> *) p. C1 c f p -> Bool
conIsTuple M1 C c a a
c of
                    True -> ShowType
Tup
                    False -> case Fixity
fixity of
                                Prefix    -> ShowType
Pref
                                Infix _ _ -> 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 -> *) -> k1 -> *)
       (f :: k1 -> *) (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 Rec     p :: ShowS
p = Char -> ShowS
showChar '{' 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 '}'
            showBraces Tup     p :: ShowS
p = Char -> ShowS
showChar '(' 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 ')'
            showBraces Pref    p :: ShowS
p = ShowS
p
            showBraces (Inf _) p :: ShowS
p = ShowS
p

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

instance (Selector s, GShowX a) => GShowX (M1 S s a) where
  gshowsPrecX :: ShowType -> Int -> M1 S s a a -> ShowS
gshowsPrecX t :: ShowType
t n :: Int
n s :: M1 S s a a
s@(M1 x :: a a
x) | M1 S s a a -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (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
== "" =   ShowType -> Int -> a a -> ShowS
forall (f :: * -> *) 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 -> *) -> k1 -> *)
       (f :: k1 -> *) (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 " = "
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowType -> Int -> a a -> ShowS
forall (f :: * -> *) a. GShowX f => ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t 0 a a
x
  isNullary :: M1 S s a a -> Bool
isNullary (M1 x :: a a
x) = a a -> Bool
forall (f :: * -> *) 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 t :: 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 n :: Int
n (M1 x :: a a
x) = ShowType -> Int -> a a -> ShowS
forall (f :: * -> *) 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 t :: ShowType
t n :: Int
n (L1 x :: a a
x) = ShowType -> Int -> a a -> ShowS
forall (f :: * -> *) a. GShowX f => ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n a a
x
  gshowsPrecX t :: ShowType
t n :: Int
n (R1 x :: b a
x) = ShowType -> Int -> b a -> ShowS
forall (f :: * -> *) 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     n :: Int
n (a :: a a
a :*: b :: b a
b) =
    ShowType -> Int -> a a -> ShowS
forall (f :: * -> *) 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 ", " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowType -> Int -> b a -> ShowS
forall (f :: * -> *) a. GShowX f => ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n     b a
b
  gshowsPrecX t :: ShowType
t@(Inf s :: String
s) n :: Int
n (a :: a a
a :*: b :: b a
b) =
    ShowType -> Int -> a a -> ShowS
forall (f :: * -> *) 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 :: * -> *) a. GShowX f => ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n     b a
b
  gshowsPrecX t :: ShowType
t@ShowType
Tup     n :: Int
n (a :: a a
a :*: b :: b a
b) =
    ShowType -> Int -> a a -> ShowS
forall (f :: * -> *) 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 ','    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowType -> Int -> b a -> ShowS
forall (f :: * -> *) a. GShowX f => ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t Int
n     b a
b
  gshowsPrecX t :: ShowType
t@ShowType
Pref    n :: Int
n (a :: a a
a :*: b :: b a
b) =
    ShowType -> Int -> a a -> ShowS
forall (f :: * -> *) a. GShowX f => ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) a a
a ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar ' '    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowType -> Int -> b a -> ShowS
forall (f :: * -> *) a. GShowX f => ShowType -> Int -> f a -> ShowS
gshowsPrecX ShowType
t (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) b a
b

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

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

-- | a variant of 'deepseqX' that is useful in some circumstances:
--
-- > forceX x = x `deepseqX` x
forceX :: Undefined a => a -> a
forceX :: a -> a
forceX x :: a
x = a
x a -> a -> a
forall a b. Undefined a => a -> b -> b
`deepseqX` a
x
{-# INLINE forceX #-}

-- | 'deepseqX': fully evaluates the first argument, before returning the
-- second. Does not propagate 'XException's.
deepseqX :: Undefined a => a -> b -> b
deepseqX :: a -> b -> b
deepseqX a :: a
a b :: b
b = a -> ()
forall a. Undefined a => a -> ()
rnfX a
a () -> b -> b
forall a b. a -> b -> b
`seq` b
b
{-# NOINLINE deepseqX #-}

-- | Reduce to weak head normal form
--
-- Equivalent to @\\x -> 'seqX' x ()@.
--
-- Useful for defining 'Undefined.rnfX' for types for which NF=WHNF holds.
rwhnfX :: a -> ()
rwhnfX :: a -> ()
rwhnfX = (a -> () -> ()
forall a b. a -> b -> b
`seqX` ())
{-# INLINE rwhnfX #-}

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

instance GNFDataX arity V1 where
  grnfX :: RnfArgs arity a -> V1 a -> ()
grnfX _ x :: 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 _ u :: 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 -> ()

instance Undefined a => GNFDataX arity (K1 i a) where
  grnfX :: RnfArgs arity a -> K1 i a a -> ()
grnfX _ = a -> ()
forall a. Undefined 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 args :: RnfArgs arity a
args a :: 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 :: * -> *) 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 -> *) (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 args :: RnfArgs arity a
args xy :: (:*:) a b a
xy@(~(x :: a a
x :*: y :: 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 :: * -> *) a.
GNFDataX arity f =>
RnfArgs arity a -> f a -> ()
grnfX RnfArgs arity a
args a a
x () -> () -> ()
forall a b. a -> b -> b
`seq` RnfArgs arity a -> b a -> ()
forall arity (f :: * -> *) 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 args :: RnfArgs arity a
args lrx :: (:+:) 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 x :: a a
x -> RnfArgs arity a -> a a -> ()
forall arity (f :: * -> *) a.
GNFDataX arity f =>
RnfArgs arity a -> f a -> ()
grnfX RnfArgs arity a
args a a
x
        R1 x :: b a
x -> RnfArgs arity a -> b a -> ()
forall arity (f :: * -> *) 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 r :: 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 r :: a -> ()
r) = (a -> ()) -> f a -> ()
forall (f :: * -> *) 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 -> *) (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 args :: RnfArgs One a
args = (g a -> ()) -> f (g a) -> ()
forall (f :: * -> *) a. NFDataX1 f => (a -> ()) -> f a -> ()
liftRnfX (RnfArgs One a -> g a -> ()
forall arity (f :: * -> *) 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 -> *) k1 (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1

-- | 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 r :: a -> ()
r = RnfArgs One a -> Rep1 f a -> ()
forall arity (f :: * -> *) 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 -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1

-- | Class that houses functions dealing with /undefined/ values in Clash. See
-- 'deepErrorX' and 'rnfX'.
class Undefined a where
  -- | Create a value where all the elements have an 'errorX', but the spine
  -- is defined.
  deepErrorX :: HasCallStack => String -> a

  default deepErrorX :: (HasCallStack, Generic a, GUndefined (Rep a)) => String -> a
  deepErrorX = (HasCallStack => String -> a) -> String -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => String -> a) -> String -> a)
-> (HasCallStack => String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> (String -> Rep a Any) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Rep a Any
forall (f :: * -> *) a.
(GUndefined f, HasCallStack) =>
String -> f a
gDeepErrorX

  -- | Evaluate a value to NF. As opposed to 'NFData's 'rnf', it does not bubble
  -- up 'XException's.
  rnfX :: a -> ()

  default rnfX :: (Generic a, GNFDataX Zero (Rep a)) => a -> ()
  rnfX = RnfArgs Zero Any -> Rep a Any -> ()
forall arity (f :: * -> *) a.
GNFDataX arity f =>
RnfArgs arity a -> f a -> ()
grnfX RnfArgs Zero Any
forall a. RnfArgs Zero a
RnfArgs0 (Rep a Any -> ()) -> (a -> Rep a Any) -> a -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

instance Undefined ()
instance (Undefined a, Undefined b) => Undefined (a,b)
instance (Undefined a, Undefined b, Undefined c) => Undefined (a,b,c)
instance (Undefined a, Undefined b, Undefined c, Undefined d) => Undefined (a,b,c,d)
instance (Undefined a, Undefined b, Undefined c, Undefined d, Undefined e) => Undefined (a,b,c,d,e)
instance (Undefined a, Undefined b, Undefined c, Undefined d, Undefined e ,Undefined f)
  => Undefined (a,b,c,d,e,f)
instance (Undefined a, Undefined b, Undefined c, Undefined d, Undefined e
         ,Undefined f, Undefined g)
  => Undefined (a,b,c,d,e,f,g)
instance (Undefined a, Undefined b, Undefined c, Undefined d, Undefined e
         ,Undefined f, Undefined g, Undefined h)
  => Undefined (a,b,c,d,e,f,g,h)
instance (Undefined a, Undefined b, Undefined c, Undefined d, Undefined e
         ,Undefined f, Undefined g, Undefined h, Undefined i)
  => Undefined (a,b,c,d,e,f,g,h,i)
instance (Undefined a, Undefined b, Undefined c, Undefined d, Undefined e
         ,Undefined f, Undefined g, Undefined h, Undefined i, Undefined j)
  => Undefined (a,b,c,d,e,f,g,h,i,j)
instance (Undefined a, Undefined b, Undefined c, Undefined d, Undefined e
         ,Undefined f, Undefined g, Undefined h, Undefined i, Undefined j
         ,Undefined k)
  => Undefined (a,b,c,d,e,f,g,h,i,j,k)
instance (Undefined a, Undefined b, Undefined c, Undefined d, Undefined e
         ,Undefined f, Undefined g, Undefined h, Undefined i, Undefined j
         ,Undefined k, Undefined l)
  => Undefined (a,b,c,d,e,f,g,h,i,j,k,l)
instance (Undefined a, Undefined b, Undefined c, Undefined d, Undefined e
         ,Undefined f, Undefined g, Undefined h, Undefined i, Undefined j
         ,Undefined k, Undefined l, Undefined m)
  => Undefined (a,b,c,d,e,f,g,h,i,j,k,l,m)
instance (Undefined a, Undefined b, Undefined c, Undefined d, Undefined e
         ,Undefined f, Undefined g, Undefined h, Undefined i, Undefined j
         ,Undefined k, Undefined l, Undefined m, Undefined n)
  => Undefined (a,b,c,d,e,f,g,h,i,j,k,l,m,n)
instance (Undefined a, Undefined b, Undefined c, Undefined d, Undefined e
         ,Undefined f, Undefined g, Undefined h, Undefined i, Undefined j
         ,Undefined k, Undefined l, Undefined m, Undefined n, Undefined o)
  => Undefined (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)

instance Undefined b => Undefined (a -> b) where
  deepErrorX :: String -> a -> b
deepErrorX = b -> a -> b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> a -> b) -> (String -> b) -> String -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> b
forall a. (Undefined a, HasCallStack) => String -> a
deepErrorX
  rnfX :: (a -> b) -> ()
rnfX = (a -> b) -> ()
forall a. a -> ()
rwhnfX

instance Undefined a => Undefined (Down a) where
  deepErrorX :: String -> Down a
deepErrorX = a -> Down a
forall a. a -> Down a
Down (a -> Down a) -> (String -> a) -> String -> Down a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
forall a. (Undefined a, HasCallStack) => String -> a
deepErrorX
  rnfX :: Down a -> ()
rnfX d :: Down a
d@(~(Down x :: a
x))= if Either String (Down a) -> Bool
forall a b. Either a b -> Bool
isLeft (Down a -> Either String (Down a)
forall a. a -> Either String a
isX Down a
d) then a -> ()
forall a. Undefined a => a -> ()
rnfX a
x else ()

instance Undefined Bool
instance Undefined a => Undefined [a]
instance (Undefined a, Undefined b) => Undefined (Either a b)
instance Undefined a => Undefined (Maybe a)

instance Undefined Char where
  deepErrorX :: String -> Char
deepErrorX = String -> Char
forall a. HasCallStack => String -> a
errorX
  rnfX :: Char -> ()
rnfX = Char -> ()
forall a. a -> ()
rwhnfX

instance Undefined Double where
  deepErrorX :: String -> Double
deepErrorX = String -> Double
forall a. HasCallStack => String -> a
errorX
  rnfX :: Double -> ()
rnfX = Double -> ()
forall a. a -> ()
rwhnfX

instance Undefined Float where
  deepErrorX :: String -> Float
deepErrorX = String -> Float
forall a. HasCallStack => String -> a
errorX
  rnfX :: Float -> ()
rnfX = Float -> ()
forall a. a -> ()
rwhnfX

instance Undefined Int where
  deepErrorX :: String -> Int
deepErrorX = String -> Int
forall a. HasCallStack => String -> a
errorX
  rnfX :: Int -> ()
rnfX = Int -> ()
forall a. a -> ()
rwhnfX

instance Undefined Int8 where
  deepErrorX :: String -> Int8
deepErrorX = String -> Int8
forall a. HasCallStack => String -> a
errorX
  rnfX :: Int8 -> ()
rnfX = Int8 -> ()
forall a. a -> ()
rwhnfX

instance Undefined Int16 where
  deepErrorX :: String -> Int16
deepErrorX = String -> Int16
forall a. HasCallStack => String -> a
errorX
  rnfX :: Int16 -> ()
rnfX = Int16 -> ()
forall a. a -> ()
rwhnfX

instance Undefined Int32 where
  deepErrorX :: String -> Int32
deepErrorX = String -> Int32
forall a. HasCallStack => String -> a
errorX
  rnfX :: Int32 -> ()
rnfX = Int32 -> ()
forall a. a -> ()
rwhnfX

instance Undefined Int64 where
  deepErrorX :: String -> Int64
deepErrorX = String -> Int64
forall a. HasCallStack => String -> a
errorX
  rnfX :: Int64 -> ()
rnfX = Int64 -> ()
forall a. a -> ()
rwhnfX

instance Undefined Integer where
  deepErrorX :: String -> Integer
deepErrorX = String -> Integer
forall a. HasCallStack => String -> a
errorX
  rnfX :: Integer -> ()
rnfX = Integer -> ()
forall a. a -> ()
rwhnfX

instance Undefined Natural where
  deepErrorX :: String -> Natural
deepErrorX = String -> Natural
forall a. HasCallStack => String -> a
errorX
  rnfX :: Natural -> ()
rnfX = Natural -> ()
forall a. a -> ()
rwhnfX

instance Undefined Word where
  deepErrorX :: String -> Word
deepErrorX = String -> Word
forall a. HasCallStack => String -> a
errorX
  rnfX :: Word -> ()
rnfX = Word -> ()
forall a. a -> ()
rwhnfX

instance Undefined Word8 where
  deepErrorX :: String -> Word8
deepErrorX = String -> Word8
forall a. HasCallStack => String -> a
errorX
  rnfX :: Word8 -> ()
rnfX = Word8 -> ()
forall a. a -> ()
rwhnfX

instance Undefined Word16 where
  deepErrorX :: String -> Word16
deepErrorX = String -> Word16
forall a. HasCallStack => String -> a
errorX
  rnfX :: Word16 -> ()
rnfX = Word16 -> ()
forall a. a -> ()
rwhnfX

instance Undefined Word32 where
  deepErrorX :: String -> Word32
deepErrorX = String -> Word32
forall a. HasCallStack => String -> a
errorX
  rnfX :: Word32 -> ()
rnfX = Word32 -> ()
forall a. a -> ()
rwhnfX

instance Undefined Word64 where
  deepErrorX :: String -> Word64
deepErrorX = String -> Word64
forall a. HasCallStack => String -> a
errorX
  rnfX :: Word64 -> ()
rnfX = Word64 -> ()
forall a. a -> ()
rwhnfX

instance Undefined Half where
  deepErrorX :: String -> Half
deepErrorX = String -> Half
forall a. HasCallStack => String -> a
errorX
  rnfX :: Half -> ()
rnfX = Half -> ()
forall a. a -> ()
rwhnfX

instance Undefined a => Undefined (Seq a) where
  deepErrorX :: String -> Seq a
deepErrorX = String -> Seq a
forall a. HasCallStack => String -> a
errorX
  rnfX :: Seq a -> ()
rnfX s :: Seq a
s =
    if Either String (Seq a) -> Bool
forall a b. Either a b -> Bool
isLeft (Seq a -> Either String (Seq a)
forall a. a -> Either String a
isX Seq a
s) then () else Seq a -> ()
forall a. Undefined a => Seq a -> ()
go Seq a
s
   where
    go :: Seq a -> ()
go Empty = ()
    go (x :: a
x :<| xs :: Seq a
xs) = a -> ()
forall a. Undefined a => a -> ()
rnfX a
x () -> () -> ()
forall a b. a -> b -> b
`seq` Seq a -> ()
go Seq a
xs

instance Undefined a => Undefined (Ratio a) where
  deepErrorX :: String -> Ratio a
deepErrorX = String -> Ratio a
forall a. HasCallStack => String -> a
errorX
  rnfX :: Ratio a -> ()
rnfX r :: Ratio a
r = a -> ()
forall a. Undefined a => a -> ()
rnfX (Ratio a -> a
forall a. Ratio a -> a
numerator Ratio a
r) () -> () -> ()
forall a b. a -> b -> b
`seq` a -> ()
forall a. Undefined a => a -> ()
rnfX (Ratio a -> a
forall a. Ratio a -> a
denominator Ratio a
r)

instance Undefined a => Undefined (Complex a) where
  deepErrorX :: String -> Complex a
deepErrorX = String -> Complex a
forall a. HasCallStack => String -> a
errorX

instance (Undefined a, Undefined b) => Undefined (SG.Arg a b)
instance Undefined (SG.All)
instance Undefined (SG.Any)
instance Undefined a => Undefined (SG.Dual a)
instance Undefined a => Undefined (SG.Endo a)
instance Undefined a => Undefined (SG.First a)
instance Undefined a => Undefined (SG.Last a)
instance Undefined a => Undefined (SG.Max a)
instance Undefined a => Undefined (SG.Min a)
instance Undefined a => Undefined (SG.Option a)
instance Undefined a => Undefined (SG.Product a)
instance Undefined a => Undefined (SG.Sum a)

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

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

instance GUndefined 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 (GUndefined a) => GUndefined (M1 m d a) where
  gDeepErrorX :: String -> M1 m d a a
gDeepErrorX e :: String
e = a a -> M1 m d a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (String -> a a
forall (f :: * -> *) a.
(GUndefined f, HasCallStack) =>
String -> f a
gDeepErrorX String
e)

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

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

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