CxxParser.hs

{-# OPTIONS_GHC -fno-warn-tabs #-}
{-# LANGUAGE
	OverloadedStrings,
	RecordWildCards,
	TupleSections,
	ViewPatterns,
	LambdaCase,
	TypeSynonymInstances,
	FlexibleInstances #-}

module CxxParser (parseLiteral, parseComment, parseCppDirective) where

import LaTeXBase (LaTeX, LaTeXUnit(..), ArgKind(..), concatRaws,
    texStripPrefix, texStripAnyPrefix, texStripInfix, texSpan, unconsRaw)
import qualified Data.Text as Text
import Data.Char (isAlpha, isSpace, isAlphaNum, isDigit)
import Control.Arrow (first)
import Prelude hiding ((.), (++))
import Util ((.), (++), Text)

texStripHash :: LaTeX -> Maybe LaTeX
texStripHash x
    | Just x' <- texStripPrefix "#" x = Just x'
    | TeXComm "#" _ [] : x' <- x = Just x'
    | otherwise = Nothing

cppDirectives :: [Text]
cppDirectives = Text.words "include define elifndef elifdef ifndef endif ifdef pragma error undef line elif warning else if"

spanLiteralChars :: String -> Maybe (String, String {- rest without the closing ' -})
spanLiteralChars [] = Nothing
spanLiteralChars ('\\' : '\'' : rest) = first ("\\'"++) . spanLiteralChars rest
spanLiteralChars ('\'' : x) = Just ([], x)
spanLiteralChars (c : rest) = first (c :) . spanLiteralChars rest

parseLiteralChars :: LaTeX -> Maybe (LaTeX, LaTeX)
parseLiteralChars [] = Nothing
parseLiteralChars (TeXRaw s : rest) = case spanLiteralChars (Text.unpack s) of
    Nothing -> Nothing
    Just (_, []) -> first (TeXRaw s :) . (parseLiteralChars rest)
    Just (x, more) -> Just ([TeXRaw (Text.pack x)], TeXRaw (Text.pack more) : rest)
parseLiteralChars (x : rest) = first (x :) . (parseLiteralChars rest)

parseCharLiteral :: LaTeX -> Maybe (LaTeX, LaTeX {- rest -})
parseCharLiteral x
    | Just (pre, x') <- texStripAnyPrefix ["'", "u'", "L'", "U'", "u8'"] x
    , Just (before, x'') <- parseLiteralChars x'
    , (suffix, x''') <- texSpan (\c -> isAlphaNum c || c == '_') x''
        = Just ([TeXRaw pre] ++ before ++ [TeXRaw $ "'" ++ suffix], x''')
    | otherwise = Nothing

parseCppDirective :: LaTeX -> Maybe (LaTeX, LaTeX {- rest -})
parseCppDirective x
    | Just x'' <- texStripHash x
    , (spaces, x''') <- texSpan isSpace x''
    , Just (directive, x'''') <- texStripAnyPrefix cppDirectives x'''
        = Just ([TeXRaw ("#" ++ spaces ++ directive)], x'''')
    | otherwise = Nothing

parseSingleLineComment :: LaTeX -> Maybe (LaTeX {- comment -}, LaTeX {- subsequent lines -})
parseSingleLineComment x
    | Just x' <- texStripPrefix "//" x = Just $ case texStripInfix "\n" x' of
        Just (commentLine, moreLines) -> (TeXRaw "//" : commentLine, TeXRaw "\n" : moreLines)
        Nothing -> (x, [])
    | rlap@(TeXComm "rlap" _ [(FixArg, [TeXComm "textnormal" _ [(FixArg,[TeXComm "textit" _ [(FixArg,[TeXRaw "//"])]])]])]) : more <- x
    , Just (commentLine, moreLines) <- texStripInfix "\n" more
        = Just ([rlap, TeXComm "tcode" "" [(FixArg, commentLine)]], TeXRaw "\n" : moreLines)
    | TeXComm "comment" _ [(FixArg, c)] : x' <- x = Just (c, x')
    | otherwise = Nothing

fromTeXRaw :: LaTeXUnit -> Text
fromTeXRaw (TeXRaw x) = x
fromTeXRaw x = error $ "fromTeXRaw (" ++ show x ++ ")"

parseStringLiteral :: LaTeX -> Maybe (LaTeX, LaTeX {- rest -})
parseStringLiteral x
    -- raw:
    | Just (pre, x') <- texStripAnyPrefix ["R\"", "u8R\"", "uR\"", "UR\"", "LR\""] x
    , Just (delim, x'') <- texStripInfix "(" x'
    , Just (body, x''') <- texStripInfix (")" ++ Text.concat (map fromTeXRaw delim) ++ "\"") (concatRaws $ f x'')
    , (suffix, x'''') <- texSpan (\c -> isAlphaNum c || c == '_') x'''
        = Just ([TeXRaw pre] ++ delim ++ [TeXRaw "("] ++ body ++ [TeXRaw ")"] ++ delim ++ [TeXRaw $ "\"" ++ suffix], x'''')
    -- normal:
    | Just (pre, x') <- texStripAnyPrefix ["\"", "u\"", "U\"", "L\"", "u8\""] x
    , Just (body, x'') <- parseBody x'
    , (suffix, x''') <- texSpan (\c -> isAlphaNum c || c == '_') x''
        = Just ([TeXRaw pre] ++ body ++ [TeXRaw $ "\"" ++ suffix], x''')
    | otherwise = Nothing
    where
        f :: LaTeX -> LaTeX
        f [] = []
        f (TeXComm "~" _ [] : more) = TeXRaw "~" : f more
        f (TeXBraces [] : more) = f more
        f (hd : t) = hd : f t
        parseBody :: LaTeX -> Maybe (LaTeX, LaTeX {- rest -})
        parseBody [] = Nothing
        parseBody (TeXComm "textbackslash" _ [] : more) = parseBody $ concatRaws $ TeXRaw "\\" : more
        parseBody (TeXRaw (Text.unpack -> raw) : more)
            | '\\':'"':t <- raw = first (TeXRaw "\\\"" :) . parseBody (TeXRaw (Text.pack t) : more)
            | "\"" <- raw = Just ([], more)
            | '"':t <- raw = Just ([], TeXRaw (Text.pack t) : more)
            | raw == "" = parseBody more
            | hd:t <- raw = first (TeXRaw (Text.pack [hd]) :) . parseBody (TeXRaw (Text.pack t) : more)
        parseBody (TeXComm "%" ws [] : more) = first (TeXComm "%" ws [] :) . parseBody more
        parseBody (y : more) = first (y :) . parseBody more

parseNumber :: LaTeX -> Maybe (Text, LaTeX)
parseNumber x
    | (raw, more) <- unconsRaw x
    , Just (n, rest) <- (parseStart `parseSeq` (\t -> Just (parseMany parseSuffix t))) raw
        = Just (n, TeXRaw rest : more)
    | otherwise = Nothing
    where
        parseDigit = parseChar isDigit
        parseNonDigit = parseChar (\c -> isAlpha c || c == '_')
        parseStart :: Text -> Maybe (Text, Text)
        parseStart = parseFirstOf [parseChar (== '.') `parseSeq` parseDigit, parseDigit]
        parseSign :: Text -> Maybe (Text, Text)
        parseSign = parseChar (\c -> c == '-' || c == '+')
        parseSuffix :: Text -> Maybe (Text, Text)
        parseSuffix = parseFirstOf
            [ parseDigit
            , parseChar (== '\'') `parseSeq` parseDigit
            , parseChar (== '\'') `parseSeq` parseNonDigit
            , parseChar (`elem` ("eEpP"::String)) `parseSeq` parseSign
            , parseChar (== '.')
            , parseNonDigit
            ]

parseLiteral :: LaTeX -> Maybe (LaTeX, LaTeX)
parseLiteral x
    | Just (number, x') <- parseNumber x = Just ([TeXRaw number], x')
    | Just (lit, x') <- parseCharLiteral x = Just (lit, x')
    | Just (lit, x') <- parseStringLiteral x = Just (lit, x')
    | otherwise = Nothing

parseComment :: LaTeX -> Maybe (LaTeX, LaTeX)
parseComment x
    | Just x' <- texStripPrefix "/*" x, Just (comment, x'') <- texStripInfix "*/" x'
        = Just ([TeXRaw "/*"] ++ comment ++ [TeXRaw "*/"], x'')
    | Just x' <- texStripPrefix "/*" x
        = Just ([TeXRaw "/*"], x')
    | Just x' <- texStripPrefix "*/" x
        = Just ([TeXRaw "*/"], x')
    | Just (comment, x') <- parseSingleLineComment x
        = Just (comment, x')
    | otherwise = Nothing

parseChar :: (Char -> Bool) -> Text -> Maybe (Text, Text)
parseChar p t
    | t /= "", p (Text.head t) = Just (Text.take 1 t, Text.drop 1 t)
    | otherwise = Nothing

parseSeq :: (Text -> Maybe (Text, Text)) -> (Text -> Maybe (Text, Text)) -> Text -> Maybe (Text, Text)
parseSeq p q t
    | Just (x, t') <- p t
    , Just (y, t'') <- q t' = Just (x ++ y, t'')
    | otherwise = Nothing

parseFirstOf :: [Text -> Maybe (a, Text)] -> Text -> Maybe (a, Text)
parseFirstOf [] _ = Nothing
parseFirstOf (p:pp) t
    | Just r <- p t = Just r
    | otherwise = parseFirstOf pp t

parseMany :: (Text -> Maybe (Text, Text)) -> Text -> (Text, Text)
parseMany p t = case p t of
    Nothing -> ("", t)
    Just (x, t') -> first (x++) (parseMany p t')