module YamlUnscrambler
(
  -- * Execution
  parseText,
  parseByteString,
  getExpectations,
  -- * DSL
  -- ** Value
  Value,
  value,
  nullableValue,
  -- *** Helpers
  sequenceValue,
  mappingValue,
  scalarsValue,
  -- ** Scalar
  Scalar,
  stringScalar,
  nullScalar,
  boolScalar,
  scientificScalar,
  doubleScalar,
  rationalScalar,
  boundedIntegerScalar,
  unboundedIntegerScalar,
  timestampScalar,
  dayScalar,
  timeScalar,
  uuidScalar,
  binaryScalar,
  -- ** Mapping
  Mapping,
  foldMapping,
  byKeyMapping,
  -- ** Sequence
  Sequence,
  foldSequence,
  byOrderSequence,
  byKeySequence,
  -- ** String
  String,
  textString,
  enumString,
  formattedString,
  attoparsedString,
  -- ** ByKey
  ByKey,
  atByKey,
  atOneOfByKey,
  -- ** ByOrder
  ByOrder,
  fetchByOrder,
  -- * Value types
  MaxInputSize(..),
  Signed(..),
  NumeralSystem(..),
  CaseSensitive(..),
)
where

import YamlUnscrambler.Prelude hiding (String)
import YamlUnscrambler.Model
import qualified YamlUnscrambler.Err as Err
import qualified Attoparsec.Time.ByteString as AsciiAtto
import qualified Control.Foldl as Fold
import qualified Data.Attoparsec.ByteString.Char8 as AsciiAtto
import qualified Data.Attoparsec.Text as TextAtto
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Base64 as Base64
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.UUID as UUID
import qualified Data.Vector as Vector
import qualified Data.Vector.Generic as GenericVector
import qualified Data.Yaml.Parser as Yaml
import qualified Text.Libyaml as Libyaml
import qualified YamlUnscrambler.AsciiAtto as AsciiAtto
import qualified YamlUnscrambler.CompactErrRendering as CompactErrRendering
import qualified YamlUnscrambler.Expectations as Ex
import qualified YamlUnscrambler.Util.ByteString as ByteString
import qualified YamlUnscrambler.Util.HashMap as HashMap
import qualified YamlUnscrambler.Util.Text as Text
import qualified YamlUnscrambler.Util.Vector as Vector
import qualified YamlUnscrambler.Util.Yaml as Yaml


-- * Execution
-------------------------

parseText :: Value a -> Text -> Either Text a
parseText value =
  parseByteString value . Text.encodeUtf8

parseByteString :: Value a -> ByteString -> Either Text a
parseByteString (Value {..}) input =
  do
    Yaml.RawDoc value map <- Yaml.parseByteStringToRawDoc input
    valueParser value map & first CompactErrRendering.renderErrAtPath

{-|
Get a tree of expectations, which can then be converted into
documentation for people working with the YAML document or
into one of the spec formats (e.g., YAML Spec, JSON Spec).
-}
getExpectations :: Value a -> Ex.Value
getExpectations =
  valueExpectation


-- *
-------------------------

data Value a =
  Value {
    valueExpectation :: Ex.Value,
    valueParser :: Yaml.YamlValue -> Yaml.AnchorMap -> Either Err.ErrAtPath a
  }
  deriving (Functor)

value :: [Scalar a] -> Maybe (Mapping a) -> Maybe (Sequence a) -> Value a
value scalars mappings sequences =
  Value expectations parse
  where
    expectations =
      Ex.Value
        scalarExpectations
        (fmap mappingExpectation mappings)
        (fmap sequenceExpectation sequences)
    scalarExpectations =
      fmap scalarExpectation scalars
    parse input anchorMap =
      case input of
        Yaml.Scalar bytes tag style _ ->
          case scalars of
            [] ->
              Left (Err.ErrAtPath [] (Err.UnexpectedScalarErr expectations))
            _ ->
              runExcept (asum (fmap parse scalars)) &
              first convErr
              where
                parse scalar =
                  except $ first (Last . Just) $ scalarParser scalar bytes tag style
                convErr (Last msg) =
                  Err.ErrAtPath [] (Err.ScalarErr scalarExpectations bytes tag style msg)
        Yaml.Mapping input _ ->
          case mappings of
            Just mapping ->
              mappingParser mapping input anchorMap
            Nothing ->
              Left (Err.ErrAtPath [] (Err.UnexpectedMappingErr expectations))
        Yaml.Sequence input _ ->
          case sequences of
            Just sequence ->
              sequenceParser sequence input anchorMap
            Nothing ->
              Left (Err.ErrAtPath [] (Err.UnexpectedSequenceErr expectations))
        Yaml.Alias anchorName ->
          case Map.lookup anchorName anchorMap of
            Just value ->
              parse value anchorMap
            Nothing ->
              Left (Err.ErrAtPath [] (Err.UnknownAnchorErr (fromString anchorName)))

nullableValue :: [Scalar a] -> Maybe (Mapping a) -> Maybe (Sequence a) -> Value (Maybe a)
nullableValue scalars mappings sequences =
  value
    ((nullScalar Nothing) : fmap (fmap Just) scalars)
    (fmap (fmap Just) mappings)
    (fmap (fmap Just) sequences)

-- ** Helpers
-------------------------

sequenceValue :: Sequence a -> Value a
sequenceValue sequence =
  value [] Nothing (Just sequence)

mappingValue :: Mapping a -> Value a
mappingValue mapping =
  value [] (Just mapping) Nothing

scalarsValue :: [Scalar a] -> Value a
scalarsValue scalars =
  value scalars Nothing Nothing


-- *
-------------------------

data Scalar a =
  Scalar {
    scalarExpectation :: Ex.Scalar,
    scalarParser :: ByteString -> Libyaml.Tag -> Libyaml.Style -> Either Text a
  }
  deriving (Functor)

bytesParsingScalar :: Ex.Scalar -> (ByteString -> Either Text a) -> Scalar a
bytesParsingScalar expectation parser =
  Scalar expectation (\ bytes _ _ -> parser bytes)

attoparsedScalar :: Ex.Scalar -> AsciiAtto.Parser a -> Scalar a
attoparsedScalar expectation parser =
  bytesParsingScalar expectation $
  first (const "") . AsciiAtto.parseOnly (parser <* AsciiAtto.endOfInput)

sizedScalar :: MaxInputSize -> Scalar a -> Scalar a
sizedScalar (MaxInputSize maxInputSize) (Scalar {..}) =
  Scalar scalarExpectation $ \ bytes tag style ->
    if ByteString.length bytes <= maxInputSize
      then
        scalarParser bytes tag style
      else
        Left ("Input is longer then the expected maximum of " <> showAsText maxInputSize <> " bytes")

stringScalar :: String a -> Scalar a
stringScalar (String exp parse) =
  bytesParsingScalar
    (Ex.StringScalar exp)
    (\ bytes -> first showAsText (Text.decodeUtf8' bytes) >>= parse)

nullScalar :: a -> Scalar a
nullScalar a =
  Scalar Ex.NullScalar $ \ bytes tag _ ->
    if
      tag == Libyaml.NullTag ||
      ByteString.null bytes ||
      bytes == "~" ||
      ByteString.saysNullInCiAscii bytes
      then
        Right a
      else
        Left "Not null"

boolScalar :: Scalar Bool
boolScalar =
  bytesParsingScalar Ex.BoolScalar $ \ bytes ->
    if ByteString.length bytes <= 5
      then let
        lowercased =
          ByteString.lowercaseInAscii bytes
        in if elem lowercased ["y", "yes", "on", "true", "t", "1"]
          then
            return True
          else if elem lowercased ["n", "no", "off", "false", "f", "0"]
            then
              return False
            else
              Left "Not a boolean"
      else
        Left "Not a boolean"

scientificScalar :: Scalar Scientific
scientificScalar =
  attoparsedScalar Ex.ScientificScalar AsciiAtto.scientific

doubleScalar :: Scalar Double
doubleScalar =
  attoparsedScalar Ex.DoubleScalar AsciiAtto.double

rationalScalar :: MaxInputSize -> Scalar Rational
rationalScalar a =
  sizedScalar a $
  attoparsedScalar (Ex.RationalScalar a) AsciiAtto.rational

{-|
E.g., 'Int', 'Int64', 'Word', but not 'Integer'.
-}
boundedIntegerScalar :: (Integral a, FiniteBits a) => Signed -> NumeralSystem -> Scalar a
boundedIntegerScalar a b =
  attoparsedScalar (Ex.BoundedIntegerScalar a b) (AsciiAtto.integralScalar a b)

unboundedIntegerScalar :: MaxInputSize -> Signed -> NumeralSystem -> Scalar Integer
unboundedIntegerScalar a b c =
  sizedScalar a $
  attoparsedScalar (Ex.UnboundedIntegerScalar a b c) (AsciiAtto.integralScalar b c)

timestampScalar :: Scalar UTCTime
timestampScalar =
  attoparsedScalar Ex.Iso8601TimestampScalar AsciiAtto.utcTimeInISO8601

dayScalar :: Scalar Day
dayScalar =
  attoparsedScalar Ex.Iso8601DayScalar AsciiAtto.dayInISO8601

timeScalar :: Scalar TimeOfDay
timeScalar =
  attoparsedScalar Ex.Iso8601TimeScalar AsciiAtto.timeOfDayInISO8601

uuidScalar :: Scalar UUID
uuidScalar =
  bytesParsingScalar Ex.UuidScalar $ \ bytes ->
    case UUID.fromASCIIBytes bytes of
      Just uuid ->
        return uuid
      Nothing ->
        Left "Invalid UUID"

binaryScalar :: Scalar ByteString
binaryScalar =
  bytesParsingScalar Ex.Base64BinaryScalar $ \ bytes ->
    let
      bytesWithoutNewlines =
        ByteString.filter (/= 10) bytes
      in case Base64.decodeBase64 bytesWithoutNewlines of
        Right res ->
          return res
        Left err ->
          Left err


-- *
-------------------------

data Mapping a =
  Mapping {
    mappingExpectation :: Ex.Mapping,
    mappingParser :: [(Text, Yaml.YamlValue)] -> Yaml.AnchorMap -> Either Err.ErrAtPath a
  }
  deriving (Functor)

foldMapping :: (key -> val -> assoc) -> Fold assoc a -> String key -> Value val -> Mapping a
foldMapping zip (Fold foldStep foldInit foldExtract) key val =
  Mapping
    (Ex.MonomorphicMapping (stringExpectation key) (valueExpectation val))
    parser
  where
    parser input anchorMap =
      foldM step foldInit input &
      fmap foldExtract
      where
        step state (keyInput, valInput) =
          do
            parsedKey <- first keyErr (stringParser key keyInput)
            parsedVal <- first (Err.atSegment keyInput) (valueParser val valInput anchorMap)
            return $! foldStep state (zip parsedKey parsedVal)
          where
            keyErr =
              Err.ErrAtPath [] .
              Err.KeyErr (stringExpectation key) keyInput

byKeyMapping :: CaseSensitive -> ByKey Text a -> Mapping a
byKeyMapping caseSensitive byKey =
  Mapping expectation parser
  where
    expectation =
      Ex.ByKeyMapping caseSensitive (byKeyExpectation byKey)
    parser input =
      either Left (first keysErr) . runExceptT . parser
      where
        parser =
          if coerce caseSensitive
            then let
              map =
                HashMap.fromList input
              lookup k =
                HashMap.lookup k map
              lookupFirst kl =
                HashMap.lookupFirst kl map
              in byKeyParser byKey id lookup lookupFirst
            else let
              map =
                HashMap.fromList (fmap (first Text.toLower) input)
              lookup k =
                HashMap.lookup (Text.toLower k) map
              lookupFirst kl =
                HashMap.lookupFirst (fmap Text.toLower kl) map
              in byKeyParser byKey id lookup lookupFirst
        keysErr keys =
          Err.ErrAtPath [] $
          Err.NoneOfMappingKeysFoundErr (byKeyExpectation byKey) caseSensitive keysAvail (toList keys)
          where
            keysAvail =
              fmap fst input


-- *
-------------------------

data Sequence a =
  Sequence {
    sequenceExpectation :: Ex.Sequence,
    sequenceParser :: [Yaml.YamlValue] -> Yaml.AnchorMap -> Either Err.ErrAtPath a
  }
  deriving (Functor)

foldSequence :: Fold a b -> Value a -> Sequence b
foldSequence (Fold foldStep foldInit foldExtract) value =
  Sequence
    (Ex.MonomorphicSequence (valueExpectation value))
    parser
  where
    parser input anchorMap =
      foldM step (0 :: Int, foldInit) input &
      fmap (foldExtract . snd)
      where
        step (!index, !state) input =
          valueParser value input anchorMap &
          first (Err.atSegment (showAsText index)) &
          fmap (\ a -> (succ index, foldStep state a))

byOrderSequence :: ByOrder a -> Sequence a
byOrderSequence (ByOrder {..}) =
  Sequence
    (Ex.ByOrderSequence byOrderExpectation)
    parser
    where
      parser input anchorMap =
        runExceptT (runReaderT (evalStateT byOrderParser (0, input)) anchorMap) &
        either Left (first mapErr)
        where
          mapErr =
            \ case
              NotEnoughElementsByOrderErr a ->
                Err.ErrAtPath [] $
                Err.NotEnoughElementsErr byOrderExpectation a

byKeySequence :: ByKey Int a -> Sequence a
byKeySequence (ByKey {..}) =
  Sequence expectation parser
  where
    expectation =
      Ex.ByKeySequence byKeyExpectation
    parser input =
      let
        vector =
          Vector.fromList input
        lookup k =
          vector Vector.!? k
        lookupFirst kl =
          Vector.lookupFirst kl vector
        in \ anchorMap ->
          runExceptT (byKeyParser showAsText lookup lookupFirst anchorMap) &
          either Left (first keysErr)
      where
        keysErr keys =
          Err.ErrAtPath [] $
          Err.NoneOfSequenceKeysFoundErr byKeyExpectation (toList keys)


-- *
-------------------------

data String a =
  String {
    stringExpectation :: Ex.String,
    stringParser :: Text -> Either Text a
  }
  deriving (Functor)

textString :: String Text
textString =
  String Ex.AnyString return

enumString :: CaseSensitive -> [(Text, a)] -> String a
enumString (CaseSensitive caseSensitive) assocList =
  String expectation parser
  where
    expectation =
      Ex.OneOfString (CaseSensitive caseSensitive) (fmap fst assocList)
    {-# NOINLINE lookup #-}
    lookup =
      if length assocList > 512
        then if caseSensitive
          then let
            hashMap =
              HashMap.fromList assocList
            in flip HashMap.lookup hashMap
          else let
            hashMap =
              HashMap.fromList (fmap (first Text.toLower) assocList)
            in flip HashMap.lookup hashMap . Text.toLower
        else if caseSensitive
          then
            flip List.lookup assocList
          else
            flip List.lookup (fmap (first Text.toLower) assocList) . Text.toLower
    parser text =
      case lookup text of
        Just a -> return a
        _ -> Left "Unexpected value"

formattedString :: Text -> (Text -> Either Text a) -> String a
formattedString format parser =
  String
    (Ex.FormattedString format)
    parser

attoparsedString :: Text -> TextAtto.Parser a -> String a
attoparsedString format parser =
  String
    (Ex.FormattedString format)
    (first fromString . TextAtto.parseOnly parser)


-- *
-------------------------

data ByKey key a =
  ByKey {
    byKeyExpectation :: Ex.ByKey key,
    byKeyParser ::
      (key -> Text) ->
      (key -> Maybe Yaml.YamlValue) ->
      ([key] -> Maybe (key, Yaml.YamlValue)) ->
      Yaml.AnchorMap ->
      ExceptT (Acc key) (Either Err.ErrAtPath) a
  }
  deriving (Functor)

instance Applicative (ByKey key) where
  pure =
    ByKey Ex.AnyByKey . const . const . const . const . pure
  (<*>) (ByKey le lp) (ByKey re rp) =
    ByKey
      (Ex.BothByKey le re)
      (\ a b c d -> lp a b c d <*> rp a b c d)

instance Selective (ByKey key) where
  select (ByKey le lp) (ByKey re rp) =
    ByKey
      (Ex.BothByKey le re)
      (\ a b c d -> select (lp a b c d) (rp a b c d))

instance Alternative (ByKey key) where
  empty =
    ByKey
      Ex.NoByKey
      (const (const (const (const empty))))
  (<|>) (ByKey le lp) (ByKey re rp) =
    ByKey
      (Ex.EitherByKey le re)
      (\ a b c d -> lp a b c d <|> rp a b c d)

atByKey :: key -> Value a -> ByKey key a
atByKey key valueSpec =
  ByKey
    (Ex.LookupByKey [key] (valueExpectation valueSpec))
    parser
  where
    parser renderKey lookup _ env =
      case lookup key of
        Just val ->
          lift $ first (Err.atSegment (renderKey key)) $
          valueParser valueSpec val env
        Nothing ->
          throwE (pure key)

atOneOfByKey :: [key] -> Value a -> ByKey key a
atOneOfByKey keys valueSpec =
  ByKey
    (Ex.LookupByKey keys (valueExpectation valueSpec))
    parser
  where
    parser renderKey _ lookup env =
      case lookup keys of
        Just (key, val) ->
          lift $ first (Err.atSegment (renderKey key)) $
          valueParser valueSpec val env
        Nothing ->
          throwE (fromList keys)


-- *
-------------------------

data ByOrderErr =
  NotEnoughElementsByOrderErr
    Int

data ByOrder a =
  ByOrder {
    byOrderExpectation :: Ex.ByOrder,
    byOrderParser :: StateT (Int, [Yaml.YamlValue]) (ReaderT Yaml.AnchorMap (ExceptT ByOrderErr (Either Err.ErrAtPath))) a
  }
  deriving (Functor)

instance Applicative ByOrder where
  pure =
    ByOrder Ex.AnyByOrder . pure
  (<*>) (ByOrder le lp) (ByOrder re rp) =
    ByOrder
      (Ex.BothByOrder le re)
      (lp <*> rp)

instance Selective ByOrder where
  select (ByOrder le lp) (ByOrder re rp) =
    ByOrder
      (Ex.BothByOrder le re)
      (select lp rp)

fetchByOrder :: Value a -> ByOrder a
fetchByOrder value =
  ByOrder
    (Ex.FetchByOrder (valueExpectation value))
    parser
  where
    parser =
      do
        (!offset, list) <- get
        case list of
          h : t ->
            do
              put (succ offset, t)
              anchorMap <- ask
              lift $ lift $ lift $ first (Err.atSegment (showAsText offset)) $ valueParser value h anchorMap
          _ ->
            throwError $ NotEnoughElementsByOrderErr offset