    {-|
    Copyright  :  (C) 2022, QBayLogic B.V.
    License    :  BSD2 (see the file LICENSE)
    Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>

    Helpers to make 'Clash.XException.XException' explicit in the type system.
    Using these helpers can help programmers account for 'Clash.XException.XException's
    properly in blackbox models or tests. Note that none of these operations can be
    translated to HDL.

    -}

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE PatternSynonyms #-}

    module Clash.XException.MaybeX
      ( MaybeX(IsX, IsDefined)

        -- * Construction
      , toMaybeX
      , hasXToMaybeX

        -- * Deconstruction
      , fromMaybeX

        -- * Operations
      , andX
      , orX
      , maybeX
      ) where

    import Prelude

    #if !MIN_VERSION_base(4,18,0)
    import Control.Applicative
    #endif
    import Control.DeepSeq (NFData)
    import Control.Exception (throw)

    import Clash.XException (XException(..), NFDataX, isX, hasX)

    -- | Structure helping programmers to deal with 'Clash.XException.XException'
    -- values. For safety reasons it can't be constructed directly, but should be
    -- constructed using either 'pure' or 'toMaybeX'. After construction, it can be
    -- deconstructed using either 'IsX' or 'IsDefined'.
    data MaybeX a
      = IsX_ String
      -- ^ Upon construction, @a@ evaluated to 'Clash.XException.XException'
      | IsDefined_ !a
      -- ^ Upon construction, @a@ evaluated to a non-bottom WHNF

    instance Show a => Show (MaybeX a) where
      showsPrec :: Int -> MaybeX a -> ShowS
    showsPrec Int
    d = \case
        IsX_ String
    msg     -> Bool -> ShowS -> ShowS
    showParen (Int
    d Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    10) (ShowS -> ShowS) -> ShowS -> ShowS
    forall a b. (a -> b) -> a -> b
    $ String -> ShowS
    showString String
    "IsX "       ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String -> ShowS
    forall a. Show a => Int -> a -> ShowS
    showsPrec Int
    11 String
    msg
        IsDefined_ a
    a -> Bool -> ShowS -> ShowS
    showParen (Int
    d Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    10) (ShowS -> ShowS) -> ShowS -> ShowS
    forall a b. (a -> b) -> a -> b
    $ String -> ShowS
    showString String
    "IsDefined " ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> a -> ShowS
    forall a. Show a => Int -> a -> ShowS
    showsPrec Int
    11 a
    a

    -- | Upon construction, @a@ evaluated to 'Clash.XException.XException'
    pattern IsX :: forall a. String -> MaybeX a
    pattern $mIsX :: forall {r} {a}. MaybeX a -> (String -> r) -> ((# #) -> r) -> r
    IsX msg <- IsX_ msg

    -- | Upon construction, @a@ evaluated to a non-bottom WHNF
    pattern IsDefined :: forall a. a -> MaybeX a
    pattern $mIsDefined :: forall {r} {a}. MaybeX a -> (a -> r) -> ((# #) -> r) -> r
    IsDefined a <- IsDefined_ a
    {-# COMPLETE IsX, IsDefined #-}

    -- | Note that 'fmap' is X-strict in its argument. That is, if its input is 'IsX',
    -- its output will be too.
    instance Functor MaybeX where
      fmap :: forall a b. (a -> b) -> MaybeX a -> MaybeX b
    fmap a -> b
    _f (IsX_ String
    msg) = String -> MaybeX b
    forall a. String -> MaybeX a
    IsX_ String
    msg
      fmap a -> b
    f  (IsDefined_ a
    a) = b -> MaybeX b
    forall a. a -> MaybeX a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure (a -> b
    f a
    a)

    -- | Note that '<*>' and 'liftA2' are X-strict in their arguments. That is, if
    -- any of their inputs are 'IsX', their outputs will be too.
    instance Applicative MaybeX where
      pure :: forall a. a -> MaybeX a
    pure = (String -> MaybeX a)
    -> (a -> MaybeX a) -> Either String a -> MaybeX a
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either String -> MaybeX a
    forall a. String -> MaybeX a
    IsX_ a -> MaybeX a
    forall a. a -> MaybeX a
    IsDefined_ (Either String a -> MaybeX a)
    -> (a -> Either String a) -> a -> MaybeX a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> Either String a
    forall a. a -> Either String a
    isX

      liftA2 :: forall a b c. (a -> b -> c) -> MaybeX a -> MaybeX b -> MaybeX c
    liftA2 a -> b -> c
    f (IsDefined_ a
    a) (IsDefined_ b
    b) = c -> MaybeX c
    forall a. a -> MaybeX a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure (a -> b -> c
    f a
    a b
    b)
      liftA2 a -> b -> c
    _ (IsX_ String
    msg)     MaybeX b
    _              = String -> MaybeX c
    forall a. String -> MaybeX a
    IsX_ String
    msg
      liftA2 a -> b -> c
    _ MaybeX a
    _              (IsX_ String
    msg)     = String -> MaybeX c
    forall a. String -> MaybeX a
    IsX_ String
    msg

    -- | Construct a 'MaybeX' value. If @a@ evaluates to 'Clash.XException.XException',
    -- this function will return 'IsX'. Otherwise, it will return 'IsDefined'.
    toMaybeX :: a -> MaybeX a
    toMaybeX :: forall a. a -> MaybeX a
    toMaybeX = a -> MaybeX a
    forall a. a -> MaybeX a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure

    -- | Construct a 'MaybeX' value. If 'hasX' evaluates to 'Left', this function
    -- will return 'IsX'. Otherwise, it will return 'IsDefined'.
    hasXToMaybeX :: (NFDataX a, NFData a) => a -> MaybeX a
    hasXToMaybeX :: forall a. (NFDataX a, NFData a) => a -> MaybeX a
    hasXToMaybeX = (String -> MaybeX a)
    -> (a -> MaybeX a) -> Either String a -> MaybeX a
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either String -> MaybeX a
    forall a. String -> MaybeX a
    IsX_ a -> MaybeX a
    forall a. a -> MaybeX a
    IsDefined_ (Either String a -> MaybeX a)
    -> (a -> Either String a) -> a -> MaybeX a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> Either String a
    forall a. (NFData a, NFDataX a) => a -> Either String a
    hasX

    -- | Deconstruct 'MaybeX' into an @a@ - the opposite of 'toMaybeX'. Be careful
    -- when using this function, because it might return an 'Clash.XException.XException'
    -- if the argument was 'IsX'.
    fromMaybeX :: MaybeX a -> a
    fromMaybeX :: forall a. MaybeX a -> a
    fromMaybeX = (String -> a) -> (a -> a) -> MaybeX a -> a
    forall b a. (String -> b) -> (a -> b) -> MaybeX a -> b
    maybeX (XException -> a
    forall a e. (HasCallStack, Exception e) => e -> a
    throw (XException -> a) -> (String -> XException) -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> XException
    XException) a -> a
    forall a. a -> a
    id

    -- | Map functions over both constructors.
    maybeX :: (String -> b) -> (a -> b) -> MaybeX a -> b
    maybeX :: forall b a. (String -> b) -> (a -> b) -> MaybeX a -> b
    maybeX String -> b
    f a -> b
    _ (IsX_ String
    msg)     = String -> b
    f String
    msg
    maybeX String -> b
    _ a -> b
    g (IsDefined_ a
    a) = a -> b
    g a
    a

    -- | Implements '&&' accounting for X
    --
    -- +-------------------------+-------------------------+-------------------------+-------------------------+
    -- |                         | &#x2003;__@X@__&#x2003; | &#x2003;__@1@__&#x2003; | &#x2003;__@0@__&#x2003; |
    -- +-------------------------+-------------------------+-------------------------+-------------------------+
    -- | &#x2003;__@X@__&#x2003; | &#x2003;@X@&#x2003;     | &#x2003;@X@&#x2003;     | &#x2003;@0@&#x2003;     |
    -- +-------------------------+-------------------------+-------------------------+-------------------------+
    -- | &#x2003;__@1@__&#x2003; | &#x2003;@X@&#x2003;     | &#x2003;@1@&#x2003;     | &#x2003;@0@&#x2003;     |
    -- +-------------------------+-------------------------+-------------------------+-------------------------+
    -- | &#x2003;__@0@__&#x2003; | &#x2003;@0@&#x2003;     | &#x2003;@0@&#x2003;     | &#x2003;@0@&#x2003;     |
    -- +-------------------------+-------------------------+-------------------------+-------------------------+

    -- (This is not part of the Haddock, a more readable version of the table
    -- above)
    --    | X | 1 | 0
    -- ---|---|---|---
    --  X | X | X | 0
    --  1 | X | 1 | 0
    --  0 | 0 | 0 | 0
    andX :: MaybeX Bool -> MaybeX Bool -> MaybeX Bool
    andX :: MaybeX Bool -> MaybeX Bool -> MaybeX Bool
    andX (IsDefined_ Bool
    False) MaybeX Bool
    _                  = Bool -> MaybeX Bool
    forall a. a -> MaybeX a
    IsDefined_ Bool
    False
    andX MaybeX Bool
    _                  (IsDefined_ Bool
    False) = Bool -> MaybeX Bool
    forall a. a -> MaybeX a
    IsDefined_ Bool
    False
    andX (IsDefined_ Bool
    True)  (IsDefined_ Bool
    True)  = Bool -> MaybeX Bool
    forall a. a -> MaybeX a
    IsDefined_ Bool
    True
    andX (IsX_ String
    msg)         MaybeX Bool
    _                  = String -> MaybeX Bool
    forall a. String -> MaybeX a
    IsX_ String
    msg
    andX MaybeX Bool
    _                  (IsX_ String
    msg)         = String -> MaybeX Bool
    forall a. String -> MaybeX a
    IsX_ String
    msg
    infixr 3 `andX`

    -- | Implements '||' accounting for X
    --
    -- +-------------------------+-------------------------+-------------------------+-------------------------+
    -- |                         | &#x2003;__@X@__&#x2003; | &#x2003;__@1@__&#x2003; | &#x2003;__@0@__&#x2003; |
    -- +-------------------------+-------------------------+-------------------------+-------------------------+
    -- | &#x2003;__@X@__&#x2003; | &#x2003;X&#x2003;       | &#x2003;1&#x2003;       | &#x2003;X&#x2003;       |
    -- +-------------------------+-------------------------+-------------------------+-------------------------+
    -- | &#x2003;__@1@__&#x2003; | &#x2003;1&#x2003;       | &#x2003;1&#x2003;       | &#x2003;1&#x2003;       |
    -- +-------------------------+-------------------------+-------------------------+-------------------------+
    -- | &#x2003;__@0@__&#x2003; | &#x2003;X&#x2003;       | &#x2003;1&#x2003;       | &#x2003;0&#x2003;       |
    -- +-------------------------+-------------------------+-------------------------+-------------------------+

    -- (This is not part of the Haddock, a more readable version of the table
    -- above)
    --    | X | 1 | 0
    -- ---|---|---|---
    --  X | X | 1 | X
    --  1 | 1 | 1 | 1
    --  0 | X | 1 | 0
    orX :: MaybeX Bool -> MaybeX Bool -> MaybeX Bool
    orX :: MaybeX Bool -> MaybeX Bool -> MaybeX Bool
    orX (IsDefined_ Bool
    True)  MaybeX Bool
    _                  = Bool -> MaybeX Bool
    forall a. a -> MaybeX a
    IsDefined_ Bool
    True
    orX MaybeX Bool
    _                  (IsDefined_ Bool
    True)  = Bool -> MaybeX Bool
    forall a. a -> MaybeX a
    IsDefined_ Bool
    True
    orX (IsDefined_ Bool
    False) (IsDefined_ Bool
    False) = Bool -> MaybeX Bool
    forall a. a -> MaybeX a
    IsDefined_ Bool
    False
    orX (IsX_ String
    msg)         MaybeX Bool
    _                  = String -> MaybeX Bool
    forall a. String -> MaybeX a
    IsX_ String
    msg
    orX MaybeX Bool
    _                  (IsX_ String
    msg)         = String -> MaybeX Bool
    forall a. String -> MaybeX a
    IsX_ String
    msg
    infixr 2 `orX`