module Graphics.Blank.Parser where

import Control.Applicative hiding (many, optional)

import Data.Char
import Data.Ix
import Data.Functor (void)

import Text.ParserCombinators.ReadP
import Text.ParserCombinators.ReadPrec (ReadPrec, readPrec_to_P)

-- | @maybeRead p@ will either parse @p@ or return 'Nothing' without consuming any
--   input. Compare to 'option' from "Text.ParserCombinators.ReadP".
maybeRead :: ReadP a -> ReadP (Maybe a)
maybeRead :: forall a. ReadP a -> ReadP (Maybe a)
maybeRead ReadP a
p = (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP a
p) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | @maybeReadPrec p@ will either parse @p@ or return 'Nothing' without consuming any
--   input. Compare to 'option' from "Text.ParserCombinators.ReadP".
maybeReadPrec :: ReadPrec a -> ReadPrec (Maybe a)
maybeReadPrec :: forall a. ReadPrec a -> ReadPrec (Maybe a)
maybeReadPrec ReadPrec a
p = (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec a
p) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | A case-insensitive version of 'string' from "Text.ParserCombinators.ReadP".
stringCI :: String -> ReadP String
stringCI :: String -> ReadP String
stringCI String
this = ReadP String
look forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> String -> ReadP String
scan String
this
  where
    scan :: String -> String -> ReadP String
    scan :: String -> String -> ReadP String
scan []     String
_                = forall (m :: * -> *) a. Monad m => a -> m a
return String
this
    scan (Char
x:String
xs) (Char
y:String
ys)
        | Char -> Char
toLower Char
x forall a. Eq a => a -> a -> Bool
== Char -> Char
toLower Char
y = ReadP Char
get forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> String -> ReadP String
scan String
xs String
ys
    scan String
_      String
_                = forall a. ReadP a
pfail

-- | Convert a 'ReadPrec' to a 'ReadP' (the converse of 'lift').
unlift :: ReadPrec a -> ReadP a
unlift :: forall a. ReadPrec a -> ReadP a
unlift = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. ReadPrec a -> Int -> ReadP a
readPrec_to_P Int
0

-- | Equivalent to the function from @parsec@, but using 'ReadP'.
noneOf :: [Char] -> ReadP Char
noneOf :: String -> ReadP Char
noneOf String
cs = (Char -> Bool) -> ReadP Char
satisfy forall a b. (a -> b) -> a -> b
$ \Char
c -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c String
cs

-------------------------------------------------------------------------------
-- Parser combinators for CSS identifiers. Adapted from the hxt-css package.
-------------------------------------------------------------------------------

-- | Parses a CSS identifier.
cssIdent :: ReadP String
cssIdent :: ReadP String
cssIdent = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Char
nmstart forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. ReadP a -> ReadP [a]
many ReadP Char
nmchar

-- | Parses the beginning character of a CSS identifier.
nmstart :: ReadP Char
nmstart :: ReadP Char
nmstart = (Char -> Bool) -> ReadP Char
satisfy Char -> Bool
p forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP Char
nonascii
  where
    p :: Char -> Bool
p Char
c = forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'a', Char
'z') Char
c Bool -> Bool -> Bool
|| forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'A', Char
'Z') Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_'

-- | Parses a non-beginning CSS identifier character.
nmchar :: ReadP Char
nmchar :: ReadP Char
nmchar = (Char -> Bool) -> ReadP Char
satisfy Char -> Bool
p forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP Char
nonascii
  where
    p :: Char -> Bool
p Char
c = forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'a', Char
'z') Char
c Bool -> Bool -> Bool
|| forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'A', Char
'Z') Char
c Bool -> Bool -> Bool
||
        Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c String
"_-"

-- | Parses a CSS string literal.
stringLit :: ReadP String
stringLit :: ReadP String
stringLit = ReadP String
string1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP String
string2
  where
    string1 :: ReadP String
string1 = Char -> ReadP Char
char Char
'"'
           forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. ReadP a -> ReadP [a]
many (String -> ReadP Char
noneOf String
"\n\r\f\\\"" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP Char
nl forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP Char
nonascii)
           forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ReadP Char
char Char
'*'
    string2 :: ReadP String
string2 = Char -> ReadP Char
char Char
'\''
           forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. ReadP a -> ReadP [a]
many (String -> ReadP Char
noneOf String
"\n\r\f\\'"  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP Char
nl forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP Char
nonascii)
           forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ReadP Char
char Char
'\''

-- | Parses a non-ASCII CSS character.
nonascii :: ReadP Char
nonascii :: ReadP Char
nonascii = (Char -> Bool) -> ReadP Char
satisfy (forall a. Ord a => a -> a -> Bool
> Char
'\DEL')

-- | Parses a CSS-style newline.
nl :: ReadP Char
nl :: ReadP Char
nl = forall a. [ReadP a] -> ReadP a
choice
    [ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
char Char
'\n'
    , Char -> ReadP Char
char Char
'\r' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. ReadP a -> ReadP ()
optional (Char -> ReadP Char
char Char
'\n')
    , forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
char Char
'\f'
    ] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\n'