module Text.Roundtrip.Combinators
(
char
, char'
, string
, comma
, dot
, many
, many1
, sepBy
, chainl1
, (*>)
, (<*)
, between
, (<+>)
, optional
, optionalBool
, optionalWithDefault
, skipSpace
, sepSpace
, optSpace
, xmlEatWhiteSpace
, xmlElem
, xmlAttr
, xmlFixedAttr
, xmlText
, xmlString
) where
import Prelude hiding (pure, (*>), (<*), (<*>), (<$>), (.), foldl)
import Control.Category ((.))
import Data.Char (isSpace)
import qualified Data.Text as T
import Data.XML.Types (Name)
import Control.Isomorphism.Partial
import Text.Roundtrip.Classes
many :: Syntax delta => delta alpha -> delta [alpha]
many p =
rule "many" p $
(cons <$> p <*> many p
<|> nil <$> pure ())
many1 :: Syntax delta => delta alpha -> delta [alpha]
many1 p =
rule "many1" p $ cons <$> p <*> many p
infixl 4 <+>
(<+>) :: Syntax delta => delta alpha -> delta beta -> delta (Either alpha beta)
p <+> q = (left <$> p) <|> (right <$> q)
char :: StringSyntax delta => Char -> delta ()
char c = ignore c <$> token (c ==)
char' :: StringSyntax delta => Char -> delta Char
char' c = token (c ==)
string :: StringSyntax delta => String -> delta ()
string [] = pure ()
string (c:cs) = inverse (element ((), ()))
<$> char c <*> string cs
infixr 6 *>, <*
(*>) :: Syntax delta => delta () -> delta alpha -> delta alpha
p *> q = ruleInfix "*>" p q $ inverse unit . commute <$> p <*> q
(<*) :: Syntax delta => delta alpha -> delta () -> delta alpha
p <* q = ruleInfix "<*" p q $ inverse unit <$> p <*> q
between :: Syntax delta => delta () -> delta () -> delta alpha -> delta alpha
between p q r = p *> r <* q
chainl1 :: Syntax delta => delta alpha -> delta beta -> Iso (alpha, (beta, alpha)) alpha -> delta alpha
chainl1 arg op f
= foldl f <$> arg <*> many (op <*> arg)
optional :: Syntax delta => delta alpha -> delta (Maybe alpha)
optional x = rule "optional" x $ just <$> x <|> nothing <$> (pure ())
optionalBool :: Syntax delta => delta () -> delta Bool
optionalBool x = maybeUnitBoolIso <$> optional x
optionalWithDefault :: (Eq alpha, Syntax delta) => alpha -> delta alpha -> delta alpha
optionalWithDefault def x = rule "optionalWithDefault" x $ x <|> pure def
sepBy :: Syntax delta => delta alpha -> delta () -> delta [alpha]
sepBy x sep
= cons <$> x <*> many (sep *> x)
<|> nil <$> (pure ())
comma :: StringSyntax delta => delta ()
comma = char ','
dot :: StringSyntax delta => delta ()
dot = char '.'
skipSpace :: StringSyntax delta => delta ()
skipSpace = ignore [] <$> many (char ' ')
optSpace :: StringSyntax delta => delta ()
optSpace = ignore [()] <$> many (char ' ')
sepSpace :: StringSyntax delta => delta ()
sepSpace = char ' ' <* skipSpace
xmlEatWhiteSpace :: XmlSyntax d => d ()
xmlEatWhiteSpace = ignore T.empty . namedSubset "allIsSpace" (T.all isSpace) <$> xmlText <|> pure ()
xmlElem :: XmlSyntax x => Name -> x a -> x a
xmlElem name children =
xmlBeginElem name *> children <* xmlEndElem name
xmlAttr :: XmlSyntax x => Name -> Iso T.Text a -> x a
xmlAttr name p = p <$> xmlAttrValue name
xmlFixedAttr :: XmlSyntax x => Name -> T.Text -> x ()
xmlFixedAttr name value = fixedValue value <$> xmlAttrValue name
xmlText :: XmlSyntax d => d T.Text
xmlText = optionalWithDefault T.empty xmlTextNotEmpty
xmlString :: XmlSyntax d => d String
xmlString = textStringIso <$> xmlText