{-# LANGUAGE CPP #-}

-- | Parsers for Mighty

module Program.Mighty.Parser (
  -- * Utilities
    parseFile
  -- * Parsers
  , spcs
  , spcs1
  , spc
  , commentLines
  , trailing
  , comment
  ) where

import qualified Data.ByteString.Lazy.Char8 as BL
import System.IO
import Text.Parsec
import Text.Parsec.ByteString.Lazy
import UnliftIO.Exception

-- $setup
-- >>> import Data.Either
-- >>> let isLeft = either (const True) (const False)

-- | Parsing a file.
--   If parsing fails, an 'IOException' is thrown.
parseFile :: Parser a -> FilePath -> IO a
parseFile :: Parser a -> FilePath -> IO a
parseFile Parser a
p FilePath
file = do
    Handle
hdl <- FilePath -> IOMode -> IO Handle
openFile FilePath
file IOMode
ReadMode
    Handle -> TextEncoding -> IO ()
hSetEncoding Handle
hdl TextEncoding
latin1
    ByteString
bs <- Handle -> IO ByteString
BL.hGetContents Handle
hdl
    case Parser a -> FilePath -> ByteString -> Either ParseError a
forall s t a.
Stream s Identity t =>
Parsec s () a -> FilePath -> s -> Either ParseError a
parse Parser a
p FilePath
"parseFile" ByteString
bs of
        Right a
x -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        Left  ParseError
e -> IOError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (IOError -> IO a) -> (ParseError -> IOError) -> ParseError -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOError
userError (FilePath -> IOError)
-> (ParseError -> FilePath) -> ParseError -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> FilePath
forall a. Show a => a -> FilePath
show (ParseError -> IO a) -> ParseError -> IO a
forall a b. (a -> b) -> a -> b
$ ParseError
e

-- | 'Parser' to consume zero or more white spaces
--
-- >>> parse spcs "" "    "
-- Right ()
-- >>> parse spcs "" ""
-- Right ()
spcs :: Parser ()
spcs :: Parser ()
spcs = () () -> ParsecT ByteString () Identity FilePath -> Parser ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT ByteString () Identity Char
spc

-- | 'Parser' to consume one or more white spaces
--
-- >>> parse spcs1 "" "    "
-- Right ()
-- >>> parse spcs1 "" " "
-- Right ()
-- >>> isLeft $ parse spcs1 "" ""
-- True
spcs1 :: Parser ()
spcs1 :: Parser ()
spcs1 = () () -> ParsecT ByteString () Identity FilePath -> Parser ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity FilePath
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT ByteString () Identity Char
spc

-- | 'Parser' to consume exactly one white space
--
-- >>> parse spc "" " "
-- Right ' '
-- >>> isLeft $ parse spc "" ""
-- True
spc :: Parser Char
spc :: ParsecT ByteString () Identity Char
spc = (Char -> Bool) -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
" \t")

-- | 'Parser' to consume one or more comment lines
--
-- >>> parse commentLines "" "# comments\n# comments\n# comments\n"
-- Right ()
commentLines :: Parser ()
commentLines :: Parser ()
commentLines = () () -> ParsecT ByteString () Identity [()] -> Parser ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser () -> ParsecT ByteString () Identity [()]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser ()
commentLine
  where
    commentLine :: Parser ()
commentLine = Parser ()
trailing

-- | 'Parser' to consume a trailing comment
--
-- >>> parse trailing "" "# comments\n"
-- Right ()
-- >>> isLeft $ parse trailing "" "X# comments\n"
-- True
trailing :: Parser ()
trailing :: Parser ()
trailing = () () -> ParsecT ByteString () Identity Char -> Parser ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Parser ()
spcs Parser () -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
comment Parser ()
-> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser ()
spcs Parser ()
-> ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
newline)

-- | 'Parser' to consume a trailing comment
--
-- >>> parse comment "" "# comments"
-- Right ()
-- >>> isLeft $ parse comment "" "foo"
-- True
comment :: Parser ()
comment :: Parser ()
comment = () () -> ParsecT ByteString () Identity Char -> Parser ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'#' Parser () -> ParsecT ByteString () Identity FilePath -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT ByteString () Identity Char
-> ParsecT ByteString () Identity FilePath
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (FilePath -> ParsecT ByteString () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
FilePath -> ParsecT s u m Char
noneOf FilePath
"\n")