Parsing.hs

{-# LANGUAGE DeriveAnyClass #-}

module Test.Blanks.Parsing where

import Control.Applicative (Alternative (..))
import Control.DeepSeq (NFData)
import Control.Exception (throwIO)
import Data.Void (Void)
import GHC.Generics (Generic)
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MPC
import qualified Text.Megaparsec.Char.Lexer as MPCL

type Parser = MP.Parsec Void String

-- The parser is not the SUT here, so if it fails,
-- so does the test. We ensure valid input.
runParserIO :: Parser a -> String -> IO a
runParserIO p s =
  case MP.runParser p "<test>" s of
    Left e -> throwIO e
    Right a -> pure a

data SourceSpan = SourceSpan
  { _ssName :: !FilePath
  , _ssStartLine :: !MP.Pos
  , _ssStartColumn :: !MP.Pos
  , _ssEndLine :: !MP.Pos
  , _ssEndColumn :: !MP.Pos
  } deriving stock (Eq, Show, Ord, Generic)
    deriving anyclass (NFData)

mkSourceSpan :: MP.SourcePos -> MP.SourcePos -> SourceSpan
mkSourceSpan (MP.SourcePos n sl sc) (MP.SourcePos _ el ec) = SourceSpan n sl sc el ec

around :: (SourceSpan -> a -> b) -> Parser a -> Parser b
around f pa = (\s a e -> f (mkSourceSpan s e) a) <$> MP.getSourcePos <*> pa <*> MP.getSourcePos

around2 :: (SourceSpan -> a -> b -> c) -> Parser (a, b) -> Parser c
around2 f pab = (\s (a, b) e -> f (mkSourceSpan s e) a b) <$> MP.getSourcePos <*> pab <*> MP.getSourcePos

around3 :: (SourceSpan -> a -> b -> c -> d) -> Parser (a, b, c) -> Parser d
around3 f pabc = (\s (a, b, c) e -> f (mkSourceSpan s e) a b c) <$> MP.getSourcePos <*> pabc <*> MP.getSourcePos

double :: Parser a -> Parser (a, a)
double p = (,) <$> p <*> p

triple :: Parser a -> Parser (a, a, a)
triple p = (,,) <$> p <*> p <*> p

spaceConsumer :: Parser ()
spaceConsumer = MPCL.space MPC.space1 lineCmnt blockCmnt
  where
    lineCmnt = MPCL.skipLineComment ";"
    blockCmnt = MPCL.skipBlockComment "#|" "|#"

lexeme :: Parser a -> Parser a
lexeme = MPCL.lexeme spaceConsumer

symbol :: String -> Parser String
symbol = MPCL.symbol spaceConsumer

parens :: Parser a -> Parser a
parens = MP.between (symbol "(") (symbol ")")

nonDelimPred :: Char -> Bool
nonDelimPred c = c /= '(' && c /= ')' && c /= ' ' && c /= '\t' && c /= '\n'

identifier :: Parser String
identifier = lexeme (MP.takeWhile1P Nothing nonDelimPred)

-- Take the first successful result, backtracking on failure.
branch :: [Parser a] -> Parser a
branch xs =
  case xs of
    [] -> empty
    x:xs' -> MP.try x <|> branch xs'

signed :: Parser Int
signed = MPCL.signed spaceConsumer (lexeme MPCL.decimal)