packages feed

partial-isomorphisms (empty) → 0.1

raw patch · 9 files changed

+325/−0 lines, 9 filesdep +basedep +template-haskellsetup-changed

Dependencies added: base, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, University of Marburg
+
+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 the University of Marburg 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
+ partial-isomorphisms.cabal view
@@ -0,0 +1,41 @@+Name:                partial-isomorphisms
+Version:             0.1
+Synopsis:            Partial isomorphisms.
+Description:         Partial isomorphisms as described in the 
+                     paper:
+                     .
+                     Tillmann Rendel and Klaus Ostermann. 
+                     Invertible Syntax Descriptions: 
+                     Unifying Parsing and Pretty Printing. 
+                     In /Proc. of Haskell Symposium/, 2010.
+                     .
+                     The paper also describes invertible syntax 
+                     descriptions as a common interface for 
+                     parsers and pretty printers. These are 
+                     distributed separately in the
+                     /invertible-syntax/ package.
+Homepage:            http://www.informatik.uni-marburg.de/~rendel/unparse
+License:             BSD3
+License-file:        LICENSE
+Author:              Tillmann Rendel
+Maintainer:          rendel@informatik.uni-marburg.de
+-- Copyright:           
+Category:            Control
+Build-type:          Simple
+-- Extra-source-files:  
+Cabal-version:       >=1.2
+
+Library
+  Hs-source-dirs:   src
+  Exposed-modules:  Control.Isomorphism.Partial
+                    Control.Isomorphism.Partial.Constructors
+                    Control.Isomorphism.Partial.Derived
+                    Control.Isomorphism.Partial.Prim
+                    Control.Isomorphism.Partial.TH
+                    Control.Isomorphism.Partial.Unsafe
+  
+  Build-depends:    base >= 3 && < 5, template-haskell
+  
+  -- Other-modules:       
+  
+  -- Build-tools:
+ src/Control/Isomorphism/Partial.hs view
@@ -0,0 +1,9 @@+module Control.Isomorphism.Partial+  ( module Control.Isomorphism.Partial.Prim+  , module Control.Isomorphism.Partial.Derived+  , module Control.Isomorphism.Partial.Constructors+  ) where+  +import Control.Isomorphism.Partial.Prim+import Control.Isomorphism.Partial.Derived+import Control.Isomorphism.Partial.Constructors
+ src/Control/Isomorphism/Partial/Constructors.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell #-}+module Control.Isomorphism.Partial.Constructors +  ( nil+  , cons+  , listCases+  , left+  , right+  , nothing+  , just+  ) where++import Prelude ()++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.Unsafe (Iso (Iso))+import Control.Isomorphism.Partial.TH (defineIsomorphisms)++nil :: Iso () [alpha]+nil = Iso f g where+  f ()  =  Just []+  g []  =  Just ()+  g _   =  Nothing++cons :: Iso (alpha, [alpha]) [alpha]+cons = Iso f g where+  f (x, xs)   =  Just (x : xs)+  g (x : xs)  =  Just (x, xs)+  g _         =  Nothing+  +listCases :: Iso (Either () (alpha, [alpha])) [alpha]+listCases = Iso 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)
+ src/Control/Isomorphism/Partial/Derived.hs view
@@ -0,0 +1,17 @@+module Control.Isomorphism.Partial.Derived +  ( foldl+  ) where++import Prelude ()+import Control.Category (Category (id, (.)))+import Control.Isomorphism.Partial.Prim (Iso, inverse, unit, associate, iterate, (***))+import Control.Isomorphism.Partial.Constructors (cons, nil)++foldl :: Iso (alpha, beta) alpha -> Iso (alpha, [beta]) alpha+foldl i = inverse unit +        . (id *** inverse nil) +        . iterate (step i) where++  step i = (i *** id) +         . associate +         . (id *** inverse cons)
+ src/Control/Isomorphism/Partial/Prim.hs view
@@ -0,0 +1,120 @@+module Control.Isomorphism.Partial.Prim+  ( Iso ()+  , inverse+  , apply+  , unapply+  , IsoFunctor ((<$>))+  , ignore+  , (***)+  , (|||)+  , associate+  , commute+  , unit+  , element+  , subset+  , iterate+  , distribute+  ) where++import Prelude ()++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.Unsafe (Iso (Iso))++inverse :: Iso alpha beta -> Iso beta alpha+inverse (Iso f g) = Iso g f++apply :: Iso alpha beta -> alpha -> Maybe beta+apply (Iso f g) = f++unapply  ::  Iso alpha beta -> beta -> Maybe alpha+unapply  =   apply . inverse++instance Category Iso where+  g . f  =  Iso  (apply f >=> apply g) +                 (unapply g >=> unapply f)+  id     =  Iso  Just Just++infix 5 <$>++class IsoFunctor f where+  (<$>) :: Iso alpha beta -> (f alpha -> f beta)++ignore :: alpha -> Iso alpha ()+ignore x = Iso 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 = Iso f g where+  f (a, b) = liftM2 (,) (apply i a) (apply j b) +  g (c, d) = liftM2 (,) (unapply i c) (unapply j d) ++-- | 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 = Iso 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)++ +-- | Nested products associate. +associate :: Iso (alpha, (beta, gamma)) ((alpha, beta), gamma)+associate = Iso 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 = Iso f f where+  f (a, b) = Just (b, a)++-- | `()` is the unit element for products. +unit :: Iso alpha (alpha, ())+unit = Iso 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  =   Iso 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 :: Eq alpha => alpha -> Iso () alpha+element x = Iso +  (\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 :: (alpha -> Bool) -> Iso alpha alpha+subset p = Iso f f where+  f x | p x = Just x | otherwise = Nothing++iterate :: Iso alpha alpha -> Iso alpha alpha+iterate step = Iso 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,54 @@+{-# LANGUAGE TemplateHaskell #-}+module Control.Isomorphism.Partial.TH +  ( constructorIso+  , defineIsomorphisms+  ) where++import Language.Haskell.TH+import Control.Monad+import Data.List (find)+import Data.Char (toLower)++import Control.Isomorphism.Partial.Unsafe (Iso (Iso))++constructorIso c = do+  DataConI n _ d _             <-  reify c+  TyConI ((DataD _ _ _ cs _))  <-  reify d+  let Just con = find (\(NormalC n' _) -> n == n') cs+  isoFromCon (wildcard cs) con++wildcard cs +  =  if length cs > 1+     then  [match (wildP) (normalB [| Nothing |]) []]+     else  []+  +defineIsomorphisms d = do+  TyConI (DataD _ _ _ cs _) <- reify d+  let rename n +        = mkName (toLower c : cs) where c : cs = nameBase n+      defFromCon con@(NormalC n _) +        =  funD (rename n) +             [clause [] (normalB (isoFromCon (wildcard cs) con)) []]+  +  mapM defFromCon cs++isoFromCon wildcard (NormalC c fs) = do+  let n     =   length fs+  (ps, vs)  <-  genPE n+  v         <-  newName "x"+  let f     =   lamE [nested tupP ps] +                  [| Just $(foldl appE (conE c) vs) |]+  let g     =   lamE [varP v] +                  (caseE (varE v) $ +                    [ match (conP c ps) +                        (normalB [| Just $(nested tupE vs) |]) []+                    ] ++ wildcard)+  [| Iso $f $g |]++genPE n = do+  ids <- replicateM n (newName "x")+  return (map varP ids, map varE ids)++nested tup []      =  tup [] +nested tup [x]     =  x+nested tup (x:xs)  =  tup [x, nested tup xs]
+ src/Control/Isomorphism/Partial/Unsafe.hs view
@@ -0,0 +1,9 @@+module Control.Isomorphism.Partial.Unsafe+  ( Iso (Iso)+  ) where++import Prelude ()+import Data.Maybe (Maybe ())++data Iso alpha beta +  = Iso (alpha -> Maybe beta) (beta -> Maybe alpha)