{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Conversions where

import           Control.Applicative
import           Control.Bool                   ( guard' )
import           Control.Exception              ( Exception )
import           Control.Monad                  ( MonadPlus(..) )
import           Control.Monad.Catch            ( MonadThrow
                                                , throwM
                                                )
import           Control.Monad.Except           ( MonadError
                                                , throwError
                                                )
import           Data.Coerce                    ( Coercible
                                                , coerce
                                                )
import           Data.Int                       ( Int16
                                                , Int32
                                                , Int64
                                                , Int8
                                                )
import           Data.Text                      ( Text )
import           Data.Typeable                  ( Typeable )
import           Data.Word                      ( Word16
                                                , Word32
                                                , Word64
                                                , Word8
                                                )
import           Numeric.Natural                ( Natural )
import           Prelude                 hiding ( max
                                                , min
                                                )

import qualified Data.ByteString               as BS
import qualified Data.ByteString.Lazy          as LBS
import qualified Data.Text                     as Text
import qualified Data.Text.Encoding            as Text
import qualified Data.Text.Lazy                as Text.Lazy
import qualified GHC.Show                      as Show
import qualified Language.Haskell.TH.Syntax    as TH

data BoundError a b = (Bounded b, Show a, Show b) => BoundError a

instance Show.Show (BoundError a b) where
  show :: BoundError a b -> String
show (BoundError a
value) = a -> b -> b -> String
forall a b. (Show a, Show b) => a -> b -> b -> String
boundError a
value (Bounded b => b
forall a. Bounded a => a
minBound @b) (Bounded b => b
forall a. Bounded a => a
maxBound @b)

instance (Typeable a, Typeable b) => Exception (BoundError a b)

data UserBoundError a b = UserBoundError a b b
  deriving stock (Typeable)

instance (Show a, Show b) => Show.Show (UserBoundError a b) where
  show :: UserBoundError a b -> String
show (UserBoundError a
value b
min b
max) = a -> b -> b -> String
forall a b. (Show a, Show b) => a -> b -> b -> String
boundError a
value b
min b
max

instance (Show a, Show b, Typeable a, Typeable b) => Exception (UserBoundError a b)

class Conversion b a where
  convert :: a -> b

  default convert :: (Coercible a b) => a -> b
  convert = a -> b
coerce

instance (MonadError (UserBoundError Int Natural) m) => Conversion (m Natural) Int where
  convert :: Int -> m Natural
convert = Int -> m Natural
forall a (m :: * -> *).
(Integral a, Bounded a, MonadError (UserBoundError a Natural) m) =>
a -> m Natural
convertErrorFromIntegral

instance (MonadError (UserBoundError Int64 Natural) m) => Conversion (m Natural) Int64 where
  convert :: Int64 -> m Natural
convert = Int64 -> m Natural
forall a (m :: * -> *).
(Integral a, Bounded a, MonadError (UserBoundError a Natural) m) =>
a -> m Natural
convertErrorFromIntegral

instance (MonadError (UserBoundError Int32 Natural) m) => Conversion (m Natural) Int32 where
  convert :: Int32 -> m Natural
convert = Int32 -> m Natural
forall a (m :: * -> *).
(Integral a, Bounded a, MonadError (UserBoundError a Natural) m) =>
a -> m Natural
convertErrorFromIntegral

instance (MonadError (UserBoundError Int16 Natural) m) => Conversion (m Natural) Int16 where
  convert :: Int16 -> m Natural
convert = Int16 -> m Natural
forall a (m :: * -> *).
(Integral a, Bounded a, MonadError (UserBoundError a Natural) m) =>
a -> m Natural
convertErrorFromIntegral

instance (MonadError (UserBoundError Int8 Natural) m) => Conversion (m Natural) Int8 where
  convert :: Int8 -> m Natural
convert = Int8 -> m Natural
forall a (m :: * -> *).
(Integral a, Bounded a, MonadError (UserBoundError a Natural) m) =>
a -> m Natural
convertErrorFromIntegral

instance (MonadError (UserBoundError Word Natural) m) => Conversion (m Natural) Word where
  convert :: Word -> m Natural
convert = Word -> m Natural
forall a (m :: * -> *).
(Integral a, Bounded a, MonadError (UserBoundError a Natural) m) =>
a -> m Natural
convertErrorFromIntegral

instance (MonadError (UserBoundError Word64 Natural) m) => Conversion (m Natural) Word64 where
  convert :: Word64 -> m Natural
convert = Word64 -> m Natural
forall a (m :: * -> *).
(Integral a, Bounded a, MonadError (UserBoundError a Natural) m) =>
a -> m Natural
convertErrorFromIntegral

instance (MonadError (UserBoundError Word32 Natural) m) => Conversion (m Natural) Word32 where
  convert :: Word32 -> m Natural
convert = Word32 -> m Natural
forall a (m :: * -> *).
(Integral a, Bounded a, MonadError (UserBoundError a Natural) m) =>
a -> m Natural
convertErrorFromIntegral

instance (MonadError (UserBoundError Word16 Natural) m) => Conversion (m Natural) Word16 where
  convert :: Word16 -> m Natural
convert = Word16 -> m Natural
forall a (m :: * -> *).
(Integral a, Bounded a, MonadError (UserBoundError a Natural) m) =>
a -> m Natural
convertErrorFromIntegral

instance (MonadError (UserBoundError Integer Text) m) => Conversion (m Natural) Integer where
  convert :: Integer -> m Natural
convert Integer
value = m Natural -> (Natural -> m Natural) -> Maybe Natural -> m Natural
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UserBoundError Integer Text -> m Natural
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (UserBoundError Integer Text -> m Natural)
-> UserBoundError Integer Text -> m Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Text -> Text -> UserBoundError Integer Text
forall a b. a -> b -> b -> UserBoundError a b
UserBoundError Integer
value Text
"0" Text
"Natural") Natural -> m Natural
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Maybe Natural -> m Natural) -> Maybe Natural -> m Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Natural
forall a b (m :: * -> *).
(MonadPlus m, Integral a, Integral b) =>
a -> m b
checkedFromIntegral Integer
value

instance (MonadError (UserBoundError Natural Int) m) => Conversion (m Int) Natural where
  convert :: Natural -> m Int
convert = Natural -> m Int
forall a (m :: * -> *).
(Integral a, Bounded a, MonadError (UserBoundError Natural a) m) =>
Natural -> m a
convertErrorFromNatural

instance (MonadError (UserBoundError Natural Int16) m) => Conversion (m Int16) Natural where
  convert :: Natural -> m Int16
convert = Natural -> m Int16
forall a (m :: * -> *).
(Integral a, Bounded a, MonadError (UserBoundError Natural a) m) =>
Natural -> m a
convertErrorFromNatural

instance (MonadError (UserBoundError Natural Int32) m) => Conversion (m Int32) Natural where
  convert :: Natural -> m Int32
convert = Natural -> m Int32
forall a (m :: * -> *).
(Integral a, Bounded a, MonadError (UserBoundError Natural a) m) =>
Natural -> m a
convertErrorFromNatural

instance (MonadError (UserBoundError Natural Int64) m) => Conversion (m Int64) Natural where
  convert :: Natural -> m Int64
convert = Natural -> m Int64
forall a (m :: * -> *).
(Integral a, Bounded a, MonadError (UserBoundError Natural a) m) =>
Natural -> m a
convertErrorFromNatural

instance Conversion a a where
  convert :: a -> a
convert = a -> a
forall a. a -> a
id

instance Conversion Integer Int where
  convert :: Int -> Integer
convert = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Conversion Integer Word32 where
  convert :: Word32 -> Integer
convert = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Conversion Integer Word16 where
  convert :: Word16 -> Integer
convert = Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Conversion Integer Word8 where
  convert :: Word8 -> Integer
convert = Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Conversion Natural Word32 where
  convert :: Word32 -> Natural
convert = Word32 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Conversion Natural Word16 where
  convert :: Word16 -> Natural
convert = Word16 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Conversion Natural Word8 where
  convert :: Word8 -> Natural
convert = Word8 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance Conversion Integer Natural where
  convert :: Natural -> Integer
convert = Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance (MonadError (BoundError Integer Int) m) => Conversion (m Int) Integer where
  convert :: Integer -> m Int
convert = Integer -> m Int
forall a b (m :: * -> *).
(Integral a, Show a, Show b, Num b, Bounded b, Conversion a b,
 MonadError (BoundError a b) m) =>
a -> m b
convertBoundedFromIntegral

instance (MonadError (BoundError Integer Word32) m) => Conversion (m Word32)  Integer where
  convert :: Integer -> m Word32
convert = Integer -> m Word32
forall a b (m :: * -> *).
(Integral a, Show a, Show b, Num b, Bounded b, Conversion a b,
 MonadError (BoundError a b) m) =>
a -> m b
convertBoundedFromIntegral

instance (MonadError (BoundError Integer Word16) m) => Conversion (m Word16) Integer where
  convert :: Integer -> m Word16
convert = Integer -> m Word16
forall a b (m :: * -> *).
(Integral a, Show a, Show b, Num b, Bounded b, Conversion a b,
 MonadError (BoundError a b) m) =>
a -> m b
convertBoundedFromIntegral

instance (MonadError (BoundError Integer Word8) m) => Conversion (m Word8) Integer where
  convert :: Integer -> m Word8
convert = Integer -> m Word8
forall a b (m :: * -> *).
(Integral a, Show a, Show b, Num b, Bounded b, Conversion a b,
 MonadError (BoundError a b) m) =>
a -> m b
convertBoundedFromIntegral

instance Conversion LBS.ByteString BS.ByteString where
  convert :: ByteString -> ByteString
convert = ByteString -> ByteString
LBS.fromStrict

instance Conversion BS.ByteString LBS.ByteString where
  convert :: ByteString -> ByteString
convert = ByteString -> ByteString
LBS.toStrict

instance Conversion BS.ByteString Text where
  convert :: Text -> ByteString
convert = Text -> ByteString
Text.encodeUtf8

instance Conversion Text.Lazy.Text Text where
  convert :: Text -> Text
convert = Text -> Text
Text.Lazy.fromStrict

instance Conversion Text Text.Lazy.Text where
  convert :: Text -> Text
convert = Text -> Text
Text.Lazy.toStrict

instance Conversion Text String where
  convert :: String -> Text
convert = String -> Text
Text.pack

instance Conversion String Text where
  convert :: Text -> String
convert = Text -> String
Text.unpack

type ToText a = Conversion Text a

convertText :: forall a b . (Conversion Text a, Conversion b Text) => a -> b
convertText :: a -> b
convertText = forall a. Conversion b a => a -> b
forall b a. Conversion b a => a -> b
convert @b (Text -> b) -> (a -> Text) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Conversion Text a => a -> Text
forall b a. Conversion b a => a -> b
convert @Text

convertErrorFromNatural
  :: forall a m
   . (Integral a, Bounded a, MonadError (UserBoundError Natural a) m)
  => Natural
  -> m a
convertErrorFromNatural :: Natural -> m a
convertErrorFromNatural Natural
value =
  m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UserBoundError Natural a -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (UserBoundError Natural a -> m a)
-> UserBoundError Natural a -> m a
forall a b. (a -> b) -> a -> b
$ Natural -> a -> a -> UserBoundError Natural a
forall a b. a -> b -> b -> UserBoundError a b
UserBoundError Natural
value a
forall a. Bounded a => a
minBound a
forall a. Bounded a => a
maxBound) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Maybe a -> m a) -> Maybe a -> m a
forall a b. (a -> b) -> a -> b
$ Natural -> Maybe a
forall a b (m :: * -> *).
(MonadPlus m, Integral a, Integral b) =>
a -> m b
checkedFromIntegral Natural
value

convertErrorFromIntegral
  :: forall a m
   . (Integral a, Bounded a, MonadError (UserBoundError a Natural) m)
  => a
  -> m Natural
convertErrorFromIntegral :: a -> m Natural
convertErrorFromIntegral a
value =
  m Natural -> (Natural -> m Natural) -> Maybe Natural -> m Natural
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (UserBoundError a Natural -> m Natural
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (UserBoundError a Natural -> m Natural)
-> UserBoundError a Natural -> m Natural
forall a b. (a -> b) -> a -> b
$ a -> Natural -> Natural -> UserBoundError a Natural
forall a b. a -> b -> b -> UserBoundError a b
UserBoundError a
value Natural
0 Natural
maxBound') Natural -> m Natural
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Maybe Natural -> m Natural) -> Maybe Natural -> m Natural
forall a b. (a -> b) -> a -> b
$ a -> Maybe Natural
forall a b (m :: * -> *).
(MonadPlus m, Integral a, Integral b) =>
a -> m b
checkedFromIntegral a
value
 where
  maxBound' :: Natural
  maxBound' :: Natural
maxBound' = a -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Natural) -> a -> Natural
forall a b. (a -> b) -> a -> b
$ Bounded a => a
forall a. Bounded a => a
maxBound @a

convertBoundedFromIntegral
  :: forall a b m
   . ( Integral a
     , Show a
     , Show b
     , Num b
     , Bounded b
     , Conversion a b
     , MonadError (BoundError a b) m
     )
  => a
  -> m b
convertBoundedFromIntegral :: a -> m b
convertBoundedFromIntegral a
value =
  if b -> a
forall b a. Conversion b a => a -> b
convert (Bounded b => b
forall a. Bounded a => a
minBound @b) a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
value Bool -> Bool -> Bool
&& a
value a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= b -> a
forall b a. Conversion b a => a -> b
convert (Bounded b => b
forall a. Bounded a => a
maxBound @b)
    then b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> m b) -> b -> m b
forall a b. (a -> b) -> a -> b
$ a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
value
    else BoundError a b -> m b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (BoundError a b -> m b) -> BoundError a b -> m b
forall a b. (a -> b) -> a -> b
$ a -> BoundError a b
forall a b. (Bounded b, Show a, Show b) => a -> BoundError a b
BoundError a
value

checkedFromIntegral
  :: forall a b m . (MonadPlus m, Integral a, Integral b) => a -> m b
checkedFromIntegral :: a -> m b
checkedFromIntegral a
value = Bool -> b -> m b
forall (m :: * -> *) a. MonadPlus m => Bool -> a -> m a
guard' (b -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
converted a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
value) b
converted
 where
  converted :: b
  converted :: b
converted = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
value

convertEither :: forall b a e . (Conversion (Either e b) a) => a -> Either e b
convertEither :: a -> Either e b
convertEither = a -> Either e b
forall b a. Conversion b a => a -> b
convert

convertUnsafe :: forall b a e . (Conversion (Either e b) a, Show e) => a -> b
convertUnsafe :: a -> b
convertUnsafe = (e -> b) -> (b -> b) -> Either e b -> b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> (e -> String) -> e -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show) b -> b
forall a. a -> a
id (Either e b -> b) -> (a -> Either e b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conversion (Either e b) a => a -> Either e b
forall b a e. Conversion (Either e b) a => a -> Either e b
convertEither @b @a @e

convertThrow
  :: forall b a e m
   . (Conversion (Either e b) a, Exception e, MonadThrow m)
  => a
  -> m b
convertThrow :: a -> m b
convertThrow = (e -> m b) -> (b -> m b) -> Either e b -> m b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e b -> m b) -> (a -> Either e b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conversion (Either e b) a => a -> Either e b
forall b a e. Conversion (Either e b) a => a -> Either e b
convertEither @b @a @e

convertFail
  :: forall b a e m
   . (Conversion (Either e b) a, Show e, MonadFail m)
  => a
  -> m b
convertFail :: a -> m b
convertFail = (e -> m b) -> (b -> m b) -> Either e b -> m b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m b
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m b) -> (e -> String) -> e -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall a. Show a => a -> String
show) b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e b -> m b) -> (a -> Either e b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conversion (Either e b) a => a -> Either e b
forall b a e. Conversion (Either e b) a => a -> Either e b
convertEither @b @a @e

convertMaybe :: forall b a e . (Conversion (Either e b) a) => a -> Maybe b
convertMaybe :: a -> Maybe b
convertMaybe = (e -> Maybe b) -> (b -> Maybe b) -> Either e b -> Maybe b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe b -> e -> Maybe b
forall a b. a -> b -> a
const Maybe b
forall (f :: * -> *) a. Alternative f => f a
empty) b -> Maybe b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e b -> Maybe b) -> (a -> Either e b) -> a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conversion (Either e b) a => a -> Either e b
forall b a e. Conversion (Either e b) a => a -> Either e b
convertEither @b @a @e

boundError :: forall a b . (Show a, Show b) => a -> b -> b -> String
boundError :: a -> b -> b -> String
boundError a
value b
min b
max =
  String
"Value should be between "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> b -> String
forall a. Show a => a -> String
show b
min
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" and "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> b -> String
forall a. Show a => a -> String
show b
max
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" but was "
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
value

mkTH
  :: forall a b e
   . (TH.Lift b, Exception e, Conversion (Either e b) a)
  => a
  -> TH.Q (TH.TExp b)
mkTH :: a -> Q (TExp b)
mkTH a
input =
  Exp -> TExp b
forall a. Exp -> TExp a
TH.TExp (Exp -> TExp b) -> Q Exp -> Q (TExp b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SomeException -> Q Exp)
-> (b -> Q Exp) -> Either SomeException b -> Q Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp)
-> (SomeException -> String) -> SomeException -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show) b -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift (a -> Either SomeException b
forall b a e (m :: * -> *).
(Conversion (Either e b) a, Exception e, MonadThrow m) =>
a -> m b
convertThrow @b @a @e a
input)

toText :: ToText a => a -> Text
toText :: a -> Text
toText = a -> Text
forall b a. Conversion b a => a -> b
convert