module Site.Model where

import Commonmark.Simple qualified as Markdown
import Data.Aeson (FromJSON (..), Options (..), defaultOptions, genericParseJSON, withText)
import Data.Char qualified as Char
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Time qualified as Time
import Ema (Ema (..))
import Ema qualified
import Graphics.ThumbnailPlus qualified as Thumb
import Network.URI.Slug (Slug (..), decodeSlug, encodeSlug)
import PyF
import Relude
import Relude.Unsafe qualified as Unsafe
import Text.Blaze.Html5 ((!))
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes qualified as A
import Text.Pandoc.Definition (Pandoc (..))
import Prelude ()

import Site.Lang
import Utils.Html

domainName :: Text
domainName = "sourcephile.fr"

orgName :: Text
orgName = "Sourcephile"

-- * Type 'Model'

{- | The state used to generate the site.
 Changing the model automatically changes the view.
-}
data Model = Model
  { modelTime :: Maybe Time.UTCTime
  , modelPosts :: Map [Slug] Page
  , modelSpecials :: Map [Slug] Page
  , modelPictures :: Map [Slug] [(Thumb.Size, FilePath)]
  , modelLocalLinks :: Map [Slug] (Set LocalLink)
  }

backLinks :: HasCallStack => LocalLink -> Map [Slug] (Set LocalLink) -> Set [Slug]
backLinks page =
  Map.foldMapWithKey
    ( \k lls ->
        if Set.member page lls
          then Set.singleton k
          else mempty
    )
-- ** Type 'Page'
data Page = Page
  { pageMeta :: Meta
  , pageDoc :: Pandoc
  , pageLocalLinks :: Set LocalLink
  }

-- *** Type 'LocalLink'
newtype LocalLink = LocalLink [Slug]
  deriving (Eq, Ord, Show)

localLink :: HasCallStack => [Slug] -> Text -> LocalLink
localLink base target = LocalLink
  case Text.span (== '/') target of
    (Text.isPrefixOf "/" -> True, absTarget) ->
      go $ decodeSlugs absTarget
    ("", relTarget) ->
      go $ base <> decodeSlugs relTarget
  where
    go = \case
      s : ".." : ss -> go ss
      ".." : ss -> go ss
      s : ss -> s : go ss
      [] -> []
-- *** Type 'Meta'
data Meta = Meta
  { metaAuthors :: Maybe (NonEmpty Entity)
  , metaLang :: Lang
  , metaPublished :: Maybe Time.Day
  , metaLisense :: Maybe Text
  , metaSummary :: Maybe Markdown
  , metaTitle :: Text
  , metaUpdated :: Maybe Time.Day
  , metatags :: Maybe (NonEmpty Tag)
  , metaDiscussion :: Maybe Discussion
  }
  deriving (Show, Generic)
instance FromJSON Meta where
  parseJSON =
    genericParseJSON
      defaultOptions
        { fieldLabelModifier = \case
            (drop 4 -> c : cs) -> Char.toLower c : cs
            _ -> error ""
        }

-- | 'metaTags can't be a list to be able to derive FromJSON
metaTags :: Meta -> [Tag]
metaTags = maybe [] toList . metatags

-- **** Type 'Markdown'
data Markdown = Markdown
  { markdownText :: Text
  , markdownPandoc :: Pandoc
  }
  deriving (Show)
instance FromJSON Markdown where
  parseJSON = withText "Markdown" $ \markdownText ->
    case Markdown.parseMarkdown "" markdownText of
      Right markdownPandoc -> pure Markdown{..}
      Left err -> fail (toString err)

-- **** Type 'Discussion'
data Discussion = Discussion
  { discussionUrl :: Text
  , discussionMail :: Text
  }
  deriving (Show, Eq, Ord, Generic)
instance FromJSON Discussion where
  parseJSON =
    genericParseJSON
      defaultOptions
        { fieldLabelModifier = \case
            (drop 10 -> c : cs) -> Char.toLower c : cs
            _ -> error ""
        }

-- **** Type 'Entity'
data Entity = Entity
  { entityName :: Text
  , entityMail :: Maybe Text
  }
  deriving (Show, Eq, Ord, Generic)
instance FromJSON Entity where
  parseJSON =
    genericParseJSON
      defaultOptions
        { fieldLabelModifier = \case
            (drop 6 -> c : cs) -> Char.toLower c : cs
            _ -> error ""
        }

-- **** Type 'Tag'
newtype Tag = Tag {unTag :: Text}
  deriving stock (Show, Eq, Ord, Generic)
  deriving (FromJSON) via Text

allTags :: HasCallStack => Model -> [Tag]
allTags =
  reverse
    . (Unsafe.head <$>)
    . List.sortOn List.length
    . List.group
    . List.sort
    . List.concat
    . (metaTags . pageMeta <$>)
    . Map.elems
    . modelPosts

-- * Type 'Route'
data Route
  = RouteFeeds
  | RouteFilter Filter
  | RouteFilterAtom Filter
  | RoutePage [Slug]
  | RouteSpecial [Slug]
  deriving (Show, Eq)

hrefRoute :: HasCallStack => Model -> Route -> H.Attribute
hrefRoute model route = A.href $ H.textValue $ {-"/" <>-} Ema.routeUrl model (Right @FilePath route)

absoluteLink :: HasCallStack => Model -> Either FilePath Route -> Text
absoluteLink model route = [fmt|https://{domainName}/{Ema.routeUrl model route}|]

encodeSlugs :: HasCallStack => [Slug] -> Text
encodeSlugs slugs = Text.concat $ "/" : List.intersperse "/" (encodeSlug <$> slugs)

decodeSlugs :: HasCallStack => Text -> [Slug]
decodeSlugs = (decodeSlug <$>) . Text.splitOn "/"

routeElem :: HasCallStack => Model -> Route -> H.Html -> H.Html
routeElem model route =
  H.a
    ! hrefRoute model route
    ! classes
      [ "hover:bg-blue-600"
      , "inline-block"
      , "p-4"
      , "text-white"
      ]

instance Ema (Either FilePath Route) where
  type ModelFor (Either FilePath Route) = Model

  -- Where to generate this Route.
  -- Called by Ema.routeUrl
  encodeRoute model@Model{..} = either id $ \case
    RoutePage page
      | Just{} <- Map.lookup page modelPosts ->
        html ("post" : page)
    RouteSpecial page
      | Just{} <- Map.lookup page modelSpecials ->
        html page
    RouteFilter Filter{filterTag = Nothing, filterLang = Nothing} ->
      html ["list", "tag"]
    RouteFilter filt@Filter{..}
      | maybe True (`elem` allTagsModel) filterTag ->
        html $ "list" : encodeFilter filt
    RouteFeeds -> html ["feeds"]
    RouteFilterAtom filt@Filter{..}
      | maybe True (`elem` allTagsModel) filterTag ->
        pathOf "xml" $ "feed" : encodeFilter filt
    _notFound ->
      --error [fmt|Route {notFound:s} does not exist.|]
      html ["not-found"]
    where
      allTagsModel = allTags model
      html = pathOf "html"
      pathOf suffix = toString . (<> "." <> suffix) . encodeSlugs

  -- Which route does this filepath correspond to?
  decodeRoute Model{..} filePath@(toText -> route)
    -- Files
    | Text.isPrefixOf "static/" route = Just $ Left filePath
    -- XML
    | Just (decodeSlugs -> slugs) <- Text.stripSuffix ".xml" route =
      case slugs of
        "feed" : (decodeFilter -> Just filt) ->
          Just $ Right $ RouteFilterAtom filt
        _ -> Nothing
    -- HTML
    | Just (decodeSlugs -> slugs) <- Text.stripSuffix ".html" route =
      case slugs of
        ["feeds"] -> Just $ Right RouteFeeds
        "list" : (decodeFilter -> Just filt) ->
          Just $ Right $ RouteFilter filt
        ["post"] -> Just $ Right $ RouteFilter noFilter
        "post" : pageName
          | Map.member pageName modelPosts ->
            Just $ Right $ RoutePage pageName
        pageName
          | Map.member pageName modelSpecials ->
            Just $ Right $ RouteSpecial pageName
        _ -> Nothing
    -- 404
    | otherwise = Nothing

  -- The routes to statically generate
  -- (not used by the live-server).
  allRoutes model =
    [Left "static", Right RouteFeeds]
    <> allPages
    <> allSpecials
    <> feeds
    <> lists
    where
      allPages = Right . RoutePage <$> Map.keys (modelPosts model)
      allSpecials = Right . RouteSpecial <$> Map.keys (modelSpecials model)
      allIndices =
        [ Filter{..}
        | filterLang <- Nothing : (Just <$> [minBound ..])
        , filterTag <- Nothing : (Just <$> toList (allTags model))
        ]
      feeds = Right . RouteFilterAtom <$> allIndices
      lists = Right . RouteFilter <$> allIndices

-- ** Type 'Filter'

-- Because the static site cannot afford
-- to generate all intersecting categories,
-- therefore select only a few whose intersection makes sense.
data Filter = Filter
  { filterLang :: Maybe Lang
  , filterTag :: Maybe Tag
  }
  deriving (Show, Eq)

noFilter :: Filter
noFilter =
  Filter
    { filterLang = Nothing
    , filterTag = Nothing
    }

encodeFilter :: HasCallStack => Filter -> [Slug]
encodeFilter Filter{..} =
  decodeSlug <$> case filterTag of
    Nothing -> langTag
    Just tag -> ["tag", unTag tag] <> langTag
  where
    langTag = textOfLang <$> maybeToList filterLang

decodeFilter :: HasCallStack => [Slug] -> Maybe Filter
decodeFilter = \case
  ["all", parseLang . encodeSlug -> filterLang] -> Just noFilter{filterLang}
  ["tag"] -> Just noFilter
  ["tag", Just . Tag . encodeSlug -> filterTag, parseLang . encodeSlug -> filterLang] -> Just Filter{..}
  ["tag", Just . Tag . encodeSlug -> filterTag] -> Just Filter{filterLang = Nothing, ..}
  _ -> Nothing

-- * Type 'Content'
data Content = Content
  { contentTitle :: Maybe Text
  , contentHtml :: H.Html
  -- , contentLang :: Maybe Lang
  }