partial-isomorphisms 0.2 → 0.2.2
raw patch · 7 files changed
+353/−318 lines, 7 filesdep ~template-haskellnew-uploader
Dependency ranges changed: template-haskell
Files
- partial-isomorphisms.cabal +22/−16
- 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/−120
- src/Control/Isomorphism/Partial/TH.hs +132/−105
- src/Control/Isomorphism/Partial/Unsafe.hs +9/−9
partial-isomorphisms.cabal view
@@ -1,17 +1,17 @@ Name: partial-isomorphisms -Version: 0.2 +Version: 0.2.2 Synopsis: Partial isomorphisms. -Description: Partial isomorphisms as described in the +Description: Partial isomorphisms as described in the paper: . - Tillmann Rendel and Klaus Ostermann. - Invertible Syntax Descriptions: - Unifying Parsing and Pretty Printing. + 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 + 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 @@ -19,12 +19,16 @@ License-file: LICENSE Author: Tillmann Rendel Maintainer: rendel@informatik.uni-marburg.de --- Copyright: +-- Copyright: Category: Control Build-type: Simple --- Extra-source-files: -Cabal-version: >=1.2 +-- Extra-source-files: +Cabal-version: >=1.6 +source-repository head + type: git + location: git://github.com/schernichkin/partial-isomorphisms.git + Library Hs-source-dirs: src Exposed-modules: Control.Isomorphism.Partial @@ -33,9 +37,11 @@ Control.Isomorphism.Partial.Prim Control.Isomorphism.Partial.TH Control.Isomorphism.Partial.Unsafe - + Build-depends: base >= 3 && < 5, template-haskell - - -- Other-modules: - - -- Build-tools: + + ghc-options: -Wall + + -- Other-modules: + + -- Build-tools:
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 #-}-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)+{-# 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,120 +1,122 @@-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+{-# 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,105 +1,132 @@-{-# 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))---- | Extract the name of a constructor, e.g. ":" or "Just".-conName :: Con -> Name-conName (NormalC name fields) = name-conName (RecC name fields) = name-conName (InfixC lhs name rhs) = name-conName (ForallC vars context con) = conName con---- | Extract the types of the constructor's fields.-conFields :: Con -> [Type]-conFields (NormalC name fields) = map (\(s, t) -> t) fields-conFields (RecC name fields) = map (\(n, s, t) -> t) fields-conFields (InfixC lhs name rhs) = map (\(s, t) -> t) [lhs, rhs]-conFields (ForallC vars context con) = conFields con---- | Extract the constructors of a type declaration-decConstructors :: Dec -> Q [Con]-decConstructors (DataD _ _ _ cs _) = return cs-decConstructors (NewtypeD _ _ _ c _) = return [c]-decConstructors _ - = fail "partial isomorphisms can only be derived for constructors of data type or newtype declarations."---- | Construct a partial isomorphism expression for a constructor, --- given the constructor's name.-constructorIso :: Name -> ExpQ-constructorIso c = do- DataConI n _ d _ <- reify c- TyConI dec <- reify d- cs <- decConstructors 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---- | Construct partial isomorphism definitions for all --- constructors of a datatype, given the datatype's name.--- The names of the partial isomorphisms are constructed by--- spelling the constructor names with an initial lower-case--- letter.-defineIsomorphisms :: Name -> Q [Dec]-defineIsomorphisms d = do- TyConI dec <- reify d- cs <- decConstructors dec- mapM (defFromCon (wildcard cs)) 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] -> Con -> DecQ-defFromCon wildcard con- = funD (rename (conName con)) - [clause [] (normalB (isoFromCon wildcard con)) []]---- | Constructs a partial isomorphism expression for a--- constructor, given information about the constructor.-isoFromCon :: [MatchQ] -> Con -> ExpQ-isoFromCon wildcard 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) |]) []- ] ++ 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]+{-# 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]
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)