module Text.Peggy.Prim (
parse,
parseString,
parseFile,
Parser(..),
Result(..),
ParseError(..),
MemoTable(..),
memo,
getPos,
setPos,
anyChar,
satisfy,
char,
string,
expect,
unexpect,
space,
defaultDelimiter,
token,
) where
import Control.Applicative
import Control.Monad.ST
import Control.Monad.Error
import Data.Char
import Data.HashTable.ST.Basic as HT
import qualified Data.ListLike as LL
import Text.Peggy.SrcLoc
parse :: MemoTable tbl
=> (forall s . Parser tbl str s a)
-> SrcPos
-> str
-> Either ParseError a
parse p pos str = runST $ do
tbl <- newTable
res <- unParser p tbl pos ' ' str
case res of
Parsed _ _ _ ret -> return $ Right ret
Failed err -> return $ Left err
parseString :: MemoTable tbl
=> (forall s . Parser tbl str s a)
-> String
-> str
-> Either ParseError a
parseString p inputName str =
parse p (SrcPos inputName 0 1 1) str
parseFile :: MemoTable tbl
=> (forall s . Parser tbl String s a)
-> FilePath
-> IO (Either ParseError a)
parseFile p fp =
parse p (SrcPos fp 0 1 1) <$> readFile fp
newtype Parser tbl str s a
= Parser { unParser :: tbl s -> SrcPos -> Char -> str -> ST s (Result str a) }
data Result str a
= Parsed SrcPos Char str a
| Failed ParseError
data ParseError
= ParseError SrcLoc String
deriving (Show)
instance Error ParseError
nullError :: ParseError
nullError = ParseError (LocPos $ SrcPos "" 0 1 1) ""
errMerge :: ParseError -> ParseError -> ParseError
errMerge e1@(ParseError loc1 msg1) e2@(ParseError loc2 msg2)
| loc1 >= loc2 = e1
| otherwise = e2
class MemoTable tbl where
newTable :: ST s (tbl s)
instance Monad (Parser tbl str s) where
return v = Parser $ \_ pos p s -> return $ Parsed pos p s v
p >>= f = Parser $ \tbl pos prev s -> do
res <- unParser p tbl pos prev s
case res of
Parsed qos q t x ->
unParser (f x) tbl qos q t
Failed err ->
return $ Failed err
instance Functor (Parser tbl str s) where
fmap f p = return . f =<< p
instance Applicative (Parser tbl str s) where
pure = return
p <*> q = do
f <- p
x <- q
return $ f x
instance MonadError ParseError (Parser tbl str s) where
throwError err = Parser $ \_ _ _ _ -> return $ Failed err
catchError p h = Parser $ \tbl pos prev s -> do
res <- unParser p tbl pos prev s
case res of
Parsed {} -> return res
Failed err -> unParser (h err) tbl pos prev s
instance Alternative (Parser tbl str s) where
empty = throwError nullError
p <|> q =
catchError p $ \perr ->
catchError q $ \qerr ->
throwError $ perr `errMerge` qerr
memo :: (tbl s -> HT.HashTable s Int (Result str a))
-> Parser tbl str s a
-> Parser tbl str s a
memo ft p = Parser $ \tbl pos@(SrcPos _ n _ _) prev s -> do
cache <- HT.lookup (ft tbl) n
case cache of
Just v -> return v
Nothing -> do
v <- unParser p tbl pos prev s
HT.insert (ft tbl) n v
return v
getPos :: Parser tbl str s SrcPos
getPos = Parser $ \_ pos prev str -> return $ Parsed pos prev str pos
setPos :: SrcPos -> Parser tbl str s ()
setPos pos = Parser $ \_ _ prev str -> return $ Parsed pos prev str ()
parseError :: String -> Parser tbl str s a
parseError msg =
throwError =<< ParseError . LocPos <$> getPos <*> pure msg
anyChar :: LL.ListLike str Char => Parser tbl str s Char
anyChar = Parser $ \_ pos _ str ->
if LL.null str
then return $ Failed nullError
else do
let c = LL.head str
cs = LL.tail str
return $ Parsed (pos `advance` c) c cs c
satisfy :: LL.ListLike str Char => (Char -> Bool) -> Parser tbl str s Char
satisfy p = do
c <- anyChar
when (not $ p c) $ throwError nullError
return c
char :: LL.ListLike str Char => Char -> Parser tbl str s Char
char c = satisfy (==c) <|> parseError ("expect " ++ show c)
string :: LL.ListLike str Char => String -> Parser tbl str s String
string str = mapM char str <|> parseError ("expect " ++ show str)
expect :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s ()
expect p = do
b <- test p
when (not b) $ parseError "unexpected input"
unexpect :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s ()
unexpect p = do
b <- test p
when b $ parseError "unexpected input"
test :: LL.ListLike str Char => Parser tbl str s a -> Parser tbl str s Bool
test p = Parser $ \tbl pos prev str -> do
res <- unParser p tbl pos prev str
return $ case res of
Parsed _ _ _ _ -> Parsed pos prev str True
Failed _ -> Parsed pos prev str False
space :: LL.ListLike str Char => Parser tbl str s ()
space = () <$ satisfy isSpace
defaultDelimiter :: LL.ListLike str Char => Parser tbl str s ()
defaultDelimiter = () <$ satisfy (\c -> isPunctuation c || c == '+')
getPrevChar :: LL.ListLike str Char => Parser tbl str s Char
getPrevChar = Parser $ \_ pos prev str ->
return $ Parsed pos prev str prev
token :: LL.ListLike str Char
=> Parser tbl str s ()
-> Parser tbl str s ()
-> Parser tbl str s a
-> Parser tbl str s a
token sp del p = do
many sp
ret <- p
prev <- getPrevChar
sp <|> expect del <|> unexpect (satisfy $ check prev)
many sp
return ret
where
check pr cr
| isAlnum' pr && isAlnum' cr = True
| isDigit pr && isDigit cr = True
| isGlyph pr && isGlyph cr = True
| otherwise = False
isAlnum' c = isAlpha' c || isDigit c
isAlpha' c = isAlpha c || c == '_'
isGlyph c = isPrint c && not (isAlpha' c) && not (isDigit c)