partial-isomorphisms 0.2.3.0 → 0.2.4.0

raw patch · 8 files changed

+344/−343 lines, 8 filesdep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +2/−2
• partial-isomorphisms.cabal +12/−7
• src/Control/Isomorphism/Partial.hs +8/−8
• src/Control/Isomorphism/Partial/Constructors.hs +43/−43
• src/Control/Isomorphism/Partial/Derived.hs +17/−17
• src/Control/Isomorphism/Partial/Prim.hs +122/−122
• src/Control/Isomorphism/Partial/TH.hs +131/−135
• src/Control/Isomorphism/Partial/Unsafe.hs +9/−9

@@ -1,3 +1,3 @@-0.2.3.0-----------------+0.2.3.0
+----------------
 * template-haskell bumped to 2.17

@@ -1,15 +1,19 @@-cabal-version: 1.12+cabal-version: 1.12
 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack ----- hash: dd98c6799f2f9942db089c22bd9435026170a33a626f7c7910fe193e3ce54b5a+-- hash: 2de2f9b97477133c659e357f0f2d42bc33287bb9e291bb1f63bf2678c3942f70  name:           partial-isomorphisms-version:        0.2.3.0+version:        0.2.4.0 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.+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. category:       Control homepage:       http://www.informatik.uni-marburg.de/~rendel/unparse bug-reports:    https://github.com/schernichkin/partial-isomorphisms/issues@@ -38,7 +42,8 @@       Paths_partial_isomorphisms   hs-source-dirs:       src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints   build-depends:-      base >=3 && <5-    , template-haskell >=2.17+      base >=4.15 && <5+    , template-haskell >=2.21   default-language: Haskell2010

@@ -1,9 +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+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

@@ -1,43 +1,43 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE KindSignatures  #-}--module Control.Isomorphism.Partial.Constructors -  ( nil-  , cons-  , listCases-  , left-  , right-  , nothing-  , just-  ) where--import Prelude ()--import Data.Either (Either (Left, Right))-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)+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE KindSignatures  #-}
+
+module Control.Isomorphism.Partial.Constructors 
+  ( nil
+  , cons
+  , listCases
+  , left
+  , right
+  , nothing
+  , just
+  ) where
+
+import Prelude ()
+
+import Data.Either (Either (Left, Right))
+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)

@@ -1,17 +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)+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)

@@ -1,122 +1,122 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--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 _) = 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-  (\_ -> 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+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+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 _) = 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
+  (\_ -> 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

@@ -1,135 +1,131 @@-{-# LANGUAGE TemplateHaskell, DataKinds #-}-module Control.Isomorphism.Partial.TH-  ( constructorIso-  , defineIsomorphisms-  ) where--import           Control.Monad-import           Data.Char                          (toLower)-import           Data.List                          (find)-import           Language.Haskell.TH--import           Control.Isomorphism.Partial.Unsafe (Iso (Iso))--gadtError :: a-gadtError = error "Control.Isomorphism.Partial.TH: GADTs currently not supported."-{-# NOINLINE gadtError #-}---- | Extract the name of a constructor, e.g. ":" or "Just".-conName :: Con -> Name-conName (NormalC name _)   =   name-conName (RecC name _)      =   name-conName (InfixC _ name _)  =   name-conName (ForallC _ _ con)  =   conName con-conName (GadtC _ _ _)      =   gadtError-conName (RecGadtC _ _ _)   =   gadtError---- | Extract the types of the constructor's fields.-conFields :: Con -> [Type]-conFields (NormalC _ fields)  =   map (\(_, t) -> t) fields-conFields (RecC _ fields)     =   map (\(_, _, t) -> t) fields-conFields (InfixC lhs _ rhs)  =   map (\(_, t) -> t) [lhs, rhs]-conFields (ForallC _ _ con)   =   conFields con-conFields (GadtC _ _ _)       =   gadtError-conFields (RecGadtC _ _ _)    =   gadtError---- Data dec information-data DecInfo flag = DecInfo Type [TyVarBndr flag] [Con]---- | Extract data or newtype declaration information-decInfo :: Dec -> Q (DecInfo ())-decInfo (DataD    _ name tyVars _ cs _) =  return $ DecInfo (ConT name) tyVars cs-decInfo (NewtypeD _ name tyVars _ c _) =  return $ DecInfo (ConT name) tyVars [c]-decInfo _ = fail "partial isomorphisms can only be derived for constructors of data type or newtype declarations."---- | Convert tyVarBndr to type-tyVarBndrToType :: TyVarBndr () -> Type-tyVarBndrToType (PlainTV n _)   = VarT n-tyVarBndrToType (KindedTV n _ k) = SigT (VarT n) k---- | Create Iso type for specified type and conctructor fields (Iso (a, b) (CustomType a b c))-isoType :: Type -> [TyVarBndr ()] -> [Type] -> Q Type-isoType typ tyVarBndrs fields = do-    isoCon <- [t| Iso |]-    return $ ForallT (map specified tyVarBndrs) [] $ isoCon `AppT` (isoArgs fields) `AppT` (applyAll typ $ map tyVarBndrToType tyVarBndrs)-    where-      specified (PlainTV name _) = PlainTV name SpecifiedSpec-      specified (KindedTV name _ kind) = KindedTV name SpecifiedSpec kind--isoArgs :: [Type] -> Type-isoArgs []     = TupleT 0-isoArgs [x]    = x-isoArgs (x:xs) = AppT (AppT (TupleT 2) x) (isoArgs xs)---- | Apply all types to supplied type-applyAll :: Type -> [Type] -> Type-applyAll = foldl AppT---- | Construct a partial isomorphism expression for a constructor,--- given the constructor's name.-constructorIso :: Name -> ExpQ-constructorIso name = do-  DataConI n _ d    <-  reify name-  TyConI dec        <-  reify d-  DecInfo _ _ cs    <-  decInfo dec-  let Just con      =   find (\c -> n == conName c) cs-  isoFromCon (wildcard cs) con--wildcard :: [Con] -> [MatchQ]-wildcard cs-  =  if length cs > 1-     then  [match (wildP) (normalB [| Nothing |]) []]-     else  []---- | Converts a constructor name (starting with an upper-case---   letter) into a function name (starting with a lower-case---   letter).-rename :: Name -> Name-rename n-  = mkName (toLower c : cs) where c : cs = nameBase n--defineIsomorphisms :: Name -> Q [Dec]-defineIsomorphisms d = do-  TyConI dec  <-  reify d-  DecInfo typ tyVarBndrs cs          <-  decInfo dec-  join `fmap` mapM (\a -> defFromCon (wildcard cs) typ tyVarBndrs a) cs---- | Constructs a partial isomorphism definition for a---   constructor, given information about the constructor.---   The name of the partial isomorphisms is constructed by---   spelling the constructor name with an initial lower-case---   letter.-defFromCon :: [MatchQ] -> Type -> [TyVarBndr ()] -> Con -> DecsQ-defFromCon matches t tyVarBndrs con = do-    let funName = rename $ conName con-    sig <- SigD funName `fmap` isoType t tyVarBndrs (conFields con)-    fun <- funD funName [ clause [] (normalB (isoFromCon matches con)) [] ]-    return [sig, fun]---- | Constructs a partial isomorphism expression for a---   constructor, given information about the constructor.-isoFromCon :: [MatchQ] -> Con -> ExpQ-isoFromCon matches con = do-  let c     =   conName con-  let fs    =   conFields con-  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) |]) []-                    ] ++ matches)-  [| Iso $f $g |]--genPE :: Int -> Q ([PatQ], [ExpQ])-genPE n = do-  ids <- replicateM n (newName "x")-  return (map varP ids, map varE ids)--nested :: ([t] -> t) -> [t] -> t-nested tup []      =  tup []-nested _   [x]     =  x-nested tup (x:xs)  =  tup [x, nested tup xs]+{-# LANGUAGE TemplateHaskell, DataKinds #-}
+module Control.Isomorphism.Partial.TH
+  ( constructorIso
+  , defineIsomorphisms
+  ) where
+
+import           Control.Monad
+import           Data.Char                          (toLower)
+import           Data.List                          (find)
+import           Language.Haskell.TH
+
+import           Control.Isomorphism.Partial.Unsafe (Iso (Iso))
+
+gadtError :: a
+gadtError = error "Control.Isomorphism.Partial.TH: GADTs currently not supported."
+{-# NOINLINE gadtError #-}
+
+-- | Extract the name of a constructor, e.g. ":" or "Just".
+conName :: Con -> Name
+conName (NormalC name _)   =   name
+conName (RecC name _)      =   name
+conName (InfixC _ name _)  =   name
+conName (ForallC _ _ con)  =   conName con
+conName (GadtC {})         =   gadtError
+conName (RecGadtC {})      =   gadtError
+
+-- | Extract the types of the constructor's fields.
+conFields :: Con -> [Type]
+conFields (NormalC _ fields)  =   map snd fields
+conFields (RecC _ fields)     =   map (\(_, _, t) -> t) fields
+conFields (InfixC lhs _ rhs)  =   map snd [lhs, rhs]
+conFields (ForallC _ _ con)   =   conFields con
+conFields (GadtC {})          =   gadtError
+conFields (RecGadtC {})       =   gadtError
+
+-- Data dec information
+data DecInfo flag = DecInfo Type [TyVarBndr flag] [Con]
+
+-- | Extract data or newtype declaration information
+decInfo :: Dec -> Q (DecInfo BndrVis)
+decInfo (DataD    _ name tyVars _ cs _) =  return $ DecInfo (ConT name) tyVars cs
+decInfo (NewtypeD _ name tyVars _ c _) =  return $ DecInfo (ConT name) tyVars [c]
+decInfo _ = fail "partial isomorphisms can only be derived for constructors of data type or newtype declarations."
+
+-- | Convert tyVarBndr to type
+tyVarBndrToType :: TyVarBndr BndrVis -> Type
+tyVarBndrToType (PlainTV n _)   = VarT n
+tyVarBndrToType (KindedTV n _ k) = SigT (VarT n) k
+
+-- | Create Iso type for specified type and conctructor fields (Iso (a, b) (CustomType a b c))
+isoType :: Type -> [TyVarBndr BndrVis] -> [Type] -> Q Type
+isoType typ tyVarBndrs fields = do
+    isoCon <- [t| Iso |]
+    return $ ForallT (map specified tyVarBndrs) [] $ isoCon `AppT` isoArgs fields `AppT` applyAll typ (map tyVarBndrToType tyVarBndrs)
+    where
+      specified (PlainTV name _) = PlainTV name SpecifiedSpec
+      specified (KindedTV name _ kind) = KindedTV name SpecifiedSpec kind
+
+isoArgs :: [Type] -> Type
+isoArgs []     = TupleT 0
+isoArgs [x]    = x
+isoArgs (x:xs) = AppT (AppT (TupleT 2) x) (isoArgs xs)
+
+-- | Apply all types to supplied type
+applyAll :: Type -> [Type] -> Type
+applyAll = foldl AppT
+
+-- | Construct a partial isomorphism expression for a constructor,
+-- given the constructor's name.
+constructorIso :: Name -> ExpQ
+constructorIso name = do
+  DataConI n _ d    <-  reify name
+  TyConI dec        <-  reify d
+  DecInfo _ _ cs    <-  decInfo dec
+  let Just con      =   find (\c -> n == conName c) cs
+  isoFromCon (wildcard cs) con
+
+wildcard :: [Con] -> [MatchQ]
+wildcard cs =  [match wildP (normalB [| Nothing |]) [] | length cs > 1]
+
+-- | Converts a constructor name (starting with an upper-case
+--   letter) into a function name (starting with a lower-case
+--   letter).
+rename :: Name -> Name
+rename n = mkName $ case nameBase n of 
+                      c:cs -> toLower c : cs
+                      a -> a
+
+defineIsomorphisms :: Name -> Q [Dec]
+defineIsomorphisms d = do
+  TyConI dec  <-  reify d
+  DecInfo typ tyVarBndrs cs          <-  decInfo dec
+  join `fmap` mapM (defFromCon (wildcard cs) typ tyVarBndrs) cs
+
+-- | Constructs a partial isomorphism definition for a
+--   constructor, given information about the constructor.
+--   The name of the partial isomorphisms is constructed by
+--   spelling the constructor name with an initial lower-case
+--   letter.
+defFromCon :: [MatchQ] -> Type -> [TyVarBndr BndrVis] -> Con -> DecsQ
+defFromCon matches t tyVarBndrs con = do
+    let funName = rename $ conName con
+    sig <- SigD funName `fmap` isoType t tyVarBndrs (conFields con)
+    fun <- funD funName [ clause [] (normalB (isoFromCon matches con)) [] ]
+    return [sig, fun]
+
+-- | Constructs a partial isomorphism expression for a
+--   constructor, given information about the constructor.
+isoFromCon :: [MatchQ] -> Con -> ExpQ
+isoFromCon matches con = do
+  let c     =   conName con
+  let fs    =   conFields con
+  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) |]) [] : matches)
+  [| Iso $f $g |]
+
+genPE :: Int -> Q ([PatQ], [ExpQ])
+genPE n = do
+  ids <- replicateM n (newName "x")
+  return (map varP ids, map varE ids)
+
+nested :: ([t] -> t) -> [t] -> t
+nested tup []      =  tup []
+nested _   [x]     =  x
+nested tup (x:xs)  =  tup [x, nested tup xs]

@@ -1,9 +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)+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)