Parser.hs

module IDE.Help.Parser where

import Control.Applicative
import Control.Monad
import qualified Data.Map as Map
import qualified Data.List as DL
import Data.Text as T
import qualified Data.Vector as V
import System.Console.ANSI (Color(..))

import Common
import qualified Compiler.Lexer.Tokens as CT
import qualified Compiler.Lexer.Identifiers as CI
import Parser.Lib
import Parser.Parser
import DiffRender.DiffRender
import Highlighter.Highlighter

data DisplayTokenRaw
  = DTPlain Text
  | DTHeading Int Text
  | DTCode CT.Token
  | DTInlineCode CT.Token
  | DTLink Bool Text
  | DTNewLine
  deriving (Show, Eq)

instance ToSource DisplayTokenRaw where
  toSource = \case
    DTPlain t -> t
    DTHeading s t -> "\n" <> renderHeader s t
    DTCode t -> toSource t
    DTInlineCode t -> toSource t
    DTLink _ t -> t
    DTNewLine -> "\n"

underlineWith :: Text -> Text -> Text
underlineWith s t = t <> "\n" <> (T.replicate (T.length t) s)

renderHeader :: Int -> Text -> Text
renderHeader 1 t = underlineWith "*" t
renderHeader 2 t = underlineWith "_" t
renderHeader 3 t = underlineWith "=" t
renderHeader 4 t = underlineWith "-" t
renderHeader 5 t = "| " <> t
renderHeader _ t = t

data DisplayToken = DisplayToken { dtTr :: DisplayTokenRaw, dtLocation :: Location, dtOffsetEnd :: Int }
  deriving (Show, Eq)

convertToDisplay :: Map.Map Text Text -> V.Vector HToken -> (Text, V.Vector DisplayToken)
convertToDisplay builtIns tokens = let (_, src, dt) = V.foldl' fn (0, "", V.empty) tokens in (src, dt)
  where
    makeArgs :: Text -> V.Vector DisplayTokenRaw
    makeArgs (T.breakOn "(" -> (fnName, (T.drop 1 . T.dropEnd 1 -> argsRaw))) = let
      fnNameTk = DTInlineCode $ CT.Token (CT.TkIdentifier $ CI.Identifier fnName) emptyLocation 0
      in V.fromList $ DTPlain "Arguments: "
          : fnNameTk : DTPlain "("
          : (DL.concat $ DL.intersperse [DTPlain ", "] $
              mkArg <$> (T.splitOn ", " argsRaw)) <> [DTPlain ")"]

    mkArg :: Text -> [DisplayTokenRaw]
    mkArg t = let
      (argName, argType) = T.breakOn ":" t
      in [DTInlineCode $ (CT.Token (CT.TkIdentifier $ CI.Identifier argName) emptyLocation 0), DTPlain argType]

    fn :: (Int, Text, V.Vector DisplayToken) -> HToken -> (Int, Text, V.Vector DisplayToken)
    fn (lastOffset, srcin, tkns) a = let
      thisTokens = case tkRaw a of
        PlainText t -> V.singleton (DTPlain t)
        Heading _ s t -> case Map.lookup (t<> "()") builtIns of
          Just x -> V.cons (DTHeading s t) (V.cons DTNewLine $ V.cons DTNewLine $ makeArgs x)
          Nothing -> V.singleton $ DTHeading s t
        Code _ t -> (V.cons DTNewLine (V.fromList (DTCode <$> t))) <> (V.singleton DTNewLine)
        InlineCode _ t -> V.fromList $ DTInlineCode <$> t
        Link t -> V.singleton (DTLink False t)
        NewLine -> V.singleton (DTNewLine)
      in V.foldl' fn2 (lastOffset, srcin, tkns) thisTokens

    fn2 :: (Int, Text, V.Vector DisplayToken) -> DisplayTokenRaw -> (Int, Text, V.Vector DisplayToken)
    fn2 (thisOffset, srcin, tkns) tkraw = let
      thisSize = T.length $ toSource tkraw
      in (thisOffset + thisSize, srcin <> (toSource tkraw), V.snoc tkns (DisplayToken tkraw (Location 0 0 thisOffset) (thisOffset + thisSize - 1)))

data HTokenRaw
  = PlainText Text
  | Heading Text Int Text
  | Code Text [CT.Token]
  | InlineCode Text [CT.Token]
  | Link Text
  | NewLine
  deriving (Show, Eq)

instance ToSource HTokenRaw where
  toSource (PlainText t)    = t
  toSource (Heading t _ _)  = t
  toSource (Code t _)       = t
  toSource (InlineCode t _) = t
  toSource (Link t) = t
  toSource NewLine          = "\n"

data HToken = HToken
   { tkRaw       :: HTokenRaw
   , tkLocation  :: Location
   , tkOffsetEnd :: Int
   } deriving (Show)

type HelpParser a = ParserM IO TextWithOffset a

parseChar :: (Char -> Bool) -> HelpParser Char
parseChar fn = ParserM "Help - Parse Char" $ \t ->
  case uncons (twText t) of
    Just (c, rst) -> case fn c of
      True -> pure (Right c, t { twText = rst, twLocation = moveCols (twLocation t) 1 })
      False -> pure (Left CantHandle, t)
    Nothing -> pure (Left CantHandle, t)

plainTextParser :: HelpParser HTokenRaw
plainTextParser = nameParser "Plain Text" $ (PlainText . T.pack) <$> (some $ parseChar fn)
  where
    fn '#'  = False
    fn '`'  = False
    fn '\n' = False
    fn _    = True

parseNLorStartWith :: HelpParser a -> HelpParser a
parseNLorStartWith pin = nlOrStart >> pin
  where
  nlOrStart = (void $ parseChar (\c -> c == '\n')) <|> (ParserM "Help - Steam start" $ \t ->
    case lcOffset $ twLocation t of
      0 -> pure (Right (), t)
      _ -> pure (Left CantHandle, t))

linkParser :: HelpParser HTokenRaw
linkParser = do
  void $ pText "#link: "
  name <- some (parseChar (/= '#'))
  void $ pChar '#'
  pure $ Link (T.pack name)

headingParser :: Int -> HelpParser HTokenRaw
headingParser s = parseNLorStartWith (headingParser' s)

codeParser :: HelpParser HTokenRaw
codeParser = parseNLorStartWith codeParser'

headingParser' :: Int -> HelpParser HTokenRaw
headingParser' hs = ParserM "Help Heading" $ \t ->
  let
    prefix = (T.replicate hs "#") <> " "
    prefixLen = T.length prefix
  in if T.take prefixLen (twText t) == prefix
    then do
      let rst = T.drop prefixLen (twText t)
      let c = T.takeWhile (\c' -> c' /= '\n') rst
      let ln = T.length c
      pure (Right $ Heading (prefix <> c) hs c, t { twText = T.drop ln rst, twLocation = moveCols (twLocation t) (ln+prefixLen)})
    else pure (Left CantHandle, t)

codeParser' :: HelpParser HTokenRaw
codeParser' = ParserM "Help Code" $ \t ->
  case T.take 4 (twText t) of
    "```\n" -> do
      let rst = T.drop 4 (twText t)
      let (c, rst') = T.breakOn "\n```\n" rst
      let ln = T.length c
      runParserEither (parser @[CT.Token]) (toTextWithOffset c) >>= \case
        Left _ -> pure (Left CantHandle, t)
        Right tokens ->
          pure (Right $ Code ("```\n" <> c <> "\n```\n") tokens, t { twText = T.drop 5 rst', twLocation = moveCols (twLocation t) (ln+9)})
    _ -> pure (Left CantHandle, t)

inlineCodeParser :: HelpParser HTokenRaw
inlineCodeParser = nameParser "Help Inline Code" $ do
  void $ parseChar (== '`')
  tokens <- parser @[CT.Token]
  void $ parseChar (== '`')
  pure $ InlineCode ("`" <> (T.concat $ toSource <$> tokens) <> "`") tokens

instance HasParser HTokenRaw where
  parser = linkParser <|> (headingParser 1 <|> headingParser 2 <|> headingParser 3 <|> headingParser 4 <|> headingParser 5) <|> codeParser <|> inlineCodeParser <|> plainTextParser <|> newLineParser

instance HasInnerParseable HToken where
  type InnerToken HToken = HTokenRaw
  assemble = HToken

instance Highlightable DisplayToken where
  getTokenLoc (DisplayToken _ loc _) = loc
  highlight = highlightTokens
  pairWithTokens tokenStack startOffset source =
    genericPairWithTokens dtOffsetEnd dtLocation startOffset source tokenStack

highlightTokens :: (StyledText, Maybe DisplayToken) -> StyledText
highlightTokens (src, Nothing) = src
highlightTokens (src, Just (dtTr -> tk')) =
  case tk' of
    DTPlain _ -> src
    DTHeading _ _-> StyledText (Fg Green) [src]
    DTCode tk -> highlight @CT.Token (src, Just tk)
    DTInlineCode tk -> highlight @CT.Token (src, Just tk)
    DTLink True _ -> StyledText (Fg Red) [src]
    DTLink _ _ -> StyledText (Fg Blue) [src]
    DTNewLine -> src

newLineParser :: HelpParser HTokenRaw
newLineParser = nameParser "Help Newline" $ do
  void $ parseChar (== '\n')
  pure NewLine

parseHelp :: Text -> IO (Either String [HToken])
parseHelp t = runParserEither (some (parser @HToken)) (toTextWithOffset t) >>= \case
  Right r  -> pure $ Right r
  Left err -> pure $ Left (show err)