module Text.Boomerang.Texts
(
TextsError
, (</>), alpha, anyChar, anyText, char, digit, digits, signed, eos, integral, int
, integer, lit, readshow, satisfy, satisfyStr, space
, rTextCons, rEmpty, rText, rText1
, isComplete, parseTexts, unparseTexts
)
where
import Prelude hiding ((.), id, (/))
import Control.Category (Category((.), id))
import Data.Char (isAlpha, isDigit, isSpace)
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Read as Text
import Text.Boomerang.Combinators (opt, duck1, manyr, somer)
import Text.Boomerang.Error (ParserError(..),ErrorMsg(..), (<?>), condenseErrors, mkParserError)
import Text.Boomerang.HStack ((:-)(..), arg)
import Text.Boomerang.Pos (InitialPosition(..), MajorMinorPos(..), incMajor, incMinor)
import Text.Boomerang.Prim (Parser(..), PrinterParser(..), parse1, xmaph, xpure, unparse1, val)
type TextsError = ParserError MajorMinorPos
instance InitialPosition TextsError where
initialPos _ = MajorMinorPos 0 0
instance a ~ b => IsString (PrinterParser TextsError [Text] a b) where
fromString = lit . Text.pack
lit :: Text -> PrinterParser TextsError [Text] r r
lit l = PrinterParser pf sf
where
pf = Parser $ \tok pos ->
case tok of
[] -> mkParserError pos [EOI "input", Expect (show l)]
(p:ps)
| Text.null p && (not $ Text.null l) -> mkParserError pos [EOI "segment", Expect (show l)]
| otherwise ->
case Text.stripPrefix l p of
(Just p') ->
[Right ((id, p':ps), incMinor (Text.length l) pos)]
Nothing ->
mkParserError pos [UnExpect (show p), Expect (show l)]
sf b = [ (\strings -> case strings of [] -> [l] ; (s:ss) -> ((l `Text.append` s) : ss), b)]
infixr 9 </>
(</>) :: PrinterParser TextsError [Text] b c -> PrinterParser TextsError [Text] a b -> PrinterParser TextsError [Text] a c
f </> g = f . eos . g
eos :: PrinterParser TextsError [Text] r r
eos = PrinterParser
(Parser $ \path pos -> case path of
[] -> [Right ((id, []), incMajor 1 pos)]
(p:ps)
| Text.null p ->
[ Right ((id, ps), incMajor 1 pos) ]
| otherwise -> mkParserError pos [Message $ "path-segment not entirely consumed: " ++ (Text.unpack p)])
(\a -> [((Text.empty :), a)])
satisfy :: (Char -> Bool) -> PrinterParser TextsError [Text] r (Char :- r)
satisfy p = val
(Parser $ \tok pos ->
case tok of
[] -> mkParserError pos [EOI "input"]
(s:ss) ->
case Text.uncons s of
Nothing -> mkParserError pos [EOI "segment"]
(Just (c, cs))
| p c ->
[Right ((c, cs : ss), incMinor 1 pos )]
| otherwise ->
mkParserError pos [SysUnExpect $ show c]
)
(\c -> [ \paths -> case paths of [] -> [Text.singleton c] ; (s:ss) -> ((Text.cons c s):ss) | p c ])
satisfyStr :: (Text -> Bool) -> PrinterParser TextsError [Text] r (Text :- r)
satisfyStr p = val
(Parser $ \tok pos ->
case tok of
[] -> mkParserError pos [EOI "input"]
(s:ss)
| Text.null s -> mkParserError pos [EOI "segment"]
| p s ->
do [Right ((s, Text.empty:ss), incMajor 1 pos )]
| otherwise ->
do mkParserError pos [SysUnExpect $ show s]
)
(\str -> [ \strings -> case strings of [] -> [str] ; (s:ss) -> ((str `Text.append` s):ss) | p str ])
digit :: PrinterParser TextsError [Text] r (Char :- r)
digit = satisfy isDigit <?> "a digit 0-9"
alpha :: PrinterParser TextsError [Text] r (Char :- r)
alpha = satisfy isAlpha <?> "an alphabetic Unicode character"
space :: PrinterParser TextsError [Text] r (Char :- r)
space = satisfy isSpace <?> "a white-space character"
anyChar :: PrinterParser TextsError [Text] r (Char :- r)
anyChar = satisfy (const True)
char :: Char -> PrinterParser TextsError [Text] r (Char :- r)
char c = satisfy (== c) <?> show [c]
readshow :: (Read a, Show a) => PrinterParser TextsError [Text] r (a :- r)
readshow =
val readParser s
where
s a = [ \strings -> case strings of [] -> [Text.pack $ show a] ; (s:ss) -> (((Text.pack $ show a) `Text.append` s):ss) ]
readParser :: (Read a) => Parser TextsError [Text] a
readParser =
Parser $ \tok pos ->
case tok of
[] -> mkParserError pos [EOI "input"]
(p:_) | Text.null p -> mkParserError pos [EOI "segment"]
(p:ps) ->
case reads (Text.unpack p) of
[] -> mkParserError pos [SysUnExpect (Text.unpack p), Message $ "decoding using 'read' failed."]
[(a,r)] ->
[Right ((a, (Text.pack r):ps), incMinor ((Text.length p) (length r)) pos)]
readIntegral :: (Integral a) => Text -> a
readIntegral s =
case (Text.signed Text.decimal) s of
(Left e) -> error $ "readIntegral: " ++ e
(Right (a, r))
| Text.null r -> a
| otherwise -> error $ "readIntegral: ambiguous parse. Left over data: " ++ Text.unpack r
rEmpty :: PrinterParser e [Text] r (Text :- r)
rEmpty = xpure (Text.empty :-) $
\(xs :- t) ->
if Text.null xs
then (Just t)
else Nothing
rTextCons :: PrinterParser e tok (Char :- Text :- r) (Text :- r)
rTextCons =
xpure (arg (arg (:-)) (Text.cons)) $
\(xs :- t) ->
do (a, as) <- Text.uncons xs
return (a :- as :- t)
rText :: PrinterParser e [Text] r (Char :- r)
-> PrinterParser e [Text] r (Text :- r)
rText r = manyr (rTextCons . duck1 r) . rEmpty
rText1 :: PrinterParser e [Text] r (Char :- r)
-> PrinterParser e [Text] r (Text :- r)
rText1 r = somer (rTextCons . duck1 r) . rEmpty
digits :: PrinterParser TextsError [Text] r (Text :- r)
digits = rText digit
signed :: PrinterParser TextsError [Text] a (Text :- r)
-> PrinterParser TextsError [Text] a (Text :- r)
signed r = opt (rTextCons . char '-') . r
integral :: (Integral a, Show a) => PrinterParser TextsError [Text] r (a :- r)
integral = xmaph readIntegral (Just . Text.pack . show) (signed digits)
int :: PrinterParser TextsError [Text] r (Int :- r)
int = integral
integer :: PrinterParser TextsError [Text] r (Integer :- r)
integer = integral
anyText :: PrinterParser TextsError [Text] r (Text :- r)
anyText = val ps ss
where
ps = Parser $ \tok pos ->
case tok of
[] -> mkParserError pos [EOI "input", Expect "any string"]
(s:ss) -> [Right ((s, Text.empty:ss), incMinor (Text.length s) pos)]
ss str = [\ss -> case ss of
[] -> [str]
(s:ss') -> ((str `Text.append` s) : ss')
]
isComplete :: [Text] -> Bool
isComplete [] = True
isComplete [t] = Text.null t
isComplete _ = False
parseTexts :: PrinterParser TextsError [Text] () (r :- ())
-> [Text]
-> Either TextsError r
parseTexts pp strs =
either (Left . condenseErrors) Right $ parse1 isComplete pp strs
unparseTexts :: PrinterParser e [Text] () (r :- ()) -> r -> Maybe [Text]
unparseTexts pp r = unparse1 [] pp r