roundtrip (empty) → 0.1.0.0
raw patch · 13 files changed
+725/−0 lines, 13 filesdep +basedep +containersdep +prettysetup-changed
Dependencies added: base, containers, pretty, safe, template-haskell, text, xml-types
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- roundtrip.cabal +47/−0
- src/Control/Isomorphism/Partial.hs +11/−0
- src/Control/Isomorphism/Partial/Constructors.hs +69/−0
- src/Control/Isomorphism/Partial/Derived.hs +24/−0
- src/Control/Isomorphism/Partial/Iso.hs +85/−0
- src/Control/Isomorphism/Partial/Prim.hs +144/−0
- src/Control/Isomorphism/Partial/TH.hs +77/−0
- src/Text/Roundtrip.hs +11/−0
- src/Text/Roundtrip/Classes.hs +36/−0
- src/Text/Roundtrip/Combinators.hs +146/−0
- src/Text/Roundtrip/SpecPrinter.hs +43/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, ++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ roundtrip.cabal view
@@ -0,0 +1,47 @@+Name: roundtrip+Version: 0.1.0.0+Synopsis: Bidirectional (de-)serialization+Description: Roundtrip allows the definition of bidirectional+ (de-)serialization specifications. The specification language+ is based on the ideas described in the paper /Invertible+ Syntax Descriptions: Unifying Parsing and Pretty Printing/+ by Tillmann Rendel and Klaus Ostermann, Haskell Symposium 2010.+ .+ This package does not provide concrete instances of the+ specification classes, see the package roundtrip-xml instead.+ .+ The package contains slightly modified code from+ Tillmann Rendel's partial-isomorphisms and invertible-syntax+ packages.+License: BSD3+License-file: LICENSE+Author: Stefan Wehr <wehr@factisresearch.com>,+ David Leuschner <leuschner@factisresearch.com>+Maintainer: Stefan Wehr <wehr@factisresearch.com>,+Category: Text+Build-type: Simple+Cabal-version: >=1.8++Library+ Extensions: TemplateHaskell+ GHC-Prof-Options: -auto-all -caf-all+ Hs-Source-Dirs: src+ Exposed-modules:+ Text.Roundtrip+ , Text.Roundtrip.Combinators+ , Text.Roundtrip.Classes+ , Text.Roundtrip.SpecPrinter+ , Control.Isomorphism.Partial+ , Control.Isomorphism.Partial.Prim+ , Control.Isomorphism.Partial.Iso+ , Control.Isomorphism.Partial.TH+ , Control.Isomorphism.Partial.Constructors+ , Control.Isomorphism.Partial.Derived+ Build-depends:+ base == 4.*+ , safe == 0.3.*+ , containers >= 0.3 && < 0.6+ , text == 0.11.*+ , template-haskell >= 2.4 && < 2.6+ , xml-types == 0.3.*+ , pretty == 1.0.*
+ src/Control/Isomorphism/Partial.hs view
@@ -0,0 +1,11 @@+module Control.Isomorphism.Partial+ ( module Control.Isomorphism.Partial.Prim+ , module Control.Isomorphism.Partial.Derived+ , module Control.Isomorphism.Partial.Constructors+ , module Control.Isomorphism.Partial.Iso+ ) where++import Control.Isomorphism.Partial.Prim+import Control.Isomorphism.Partial.Derived+import Control.Isomorphism.Partial.Constructors+import Control.Isomorphism.Partial.Iso
+ src/Control/Isomorphism/Partial/Constructors.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TemplateHaskell #-}+module Control.Isomorphism.Partial.Constructors+ ( nil+ , cons+ , listCases+ , left+ , right+ , nothing+ , just+ , readShowIso+ , textStringIso+ , lazyStrictTextIso+ , listMapIso+ ) where++import Prelude hiding ((.), id)+import Control.Category ((.), id)++import Data.Bool (Bool, otherwise)+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+import Control.Isomorphism.Partial.TH (defineIsomorphisms)++nil :: Iso () [alpha]+nil = unsafeMakeIso f g where+ f () = Just []+ g [] = Just ()+ g _ = Nothing++cons :: Iso (alpha, [alpha]) [alpha]+cons = unsafeMakeIso 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+ where+ f (Left ()) = Just []+ f (Right (x, xs)) = Just (x : xs)+ g [] = Just (Left ())+ g (x:xs) = Just (Right (x, xs))++$(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)
+ src/Control/Isomorphism/Partial/Derived.hs view
@@ -0,0 +1,24 @@+module Control.Isomorphism.Partial.Derived (++ foldl, swap23++) where++import Prelude ()+import Control.Category (Category (id, (.)))++import Control.Isomorphism.Partial.Iso (Iso)+import Control.Isomorphism.Partial.Prim+import Control.Isomorphism.Partial.Constructors (cons, nil)++foldl :: Iso (alpha, beta) alpha -> Iso (alpha, [beta]) alpha+foldl i = inverse unit+ . (id *** inverse nil)+ . iterateIso (step i) where++ step i = (i *** id)+ . associate+ . (id *** inverse cons)++swap23 :: Iso (a, (b, c)) (a, (c, b))+swap23 = id *** commute
+ src/Control/Isomorphism/Partial/Iso.hs view
@@ -0,0 +1,85 @@+module Control.Isomorphism.Partial.Iso (++ Iso, unsafeMakeIso, unsafeMakeIso', unsafeMakeNamedIso, unsafeMakeNamedIsoL+ , unsafeMakeNamedIsoR, unsafeMakeNamedIsoLR, isoRL, isoLR, isoName+ , isoShowSL, isoShowSR, isoShowL, isoShowR+ , isoFailedErrorMessageL, isoFailedErrorMessageR++) where++data Iso a b = Iso {+ isoLR :: a -> Maybe b+ , isoRL :: b -> Maybe a+ , isoName :: String+ , isoShowSL :: Maybe (a -> ShowS)+ , isoShowSR :: Maybe (b -> ShowS)+ }++unsafeMakeIso :: (alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta+unsafeMakeIso f g = Iso { isoLR = f+ , isoRL = g+ , isoName = "?"+ , isoShowSL = Nothing+ , isoShowSR = Nothing }++unsafeMakeIso' :: String -> Maybe (a -> ShowS) -> Maybe (b -> ShowS)+ -> (a -> Maybe b) -> (b -> Maybe a) -> Iso a b+unsafeMakeIso' name showSL showSR f g = Iso { isoLR = f+ , isoRL = g+ , isoName = name+ , isoShowSL = showSL+ , isoShowSR = showSR }++unsafeMakeNamedIso :: String -> (alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta+unsafeMakeNamedIso name f g = Iso { isoLR = f+ , isoRL = g+ , isoName = name+ , isoShowSL = Nothing+ , isoShowSR = Nothing }++unsafeMakeNamedIsoL :: Show alpha+ => String -> (alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta+unsafeMakeNamedIsoL name f g = Iso { isoLR = f+ , isoRL = g+ , isoName = name+ , isoShowSL = Just shows+ , isoShowSR = Nothing }++unsafeMakeNamedIsoR :: Show beta+ => String -> (alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta+unsafeMakeNamedIsoR name f g = Iso { isoLR = f+ , isoRL = g+ , isoName = name+ , isoShowSL = Nothing+ , isoShowSR = Just shows }++unsafeMakeNamedIsoLR :: (Show alpha, Show beta)+ => String -> (alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta+unsafeMakeNamedIsoLR name f g = Iso { isoLR = f+ , isoRL = g+ , isoName = name+ , isoShowSL = Just shows+ , isoShowSR = Just shows }++isoShowL :: Iso a b -> Maybe (a -> String)+isoShowL iso = makeShow (isoShowSL iso)++isoShowR :: Iso a b -> Maybe (b -> String)+isoShowR iso = makeShow (isoShowSR iso)++makeShow :: Maybe (a -> ShowS) -> Maybe (a -> String)+makeShow Nothing = Nothing+makeShow (Just f) = Just (\x -> f x "")++isoFailedErrorMessageL :: Iso a b -> a -> String+isoFailedErrorMessageL iso = isoFailedErrorMessage (isoName iso) (isoShowSL iso)++isoFailedErrorMessageR :: Iso a b -> b -> String+isoFailedErrorMessageR iso = isoFailedErrorMessage (isoName iso) (isoShowSR iso)++isoFailedErrorMessage :: String -> Maybe (a -> ShowS) -> a -> String+isoFailedErrorMessage name mf x =+ "Isomorphism " ++ name ++ " failed" +++ (case mf of+ Nothing -> ""+ Just f -> " on input " ++ f x "")
+ src/Control/Isomorphism/Partial/Prim.hs view
@@ -0,0 +1,144 @@+module Control.Isomorphism.Partial.Prim+ ( idIso+ , inverse+ , apply+ , unapply+ , IsoFunctor ((<$>))+ , ignore+ , (***)+ , (|||)+ , associate+ , commute+ , unit+ , element+ , subset+ , iterateIso+ , distribute+ ) where++import Prelude hiding ((.), id)++import Control.Monad (liftM2, (>=>), fmap, mplus)+import Control.Category (Category (id, (.)))++import Data.Bool (Bool, otherwise)+import Data.Either (Either (Left, Right))+import Data.Eq (Eq ((==)))+import Data.Maybe (Maybe (Just, Nothing))++import Control.Isomorphism.Partial.Iso++inverse :: Iso alpha beta -> Iso beta alpha+inverse iso = unsafeMakeIso' name' (isoShowSR iso) (isoShowSL iso) (isoRL iso) (isoLR iso)+ where+ name' = "inverse(" ++ isoName iso ++ ")"++apply :: Iso alpha beta -> alpha -> Maybe beta+apply = isoLR++unapply :: Iso alpha beta -> beta -> Maybe alpha+unapply = isoRL++idIso :: Iso a a+idIso = unsafeMakeNamedIso "id" Just Just++instance Category Iso where+ g . f = unsafeMakeIso' name' (isoShowSL f) (isoShowSR g)+ (apply f >=> apply g) (unapply g >=> unapply f)+ where+ name' = "(" ++ isoName g ++ " . " ++ isoName f ++ ")"+ id = idIso++infix 5 <$>++class IsoFunctor f where+ (<$>) :: Iso alpha beta -> (f alpha -> f beta)++ignore :: alpha -> Iso alpha ()+ignore x = unsafeMakeNamedIsoR "ignore" f g where+ f _ = Just ()+ g () = Just x++-- | the product type constructor `(,)` is a bifunctor from+-- `Iso` $\times$ `Iso` to `Iso`, so that we have the+-- bifunctorial map `***` which allows two separate isomorphisms+-- to work on the two components of a tuple.+(***) :: Iso alpha beta -> Iso gamma delta -> Iso (alpha, gamma) (beta, delta)+i *** j = unsafeMakeIso' name (showPair isoShowSL isoShowSL) (showPair isoShowSR isoShowSR) f g+ where+ f (a, b) = liftM2 (,) (apply i a) (apply j b)+ g (c, d) = liftM2 (,) (unapply i c) (unapply j d)+ name = "(" ++ isoName i ++ " *** " ++ isoName j ++ ")"+ showPair f g =+ case (f i, g j) of+ (Just si, Just sj) -> Just $ \(x,y) -> showChar '(' . si x . showString ", "+ . sj y . showString ")"+ _ -> Nothing++-- | The mediating arrow for sums constructed with `Either`.+-- This is not a proper partial isomorphism because of `mplus`.+(|||) :: Iso alpha gamma -> Iso beta gamma -> Iso (Either alpha beta) gamma+i ||| j = unsafeMakeIso' name showEither (isoShowSR i `mplus` isoShowSR j) f g+ where+ f (Left x) = apply i x+ f (Right x) = apply j x+ g y = (Left `fmap` unapply i y) `mplus` (Right `fmap` unapply j y)+ name = "(" ++ isoName i ++ " ||| " ++ isoName j ++ ")"+ showEither =+ case (isoShowSL i, isoShowSL j) of+ (Just si, Just sj) -> Just $ \e -> case e of+ Left x -> showChar '(' . showString "Left " .+ si x . showChar ')'+ Right x -> showChar '(' . showString "Right " .+ sj x . showChar ')'+ _ -> Nothing++-- | Nested products associate.+associate :: Iso (alpha, (beta, gamma)) ((alpha, beta), gamma)+associate = unsafeMakeIso f g where+ f (a, (b, c)) = Just ((a, b), c)+ g ((a, b), c) = Just (a, (b, c))++-- | Products commute.+commute :: Iso (alpha, beta) (beta, alpha)+commute = unsafeMakeIso f f where+ f (a, b) = Just (b, a)++-- | `()` is the unit element for products.+unit :: Iso alpha (alpha, ())+unit = unsafeMakeNamedIso "unit" f g+ where+ f a = Just (a, ())+ g (a, ()) = Just a++-- | Products distribute over sums.+distribute :: Iso (alpha, Either beta gamma) (Either (alpha, beta) (alpha, gamma))+distribute = unsafeMakeIso f g where+ f (a, Left b) = Just (Left (a, b))+ f (a, Right c) = Just (Right (a, c))+ g (Left (a, b)) = Just (a, Left b)+ g (Right (a, b)) = Just (a, Right b)++-- | `element x` is the partial isomorphism between `()` and the+-- singleton set which contains just `x`.+element :: (Show alpha, Eq alpha) => alpha -> Iso () alpha+element x = unsafeMakeNamedIsoR ("element(" ++ show x ++ ")")+ (\a -> 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+ f x | p x = Just x+ | otherwise = Nothing++iterateIso :: Iso alpha alpha -> Iso alpha alpha+iterateIso step = unsafeMakeIso f g where+ f = Just . driver (apply step)+ g = Just . driver (unapply step)+ driver :: (alpha -> Maybe alpha) -> (alpha -> alpha)+ driver step state+ = case step state of+ Just state' -> driver step state'+ Nothing -> state
+ src/Control/Isomorphism/Partial/TH.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TemplateHaskell #-}+module Control.Isomorphism.Partial.TH+ ( defineIsomorphisms+ , defineIsomorphisms'+ ) where++----------------------------------------+-- SITE-PACKAGES+----------------------------------------+import Language.Haskell.TH ( lamE, tupP, appE, conE, varP, caseE+ , match, conP, normalB, newName, clause+ , funD, mkName, reify, varE, nameBase+ , Info(..), Dec(..), Con(..), wildP, tupE+ , Name, Q, MatchQ+ )+import Control.Monad (replicateM)+import Data.List (find)+import Data.Char (toLower)++----------------------------------------+-- LOCAL+----------------------------------------+import Control.Isomorphism.Partial.Iso (Iso, unsafeMakeIso)++defineIsomorphisms :: Name -> Q [Dec]+defineIsomorphisms d = defineIsomorphisms' d (\(x:xs) -> (toLower x):xs)++defineIsomorphisms' :: Name -> (String -> String) -> Q [Dec]+defineIsomorphisms' d renameFun =+ do info <- reify d+ let cs = case info of+ TyConI (DataD _ _ _ cs _) -> cs+ TyConI (NewtypeD _ _ _ c _) -> [c]+ otherwise -> error $ show d +++ " neither denotes a data or newtype declaration. Found: " +++ show info+ mapM (defFromCon (length cs > 1) renameFun) cs++defFromCon :: Bool -> (String -> String) -> Con -> Q Dec+defFromCon wc renameFun con@(NormalC n fields) = funCreation wc n (length fields) renameFun+defFromCon wc renameFun con@(RecC n fields) = funCreation wc n (length fields) renameFun+defFromCon wc renameFun con@(InfixC _ n _) = funCreation wc n 2 renameFun+defFromCon wc renameFun con@(ForallC _ _ _) = error $ "defineIsomorphisms not available for " +++ "existential data constructors"++funCreation :: Bool -> Name -> Int -> (String -> String) -> Q Dec+funCreation wc n nfields renameFun =+ funD (mkName $ renameFun $ nameBase n)+ [clause [] (normalB (isoFromCon (wildcard wc) n nfields)) []]++isoFromCon wildcard conName nfields =+ do (paths, exprs) <- genPE nfields+ dat <- newName "x"+ let f = lamE [nested tupP paths]+ [| Just $(foldl appE (conE conName) exprs) |]+ let g = lamE [varP dat]+ (caseE (varE dat) $+ [ match (conP conName paths)+ (normalB [| Just $(nested tupE exprs) |]) []+ ] ++ wildcard)+ [| unsafeMakeIso $f $g |]++wildcard :: Bool -> [MatchQ]+wildcard True = [match (wildP) (normalB [| Nothing |]) []]+wildcard _ = []++genPE number = do+ ids <- replicateM number (newName "x")+ return (map varP ids, map varE ids)++checkInfix :: Con -> Bool+checkInfix (InfixC _ _ _) = False+checkInfix _ = True++nested tup [] = tup []+nested tup [x] = x+nested tup (x:xs) = tup [x, nested tup xs]
+ src/Text/Roundtrip.hs view
@@ -0,0 +1,11 @@+module Text.Roundtrip (++ module Text.Roundtrip.Classes+ , module Text.Roundtrip.Combinators+ , module Control.Isomorphism.Partial++) where++import Text.Roundtrip.Classes+import Text.Roundtrip.Combinators+import Control.Isomorphism.Partial
+ src/Text/Roundtrip/Classes.hs view
@@ -0,0 +1,36 @@+module Text.Roundtrip.Classes where++--import Prelude ()++import Control.Isomorphism.Partial (IsoFunctor)+import Data.Eq (Eq)+import Data.Char (Char)++infixl 3 <|>+infixl 3 <||>+infixr 6 <*>++class ProductFunctor f where+ (<*>) :: f alpha -> f beta -> f (alpha, beta)++class Alternative f where+ -- one token lookahead for lhs+ (<|>) :: f alpha -> f alpha -> f alpha+ -- infinite lookahead for lhs+ (<||>) :: f alpha -> f alpha -> f alpha+ empty :: f alpha++class (IsoFunctor delta, ProductFunctor delta, Alternative delta)+ => Syntax delta where+ -- (<$>) :: Iso alpha beta -> delta alpha -> delta beta+ -- (<*>) :: delta alpha -> delta beta -> delta (alpha, beta)+ -- (<|>) :: delta alpha -> delta alpha -> delta alpha+ -- empty :: delta alpha+ pure :: Eq alpha => alpha -> delta alpha+ rule :: String -> delta beta -> delta alpha -> delta alpha+ rule _ _ x = x+ ruleInfix :: String -> delta beta -> delta gamma -> delta alpha -> delta alpha+ ruleInfix _ _ _ x = x++class Syntax delta => StringSyntax delta where+ token :: delta Char
+ src/Text/Roundtrip/Combinators.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE BangPatterns #-}+module Text.Roundtrip.Combinators+ ( -- * Lexemes+ text+ , comma+ , dot+ -- * Repetition+ , many+ , many1+ , sepBy+ , chainl1+ -- * Sequencing+ , (*>)+ , (<*)+ , between+ -- * Alternation+ , (<+>)+ , optional+ , optionalWithDefault+ -- * Whitespace+ , skipSpace+ , sepSpace+ , optSpace++ -- * Other+ , fixedValue+) 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.Maybe (Maybe)+import Data.Either (Either)++import Text.Roundtrip.Classes++-- derived combinators+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)++-- | `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++infixr 6 *>, <*++-- | This variant of `<*>` ignores its left result.+-- In contrast to its counterpart derived from the `Applicative` class, the ignored+-- parts have type `delta ()` rather than `delta beta` because otherwise information relevant+-- for pretty-printing would be lost.++(*>) :: Syntax delta => delta () -> delta alpha -> delta alpha+p *> q = ruleInfix "*>" p q $ inverse unit . commute <$> p <*> q++-- | This variant of `<*>` ignores its right result.+-- In contrast to its counterpart derived from the `Applicative` class, the ignored+-- parts have type `delta ()` rather than `delta beta` because otherwise information relevant+-- for pretty-printing would be lost.++(<*) :: Syntax delta => delta alpha -> delta () -> delta alpha+p <* q = ruleInfix "<*" p q $ inverse unit <$> p <*> q++-- | The `between` function combines `*>` and `<*` in the obvious way.+between :: Syntax delta => delta () -> delta () -> delta alpha -> delta alpha+between p q r = p *> r <* q++-- | The `chainl1` combinator is used to parse a+-- left-associative chain of infix operators.+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 ())++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 = text ","++dot :: StringSyntax delta => delta ()+dot = text "."+++-- Expressing whitespace+-- ---------------------+--+-- Parsers and pretty printers treat whitespace+-- differently. Parsers+-- specify where whitespace is allowed or required to occur, while+-- pretty printers specify how much whitespace is to be inserted at+-- these locations. To account for these different roles of+-- whitespace, the following three syntax descriptions provide+-- fine-grained control over where whitespace is allowed, desired or+-- required to occur.++-- | `skipSpace` marks a position where whitespace is allowed to+-- occur. It accepts arbitrary space while parsing, and produces+-- no space while printing.++skipSpace :: StringSyntax delta => delta ()+skipSpace = ignore [] <$> many (text " ")++-- | `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 " ")++-- | `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++fixedValue :: (Show a, Eq a) => a -> Iso a ()+fixedValue = inverse . element
+ src/Text/Roundtrip/SpecPrinter.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Text.Roundtrip.SpecPrinter (++ SpecPrinter, specPrinter, runSpecPrinter++) where++import Prelude hiding (catch)++import Control.Exception (AsyncException, catch)+import qualified Data.Text.Lazy as TL+import Text.PrettyPrint.HughesPJ++import Control.Isomorphism.Partial+import Text.Roundtrip hiding (text, (<+>))++newtype SpecPrinter a = SpecPrinter { unSpecPrinter :: Doc }++specPrinter :: Doc -> SpecPrinter a+specPrinter = SpecPrinter++instance IsoFunctor SpecPrinter where+ iso <$> (SpecPrinter p) = SpecPrinter $ text (isoName iso) <+> text "<$>" <+> p++instance ProductFunctor SpecPrinter where+ (SpecPrinter p) <*> (SpecPrinter q) =+ SpecPrinter $ parens (p <+> text "<*>" <+> q)++instance Alternative SpecPrinter where+ (SpecPrinter p) <|> (SpecPrinter q) =+ SpecPrinter $ parens (p <+> text "<|>" <+> q)+ (SpecPrinter p) <||> (SpecPrinter q) =+ SpecPrinter $ parens (p <+> text "<||>" <+> q)+ empty = SpecPrinter $ text "empty"++instance Syntax SpecPrinter where+ pure _ = SpecPrinter $ text "pure"+ rule name (SpecPrinter p) _ = SpecPrinter $ text name <+> p+ ruleInfix name (SpecPrinter p) (SpecPrinter q) _ = SpecPrinter $ p <+> text name <+> q++runSpecPrinter :: SpecPrinter a -> String+runSpecPrinter (SpecPrinter p) = render p