{-|
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) -> (Void# -> 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) -> (Void# -> 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 :: (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 (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 :: 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 :: (a -> b -> c) -> MaybeX a -> MaybeX b -> MaybeX c
liftA2 a -> b -> c
f (IsDefined_ a
a) (IsDefined_ b
b) = c -> MaybeX c
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 :: a -> MaybeX a
toMaybeX = 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 :: 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 :: 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. 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 :: (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`