Piso (empty) → 0.1

raw patch · 7 files changed

+423/−0 lines, 7 filesdep +basedep +template-haskellsetup-changed

Dependencies added: base, template-haskell

Files

Data/Piso.hs +74/−0
Data/Piso/Common.hs +70/−0
Data/Piso/Generic.hs +119/−0
Data/Piso/TH.hs +102/−0
LICENSE +24/−0
Piso.cabal +32/−0
Setup.hs +2/−0

+ Data/Piso.hs view

@@ -0,0 +1,74 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveFunctor #-}++module Data.Piso (++  -- * Partial isomorphisms+  Piso(..), forward, backward,+  FromPiso(..),+  (:-)(..)++  ) where+++import Prelude hiding (id, (.))++import Control.Monad ((>=>))+import Control.Category (Category(..))+++-- | Bidirectional isomorphism that is partial in the backward direction.+--+-- This can be used to express constructor-deconstructor pairs. For example:+--+-- > nil :: Piso t ([a] :- t)+-- > nil = Piso f g+-- >   where+-- >     f        t  = [] :- t+-- >     g ([] :- t) = Just t+-- >     g _         = Nothing+-- >+-- > cons :: Piso (a :- [a] :- t) ([a] :- t)+-- > cons = Piso f g+-- >   where+-- >     f (x :- xs  :- t) = (x : xs) :- t+-- >     g ((x : xs) :- t) = Just (x :- xs :- t)+-- >     g _               = Nothing+--+-- Here ':-' can be read as \'cons\', forming a stack of values. For example,+-- @nil@ pushes @[]@ onto the stack; or, in the backward direction, tries to+-- remove @[]@ from the stack. Representing constructor-destructor pairs as+-- stack manipulators allows them to be composed more easily.+--+-- Module @Data.Piso.Common@ contains @Piso@s for some common datatypes.+--+-- Modules @Data.Piso.Generic@ and @Data.Piso.TH@ offer generic ways of deriving @Piso@s for custom datatypes.++data Piso a b = Piso (a -> b) (b -> Maybe a)++instance Category Piso where+  id                          = Piso id Just+  ~(Piso f1 g1) . ~(Piso f2 g2) = Piso (f1 . f2) (g1 >=> g2)+++-- | Apply an isomorphism in forward direction.+forward :: Piso a b -> a -> b+forward (Piso f _) = f++-- | Apply an isomorphism in backward direction.+backward :: Piso a b -> b -> Maybe a+backward (Piso _ g) = g+++-- | A type class that expresses that a category is able to embed 'Piso' values.+class Category cat => FromPiso cat where+  fromPiso :: Piso a b -> cat a b++instance FromPiso Piso where+  fromPiso = id+++-- | Heterogenous stack with a head and a tail. Or: an infix way to write @(,)@.+data h :- t = h :- t+  deriving (Eq, Show, Functor)+infixr 5 :-

+ Data/Piso/Common.hs view

@@ -0,0 +1,70 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoMonoPatBinds #-}++-- | Constructor-destructor isomorphisms for some common datatypes.+module Data.Piso.Common (++  -- * @()@+  unit,+  +  -- * @(,)@+  tup,+  +  -- * @(,,)@+  tup3,++  -- * @Maybe a@+  nothing, just,+  +  -- * @[a]@+  nil, cons,+  +  -- * @Either a b@+  left, right,+  +  -- * @Bool@+  false, true++  ) where++import Prelude hiding (id, (.), maybe, either)++import Data.Piso+import Data.Piso.TH+++unit :: Piso t (() :- t)+unit = $(derivePisos ''())++tup :: Piso (a :- b :- t) ((a, b) :- t)+tup = $(derivePisos ''(,))++tup3 :: Piso (a :- b :- c :- t) ((a, b, c) :- t)+tup3 = $(derivePisos ''(,,))++nothing :: Piso t (Maybe a :- t)+just    :: Piso (a :- t) (Maybe a :- t)+(nothing, just) = $(derivePisos ''Maybe)++nil :: Piso t ([a] :- t)+nil = Piso f g+  where+    f        t  = [] :- t+    g ([] :- t) = Just t+    g _         = Nothing++cons :: Piso (a :- [a] :- t) ([a] :- t)+cons = Piso f g+  where+    f (x :- xs  :- t) = (x : xs) :- t+    g ((x : xs) :- t) = Just (x :- xs :- t)+    g _               = Nothing++left  :: Piso (a :- t) (Either a b :- t)+right :: Piso (b :- t) (Either a b :- t)+(left, right) = $(derivePisos ''Either)++false :: Piso t (Bool :- t)+true  :: Piso t (Bool :- t)+(false, true) = $(derivePisos ''Bool)

+ Data/Piso/Generic.hs view

@@ -0,0 +1,119 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}++module Data.Piso.Generic (mkPisoList, PisoList(..), PisoLhs) where++import Data.Piso+import GHC.Generics+++-- | Derive a list of partial isomorphisms, one for each constructor in the 'Generic' datatype @a@. The list is wrapped in the unary constructor @PisoList@. Within that constructor, the isomorphisms are separated by the right-associative binary infix constructor @:&@. Finally, the individual isomorphisms are wrapped in the unary constructor @I@. These constructors are all exported by this module, but no documentation is generated for them by Hackage.+--+-- As an example, here is how to define the isomorphisms @nil@ and @cons@ for @[a]@, which is an instance of @Generic@:+--+-- > nil  :: Piso              t  ([a] :- t)+-- > cons :: Piso (a :- [a] :- t) ([a] :- t)+-- > (nil, cons) = (nil', cons')+-- >   where+-- >     PisoList (I nil' :& I cons') = mkPisoList+--+-- GHC 7.6.3 requires the extra indirection through @nil'@ and @cons'@, due to bug 7268 (<http://ghc.haskell.org/trac/ghc/ticket/7268>). When it is fixed, the example above can be written in a more direct way:+--+-- > nil  :: Piso              t  ([a] :- t)+-- > cons :: Piso (a :- [a] :- t) ([a] :- t)+-- > PisoList (I nil :& I cons) = mkPisoList+--+-- If you are familiar with the generic representations from @Data.Generic@, you might be interested in the exact types of the various constructors in which the isomorphisms are wrapped:+--+-- > I        :: (forall t. Piso (PisoLhs f t) (a :- t)) -> PisoList (M1 C c f) a+-- > (:&)     :: PisoList f a -> PisoList g a -> PisoList (f :+: g) a+-- > PisoList :: PisoList f a -> PisoList (M1 D c f) a+--+-- The type constructor @PisoLhs@ that appears in the type of @I@ is an internal type family that builds the proper heterogenous list of types (using ':-') based on the constructor's fields.+mkPisoList :: (Generic a, MkPisoList (Rep a)) => PisoList (Rep a) a+mkPisoList = mkPisoList' to (Just . from)+++class MkPisoList (f :: * -> *) where+  data PisoList (f :: * -> *) (a :: *)+  mkPisoList' :: (f p -> a) -> (a -> Maybe (f q)) -> PisoList f a+++instance MkPisoList f => MkPisoList (M1 D c f) where+  data PisoList (M1 D c f) a = PisoList (PisoList f a)+  mkPisoList' f' g' = PisoList (mkPisoList' (f' . M1) (fmap unM1 . g'))+++infixr :&++instance (MkPisoList f, MkPisoList g) => MkPisoList (f :+: g) where+  data PisoList (f :+: g) a = PisoList f a :& PisoList g a+  mkPisoList' f' g' = f f' g' :& g f' g'+    where+      f :: forall a p q. ((f :+: g) p -> a) -> (a -> Maybe ((f :+: g) q)) -> PisoList f a+      f _f' _g' = mkPisoList' (\fp -> _f' (L1 fp)) (matchL _g')+      g :: forall a p q. ((f :+: g) p -> a) -> (a -> Maybe ((f :+: g) q)) -> PisoList g a+      g _f' _g' = mkPisoList' (\gp -> _f' (R1 gp)) (matchR _g')++      matchL :: (a -> Maybe ((f :+: g) q)) -> a -> Maybe (f q)+      matchL _g' a = case _g' a of+        Just (L1 f'') -> Just f''+        _ -> Nothing++      matchR :: (a -> Maybe ((f :+: g) q)) -> a -> Maybe (g q)+      matchR _g' a = case _g' a of+        Just (R1 g'') -> Just g''+        _ -> Nothing+++instance MkPiso f => MkPisoList (M1 C c f) where++  data PisoList (M1 C c f) a = I (forall t cat. FromPiso cat => cat (PisoLhs f t) (a :- t))++  mkPisoList' f' g' = I (fromPiso (Piso (f f') (g g')))+    where+      f :: forall a p t. (M1 C c f p -> a) -> PisoLhs f t -> a :- t+      f _f' lhs = mapHead (_f' . M1) (mkR lhs)+      g :: forall a p t. (a -> Maybe (M1 C c f p)) -> (a :- t) -> Maybe (PisoLhs f t)+      g _g' (a :- t) = fmap (mkL . (:- t) . unM1) (_g' a)+++-- Deriving types and conversions for single constructors++class MkPiso (f :: * -> *) where+  type PisoLhs (f :: * -> *) (t :: *) :: *+  mkR :: forall p t. PisoLhs f t -> (f p :- t)+  mkL :: forall p t. (f p :- t) -> PisoLhs f t++instance MkPiso U1 where+  type PisoLhs U1 t = t+  mkR t         = U1 :- t+  mkL (U1 :- t) = t++instance MkPiso (K1 i a) where+  type PisoLhs (K1 i a) t = a :- t+  mkR (h :- t) = K1 h :- t+  mkL (K1 h :- t) = h :- t++instance MkPiso f => MkPiso (M1 i c f) where+  type PisoLhs (M1 i c f) t = PisoLhs f t+  mkR = mapHead M1 . mkR+  mkL = mkL . mapHead unM1++instance (MkPiso f, MkPiso g) => MkPiso (f :*: g) where+  type PisoLhs (f :*: g) t = PisoLhs f (PisoLhs g t)+  mkR t = (hf :*: hg) :- tg+    where+      hf :- tf = mkR t+      hg :- tg = mkR tf+  mkL ((hf :*: hg) :- t) = mkL (hf :- mkL (hg :- t))++++mapHead :: (a -> b) -> (a :- t) -> (b :- t)+mapHead f (h :- t) = f h :- t

+ Data/Piso/TH.hs view

@@ -0,0 +1,102 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Piso.TH (derivePisos) where++import Data.Piso+import Language.Haskell.TH+import Control.Applicative+import Control.Monad+++-- | Derive partial isomorphisms for a given datatype. The resulting+-- expression is a tuple with one isomorphism element for each constructor in+-- the datatype.+-- +-- For example:+-- +-- > nothing :: Piso t (Maybe a :- t)+-- > just    :: Piso (a :- t) (Maybe a :- t)+-- > (nothing, just) = $(derivePisos ''Maybe)+-- +-- Deriving isomorphisms this way requires @-XNoMonoPatBinds@.+derivePisos :: Name -> Q Exp+derivePisos name = do+  info <- reify name+  routers <-+    case info of+      TyConI (DataD _ _ _ cons _)   ->+        mapM (derivePiso (length cons /= 1)) cons+      TyConI (NewtypeD _ _ _ con _) ->+        (:[]) <$> derivePiso False con+      _ ->+        fail $ show name ++ " is not a datatype."+  return (TupE routers)+++derivePiso :: Bool -> Con -> Q Exp+derivePiso matchWildcard con =+  case con of+    NormalC name tys -> go name (map snd tys)+    RecC name tys -> go name (map (\(_,_,ty) -> ty) tys)+    _ -> fail $ "Unsupported constructor " ++ show (conName con)+  where+    go name tys = do+      piso <- [| Piso |]+      pisoCon <- deriveConstructor name tys+      pisoDes <- deriveDestructor matchWildcard name tys+      return $ piso `AppE` pisoCon `AppE` pisoDes+++deriveConstructor :: Name -> [Type] -> Q Exp+deriveConstructor name tys = do+  -- Introduce some names+  t          <- newName "t"+  fieldNames <- replicateM (length tys) (newName "a")++  -- Figure out the names of some constructors+  ConE cons  <- [| (:-) |]++  let pat = foldr (\f fs -> ConP cons [VarP f, fs]) (VarP t) fieldNames+  let applyCon = foldl (\f x -> f `AppE` VarE x) (ConE name) fieldNames+  let body = ConE cons `AppE` applyCon `AppE` VarE t++  return $ LamE [pat] body+++deriveDestructor :: Bool -> Name -> [Type] -> Q Exp+deriveDestructor matchWildcard name tys = do+  -- Introduce some names+  x          <- newName "x"+  r          <- newName "r"+  fieldNames <- replicateM (length tys) (newName "a")++  -- Figure out the names of some constructors+  ConE just  <- [| Just |]+  ConE cons  <- [| (:-) |]+  nothing    <- [| Nothing |]++  let conPat   = ConP name (map VarP fieldNames)+  let okBody   = ConE just `AppE`+                  foldr+                    (\h t -> ConE cons `AppE` VarE h `AppE` t)+                    (VarE r)+                    fieldNames+  let okCase   = Match (ConP cons [conPat, VarP r]) (NormalB okBody) []+  let failCase = Match WildP (NormalB nothing) []+  let allCases =+        if matchWildcard+              then [okCase, failCase]+              else [okCase]++  return $ LamE [VarP x] (CaseE (VarE x) allCases)+++-- Retrieve the name of a constructor.+conName :: Con -> Name+conName con =+  case con of+    NormalC name _  -> name+    RecC name _     -> name+    InfixC _ name _ -> name+    ForallC _ _ con' -> conName con'

+ LICENSE view

@@ -0,0 +1,24 @@+Copyright (c) 2013, Martijn van Steenbergen+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 author nor the+      names of his contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 <copyright holder> 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.

+ Piso.cabal view

@@ -0,0 +1,32 @@+Name:           Piso+Version:        0.1+Synopsis:       Partial isomorphisms+Description:   	Partial isomorphisms+++Author:         Martijn van Steenbergen+Maintainer:     martijn@van.steenbergen.nl+Stability:      Experimental+Copyright:      Some Rights Reserved (CC) 2013 Martijn van Steenbergen+Homepage:       https://github.com/MedeaMelana/Piso+Bug-reports:    https://github.com/MedeaMelana/Piso/issues+++Cabal-Version:  >= 1.6+License:        BSD3+License-file:   LICENSE+Category:       Data+Build-type:     Simple+++Library+  Exposed-Modules:  Data.Piso,+                    Data.Piso.Common,+                    Data.Piso.TH,+                    Data.Piso.Generic+  Build-Depends:    base >= 3.0 && < 5,+                    template-haskell++Source-Repository head+  Type:         git+  Location:     https://github.com/MedeaMelana/Piso

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain