{-# LANGUAGE Strict #-}

module Polysemy.Commonmark.AST (Inline, Block, commonmark) where

import Relude

import Commonmark (commonmarkWith)
import Commonmark.Extensions.Strikethrough
import Commonmark.Parser (ParseError)
import Commonmark.Syntax (defaultSyntaxSpec)
import Commonmark.Types
import Data.Char qualified as C
import Data.Sequence ( Seq ((:<|), Empty)
                     , ViewL ((:<)), ViewR ((:>))
                     , viewl, viewr
                     )
import Data.Text qualified as T
import Polysemy.Output.IO (putTextO, putTextLnO)
import Polysemy.Sgr (withSgr)
import Color.Print
import System.Console.ANSI qualified as ANSI
import Color.Utils

commonmark :: String -> Text -> Either ParseError Block
commonmark filename source =
  runIdentity $ commonmarkWith @Identity @Inline @Block (defaultSyntaxSpec <> strikethroughSpec)
                                                        filename
                                                        source

-- TODO: add spoilers
data InlinePiece = Str Text
                 | Emph Inline
                 | Strong Inline
                 | Underline Inline
                 | Strikethrough Inline
                 -- | Autolink { dest :: Text }
                 | Link { dest, title :: Text
                        , descr :: Inline
                        }
                 | Code Text
                 deriving stock (Show)

newtype Inline = Inline (Seq InlinePiece)
               deriving newtype (IsList, Show)

mapText :: (Text -> Text) -> Inline -> Inline
mapText f (Inline pieces) = Inline (mapText' <$> pieces) where
  mapText' (Str t) = Str (f t)
  mapText' (Emph i) = Emph (mapText f i)
  mapText' (Strong i) = Strong (mapText f i)
  mapText' (Underline i) = Underline (mapText f i)
  mapText' (Strikethrough i) = Strikethrough (mapText f i)
  mapText' Link{dest, title, descr} = Link { dest, title, descr = mapText f descr }
  mapText' (Code t) = Code t

instance Semigroup Inline where
  Inline as <> Inline bs =
    case (viewr as, viewl bs) of
      (as' :> Str a, Str b :< bs') -> Inline as' <> Inline (Str (a <> b) :<| bs')
      (as' :> Emph a, Emph b :< bs') -> Inline as' <> Inline (Emph (a <> b) :<| bs')
      (as' :> Strong a, Strong b :< bs') -> Inline as' <> Inline (Strong (a <> b) :<| bs')
      (as' :> Underline a, Underline b :< bs') -> Inline as' <> Inline (Underline (a <> b) :<| bs')
      (as' :> Code a, Code b :< bs') -> Inline as' <> Inline (Code (a <> b) :<| bs')
      _ -> Inline (as <> bs)

instance Monoid Inline where
  mempty = Inline Empty

instance Rangeable Inline where
  ranged = const id

instance HasAttributes Inline where
  addAttributes = const id

instance IsInline Inline where
  str = Inline . one . Str
  lineBreak = str "\n"
  softBreak = str " "
  entity = str
  escapedChar c = str $ "\\" <> one c
  emph = Inline . one . Emph
  strong = Inline . one . Strong
  link dest _title descr =
    descr <> fromList [ Str " ("
                      , Underline (str dest)
                      , Str ")"]
  image = link
  code c = Inline . one $ Code $ "`" <> c <> "`"
  rawInline _ = code

data BlockPiece = Paragraph Inline
                | Plain Inline
                | ThematicBreak
                | BlockQuote Block
                | CodeBlock Text Text
                | Heading Int Inline
                | ReferenceLinkDefinition { label :: Text, dest :: Text, title :: Text }
                | List ListType ListSpacing [Block]
                deriving stock (Show)

newtype Block = Block [BlockPiece]
              deriving newtype (Show, Semigroup, Monoid)

instance Rangeable Block where
  ranged = const id

instance HasAttributes Block where
  addAttributes = const id

instance IsBlock Inline Block where
  paragraph = Block . one . Paragraph
  plain = Block . one . Plain
  thematicBreak = Block [ThematicBreak]
  blockQuote = Block . one . BlockQuote
  codeBlock lang = Block . one . CodeBlock lang
  heading lvl = Block . one . Heading lvl
  rawBlock (Format t) = codeBlock t
  referenceLinkDefinition label (dest, title) = Block [ReferenceLinkDefinition label dest title]
  list type_ spacing = Block . one . List type_ spacing

instance PrintColor Inline where
  -- TODO: needs to be aware of prefix and line length
  -- and perform line wrapping
  printColor (Inline pieces) = for_ pieces printPiece where
    printPiece (Str t) = case t of
      "" -> pass
      "@" -> putTextO t
      _ ->
        let (beforeUsername, withUsername) = (/= '@') `T.span` t
            ~isNotPartOfWord = T.null beforeUsername || C.isSpace (T.last beforeUsername)
            ~(username, rest) = T.span isUsernameSym (T.tail withUsername)
         in if not (T.null withUsername) && isNotPartOfWord
              then do
                putTextO beforeUsername
                withSgr [ ANSI.SetPaletteColor ANSI.Foreground (textColor username)
                        -- , ANSI.SetSwapForegroundBackground True
                        , ANSI.SetConsoleIntensity ANSI.BoldIntensity
                        ] do
                  putTextO $ "@" <> username
                printPiece (Str rest)
              else putTextO t
      where
        isUsernameSym c = C.isAlphaNum c || elem c ['_', '-']
    printPiece (Emph i) = withSgr [ANSI.SetItalicized True] $ printColor i
    printPiece (Strong i) = withSgr [ANSI.SetConsoleIntensity ANSI.BoldIntensity] $ printColor i
    printPiece (Underline i) = withSgr [ANSI.SetUnderlining ANSI.SingleUnderline] $ printColor i
    printPiece (Strikethrough i) = printColor (mapText mkStrikethrough i)
      where
        mkStrikethrough :: (IsString s, ToString s) => s -> s
        mkStrikethrough s = fromString do { c <- toString s; [c, chr 822] }
    printPiece Link{dest, descr} = do
      printColor descr
      withSgr [ANSI.SetUnderlining ANSI.SingleUnderline] do
        putTextO $ " (" <> dest <> ")"
    printPiece (Code t) =
      withSgr [ ANSI.SetColor ANSI.Background ANSI.Vivid ANSI.Black
              , ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White
              ] do
        putTextO t

instance HasStrikethrough Inline where
  strikethrough = Inline . one . Strikethrough

instance PrintColor Block where
  printColor = printBlockP "" where
    printBlockP prefix (Block b) = for_ b (printBlockOne prefix)

    printBlockOne prefix (Paragraph i) = do
      putTextO prefix
      printColor i
      putTextLnO ""
    printBlockOne prefix (Plain i) = do
      putTextO prefix
      printColor i
    printBlockOne prefix ThematicBreak = do
      putTextO prefix
      -- TODO: this should depend on terminal width
      putTextLnO . fromString $ replicate (80 - T.length prefix) '─'
    printBlockOne prefix (BlockQuote b) = printBlockP (prefix <> "> ") b
    printBlockOne prefix (CodeBlock lang content) = do
      putTextLnO $ prefix <> "```" <> lang
      withSgr [ANSI.SetColor ANSI.Background ANSI.Vivid ANSI.Black] do
        for_ (lines content) $ putTextLnO . (prefix <>)
      putTextLnO $ prefix <> "```"
    printBlockOne prefix (Heading lvl i) = do
      withSgr [ANSI.SetConsoleIntensity ANSI.BoldIntensity] do
        putTextO $ prefix <> fromString (replicate lvl '#')
      putTextO $ prefix <> " "
      printColor i
      putTextLnO ""
    printBlockOne prefix (List type_ _spacing blocks) =
      for_ (zip (listPrefixes type_) blocks) \(listPrefix, block) -> do
        printBlockP (prefix <> listPrefix) block
        putTextLnO ""
    printBlockOne _prefix x = error $ "printBlockOne: " <> show x

    listPrefixes :: ListType -> [Text]
    listPrefixes (BulletList c) = repeat (fromString [c, ' '])
    listPrefixes (OrderedList start enumType delimType) =
      [start..] <&> \i -> enumFor i <> delim <> " "
      where
        infAlph xs = xs ++ ((<>) <$> infAlph xs <*> xs)
        enumFor i = case enumType of
          UpperAlpha -> infAlph (fromString . one <$> ['A'..'Z']) !!? i & fromMaybe (error "Impossible")
          LowerAlpha -> infAlph (fromString . one <$> ['a'..'z']) !!? i & fromMaybe (error "Impossible")
          _ -> show i
        delim = case delimType of
          Period -> "."
          OneParen -> ")"
          TwoParens -> "))"