{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

-- |
-- Module      : Finance.Belgium.StructuredCommunication
-- Description : A module to parse, render and manipulate Belgian structured communication for financial transactions.
-- Maintainer  : hapytexeu+gh@gmail.com
-- Stability   : experimental
-- Portability : POSIX
--
-- Belgian companies often make use of /structured communication/ with a checksum. This package aims to provide a toolkit to parse, render and manipulate 'StructuredCommunication'.
module Finance.Belgium.StructuredCommunication
  ( -- * Constructing 'StructuredCommunication'
    StructuredCommunication (StructuredCommunication),
    structuredCommunication,

    -- * determining the checksum
    checksum,
    determineChecksum,
    validChecksum,
    fixChecksum,

    -- * Converting to text
    communicationToString,
    communicationToText,

    -- * Parsing from text
    communicationParser,
    communicationParser',
    communicationEParser,
    communicationEParser',
    parseCommunication,
    parseCommunication',
    parseCommunicationE,
    parseCommunicationE',

    -- * Quasi quotation
    beCommunication,
  )
where

import Control.Applicative ((<|>))
import Control.Monad ((>=>))
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail(MonadFail)
#endif
import Data.Binary (Binary (get, put))
import Data.Char (digitToInt)
import Data.Data (Data)
import Data.Functor.Identity (Identity)
import Data.Hashable (Hashable)
import Data.Int (Int64)
import Data.Text (Text, pack)
import Data.Typeable (Typeable)
#if MIN_VERSION_validity(0,9,0)
import Data.Validity (Validity (validate), check, prettyValidate)
#else
import Data.Validity (Validation(Validation), Validity (validate), check)
#endif
import Data.Word (Word16, Word32)
import GHC.Generics (Generic)
import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter, quoteDec, quoteExp, quotePat, quoteType))
#if MIN_VERSION_template_haskell(2, 17, 0)
import Language.Haskell.TH.Syntax (Code (Code), Exp (AppE, ConE, LitE), Lift (lift, liftTyped), Lit (IntegerL), Pat (ConP, LitP), TExp (TExp))
#elif MIN_VERSION_template_haskell(2, 16, 0)
import Language.Haskell.TH.Syntax (Exp (AppE, ConE, LitE), Lift (lift, liftTyped), Lit (IntegerL), Pat (ConP, LitP), TExp (TExp))
#else
import Language.Haskell.TH.Syntax (Exp (AppE, ConE, LitE), Lift (lift), Lit (IntegerL), Pat (ConP, LitP))
#endif
import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary))
import Test.QuickCheck.Gen (choose)
import Text.Parsec (ParseError)
import Text.Parsec.Char (char, digit, space)
import Text.Parsec.Combinator (eof)
import Text.Parsec.Prim (ParsecT, Stream, runParser, skipMany, try)
import Text.Printf (printf)

-- | A data type that stores three numbers: one with three digits (@000–999@), four digits (@0000–9999@) and five digits (@00001–99997@). The data
-- constructor itself is not accessible, since the `StructuredCommunication` could produce objects that are out of the given ranges, or where the
-- checksum is not valid. The module thus aims to prevent parsing, changing, etc. 'StructuredCommunication' objects into an invalid state.
data StructuredCommunication = StructuredCommunication !Word16 !Word16 !Word32 deriving (Data, Eq, Generic, Ord, Read, Typeable)

_maxVal :: Integral a => a
_maxVal = 9999999999

_numVals :: Integral a => a
_numVals = 10000000000

_fromEnum :: StructuredCommunication -> Int64
_fromEnum (StructuredCommunication v₀ v₁ v₂) = fromIntegral v₀ * 10000000 + fromIntegral v₁ * 1000 + fromIntegral (v₂ `div` 100)

_toEnum :: Int64 -> StructuredCommunication
_toEnum v = fixChecksum (StructuredCommunication (fromIntegral v₀) (fromIntegral v₁) (fromIntegral v₂))
  where
    v₂ = (v `mod` 1000) * 100
    v₁ = (v `div` 1000) `mod` 10000
    v₀ = v `div` 10000000

instance Num StructuredCommunication where
  fromInteger = _toEnum . fromInteger . (`mod` _numVals)
  v1 + v2 = _toEnum ((_fromEnum v1 + _fromEnum v2) `mod` _numVals)
  v1 - v2 = _toEnum ((_fromEnum v1 - _fromEnum v2) `mod` _numVals)
  negate = _toEnum . (`mod` _numVals) . negate . _fromEnum
  abs = id
  signum 0 = 0
  signum _ = 1
  v1' * v2' = _toEnum ((m1 * v2 + (v1 - m1) * m2) `mod` _numVals)
    where
      v1 = _fromEnum v1'
      v2 = _fromEnum v2'
      m1 = v1 `mod` 100000
      m2 = v2 `mod` 100000

_both :: (a -> b) -> (a, a) -> (b, b)
_both f ~(x, y) = (f x, f y)

instance Real StructuredCommunication where
  toRational = toRational . toInteger

instance Integral StructuredCommunication where
  toInteger = toInteger . _fromEnum
  quot x = _toEnum . quot (_fromEnum x) . _fromEnum
  rem x = _toEnum . rem (_fromEnum x) . _fromEnum
  quotRem x = _both _toEnum . quotRem (_fromEnum x) . _fromEnum
  div x = _toEnum . div (_fromEnum x) . _fromEnum
  mod x = _toEnum . mod (_fromEnum x) . _fromEnum
  divMod x = _both _toEnum . quotRem (_fromEnum x) . _fromEnum

instance Show StructuredCommunication where
  show c = "[beCommunication|" ++ communicationToString c ++ "|]"

instance Hashable StructuredCommunication

-- | Determining the /checksum/-part for the given 'StructuredCommunication'. This thus takes the last two digits, or the third number modulo one hundred.
checksum ::
  -- | The 'StructuredCommunication' for which we determine the checkum.
  StructuredCommunication ->
  -- | The last two digits of the 'StructuredCommunication' object. The checksum is /not/ per se valid.
  Word32
checksum (StructuredCommunication _ _ v₂) = v₂ `mod` 100

_rcheck :: Integral i => Integer -> i -> Bool
_rcheck mx = go
  where
    go v = 0 <= i && i <= mx where i = fromIntegral v

-- | Construct a 'StructuredCommunication' object for the given three integral values that form the three sequences of digits.
structuredCommunication ::
  (Integral i, Integral j, Integral k) =>
  -- | The first number, should be between @000@ and @999@.
  i ->
  -- | The second number, should be between @0000@ and @9999@.
  j ->
  -- | The third number, should be between @00001@ and @99997@.
  k ->
  -- | The 'StructuredCommunication' wrapped in a 'Just' of the three numbers are in range, and the checksum matches, otherwise 'Nothing'.
  Maybe StructuredCommunication
structuredCommunication v₀ v₁ v₂
  | _rcheck 999 v₀ && _rcheck 9999 v₁ && _rcheck 99997 v₂ && validChecksum s = Just s
  | otherwise = Nothing
  where
    s = StructuredCommunication (fromIntegral v₀) (fromIntegral v₁) (fromIntegral v₂)

instance Arbitrary StructuredCommunication where
  arbitrary = fixChecksum <$> (StructuredCommunication <$> choose (0, 999) <*> choose (0, 9999) <*> ((100 *) <$> choose (0, 999)))

instance Bounded StructuredCommunication where
  minBound = fixChecksum (StructuredCommunication 0 0 0)
  maxBound = fixChecksum (StructuredCommunication 999 9999 99900)

instance Enum StructuredCommunication where
  fromEnum = fromIntegral . _fromEnum
  toEnum = _toEnum . fromIntegral
  succ = _toEnum . succ . _fromEnum
  pred = _toEnum . pred . _fromEnum
  enumFrom v = map _toEnum [_fromEnum v .. _maxVal]
  enumFromThen v₀ v₁
    | v₀ <= v₁ = map _toEnum [_fromEnum v₀, _fromEnum v₁ .. _maxVal]
    | otherwise = map _toEnum [_fromEnum v₀, _fromEnum v₁ .. 0]
  enumFromTo v₀ v₁ = map _toEnum [_fromEnum v₀ .. _fromEnum v₁]
  enumFromThenTo v₀ v₁ v₂ = map _toEnum [_fromEnum v₀, _fromEnum v₁ .. _fromEnum v₂]

instance Binary StructuredCommunication where
  get = StructuredCommunication <$> get <*> get <*> get
  put (StructuredCommunication v₀ v₁ v₂) = put v₀ >> put v₁ >> put v₂

instance Validity StructuredCommunication where
  validate s@(StructuredCommunication v₀ v₁ v₂) =
    check (v₀ <= 999) "first sequence larger has more than three digits."
      `mappend` check (v₁ <= 9999) "second sequence larger has more than four digits."
      `mappend` check (v₂ <= 99999) "third sequence larger has more than five digits."
      `mappend` check (0 < c && c <= 97) "checksum out of the 1–97 range."
      `mappend` check (determineChecksum s == c) "checksum does not match."
    where
      c = checksum s

-- | Determine the checksum based on the first ten digits. If the 'StructuredCommunication' is not valid, its 'checksum' will /not/ match the result of the 'determineChecksum'.
determineChecksum ::
  -- | The 'StructuredCommunication' to determine the /checksum/ from.
  StructuredCommunication ->
  -- | The checksum determined by the first ten digits, not per se the /real/ checksum of the 'StructuredCommunication'.
  Word32
determineChecksum (StructuredCommunication v₀ v₁ v₂)
  | cs₂ == 0 = 97
  | otherwise = cs₂
  where
    cs₀ = v₀ `mod` 97
    cs₁ = (cs₀ * 9 + v₁) `mod` 97 -- 10000 `mod` 97 ==  9  (shift four decimal places)
    cs₂ = (fromIntegral cs₁ * 30 + v₂ `div` 100) `mod` 97 --  1000 `mod` 97 == 30  (shift three decimal places)

-- | Check if the checksum matches for the given 'StructuredCommunication'.
validChecksum ::
  -- | The 'StructuredCommunication' for which we check the checksum.
  StructuredCommunication ->
  -- | 'True' if the checksum is valid; 'False' otherwise.
  Bool
validChecksum s@(StructuredCommunication _ _ v₂) = determineChecksum s == v₂ `mod` 100

-- | Convert the given 'StructuredCommunication' to one where the checksum is valid. If the checksum was already valid, it returns an equivalent
-- 'StructuredCommunication', this operation is thus /idempotent/.
fixChecksum ::
  -- | The given 'StructuredCommunication' to fix.
  StructuredCommunication ->
  -- | A variant of the given 'StructuredCommunication' where only the last two digits are changed to have a valid checksum.
  StructuredCommunication
fixChecksum s@(StructuredCommunication v₀ v₁ v₂) = StructuredCommunication v₀ v₁ (v₂ - (v₂ `mod` 100) + determineChecksum s)

-- | Convert the given 'StructuredCommunication' to a 'String' that looks like a structured communication, so @+++000\/0000\/00097+++@.
communicationToString ::
  -- | The given 'StructuredCommunication' to convert to a 'String'.
  StructuredCommunication ->
  -- | The corresponding 'String', of the form @+++000\/0000\/00097+++@.
  String
communicationToString (StructuredCommunication v₀ v₁ v₂) = "+++" ++ printf "%03d" v₀ ++ "/" ++ printf "%04d" v₁ ++ "/" ++ printf "%05d" v₂ ++ "+++"

-- | Convert the given 'StructuredCommunication' to a 'Text' that looks like a structured communication, so @+++000\/0000\/00097+++@.
communicationToText ::
  -- | The given 'StructuredCommunication' to convert to a 'Text'.
  StructuredCommunication ->
  -- | The corresponding 'Text', of the form @+++000\/0000\/00097+++@.
  Text
communicationToText = pack . communicationToString

_parseNatWidth :: (Integral i, Stream s m Char) => Int -> ParsecT s u m i
_parseNatWidth m
  | m >= 0 = go m 0
  | otherwise = fail "negative number of digits"
  where
    go 0 v = pure v
    go n v = digit >>= go (n - 1) . ((10 * v) +) . fromIntegral . digitToInt

_char3 :: Stream s m Char => Char -> ParsecT s u m Char
_char3 c = c' <* c' <* c'
  where
    c' = char c

_presuf :: Stream s m Char => ParsecT s u m Char
_presuf = try (_char3 '+') <|> _char3 '*'

_slash :: Stream s m Char => ParsecT s u m Char
_slash = _space *> char '/' <* _space

_space :: Stream s m Char => ParsecT s u m ()
_space = skipMany space

-- | A 'ParsecT' that parses a string into a 'StructuredCommunication', the 'StructuredCommunication' can be invalid. The parser also does /not/ (per se) ends with an 'eof'.
communicationParser' ::
  Stream s m Char =>
  -- | The 'ParsecT' object that parses the structured communication of the form @+++000\/0000\/00097+++@.
  ParsecT s u m StructuredCommunication
communicationParser' = do
  c <- _presuf <* _space
  c1 <- _parseNatWidth 3 <* _slash
  c2 <- _parseNatWidth 4 <* _slash
  c3 <- _parseNatWidth 5
  StructuredCommunication c1 c2 c3 <$ _space <* _char3 c

-- | A 'ParsecT' that parses a string into a 'StructuredCommunication', the 'StructuredCommunication' is checked for its validity (checksum). The parser does /not/ (per se) ends with an 'eof'.
communicationParser ::
  Stream s m Char =>
  -- | The 'ParsecT' object that parses the structured communication of the form @+++000\/0000\/00097+++@.
  ParsecT s u m StructuredCommunication
communicationParser = communicationParser' >>= _liftEither . prettyValidate

-- | A 'ParsecT' that parses a string into a 'StructuredCommunication', the 'StructuredCommunication' can be invalid. The parser also checks if this is the end of the stream.
communicationEParser' ::
  Stream s m Char =>
  -- | The 'ParsecT' object that parses the structured communication of the form @+++000\/0000\/00097+++@.
  ParsecT s u m StructuredCommunication
communicationEParser' = communicationParser <* eof

-- | A 'ParsecT' that parses a string into a 'StructuredCommunication', the 'StructuredCommunication' is checked for its validity (checksum). The parser also checks that this is the end of the stream.
communicationEParser ::
  Stream s m Char =>
  -- | The 'ParsecT' object that parses the structured communication of the form @+++000\/0000\/00097+++@.
  ParsecT s u m StructuredCommunication
communicationEParser = communicationEParser' >>= _liftEither . prettyValidate

-- | Parsing a stream into a 'StructuredCommunication' that also validates the checksum of the communication. The stream does not per se needs to end with structured communcation.
parseCommunication ::
  Stream s Identity Char =>
  -- | The stream that is parsed into a 'StructuredCommunication'
  s ->
  -- | The result of parsing, either a 'StructuredCommunication' wrapped in a 'Right' or a parsing error wrapped in a 'Left'.
  Either ParseError StructuredCommunication
parseCommunication = runParser communicationParser () ""

-- | Parsing a stream into a 'StructuredCommunication' that does /noet/ validate the checksum of the communication. The stream does not per se needs to end with structured communcation.
parseCommunication' ::
  Stream s Identity Char =>
  -- | The stream that is parsed into a 'StructuredCommunication'
  s ->
  -- | The result of parsing, either a 'StructuredCommunication' wrapped in a 'Right' or a parsing error wrapped in a 'Left'.
  Either ParseError StructuredCommunication
parseCommunication' = runParser communicationParser' () ""

-- | Parsing a stream into a 'StructuredCommunication' that also validates the checksum of the communication. After the structured communication, the stream needs to end.
parseCommunicationE ::
  Stream s Identity Char =>
  -- | The stream that is parsed into a 'StructuredCommunication'
  s ->
  -- | The result of parsing, either a 'StructuredCommunication' wrapped in a 'Right' or a parsing error wrapped in a 'Left'.
  Either ParseError StructuredCommunication
parseCommunicationE = runParser communicationEParser () ""

-- | Parsing a stream into a 'StructuredCommunication' that does /noet/ validate the checksum of the communication. After the structured communication, the stream needs to end.
parseCommunicationE' ::
  Stream s Identity Char =>
  -- | The stream that is parsed into a 'StructuredCommunication'
  s ->
  -- | The result of parsing, either a 'StructuredCommunication' wrapped in a 'Right' or a parsing error wrapped in a 'Left'.
  Either ParseError StructuredCommunication
parseCommunicationE' = runParser communicationEParser' () ""

_liftEither :: Show s => MonadFail m => Either s a -> m a
_liftEither = either (fail . show) pure

_toPattern :: StructuredCommunication -> Pat

#if MIN_VERSION_template_haskell(2, 18, 0)
_toPattern (StructuredCommunication v₀ v₁ v₂) = ConP 'StructuredCommunication [] [f (fromIntegral v₀), f (fromIntegral v₁), f (fromIntegral v₂)]
  where
    f = LitP . IntegerL
#else
_toPattern (StructuredCommunication v₀ v₁ v₂) = ConP 'StructuredCommunication [f (fromIntegral v₀), f (fromIntegral v₁), f (fromIntegral v₂)]
  where
    f = LitP . IntegerL
#endif

#if !MIN_VERSION_validity(0,9,0)
prettyValidate :: Validity a => a -> Either String a
prettyValidate a = go (validate a)
  where go (Validation []) = Right a
        go v = Left (show v)
#endif

-- | A 'QuasiQuoter' that can parse a string into an expression or pattern. It will thus convert @+++000\/000\/00097+++@ into a 'StructuredCommunication' as expression or pattern.
beCommunication ::
  -- | A 'QuasiQuoter' to parse to a 'StructuredCommunication'.
  QuasiQuoter
beCommunication =
  QuasiQuoter
    { quoteExp = (_liftEither >=> lift) . runParser communicationEParser () "",
      quotePat = (_liftEither >=> pure . _toPattern) . runParser communicationEParser () "",
      quoteType = const (fail "can not produce a type with this QuasiQuoter"),
      quoteDec = const (fail "can not produce a declaration with this QuasiQuoter")
    }

instance Lift StructuredCommunication where
  lift (StructuredCommunication v₀ v₁ v₂) = pure (ConE 'StructuredCommunication `AppE` f (fromIntegral v₀) `AppE` f (fromIntegral v₁) `AppE` f (fromIntegral v₂))
    where
      f = LitE . IntegerL

#if MIN_VERSION_template_haskell(2, 17, 0)
  liftTyped (StructuredCommunication v₀ v₁ v₂) = Code (pure (TExp (ConE 'StructuredCommunication `AppE` f (fromIntegral v₀) `AppE` f (fromIntegral v₁) `AppE` f (fromIntegral v₂))))
    where
      f = LitE . IntegerL
#elif MIN_VERSION_template_haskell(2, 16, 0)
  liftTyped (StructuredCommunication v₀ v₁ v₂) = pure (TExp (ConE 'StructuredCommunication `AppE` f (fromIntegral v₀) `AppE` f (fromIntegral v₁) `AppE` f (fromIntegral v₂)))
    where
      f = LitE . IntegerL
#endif