partial-isomorphisms 0.2.2.1 → 0.2.3.0
raw patch · 9 files changed
+384/−381 lines, 9 filesdep ~basedep ~template-haskell
Dependency ranges changed: base, template-haskell
Files
- CHANGELOG.md +3/−0
- README.md +3/−0
- partial-isomorphisms.cabal +44/−50
- 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 +135/−132
- src/Control/Isomorphism/Partial/Unsafe.hs +9/−9
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+0.2.3.0+----------------+* template-haskell bumped to 2.17
+ README.md view
@@ -0,0 +1,3 @@+# partial-isomorphism +[](https://travis-ci.org/schernichkin/partial-isomorphisms) +[](https://hackage.haskell.org/package/partial-isomorphisms)
partial-isomorphisms.cabal view
@@ -1,50 +1,44 @@-Name: partial-isomorphisms -Version: 0.2.2.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: Tillmann Rendel <rendel@informatik.uni-marburg.de> - Stanislav Chernichkin <schernichkin@gmail.com> --- Copyright: -Category: Control -Build-type: Simple --- Extra-source-files: -Cabal-version: >=1.10 - -source-repository head - type: git - location: git://github.com/schernichkin/partial-isomorphisms.git - -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 - - default-language: Haskell2010 - other-extensions: TemplateHaskell, KindSignatures - Build-depends: base >= 3 && < 5, template-haskell >= 2.11 - - ghc-options: -Wall - - -- Other-modules: - - -- Build-tools: +cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: dd98c6799f2f9942db089c22bd9435026170a33a626f7c7910fe193e3ce54b5a++name: partial-isomorphisms+version: 0.2.3.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.+category: Control+homepage: http://www.informatik.uni-marburg.de/~rendel/unparse+bug-reports: https://github.com/schernichkin/partial-isomorphisms/issues+author: Tillmann Rendel <rendel@informatik.uni-marburg.de>+maintainer: Stanislav Chernichkin <schernichkin@gmail.com>+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/schernichkin/partial-isomorphisms++library+ 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+ other-modules:+ Paths_partial_isomorphisms+ hs-source-dirs:+ src+ build-depends:+ base >=3 && <5+ , template-haskell >=2.17+ default-language: Haskell2010
src/Control/Isomorphism/Partial.hs view
@@ -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
src/Control/Isomorphism/Partial/Constructors.hs view
@@ -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)
src/Control/Isomorphism/Partial/Derived.hs view
@@ -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)
src/Control/Isomorphism/Partial/Prim.hs view
@@ -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
src/Control/Isomorphism/Partial/TH.hs view
@@ -1,132 +1,135 @@-{-# LANGUAGE TemplateHaskell #-} -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 = DecInfo Type [TyVarBndr] [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 tyVarBndrs [] $ isoCon `AppT` (isoArgs fields) `AppT` (applyAll typ $ map tyVarBndrToType tyVarBndrs) - -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 (\(_, 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]
src/Control/Isomorphism/Partial/Unsafe.hs view
@@ -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)