module Model.Types.Markup
  ( MarkupFormat(..)
  , StoredMarkup(..)
  , htmlToStoredMarkup, plaintextToStoredMarkup, preEscapedToStoredMarkup
  , esqueletoMarkupOutput
  , I18nStoredMarkup
  ) where

import Import.NoModel

import Text.Blaze (ToMarkup(..))
import Text.Blaze.Html.Renderer.Text (renderHtml)

import qualified Data.Text.Lazy as LT
import qualified Data.ByteString.Lazy as LBS
import Data.Text.Encoding (decodeUtf8')

import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson

import qualified Data.Csv as Csv

import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Internal as E
import Database.Persist.Sql


data MarkupFormat
  = MarkupMarkdown
  | MarkupHtml
  | MarkupPlaintext
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
  deriving anyclass (Universe, Finite, Binary, Hashable, NFData)
nullaryPathPiece ''MarkupFormat $ camelToPathPiece' 1
pathPieceJSON ''MarkupFormat

data StoredMarkup = StoredMarkup
  { markupInputFormat :: MarkupFormat
  , markupInput       :: LT.Text
  , markupOutput      :: Html
  }
  deriving (Read, Show, Generic, Typeable)
  deriving anyclass (Binary, Hashable, NFData)

htmlToStoredMarkup :: Html -> StoredMarkup
htmlToStoredMarkup html = StoredMarkup
  { markupInputFormat = MarkupHtml
  , markupInput = renderHtml html
  , markupOutput = html
  }
plaintextToStoredMarkup :: Textual t => t -> StoredMarkup
plaintextToStoredMarkup (repack -> t) = StoredMarkup
  { markupInputFormat = MarkupPlaintext
  , markupInput = t
  , markupOutput = toMarkup t
  }
preEscapedToStoredMarkup :: Textual t => t -> StoredMarkup
preEscapedToStoredMarkup (repack -> t) = StoredMarkup
  { markupInputFormat = MarkupHtml
  , markupInput = fromStrict t
  , markupOutput = preEscapedToMarkup t
  }

esqueletoMarkupOutput :: E.SqlExpr (E.Value StoredMarkup) -> E.SqlExpr (E.Value Html)
esqueletoMarkupOutput sMarkup = E.maybe (E.val mempty) E.veryUnsafeCoerceSqlExprValue $ E.maybe (sMarkup E.#>>. "{}") E.just (sMarkup E.#>>. "{\"markup-output\"}")

instance Eq StoredMarkup where
  (==) = (==) `on` LT.strip . renderHtml . markupOutput
instance Ord StoredMarkup where
  compare = comparing $ LT.strip . renderHtml . markupOutput

instance ToJSON StoredMarkup where
  toJSON StoredMarkup{..}
    | markupInputFormat == MarkupHtml
    , renderHtml markupOutput == markupInput
    = Aeson.String $ toStrict markupInput
    | otherwise
    = Aeson.object
        [ "input-format"  Aeson..= markupInputFormat
        , "markup-input"  Aeson..= markupInput
        , "markup-output" Aeson..= markupOutput
        ]
instance FromJSON StoredMarkup where
  parseJSON v = case v of
    Aeson.String t -> return $ preEscapedToStoredMarkup t
    Aeson.Object o -> do
      markupInputFormat <- o Aeson..: "input-format"
      markupInput       <- o Aeson..: "markup-input"
      markupOutput      <- o Aeson..: "markup-output"
      return StoredMarkup{..}
    other -> Aeson.typeMismatch "StoredMarkup" other

instance IsString StoredMarkup where
  fromString = preEscapedToStoredMarkup
instance ToMarkup StoredMarkup where
  toMarkup = markupOutput
instance ToWidget site StoredMarkup where
  toWidget = toWidget . toMarkup

instance Semigroup StoredMarkup where
  a <> b
    | markupInputFormat a == markupInputFormat b
    = StoredMarkup
      { markupInputFormat = markupInputFormat a
      , markupInput = ((<>) `on` markupInput) a b -- this seems optimistic...
      , markupOutput = ((<>) `on` markupOutput) a b
      }
    | null $ markupInput a
    = b
    | null $ markupInput b
    = a
    | otherwise
    = StoredMarkup
      { markupInputFormat = MarkupHtml
      , markupInput = renderHtml $ ((<>) `on` markupOutput) a b
      , markupOutput = ((<>) `on` markupOutput) a b
      }
instance Monoid StoredMarkup where
  mempty = fromString mempty

instance Csv.ToField StoredMarkup where
  toField = Csv.toField . markupOutput
instance Csv.FromField StoredMarkup where
  parseField = fmap htmlToStoredMarkup . Csv.parseField

instance PersistField StoredMarkup where
  fromPersistValue (PersistLiteralEscaped bs) = first pack $ Aeson.eitherDecodeStrict' bs
  fromPersistValue (PersistByteString bs)     = first pack $ Aeson.eitherDecodeStrict' bs
                                                         <|> bimap show preEscapedToStoredMarkup (decodeUtf8' bs)
  fromPersistValue (PersistText t)            = first pack $ Aeson.eitherDecodeStrict' (encodeUtf8 t)
                                                         <|> return (preEscapedToStoredMarkup t)
  fromPersistValue  x                         = Left $ fromPersistValueErrorSql (Proxy @StoredMarkup) x
  toPersistValue = PersistLiteralEscaped . LBS.toStrict . Aeson.encode
instance PersistFieldSql StoredMarkup where
  sqlType _ = SqlOther "jsonb"

type I18nStoredMarkup = I18n StoredMarkup
