{-# LANGUAGE Haskell2010                #-}
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE BinaryLiterals             #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveLift                 #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs               #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiWayIf                 #-}
{-# LANGUAGE NumericUnderscores         #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE PackageImports             #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE StrictData                 #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}

{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE TypeSynonymInstances       #-}

module Data.Multibase.Types.Internal.IsCodec.Kit
  ( module Data.Multibase.Types.Internal.IsCodec.Kit
  , module M
  ) where

import           Data.Bifunctor
import           Data.Coerce
import qualified Data.Text.Encoding              as TE
import           Data.Text.Encoding.Error
import qualified Data.Text.Lazy.Encoding         as LE
import qualified Data.Text.Short                 as ST
import           Data.Multibase.Types.Internal.Basic                  as M
import           Data.Multibase.Types.Internal.IsConvertible          as M
import           Data.Multibase.Types.Internal.MbAlgorithm            as M
import           Data.Multibase.Types.Internal.MbDecodeFailure        as M


mbAlgorithm       :: forall a . IsCodec a => Proxy a -> MbAlgorithm
mbDocs            :: forall a . IsCodec a => Proxy a -> CodecDocs

mbEncode          :: forall a . IsCodec a => ByteString      -> MbString a Text
mbLazyEncode      :: forall a . IsCodec a => ByteStringLazy  -> MbString a TextLazy
mbShortEncode     :: forall a . IsCodec a => ByteStringShort -> MbString a TextShort

mbEncode'         :: forall a . IsCodec a => ByteString      -> MbString a ByteString
mbLazyEncode'     :: forall a . IsCodec a => ByteStringLazy  -> MbString a ByteStringLazy
mbShortEncode'    :: forall a . IsCodec a => ByteStringShort -> MbString a ByteStringShort

mbTextEncode      :: forall a . IsCodec a => Text            -> MbString a Text
mbTextLazyEncode  :: forall a . IsCodec a => TextLazy        -> MbString a TextLazy
mbTextShortEncode :: forall a . IsCodec a => TextShort       -> MbString a TextShort

mbDecode          :: forall a . IsCodec a => MbString a Text            ~~> ByteString
mbLazyDecode      :: forall a . IsCodec a => MbString a TextLazy        ~~> ByteStringLazy
mbShortDecode     :: forall a . IsCodec a => MbString a TextShort       ~~> ByteStringShort

mbDecode'         :: forall a . IsCodec a => MbString a ByteString      ~~> ByteString
mbLazyDecode'     :: forall a . IsCodec a => MbString a ByteStringLazy  ~~> ByteStringLazy
mbShortDecode'    :: forall a . IsCodec a => MbString a ByteStringShort ~~> ByteStringShort

mbTextDecode      :: forall a . IsCodec a => MbString a Text            ~~> Text
mbTextLazyDecode  :: forall a . IsCodec a => MbString a TextLazy        ~~> TextLazy
mbTextShortDecode :: forall a . IsCodec a => MbString a TextShort       ~~> TextShort

isValidMb         :: forall a . IsCodec a => MbString a Text            -> Bool
isValidMbLazy     :: forall a . IsCodec a => MbString a TextLazy        -> Bool
isValidMbShort    :: forall a . IsCodec a => MbString a TextShort       -> Bool

isValidMb'        :: forall a . IsCodec a => MbString a ByteString      -> Bool
isValidMbLazy'    :: forall a . IsCodec a => MbString a ByteStringLazy  -> Bool
isValidMbShort'   :: forall a . IsCodec a => MbString a ByteStringShort -> Bool

testVectors       :: forall a . IsCodec a => [TestVector a]

mbAlgorithm       = _icm_algorithm         . isCodecM
mbDocs            = _icm_docs              . isCodecM
mbEncode          = _icm_mbEncode          $ isCodecM $ Proxy @a
mbLazyEncode      = _icm_mbLazyEncode      $ isCodecM $ Proxy @a
mbShortEncode     = _icm_mbShortEncode     $ isCodecM $ Proxy @a
mbEncode'         = _icm_mbEncode'         $ isCodecM $ Proxy @a
mbLazyEncode'     = _icm_mbLazyEncode'     $ isCodecM $ Proxy @a
mbShortEncode'    = _icm_mbShortEncode'    $ isCodecM $ Proxy @a
mbTextEncode      = _icm_mbTextEncode      $ isCodecM $ Proxy @a
mbTextLazyEncode  = _icm_mbTextLazyEncode  $ isCodecM $ Proxy @a
mbTextShortEncode = _icm_mbTextShortEncode $ isCodecM $ Proxy @a
mbDecode          = _icm_mbDecode          $ isCodecM $ Proxy @a
mbLazyDecode      = _icm_mbLazyDecode      $ isCodecM $ Proxy @a
mbShortDecode     = _icm_mbShortDecode     $ isCodecM $ Proxy @a
mbDecode'         = _icm_mbDecode'         $ isCodecM $ Proxy @a
mbLazyDecode'     = _icm_mbLazyDecode'     $ isCodecM $ Proxy @a
mbShortDecode'    = _icm_mbShortDecode'    $ isCodecM $ Proxy @a
mbTextDecode      = _icm_mbTextDecode      $ isCodecM $ Proxy @a
mbTextLazyDecode  = _icm_mbTextLazyDecode  $ isCodecM $ Proxy @a
mbTextShortDecode = _icm_mbTextShortDecode $ isCodecM $ Proxy @a
isValidMb         = _icm_isValidMb         $ isCodecM $ Proxy @a
isValidMbLazy     = _icm_isValidMbLazy     $ isCodecM $ Proxy @a
isValidMbShort    = _icm_isValidMbShort    $ isCodecM $ Proxy @a
isValidMb'        = _icm_isValidMb'        $ isCodecM $ Proxy @a
isValidMbLazy'    = _icm_isValidMbLazy'    $ isCodecM $ Proxy @a
isValidMbShort'   = _icm_isValidMbShort'   $ isCodecM $ Proxy @a
testVectors       = _icm_testVectors       $ isCodecM $ Proxy @a

{-# INLINE mbAlgorithm       #-}
{-# INLINE mbDocs            #-}
{-# INLINE mbEncode          #-}
{-# INLINE mbLazyEncode      #-}
{-# INLINE mbShortEncode     #-}
{-# INLINE mbEncode'         #-}
{-# INLINE mbLazyEncode'     #-}
{-# INLINE mbShortEncode'    #-}
{-# INLINE mbTextEncode      #-}
{-# INLINE mbTextLazyEncode  #-}
{-# INLINE mbTextShortEncode #-}
{-# INLINE mbDecode          #-}
{-# INLINE mbLazyDecode      #-}
{-# INLINE mbShortDecode     #-}
{-# INLINE mbDecode'         #-}
{-# INLINE mbLazyDecode'     #-}
{-# INLINE mbShortDecode'    #-}
{-# INLINE mbTextDecode      #-}
{-# INLINE mbTextLazyDecode  #-}
{-# INLINE mbTextShortDecode #-}
{-# INLINE isValidMb         #-}
{-# INLINE isValidMbLazy     #-}
{-# INLINE isValidMbShort    #-}
{-# INLINE isValidMb'        #-}
{-# INLINE isValidMbLazy'    #-}
{-# INLINE isValidMbShort'   #-}
{-# INLINE testVectors       #-}

class (IsCodecEncoding a,Show a,Typeable a) => IsCodec a where
  isCodecM :: Proxy a -> IsCodecM a

data IsCodecM a =
  IsCodecM
    { _icm_algorithm         :: MbAlgorithm
    , _icm_docs              :: CodecDocs

    , _icm_mbEncode          :: ByteString      -> MbString a Text
    , _icm_mbLazyEncode      :: ByteStringLazy  -> MbString a TextLazy
    , _icm_mbShortEncode     :: ByteStringShort -> MbString a TextShort

    , _icm_mbEncode'         :: ByteString      -> MbString a ByteString
    , _icm_mbLazyEncode'     :: ByteStringLazy  -> MbString a ByteStringLazy
    , _icm_mbShortEncode'    :: ByteStringShort -> MbString a ByteStringShort

    , _icm_mbTextEncode      :: Text            -> MbString a Text
    , _icm_mbTextLazyEncode  :: TextLazy        -> MbString a TextLazy
    , _icm_mbTextShortEncode :: TextShort       -> MbString a TextShort

    , _icm_mbDecode          :: MbString a Text            ~~> ByteString
    , _icm_mbLazyDecode      :: MbString a TextLazy        ~~> ByteStringLazy
    , _icm_mbShortDecode     :: MbString a TextShort       ~~> ByteStringShort

    , _icm_mbDecode'         :: MbString a ByteString      ~~> ByteString
    , _icm_mbLazyDecode'     :: MbString a ByteStringLazy  ~~> ByteStringLazy
    , _icm_mbShortDecode'    :: MbString a ByteStringShort ~~> ByteStringShort

    , _icm_mbTextDecode      :: MbString a Text            ~~> Text
    , _icm_mbTextLazyDecode  :: MbString a TextLazy        ~~> TextLazy
    , _icm_mbTextShortDecode :: MbString a TextShort       ~~> TextShort

    , _icm_isValidMb         :: MbString a Text            -> Bool
    , _icm_isValidMbLazy     :: MbString a TextLazy        -> Bool
    , _icm_isValidMbShort    :: MbString a TextShort       -> Bool

    , _icm_isValidMb'        :: MbString a ByteString      -> Bool
    , _icm_isValidMbLazy'    :: MbString a ByteStringLazy  -> Bool
    , _icm_isValidMbShort'   :: MbString a ByteStringShort -> Bool

    , _icm_testVectors       :: [TestVector a]
    }

type (~~>) a b = a -> Either MbDecodeFailure b

type IsCodecEncoding a = Coercible a Text

newtype MbString a b = 
  MbString
    { getMbString :: b
    }
  deriving stock (Eq,Ord,Show)

instance Bifunctor MbString where
  bimap _ g (MbString s) = MbString $ g s

mbText :: forall a . IsCodecEncoding a => a -> Text
mbText = coerce
{-# INLINE mbText #-}


noCodecM :: (IsCodecEncoding a,Show a,Typeable a) => MbAlgorithm -> Proxy a -> IsCodecM a
noCodecM mba _ =
  IsCodecM
    { _icm_algorithm         = mba
    , _icm_docs              = noCodecDocs mba

    , _icm_mbEncode          = const nope
    , _icm_mbLazyEncode      = const nope
    , _icm_mbShortEncode     = const nope

    , _icm_mbEncode'         = const nope
    , _icm_mbLazyEncode'     = const nope
    , _icm_mbShortEncode'    = const nope

    , _icm_mbTextEncode      = const nope
    , _icm_mbTextLazyEncode  = const nope
    , _icm_mbTextShortEncode = const nope

    , _icm_mbDecode          = const nope
    , _icm_mbLazyDecode      = const nope
    , _icm_mbShortDecode     = const nope

    , _icm_mbDecode'         = const nope
    , _icm_mbLazyDecode'     = const nope
    , _icm_mbShortDecode'    = const nope

    , _icm_mbTextDecode      = const nope
    , _icm_mbTextLazyDecode  = const nope
    , _icm_mbTextShortDecode = const nope

    , _icm_isValidMb         = const nope
    , _icm_isValidMbLazy     = const nope
    , _icm_isValidMbShort    = const nope

    , _icm_isValidMb'        = const nope
    , _icm_isValidMbLazy'    = const nope
    , _icm_isValidMbShort'   = const nope

    , _icm_testVectors       = []
    }
  where
    nope :: a
    nope = error $ "codec not implemented yet: " ++ show mba


----------------------------------------------------------------------------------------------------
-- codecComplete
----------------------------------------------------------------------------------------------------

-- | a codec is considered complete when it has test vectors
isCodecComplete :: forall a . IsCodec a => Proxy a -> Bool
isCodecComplete = not . null . tv
  where
    tv :: Proxy a -> [TestVector a]
    tv _ = testVectors


----------------------------------------------------------------------------------------------------
-- CodecDocs
----------------------------------------------------------------------------------------------------

data CodecDocs =
  CodecDocs
    { _cdocs_url         :: Text
    , _cdocs_summary     :: Text
    , _cdocs_text_based  :: Bool
    , _cdocs_has_lazy    :: Bool
    , _cdocs_has_short   :: Bool
    , _cdocs_pipelines   :: [MbPipeline]
    }
  deriving (Show)

noCodecDocs :: MbAlgorithm -> CodecDocs
noCodecDocs mba =
  CodecDocs
    { _cdocs_url         = fromString $ "http://" ++ show mba
    , _cdocs_summary     = fromString $ "The vapourware codec " ++ show mba
    , _cdocs_text_based  = True
    , _cdocs_has_lazy    = False
    , _cdocs_has_short   = False
    , _cdocs_pipelines   = [MP_Text]
    }


----------------------------------------------------------------------------------------------------
-- TestVector
----------------------------------------------------------------------------------------------------

data TestVector a =
  TestVector
    { _tstv_encdg :: Text
    , _tstv_plain :: Decoding a
    }
  deriving stock (Functor,Show)

data Decoding a
  = InvalidInput
  | DecodeFailure
  | ValidDocode (MbString a ByteString)
  deriving stock (Eq,Ord,Show)

instance Functor Decoding where
  fmap f = \case
    InvalidInput    -> InvalidInput
    DecodeFailure   -> DecodeFailure
    ValidDocode x   -> ValidDocode $ first f x

validDecodeTV :: ByteString -> Text -> TestVector a
validDecodeTV bs tx = TestVector tx $ ValidDocode $ MbString bs

invalidInputTV :: Text -> TestVector a
invalidInputTV tx = TestVector tx InvalidInput

decodeFailTV :: Text -> TestVector a
decodeFailTV tx = TestVector tx DecodeFailure


----------------------------------------------------------------------------------------------------
-- generic conversion functions
----------------------------------------------------------------------------------------------------

mbTextEncode' :: IsCodec a => Text -> MbString a ByteString
mbTextEncode' = mbEncode' . TE.encodeUtf8
{-# INLINE mbTextEncode' #-}

mbTextLazyEncode' :: IsCodec a => TextLazy -> MbString a ByteStringLazy
mbTextLazyEncode' = mbLazyEncode' . LE.encodeUtf8
{-# INLINE mbTextLazyEncode' #-}

mbTextShortEncode' :: IsCodec a => TextShort -> MbString a ByteStringShort
mbTextShortEncode' = mbShortEncode' . ST.toShortByteString
{-# INLINE mbTextShortEncode' #-}

mbTextDecode' :: IsCodec a => MbString a ByteString ~~> Text
mbTextDecode' = compose_decodes mbDecode' TE.decodeUtf8'
{-# INLINE mbTextDecode' #-}

mbTextLazyDecode' :: IsCodec a => MbString a ByteStringLazy ~~> TextLazy
mbTextLazyDecode' = compose_decodes mbLazyDecode' LE.decodeUtf8'
{-# INLINE mbTextLazyDecode' #-}

mbTextShortDecode' :: IsCodec a => MbString a ByteStringShort ~~> TextShort
mbTextShortDecode' = compose_decodes mbShortDecode' from_short_bs
{-# INLINE mbTextShortDecode' #-}


----------------------------------------------------------------------------------------------------
-- generic input checkers
----------------------------------------------------------------------------------------------------

isMb         :: forall a . IsCodec a => MbString a Text            -> Bool
isMbLazy     :: forall a . IsCodec a => MbString a TextLazy        -> Bool
isMbShort    :: forall a . IsCodec a => MbString a TextShort       -> Bool
isMb'        :: forall a . IsCodec a => MbString a ByteString      -> Bool
isMbLazy'    :: forall a . IsCodec a => MbString a ByteStringLazy  -> Bool
isMbShort'   :: forall a . IsCodec a => MbString a ByteStringShort -> Bool

isMb         = check_is_mb isValidMb       mbDecode
isMbLazy     = check_is_mb isValidMbLazy   mbLazyDecode
isMbShort    = check_is_mb isValidMbShort  mbShortDecode
isMb'        = check_is_mb isValidMb'      mbDecode'
isMbLazy'    = check_is_mb isValidMbLazy'  mbLazyDecode'
isMbShort'   = check_is_mb isValidMbShort' mbShortDecode'

{-# INLINE isMb       #-}
{-# INLINE isMbLazy   #-}
{-# INLINE isMbShort  #-}
{-# INLINE isMb'      #-}
{-# INLINE isMbLazy'  #-}
{-# INLINE isMbShort' #-}

check_is_mb :: (a->Bool) -> (a->Either e r) -> a -> Bool
check_is_mb vdt dec x = if vdt x then either (const False) (const True) $ dec x else False


----------------------------------------------------------------------------------------------------
-- HasMbDocs, HasDocURL, DocURL
----------------------------------------------------------------------------------------------------

class HasDocURL a where
  yieldDocURL :: Proxy a -> DocURL

type DocURL = Text


----------------------------------------------------------------------------------------------------
-- HasTextDecoder
----------------------------------------------------------------------------------------------------

class HasTextDecoder b t where
  decodeText :: b -> Either MbDecodeFailure t

instance HasTextDecoder ByteString      Text      where decodeText = mapLeft MBDF_unicode_decode . TE.decodeUtf8'
instance HasTextDecoder ByteStringLazy  TextLazy  where decodeText = mapLeft MBDF_unicode_decode . LE.decodeUtf8'

instance HasTextDecoder ByteStringShort TextShort where 
  decodeText = maybe urk Right . ST.fromShortByteString
    where
      urk = Left $ MBDF_unicode_decode $ DecodeError "UTF-8 decode error" Nothing


----------------------------------------------------------------------------------------------------
-- useTextDecoder, fromRawDecode, fromRawValidator
----------------------------------------------------------------------------------------------------

class IsCodecErrorText t where
  codecErrorText :: t -> Text

instance IsCodecErrorText Text where codecErrorText = id

useTextDecoder :: forall a i i' b t e . 
    ( IsCodec             a
    , IsConvertible    i' i
    , IsCodecErrorText    e
    , HasTextDecoder b    t
    ) => Proxy a
      -> (i->Either e b)
      -> MbString a i' -> Either MbDecodeFailure t
useTextDecoder _ dec (MbString i') = either (Left . urk) decodeText $ dec i
  where
    urk :: e -> MbDecodeFailure
    urk msg = MBDF_codec $
      MbDecoderFailure
        { _mbdf_input_text  = summarizeTextInput i' i
        , _mbdf_message     = codecErrorText msg
        }

    i :: i
    i = convertText i'

fromRawDecoder :: forall a i i' o o' e . 
    ( IsCodec             a
    , IsConvertible    i' i
    , IsCodecErrorText    e
    , IsConvertible    o  o'
    ) => Proxy a
      -> (i->Either e o)
      -> MbString a i' -> Either MbDecodeFailure o'
fromRawDecoder _ dec (MbString i') = fmap convertText $ mapLeft urk $ dec i
  where
    urk :: e -> MbDecodeFailure
    urk msg = MBDF_codec $
      MbDecoderFailure
        { _mbdf_input_text  = summarizeTextInput i' i
        , _mbdf_message     = codecErrorText msg
        }

    i :: i
    i = convertText i'

fromRawValidator :: forall a i i' . 
    ( IsCodec    a
    , IsConvertible  i' i
    ) => Proxy a
      -> (i->Bool)
      -> MbString a i' -> Bool
fromRawValidator _ val (MbString i') = val $ convertText i'


----------------------------------------------------------------------------------------------------
-- decode helpers
----------------------------------------------------------------------------------------------------

compose_decodes :: (MbString a bs ~~> bs)
                -> (bs -> Either UnicodeException t)
                -> MbString a bs ~~> t
compose_decodes dec udec mbstr = do
    bs <- dec mbstr
    case udec bs of
      Left ue -> Left $ MBDF_unicode_decode ue
      Right t -> Right t

from_short_bs :: ByteStringShort -> Either UnicodeException TextShort
from_short_bs = maybe (Left urk) Right . ST.fromShortByteString
  where
    urk :: UnicodeException
    urk = DecodeError "bad UTF8 stream" Nothing


----------------------------------------------------------------------------------------------------
-- mapLeft
----------------------------------------------------------------------------------------------------

mapLeft :: (a -> a') -> Either a b -> Either a' b
mapLeft f (Left  a) = Left $ f a
mapLeft _ (Right b) = Right    b

-- makeLenses ''IsCodecM