Parser.hs

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 p = (Just <$> p) <|> return 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 p = (Just <$> p) <|> return Nothing

-- | A case-insensitive version of 'string' from "Text.ParserCombinators.ReadP".
stringCI :: String -> ReadP String
stringCI this = look >>= scan this
  where
    scan :: String -> String -> ReadP String
    scan []     _                = return this
    scan (x:xs) (y:ys)
        | toLower x == toLower y = get *> scan xs ys
    scan _      _                = pfail

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

-- | Equivalent to the function from @parsec@, but using 'ReadP'.
noneOf :: [Char] -> ReadP Char
noneOf cs = satisfy $ \c -> not $ elem c cs

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

-- | Parses a CSS identifier.
cssIdent :: ReadP String
cssIdent = (:) <$> nmstart <*> many nmchar

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

-- | Parses a non-beginning CSS identifier character.
nmchar :: ReadP Char
nmchar = satisfy p <|> nonascii
  where
    p c = inRange ('a', 'z') c || inRange ('A', 'Z') c ||
        isDigit c || elem c "_-"

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

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

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