module Text.Boomerang.Strings
(
StringsError
, (</>), alpha, anyChar, anyString, char, digit, eos, int
, integer, lit, readshow, satisfy, satisfyStr, space
, isComplete, parseStrings, unparseStrings
)
where
import Prelude hiding ((.), id, (/))
import Control.Category (Category((.), id))
import Data.Char (isAlpha, isDigit, isSpace)
import Data.Data (Data, Typeable)
import Data.List (stripPrefix)
import Data.String (IsString(..))
import Numeric (readDec, readSigned)
import Text.Boomerang.Combinators (opt, rCons, rList1)
import Text.Boomerang.Error (ParserError(..),ErrorMsg(..), (<?>), condenseErrors, mkParserError)
import Text.Boomerang.HStack ((:-)(..))
import Text.Boomerang.Pos (InitialPosition(..), MajorMinorPos(..), incMajor, incMinor)
import Text.Boomerang.Prim (Parser(..), PrinterParser(..), parse1, xmaph, unparse1, val)
type StringsError = ParserError MajorMinorPos
instance InitialPosition StringsError where
initialPos _ = MajorMinorPos 0 0
instance a ~ b => IsString (PrinterParser StringsError [String] a b) where
fromString = lit
lit :: String -> PrinterParser StringsError [String] r r
lit l = PrinterParser pf sf
where
pf = Parser $ \tok pos ->
case tok of
[] -> mkParserError pos [EOI "input", Expect (show l)]
("":_) | (not $ null l) -> mkParserError pos [EOI "segment", Expect (show l)]
(p:ps) ->
case stripPrefix l p of
(Just p') ->
do [Right ((id, p':ps), incMinor (length l) pos)]
Nothing ->
mkParserError pos [UnExpect (show p), Expect (show l)]
sf b = [ (\strings -> case strings of [] -> [l] ; (s:ss) -> ((l ++ s) : ss), b)]
infixr 9 </>
(</>) :: PrinterParser StringsError [String] b c -> PrinterParser StringsError [String] a b -> PrinterParser StringsError [String] a c
f </> g = f . eos . g
eos :: PrinterParser StringsError [String] r r
eos = PrinterParser
(Parser $ \path pos -> case path of
[] -> [Right ((id, []), incMajor 1 pos)]
("":ps) ->
[ Right ((id, ps), incMajor 1 pos) ]
(p:_) -> mkParserError pos [Message $ "path-segment not entirely consumed: " ++ p])
(\a -> [(("" :), a)])
satisfy :: (Char -> Bool) -> PrinterParser StringsError [String] r (Char :- r)
satisfy p = val
(Parser $ \tok pos ->
case tok of
[] -> mkParserError pos [EOI "input"]
("":ss) -> mkParserError pos [EOI "segment"]
((c:cs):ss)
| p c ->
do [Right ((c, cs : ss), incMinor 1 pos )]
| otherwise ->
do mkParserError pos [SysUnExpect $ show c]
)
(\c -> [ \paths -> case paths of [] -> [[c]] ; (s:ss) -> ((c:s):ss) | p c ])
satisfyStr :: (String -> Bool) -> PrinterParser StringsError [String] r (String :- r)
satisfyStr p = val
(Parser $ \tok pos ->
case tok of
[] -> mkParserError pos [EOI "input"]
("":ss) -> mkParserError pos [EOI "segment"]
(s:ss)
| p s ->
do [Right ((s, "":ss), incMajor 1 pos )]
| otherwise ->
do mkParserError pos [SysUnExpect $ show s]
)
(\str -> [ \strings -> case strings of [] -> [str] ; (s:ss) -> ((str++s):ss) | p str ])
digit :: PrinterParser StringsError [String] r (Char :- r)
digit = satisfy isDigit <?> "a digit 0-9"
alpha :: PrinterParser StringsError [String] r (Char :- r)
alpha = satisfy isAlpha <?> "an alphabetic Unicode character"
space :: PrinterParser StringsError [String] r (Char :- r)
space = satisfy isSpace <?> "a white-space character"
anyChar :: PrinterParser StringsError [String] r (Char :- r)
anyChar = satisfy (const True)
char :: Char -> PrinterParser StringsError [String] r (Char :- r)
char c = satisfy (== c) <?> show [c]
readshow :: (Read a, Show a) => PrinterParser StringsError [String] r (a :- r)
readshow =
val readParser s
where
s a = [ \strings -> case strings of [] -> [show a] ; (s:ss) -> (((show a)++s):ss) ]
readParser :: (Read a) => Parser StringsError [String] a
readParser =
Parser $ \tok pos ->
case tok of
[] -> mkParserError pos [EOI "input"]
("":_) -> mkParserError pos [EOI "segment"]
(p:ps) ->
case reads p of
[] -> mkParserError pos [SysUnExpect p, Message $ "decoding using 'read' failed."]
[(a,r)] ->
[Right ((a, r:ps), incMinor ((length p) (length r)) pos)]
readIntegral :: (Read a, Eq a, Num a, Real a) => String -> a
readIntegral s =
case (readSigned readDec) s of
[(x, [])] -> x
[] -> error "readIntegral: no parse"
_ -> error "readIntegral: ambiguous parse"
int :: PrinterParser StringsError [String] r (Int :- r)
int = xmaph readIntegral (Just . show) (opt (rCons . char '-') . (rList1 digit))
integer :: PrinterParser StringsError [String] r (Integer :- r)
integer = xmaph readIntegral (Just . show) (opt (rCons . char '-') . (rList1 digit))
anyString :: PrinterParser StringsError [String] r (String :- r)
anyString = val ps ss
where
ps = Parser $ \tok pos ->
case tok of
[] -> mkParserError pos [EOI "input", Expect "any string"]
(s:ss) -> [Right ((s, "":ss), incMinor (length s) pos)]
ss str = [\ss -> case ss of
[] -> [str]
(s:ss') -> ((str ++ s) : ss')
]
isComplete :: [String] -> Bool
isComplete [] = True
isComplete [""] = True
isComplete _ = False
parseStrings :: PrinterParser StringsError [String] () (r :- ())
-> [String]
-> Either StringsError r
parseStrings pp strs =
either (Left . condenseErrors) Right $ parse1 isComplete pp strs
unparseStrings :: PrinterParser e [String] () (r :- ()) -> r -> Maybe [String]
unparseStrings pp r = unparse1 [] pp r