SmartLine.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Description: Template Haskell code for persistent. This code needs to be in
-- a separate module because of GHC stage restriction.

-- Some of the code in this module is inspired by neat-interpolation by
-- nikita-volkov.

module BenchReport.Utils
    ( line
    ) where

import Control.Monad (void)
import Control.Applicative (Alternative(..))
import Control.Monad.Catch (MonadCatch)
import Data.Char (isAlphaNum)
import Streamly.Internal.Data.Parser (Parser)

import Language.Haskell.TH.Quote
import Language.Haskell.TH

import qualified Streamly.Internal.Data.Stream.IsStream as Stream
import qualified Streamly.Internal.Data.Parser as Parser
import qualified Streamly.Internal.Data.Fold as Fold

type Line = [LineContent]

data LineContent
    = LineContentText String
    | LineContentIdentifier String
    deriving (Show)

line :: QuasiQuoter
line =
    QuasiQuoter
        { quoteExp = smartStringE
        , quotePat = notSupported
        , quoteType = notSupported
        , quoteDec = notSupported
        }

    where

    notSupported = error "str: Not supported."

-- | Clear all new lines and trim the input
-- This has a small workaround for parser alternative instance bug
-- We add a space in the end
makeSimpleLine :: String -> String
makeSimpleLine =
    filter (/= '\n')
        . reverse . (' ':) . dropWhile (== ' ') . reverse . dropWhile (== ' ')

smartStringE :: String -> Q Exp
smartStringE line =
    case Stream.parse lineParser (Stream.fromList (makeSimpleLine line)) of
        Left _ -> fail "Some error has occured."
        Right xs -> lineExp xs

lineExp :: Line -> Q Exp
lineExp xs = appE [| concat |] $ listE $ map contentExp xs

contentExp :: LineContent -> Q Exp
contentExp (LineContentText text) = stringE text
contentExp (LineContentIdentifier name) = do
    valueName <- lookupValueName name
    case valueName of
        Just vn -> varE vn
        Nothing -> fail $ "Value `" ++ name ++ "` is not in scope"

-- streamly-0.8.0 does not expose char parser
-- We need to get all the utils working with streamly-0.8.1 for migration
charP :: MonadCatch m => Char -> Parser m Char Char
charP c = Parser.satisfy (== c)

-- streamly-0.8.0 does not expose alphaNum parser
-- We need to get all the utils working with streamly-0.8.1 for migration
alphaNumP :: MonadCatch m => Parser m Char Char
alphaNumP = Parser.satisfy isAlphaNum

lineParser :: MonadCatch m => Parser m Char Line
lineParser = Parser.many content Fold.toList

    where

    identifierSimple =
        Parser.some (alphaNumP <|> charP '\'' <|> charP '_') Fold.toList
    identifierInBraces = charP '{' *> identifierSimple <* charP '}'
    identifier =
        fmap LineContentIdentifier
            $ charP '$' *> (identifierInBraces <|> identifierSimple)
    escapedDollar = fmap (LineContentText . (: [])) $ charP '$' *> charP '$'
    -- "Parser.count" is undefined. The current implementation eats the
    -- malformed '$' instead of erroring out. This should be fixed if 'count' is
    -- used.
    -- escapedDollar =
    --     fmap LineContentText
    --         $ charP '$' *> Parser.count 1 (charP '$') Fold.toList
    anySingle = Parser.satisfy (const True)
    end =
        void (Parser.lookAhead escapedDollar)
            <|> void (Parser.lookAhead identifier)
            <|> Parser.eof
    contentText = LineContentText <$> Parser.manyTill anySingle end Fold.toList
    content = escapedDollar <|> identifier <|> contentText

\n shouldn't be ignored but add a space instead.