module Text.ParserCombinators.Poly.Base
(
Commitment(..)
, PolyParse
, apply
, discard
, failBad
, adjustErrBad
, indent
, oneOf
, exactly
, upto
, many1
, sepBy
, sepBy1
, bracketSep
, bracket
, manyFinally
, manyFinally'
) where
import Control.Applicative
import qualified Control.Monad.Fail as Fail
#ifdef __NHC__
default (Integer,Double,[])
instance Commitment []
instance PolyParse []
#endif
class Commitment p where
commit :: p a -> p a
adjustErr :: p a -> (String -> String) -> p a
oneOf' :: [(String, p a)] -> p a
class (Functor p, Monad p, Fail.MonadFail p, Applicative p, Alternative p, Commitment p) =>
PolyParse p
infixl 3 `apply`
infixl 3 `discard`
apply :: PolyParse p => p (a->b) -> p a -> p b
apply :: forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
apply = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
discard :: PolyParse p => p a -> p b -> p a
p a
px discard :: forall (p :: * -> *) a b. PolyParse p => p a -> p b -> p a
`discard` p b
py = do { a
x <- p a
px; b
y <- p b
py; b
y seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return a
x; }
failBad :: PolyParse p => String -> p a
failBad :: forall (p :: * -> *) a. PolyParse p => String -> p a
failBad String
e = forall (p :: * -> *) a. Commitment p => p a -> p a
commit (forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
e)
adjustErrBad :: PolyParse p => p a -> (String->String) -> p a
p a
p adjustErrBad :: forall (p :: * -> *) a.
PolyParse p =>
p a -> (String -> String) -> p a
`adjustErrBad` String -> String
f = forall (p :: * -> *) a. Commitment p => p a -> p a
commit (p a
p forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` String -> String
f)
oneOf :: PolyParse p => [p a] -> p a
oneOf :: forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [] = forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
"failed to parse any of the possible choices")
oneOf (p a
p:[p a]
ps) = p a
p forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (p :: * -> *) a. PolyParse p => [p a] -> p a
oneOf [p a]
ps
indent :: Int -> String -> String
indent :: Int -> String -> String
indent Int
n = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> a -> [a]
replicate Int
n Char
' ' forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
exactly :: PolyParse p => Int -> p a -> p [a]
exactly :: forall (p :: * -> *) a. PolyParse p => Int -> p a -> p [a]
exactly Int
0 p a
p = forall (m :: * -> *) a. Monad m => a -> m a
return []
exactly Int
n p a
p = forall (m :: * -> *) a. Monad m => a -> m a
return (:) forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` (p a
p forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` ((String
"When expecting exactly "
forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Int
nforall a. [a] -> [a] -> [a]
++String
" more items")forall a. [a] -> [a] -> [a]
++))
forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (p :: * -> *) a. PolyParse p => Int -> p a -> p [a]
exactly (Int
nforall a. Num a => a -> a -> a
-Int
1) p a
p
upto :: PolyParse p => Int -> p a -> p [a]
upto :: forall (p :: * -> *) a. PolyParse p => Int -> p a -> p [a]
upto Int
0 p a
p = forall (m :: * -> *) a. Monad m => a -> m a
return []
upto Int
n p a
p = do a
x <- p a
p; forall (m :: * -> *) a. Monad m => a -> m a
return (a
xforall a. a -> [a] -> [a]
:) forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (p :: * -> *) a. PolyParse p => Int -> p a -> p [a]
upto (Int
nforall a. Num a => a -> a -> a
-Int
1) p a
p
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return []
many1 :: PolyParse p => p a -> p [a]
many1 :: forall (p :: * -> *) a. PolyParse p => p a -> p [a]
many1 p a
p = do { a
x <- p a
p forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` ((String
"In a sequence:\n"forall a. [a] -> [a] -> [a]
++)forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
indent Int
2)
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
xforall a. a -> [a] -> [a]
:) forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f [a]
many p a
p
}
sepBy :: PolyParse p => p a -> p sep -> p [a]
sepBy :: forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
sepBy p a
p p sep
sep = do forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
sepBy1 p a
p p sep
sep forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return []
sepBy1 :: PolyParse p => p a -> p sep -> p [a]
sepBy1 :: forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
sepBy1 p a
p p sep
sep = do { a
x <- p a
p
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
xforall a. a -> [a] -> [a]
:) forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (do {p sep
sep; p a
p})
}
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String
"When looking for a non-empty sequence with separators:\n\t"forall a. [a] -> [a] -> [a]
++)
bracketSep :: PolyParse p => p bra -> p sep -> p ket -> p a -> p [a]
bracketSep :: forall (p :: * -> *) bra sep ket a.
PolyParse p =>
p bra -> p sep -> p ket -> p a -> p [a]
bracketSep p bra
open p sep
sep p ket
close p a
p =
do { p bra
open; p ket
close; forall (m :: * -> *) a. Monad m => a -> m a
return [] }
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
do { p bra
open forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String
"Missing opening bracket:\n\t"forall a. [a] -> [a] -> [a]
++)
; a
x <- p a
p forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String
"After first bracket in a group:\n\t"forall a. [a] -> [a] -> [a]
++)
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
xforall a. a -> [a] -> [a]
:)
forall (p :: * -> *) a b. PolyParse p => p (a -> b) -> p a -> p b
`apply` forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
manyFinally (do {p sep
sep; p a
p})
(p ket
close forall (p :: * -> *) a.
PolyParse p =>
p a -> (String -> String) -> p a
`adjustErrBad` (String
"When looking for closing bracket:\n\t"forall a. [a] -> [a] -> [a]
++))
}
bracket :: PolyParse p => p bra -> p ket -> p a -> p a
bracket :: forall (p :: * -> *) bra ket a.
PolyParse p =>
p bra -> p ket -> p a -> p a
bracket p bra
open p ket
close p a
p = do
do { p bra
open forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String
"Missing opening bracket:\n\t"forall a. [a] -> [a] -> [a]
++)
; p a
p forall (p :: * -> *) a b. PolyParse p => p a -> p b -> p a
`discard` (p ket
close forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` (String
"Missing closing bracket:\n\t"forall a. [a] -> [a] -> [a]
++))
}
manyFinally :: PolyParse p => p a -> p z -> p [a]
manyFinally :: forall (p :: * -> *) a sep. PolyParse p => p a -> p sep -> p [a]
manyFinally p a
p p z
t =
do { [a]
xs <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many p a
p
; forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf' [ (String
"sequence terminator", do { p z
t; forall (m :: * -> *) a. Monad m => a -> m a
return () } )
, (String
"item in a sequence", do { p a
p; forall (m :: * -> *) a. Monad m => a -> m a
return () } )
]
; forall (m :: * -> *) a. Monad m => a -> m a
return [a]
xs
}
manyFinally' :: (PolyParse p, Show a) => p a -> p z -> p [a]
manyFinally' :: forall (p :: * -> *) a z.
(PolyParse p, Show a) =>
p a -> p z -> p [a]
manyFinally' p a
p p z
t = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ [a] -> p [a]
go []
where
go :: [a] -> p [a]
go [a]
acc = ( do p z
t; forall (m :: * -> *) a. Monad m => a -> m a
return [a]
acc )
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
( do { a
x <- p a
p
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
oneOf' [ ( String
"terminator in a manyFinally' sequence"
, do { p z
t; forall (m :: * -> *) a. Monad m => a -> m a
return forall a. HasCallStack => a
undefined }
)
, ( String
"item in a manyFinally' sequence", p a
p)
]
forall (p :: * -> *) a.
Commitment p =>
p a -> (String -> String) -> p a
`adjustErr` ((String
"After successful partial sequence "
forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show (forall a. [a] -> [a]
reverse [a]
acc)forall a. [a] -> [a] -> [a]
++String
",\n")forall a. [a] -> [a] -> [a]
++)
; [a] -> p [a]
go (a
xforall a. a -> [a] -> [a]
: [a]
acc)
}
)