roundtrip 0.1.0.0 → 0.2.0.0

raw patch · 9 files changed

+153/−66 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• LICENSE +2/−2
• roundtrip.cabal +2/−4
• src/Control/Isomorphism/Partial.hs +2/−0
• src/Control/Isomorphism/Partial/Constructors.hs +3/−28
• src/Control/Isomorphism/Partial/Derived.hs +5/−2
• src/Control/Isomorphism/Partial/Prim.hs +44/−3
• src/Text/Roundtrip/Classes.hs +19/−4
• src/Text/Roundtrip/Combinators.hs +58/−22
• src/Text/Roundtrip/SpecPrinter.hs +18/−1

@@ -1,4 +1,4 @@-Copyright (c)2011, +Copyright (c) 2011 factis research GmbH  All rights reserved. @@ -13,7 +13,7 @@       disclaimer in the documentation and/or other materials provided       with the distribution. -    * Neither the name of  nor the names of other+    * Neither the name offactis research GmbH nor the names of other       contributors may be used to endorse or promote products derived       from this software without specific prior written permission. 

@@ -1,5 +1,5 @@ Name:           roundtrip-Version:        0.1.0.0+Version:        0.2.0.0 Synopsis:       Bidirectional (de-)serialization Description:    Roundtrip allows the definition of bidirectional                 (de-)serialization specifications. The specification language@@ -12,7 +12,7 @@                 .                 The package contains slightly modified code from                 Tillmann Rendel's partial-isomorphisms and invertible-syntax-                packages.+                packages (Copyright (c) 2010-11 University of Marburg). License:        BSD3 License-file:   LICENSE Author:         Stefan Wehr <wehr@factisresearch.com>,@@ -23,8 +23,6 @@ Cabal-version:  >=1.8  Library-  Extensions: TemplateHaskell-  GHC-Prof-Options: -auto-all -caf-all   Hs-Source-Dirs: src   Exposed-modules:       Text.Roundtrip

@@ -3,9 +3,11 @@   , module Control.Isomorphism.Partial.Derived   , module Control.Isomorphism.Partial.Constructors   , module Control.Isomorphism.Partial.Iso+  , module Control.Isomorphism.Partial.TH   ) where  import Control.Isomorphism.Partial.Prim import Control.Isomorphism.Partial.Derived import Control.Isomorphism.Partial.Constructors import Control.Isomorphism.Partial.Iso+import Control.Isomorphism.Partial.TH

@@ -7,10 +7,6 @@   , right   , nothing   , just-  , readShowIso-  , textStringIso-  , lazyStrictTextIso-  , listMapIso   ) where  import Prelude hiding ((.), id)@@ -21,29 +17,23 @@ import Data.Eq (Eq ((==))) import Data.Maybe (Maybe (Just, Nothing)) -import qualified Data.Map as Map-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL--import Safe (readMay)- import Control.Isomorphism.Partial.Iso import Control.Isomorphism.Partial.TH (defineIsomorphisms)  nil :: Iso () [alpha]-nil = unsafeMakeIso f g where+nil = unsafeMakeNamedIso "nil" f g where   f ()  =  Just []   g []  =  Just ()   g _   =  Nothing  cons :: Iso (alpha, [alpha]) [alpha]-cons = unsafeMakeIso f g where+cons = unsafeMakeNamedIso "cons" f g where   f (x, xs)   =  Just (x : xs)   g (x : xs)  =  Just (x, xs)   g _         =  Nothing  listCases :: Iso (Either () (alpha, [alpha])) [alpha]-listCases = unsafeMakeIso f g+listCases = unsafeMakeNamedIso "listCases" f g   where     f (Left ())        =  Just []     f (Right (x, xs))  =  Just (x : xs)@@ -52,18 +42,3 @@  $(defineIsomorphisms ''Either) $(defineIsomorphisms ''Maybe)--readShowIso :: (Read a, Show a) => Iso T.Text a-readShowIso = unsafeMakeNamedIsoLR "readShow" (readMay . T.unpack) (Just . T.pack . show)--textStringIso :: Iso T.Text String-textStringIso = unsafeMakeNamedIsoLR "textString" (Just . T.unpack) (Just . T.pack)--lazyStrictTextIso :: Iso TL.Text T.Text-lazyStrictTextIso = unsafeMakeNamedIsoLR "lazyStrictText" lazyToStrict strictToLazy-    where-      lazyToStrict = Just . T.concat . TL.toChunks-      strictToLazy = Just . TL.fromChunks . (:[])--listMapIso :: Ord a => Iso ([(a, b)]) (Map.Map a b)-listMapIso = unsafeMakeNamedIso "listMap" (Just . Map.fromList) (Just . Map.toList)

@@ -1,10 +1,10 @@ module Control.Isomorphism.Partial.Derived ( -    foldl, swap23+    foldl, swap23, fixedValue  ) where -import Prelude ()+import Prelude (Show, Eq) import Control.Category (Category (id, (.)))  import Control.Isomorphism.Partial.Iso (Iso)@@ -22,3 +22,6 @@  swap23 :: Iso (a, (b, c)) (a, (c, b)) swap23 = id *** commute++fixedValue :: (Show a, Eq a) => a -> Iso a ()+fixedValue = inverse . element

@@ -12,8 +12,15 @@   , unit   , element   , subset+  , namedSubset   , iterateIso   , distribute+  , readShowIso+  , readShowTextIso+  , textStringIso+  , lazyStrictTextIso+  , listMapIso+  , maybeUnitBoolIso   ) where  import Prelude hiding ((.), id)@@ -25,7 +32,13 @@ import Data.Either (Either (Left, Right)) import Data.Eq (Eq ((==))) import Data.Maybe (Maybe (Just, Nothing))+import qualified Data.Map as Map +import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++import Safe (readMay)+ import Control.Isomorphism.Partial.Iso  inverse :: Iso alpha beta -> Iso beta alpha@@ -123,13 +136,16 @@ -- singleton set which contains just `x`. element :: (Show alpha, Eq alpha) => alpha -> Iso () alpha element x = unsafeMakeNamedIsoR ("element(" ++ show x ++ ")")-  (\a -> Just x)+  (\() -> Just x)   (\b -> if x == b then Just () else Nothing)  -- | For a predicate `p`, `subset p` is the identity isomorphism -- restricted to elements matching the predicate.-subset :: Show alpha => String -> (alpha -> Bool) -> Iso alpha alpha-subset name p = unsafeMakeNamedIsoLR ("subset(" ++ name ++ ")") f f where+subset :: Show alpha => (alpha -> Bool) -> Iso alpha alpha+subset = namedSubset "?"++namedSubset :: Show alpha => String -> (alpha -> Bool) -> Iso alpha alpha+namedSubset name p = unsafeMakeNamedIsoLR ("subset(" ++ name ++ ")") f f where   f x | p x = Just x       | otherwise = Nothing @@ -142,3 +158,28 @@     =  case step state of          Just state'  ->  driver step state'          Nothing      ->  state++readShowIso :: (Read a, Show a) => Iso String a+readShowIso = unsafeMakeNamedIsoLR "readShow" readMay (Just . show)++readShowTextIso :: (Read a, Show a) => Iso T.Text a+readShowTextIso = unsafeMakeNamedIsoLR "readShowText" (readMay . T.unpack) (Just . T.pack . show)++textStringIso :: Iso T.Text String+textStringIso = unsafeMakeNamedIsoLR "textString" (Just . T.unpack) (Just . T.pack)++lazyStrictTextIso :: Iso TL.Text T.Text+lazyStrictTextIso = unsafeMakeNamedIsoLR "lazyStrictText" lazyToStrict strictToLazy+    where+      lazyToStrict = Just . T.concat . TL.toChunks+      strictToLazy = Just . TL.fromChunks . (:[])++listMapIso :: Ord a => Iso ([(a, b)]) (Map.Map a b)+listMapIso = unsafeMakeNamedIso "listMap" (Just . Map.fromList) (Just . Map.toList)++maybeUnitBoolIso :: Iso (Maybe ()) Bool+maybeUnitBoolIso = unsafeMakeNamedIso "maybeUnitBoolIso" f g+    where f (Just ()) = Just True+          f _ = Just False+          g True = Just (Just ())+          g _ = Just Nothing

@@ -1,11 +1,13 @@ module Text.Roundtrip.Classes where ---import Prelude ()--import Control.Isomorphism.Partial (IsoFunctor) import Data.Eq (Eq) import Data.Char (Char) +import Data.Text as T+import Data.XML.Types (Name(..), Content)++import Control.Isomorphism.Partial (IsoFunctor)+ infixl 3 <|> infixl 3 <||> infixr 6 <*>@@ -16,6 +18,7 @@ class Alternative f where   -- one token lookahead for lhs   (<|>)  :: f alpha -> f alpha -> f alpha+  x <|> y = x <||> y   -- infinite lookahead for lhs   (<||>) :: f alpha -> f alpha -> f alpha   empty  :: f alpha@@ -33,4 +36,16 @@   ruleInfix _ _ _ x = x  class Syntax delta => StringSyntax delta where-  token  ::  delta Char+  token :: (Char -> Bool) -> delta Char+  anyToken :: delta Char+  anyToken = token (const True)++type Attribute = (Name, [Content])++class Syntax delta => XmlSyntax delta where+    xmlBeginDoc :: delta ()+    xmlEndDoc :: delta ()+    xmlBeginElem :: Name -> delta ()+    xmlEndElem :: Name -> delta ()+    xmlAttrValue :: Name -> delta T.Text -- FIXME: parser for attr value+    xmlTextNotEmpty :: delta T.Text

@@ -1,7 +1,9 @@ {-# LANGUAGE BangPatterns #-} module Text.Roundtrip.Combinators   (  -- * Lexemes-     text+     char+   , char'+  ,  string   ,  comma   ,  dot      -- * Repetition@@ -16,28 +18,35 @@      -- * Alternation   ,  (<+>)   ,  optional+  ,  optionalBool   ,  optionalWithDefault      -- * Whitespace   ,  skipSpace   ,  sepSpace   ,  optSpace--     -- * Other-  ,  fixedValue+     -- * XML+  , xmlEatWhiteSpace+  , xmlElem+  , xmlAttr+  , xmlFixedAttr+  , xmlText+  , xmlString ) where  import Prelude hiding ((.), foldl)  import Control.Category ((.))-import Control.Isomorphism.Partial.Constructors (nothing, just, nil, cons, left, right)-import Control.Isomorphism.Partial.Derived (foldl)-import Control.Isomorphism.Partial.Iso (Iso)-import Control.Isomorphism.Partial.Prim ((<$>), inverse, element, unit, commute, ignore) -import Data.Char (String)+import Data.Char (String, isSpace) import Data.Maybe (Maybe) import Data.Either (Either) +import qualified Data.Text as T++import Data.XML.Types (Name)++import Control.Isomorphism.Partial+ import Text.Roundtrip.Classes  -- derived combinators@@ -56,13 +65,18 @@ (<+>) :: Syntax delta => delta alpha -> delta beta -> delta (Either alpha beta) p <+> q = (left <$> p) <|> (right <$> q) --- | `text` parses\/prints a fixed text and consumes\/produces a unit value.-text :: StringSyntax delta => String -> delta ()-text []      =    pure ()-text (c:cs)  =    inverse (element ((), ()))-             <$>  (inverse (element c) <$> token)-             <*>  text cs+char :: StringSyntax delta => Char -> delta ()+char c = ignore c <$> token (c ==) +char' :: StringSyntax delta => Char -> delta Char+char' c = token (c ==)++-- | `string` parses\/prints a fixed text and consumes\/produces a unit value.+string :: StringSyntax delta => String -> delta ()+string []      =    pure ()+string (c:cs)  =    inverse (element ((), ()))+               <$>  char c <*>  string cs+ infixr 6 *>, <*  -- | This variant of `<*>` ignores its left result.@@ -94,6 +108,9 @@ 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 @@ -103,10 +120,10 @@   <|> nil <$> (pure ())  comma :: StringSyntax delta => delta ()-comma = text ","+comma = char ','  dot :: StringSyntax delta => delta ()-dot = text "."+dot = char '.'   -- Expressing whitespace@@ -126,21 +143,40 @@ -- no space while printing.  skipSpace  ::  StringSyntax delta => delta ()-skipSpace  =   ignore []    <$>  many (text " ")+skipSpace  =   ignore []    <$>  many (char ' ')  -- | `optSpace` marks a position where whitespace is desired to occur. -- It accepts arbitrary space while parsing, and produces a -- single space character while printing.  optSpace  ::  StringSyntax delta => delta ()-optSpace  =   ignore [()]  <$>  many (text " ")+optSpace  =   ignore [()]  <$>  many (char ' ')  -- | `sepSpace` marks a position where whitespace is required to -- occur. It requires one or more space characters while parsing, -- and produces a single space character while printing.  sepSpace  ::  StringSyntax delta => delta ()-sepSpace  =   text " " <* skipSpace+sepSpace  =   char ' ' <* skipSpace -fixedValue :: (Show a, Eq a) => a -> Iso a ()-fixedValue = inverse . element+--+-- XML+--+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

@@ -9,11 +9,13 @@ import Prelude hiding (catch)  import Control.Exception (AsyncException, catch)+import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Text.PrettyPrint.HughesPJ+import Data.XML.Types (Name(..), Content)  import Control.Isomorphism.Partial-import Text.Roundtrip hiding (text, (<+>))+import Text.Roundtrip hiding ((<+>))  newtype SpecPrinter a = SpecPrinter { unSpecPrinter :: Doc } @@ -38,6 +40,21 @@     pure _ = SpecPrinter $ text "pure"     rule name (SpecPrinter p) _ = SpecPrinter $ text name <+> p     ruleInfix name (SpecPrinter p) (SpecPrinter q) _ = SpecPrinter $ p <+> text name <+> q++instance XmlSyntax SpecPrinter where+    xmlBeginDoc = specPrinter $ text "begin-doc"+    xmlEndDoc = specPrinter $ text "end-doc"+    xmlBeginElem name = specPrinter $ text "<" <> text (formatName name) <+> text "...>"+    xmlEndElem name = specPrinter $ text "</" <> text (formatName name) <> text ">"+    xmlAttrValue name = specPrinter $ text "attr" <+> text (formatName name)+    xmlTextNotEmpty = specPrinter $ text "text-node"++formatName :: Name -> String+formatName n =+    case n of+      Name localName _ (Just prefix) -> T.unpack prefix ++ ':' : T.unpack localName+      Name localName (Just ns) Nothing -> '{' : (T.unpack ns ++ '}' : T.unpack localName)+      Name localName Nothing Nothing -> T.unpack localName  runSpecPrinter :: SpecPrinter a -> String runSpecPrinter (SpecPrinter p) = render p