content: {-|
  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 d = \case
      IsX_ msg     -> showParen (d > 10) $ showString "IsX "       . showsPrec 11 msg
      IsDefined_ a -> showParen (d > 10) $ showString "IsDefined " . showsPrec 11 a
  
  -- | Upon construction, @a@ evaluated to 'Clash.XException.XException'
  pattern IsX :: forall a. String -> MaybeX a
  pattern IsX msg <- IsX_ msg
  
  -- | Upon construction, @a@ evaluated to a non-bottom WHNF
  pattern IsDefined :: forall a. a -> MaybeX a
  pattern 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 _f (IsX_ msg) = IsX_ msg
    fmap f  (IsDefined_ a) = pure (f 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 = either IsX_ IsDefined_ . isX
  
    liftA2 f (IsDefined_ a) (IsDefined_ b) = pure (f a b)
    liftA2 _ (IsX_ msg)     _              = IsX_ msg
    liftA2 _ _              (IsX_ msg)     = IsX_ 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 = 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 = either IsX_ IsDefined_ . 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 = maybeX (throw . XException) id
  
  -- | Map functions over both constructors.
  maybeX :: (String -> b) -> (a -> b) -> MaybeX a -> b
  maybeX f _ (IsX_ msg)     = f msg
  maybeX _ g (IsDefined_ a) = g 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 (IsDefined_ False) _                  = IsDefined_ False
  andX _                  (IsDefined_ False) = IsDefined_ False
  andX (IsDefined_ True)  (IsDefined_ True)  = IsDefined_ True
  andX (IsX_ msg)         _                  = IsX_ msg
  andX _                  (IsX_ msg)         = IsX_ 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 (IsDefined_ True)  _                  = IsDefined_ True
  orX _                  (IsDefined_ True)  = IsDefined_ True
  orX (IsDefined_ False) (IsDefined_ False) = IsDefined_ False
  orX (IsX_ msg)         _                  = IsX_ msg
  orX _                  (IsX_ msg)         = IsX_ msg
  infixr 2 `orX`
  