{-# 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 TypeOperators              #-}
{-# LANGUAGE TypeSynonymInstances       #-}

module Data.Multibase.Types.Internal.MbAlgorithm 
  ( MbAlgorithm(..)
  , algorithmSelector
  , algorithmMultibaseName
  , MbAlgorithmDescriptor(..)
  , algorithmDescriptor
  , reverseLookupAlgorithm
  , MbEncodable(..)
  , MbDecodable(..)
  , validtMb
  ) where

import           Control.Applicative
import           Control.DeepSeq
import           Data.Array
import           Data.Coerce
import qualified Data.ByteString                    as BS
import           Data.ByteString.Internal(w2c)
import qualified Data.ByteString.Lazy               as LB
import qualified Data.ByteString.Short              as SB
import qualified Data.Text                          as TX
import qualified Data.Text.Encoding                 as TE
import qualified Data.Text.Lazy                     as LT
import qualified Data.Text.Lazy.Encoding            as TEL
import qualified Data.Text.Short                    as ST
import           Data.Word
import           GHC.Generics
import           Data.Multibase.Types.Internal.Basic
import           Data.Multibase.Types.Internal.MbDecodeFailure


data MbAlgorithm
  = MbIdentityBase
  | MbBase2
  | MbBase8
  | MbBase10
  | MbBase16Lower
  | MbBase16Upper
  | MbBase32HexNoPadLower
  | MbBase32HexNoPadUpper
  | MbBase32HexPadLower
  | MbBase32HexPadUpper
  | MbBase32NoPadLower
  | MbBase32NoPadUpper
  | MbBase32PadLower
  | MbBase32PadUpper
  | MbBase32z
  | MbBase36Lower
  | MbBase36Upper
  | MbBase58Btc
  | MbBase58Flickr
  | MbBase64NoPad
  | MbBase64Pad
  | MbBase64UrlNoPad
  | MbBase64urlPad
  | MbProquint
  | MbBase256Emoji
  deriving stock (Bounded,Enum,Eq,Ix,Generic,Lift,Ord,Show)
  deriving anyclass (NFData)

algorithmSelector :: MbAlgorithm -> Char
algorithmSelector = _mbad_code . algorithmDescriptor

algorithmMultibaseName :: MbAlgorithm -> Text
algorithmMultibaseName = _mbad_oname . algorithmDescriptor

data MbAlgorithmDescriptor =
  MbAlgorithmDescriptor
    { _mbad_code  :: Char
    , _mbad_name  :: Text
    , _mbad_oname :: Text
    }
  deriving (Show)

algorithmDescriptor :: MbAlgorithm -> MbAlgorithmDescriptor
algorithmDescriptor mba = case mba of
    MbIdentityBase        -> mk '\NUL' "identity"
    MbBase2               -> mk '0'    "base2"
    MbBase8               -> mk '7'    "base8"
    MbBase10              -> mk '9'    "base10"
    MbBase16Lower         -> mk 'f'    "base16"
    MbBase16Upper         -> mk 'F'    "base16upper"
    MbBase32HexNoPadLower -> mk 'v'    "base32hex"
    MbBase32HexNoPadUpper -> mk 'V'    "base32hexupper"
    MbBase32HexPadLower   -> mk 't'    "base32hexpad"
    MbBase32HexPadUpper   -> mk 'T'    "base32hexpadupper"
    MbBase32NoPadLower    -> mk 'b'    "base32"
    MbBase32NoPadUpper    -> mk 'B'    "base32upper"
    MbBase32PadLower      -> mk 'c'    "base32pad"
    MbBase32PadUpper      -> mk 'C'    "base32padupper"
    MbBase32z             -> mk 'h'    "base32z"
    MbBase36Lower         -> mk 'k'    "base36"
    MbBase36Upper         -> mk 'K'    "base36upper"
    MbBase58Btc           -> mk 'z'    "base58btc"
    MbBase58Flickr        -> mk 'Z'    "base58flickr"
    MbBase64NoPad         -> mk 'm'    "base64"
    MbBase64Pad           -> mk 'M'    "base64pad"
    MbBase64UrlNoPad      -> mk 'u'    "base64url"
    MbBase64urlPad        -> mk 'U'    "base64urlpad"
    MbProquint            -> mk 'p'    "proquint"
    MbBase256Emoji        -> mk '🚀'   "base256emoji"
  where
    mk :: Char -> Text -> MbAlgorithmDescriptor
    mk code oname = MbAlgorithmDescriptor
      { _mbad_code  = code
      , _mbad_name  = TX.pack $ drop 2 $ show mba
      , _mbad_oname = oname
      }


----------------------------------------------------------------------------------------------------
-- MbEncodable
----------------------------------------------------------------------------------------------------

class MbEncodable o where
  encodeMb :: forall i m . (Coercible o m)
            => (i->o)
            -> MbAlgorithm
            -> i
            -> m
  encodeMb enc mba = coerce . consEMB (algorithmSelector mba) . enc
  {-# INLINE encodeMb #-}

  consEMB :: Char -> o -> o

instance MbEncodable Text            where 
  consEMB     = \c -> (TX.singleton c<>) -- TX.cons
  {-# INLINE consEMB #-}
instance MbEncodable TextLazy        where 
  consEMB     = \c -> (LT.singleton c<>) -- LT.cons
  {-# INLINE consEMB #-}
instance MbEncodable TextShort       where  
  consEMB     = ST.cons
  {-# INLINE consEMB #-}
instance MbEncodable ByteString      where 
  consEMB c b = (TE.encodeUtf8 $ TX.singleton c) <> b
  {-# INLINE consEMB #-}
instance MbEncodable ByteStringLazy  where 
  consEMB c l = (TEL.encodeUtf8 $ LT.singleton c) <> l
  {-# INLINE consEMB #-}
instance MbEncodable ByteStringShort where 
  consEMB c s = (ST.toShortByteString $ ST.singleton c) <> s
  {-# INLINE consEMB #-}


----------------------------------------------------------------------------------------------------
-- MbDecodable
----------------------------------------------------------------------------------------------------

class MbDecodable a where
  decodeMb :: forall r m . Coercible m a
           => (a -> MbAlgorithm -> Either MbDecodeFailure r)
           -> m 
           -> Either MbDecodeFailure r

instance MbDecodable Text            where decodeMb dec m = decodeTX dec $ TX.uncons $ coerce m
instance MbDecodable TextLazy        where decodeMb dec m = decodeTX dec $ LT.uncons $ coerce m
instance MbDecodable TextShort       where decodeMb dec m = decodeTX dec $ ST.uncons $ coerce m
instance MbDecodable ByteString      where decodeMb       = decodeBS
instance MbDecodable ByteStringLazy  where decodeMb       = decodeBS
instance MbDecodable ByteStringShort where decodeMb       = decodeBS

validtMb :: forall a m . (MbDecodable a,Coercible m a)
           => (a -> MbAlgorithm -> Bool)
           -> m 
           -> Bool
validtMb vdt = either (const False) (const True) . decodeMb dec 
  where
    dec x mba = case vdt x mba of
      True  -> Right ()
      False -> Left MBDF_empty


----------------------------------------------------------------------------------------------------
-- decodeBS
----------------------------------------------------------------------------------------------------

decodeBS :: forall r m bs . (IsBS bs, Coercible m bs)
         => (bs -> MbAlgorithm -> Either MbDecodeFailure r)
         -> m 
         -> Either MbDecodeFailure r
decodeBS dec m = case unconsBS bs of
    Nothing -> decodeBS dec m
    Just (w,bs') -> case w<0x80 of
      True  -> decodeChar (dec bs') $ w2c w
      False -> decodeBS' dec m
  where
    bs :: bs
    bs = coerce m

decodeBS' :: forall r m bs . (IsBS bs, Coercible m bs)
          => (bs -> MbAlgorithm -> Either MbDecodeFailure r)
          -> m 
          -> Either MbDecodeFailure r
decodeBS' cont m = maybe urk (uncurry cont) $ asum $ map (uncurry trial) algo_assocs
  where
    urk :: Either MbDecodeFailure r
    urk = Left MBDF_codec_select_char

    trial :: Char -> MbAlgorithm -> Maybe (bs,MbAlgorithm)
    trial c mba = case c_bs == c_bs' of
        True  -> Just (bs',mba)
        False -> Nothing
      where
        c_bs', bs' :: bs
        (c_bs',bs') = splitAtBS len_c bs

        len_c :: Int
        len_c = lengthBS c_bs

        bs, c_bs :: bs
        c_bs = singletonBS c
        bs   = coerce m

class Eq a => IsBS a where
  unconsBS    :: a -> Maybe (Word8,a)
  splitAtBS   :: Int -> a -> (a,a)
  lengthBS    :: a -> Int
  singletonBS :: Char -> a

instance IsBS ByteString where
  unconsBS    = BS.uncons
  splitAtBS   = BS.splitAt
  lengthBS    = BS.length
  singletonBS = TE.encodeUtf8 . TX.singleton

instance IsBS ByteStringLazy where
  unconsBS    = LB.uncons
  splitAtBS   = LB.splitAt . fromIntegral
  lengthBS    = fromIntegral . LB.length
  singletonBS = LB.fromStrict . singletonBS

instance IsBS ByteStringShort where
  unconsBS    = SB.uncons
  splitAtBS   = SB.splitAt
  lengthBS    = SB.length
  singletonBS = SB.toShort . singletonBS


----------------------------------------------------------------------------------------------------
-- decodeTX
----------------------------------------------------------------------------------------------------

decodeTX :: forall t a
         .  (t -> MbAlgorithm -> Either MbDecodeFailure a)
         -> Maybe (Char,t) 
         -> Either MbDecodeFailure a
decodeTX dec = maybe (Left MBDF_empty) $ uncurry lu
  where
    lu :: Char -> t -> Either MbDecodeFailure a
    lu c t = decodeChar (dec t) c
{-# INLINE decodeTX #-}


----------------------------------------------------------------------------------------------------
-- reverseLookupAlgorithm
----------------------------------------------------------------------------------------------------

decodeChar :: (MbAlgorithm->Either MbDecodeFailure a) -> Char -> Either MbDecodeFailure a
decodeChar dec = maybe (Left MBDF_codec_select_char) dec . reverseLookupAlgorithm
{-# INLINE decodeChar #-}

reverseLookupAlgorithm :: Char -> Maybe MbAlgorithm
reverseLookupAlgorithm c
  | inRange fast_lokkup_bounds c = fast_lookup ! c
  | c == '\NUL'                  = Just MbIdentityBase
  | otherwise                    = lookup c rev_algo_assocs
{-# INLINE reverseLookupAlgorithm #-}

fast_lookup :: Array Char (Maybe MbAlgorithm)
fast_lookup = array fast_lokkup_bounds as
  where
    as = [ (c,lookup c algo_assocs) | c<-range fast_lokkup_bounds ]

fast_lokkup_bounds :: (Char,Char)
fast_lokkup_bounds = ('0','z')

rev_algo_assocs :: [(Char,MbAlgorithm)]
rev_algo_assocs = reverse algo_assocs

algo_assocs :: [(Char,MbAlgorithm)]
algo_assocs =
    [ (_mbad_code,mba) 
        | mba<-[minBound..maxBound]
        , let MbAlgorithmDescriptor{..} = algorithmDescriptor mba 
        ]