regular (empty) → 0.1
raw patch · 9 files changed
+917/−0 lines, 9 filesdep +basedep +template-haskellbuild-type:Customsetup-changed
Dependencies added: base, template-haskell
Files
- LICENSE +28/−0
- Setup.hs +6/−0
- examples/Test.hs +59/−0
- regular.cabal +48/−0
- src/Generics/Regular.hs +43/−0
- src/Generics/Regular/Base.hs +113/−0
- src/Generics/Regular/Constructor.hs +36/−0
- src/Generics/Regular/Functions.hs +344/−0
- src/Generics/Regular/TH.hs +240/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2009 Universiteit Utrecht+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. 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.++3. Neither the name of Universiteit Utrecht nor the names of its 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,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ examples/Test.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE EmptyDataDecls #-}++module Test where++import Generics.Regular++-- * Datatype representing logical expressions+data Logic = Var String+ | Logic :->: Logic -- implication+ | Logic :<->: Logic -- equivalence+ | Logic :&&: Logic -- and (conjunction)+ | Logic :||: Logic -- or (disjunction)+ | Not Logic -- not+ | T -- true+ | F -- false+ deriving Show++-- * Instantiating Regular for Logic using TH+-- ** Constructors+$(deriveConstructors ''Logic)++-- ** Functor encoding and 'Regular' instance+$(deriveRegular ''Logic "PFLogic")+type instance PF Logic = PFLogic++-- * Example logical expressions+l1, l2, l3 :: Logic+l1 = Var "p"+l2 = Not l1+l3 = l1 :->: l2++-- * Testing flattening+ex0 :: [Logic]+ex0 = flatten (from l3)++-- * Testing generic equality+ex1, ex2 :: Bool+ex1 = geq l3 l3+ex2 = geq l3 l2++-- * Testing generic show+ex3 :: String+ex3 = gshow l3 ""++-- * Testing value generation+ex4, ex5 :: Logic+ex4 = left+ex5 = right++-- * Testing folding+ex6 :: (String -> Bool) -> Logic -> Bool+ex6 env = fold (env & impl & (==) & (&&) & (||) & not & True & False)+ where impl p q = not p || q++ex7 :: Bool+ex7 = ex6 (\_ -> False) l3
+ regular.cabal view
@@ -0,0 +1,48 @@+name: regular+version: 0.1+synopsis: Generic programming library for regular datatypes.+description:++ This package provides generic functionality for regular datatypes.+ Regular datatypes are recursive datatypes such as lists, binary trees,+ etc. This library cannot be used with mutually recursive datatypes or+ with nested datatypes. The multirec library [1] can deal with mutually+ recursive datatypes.+ . + This library has been described in the paper:+ .+ * /A Lightweight Approach to Datatype-Generic Rewriting./+ Thomas van Noort, Alexey Rodriguez, Stefan Holdermans, Johan Jeuring, Bastiaan Heeren.+ ACM SIGPLAN Workshop on Generic Programming 2008.+ .+ More information about this library can be found at+ <http://www.cs.uu.nl/wiki/GenericProgramming/Regular>.+ .+ \[1] <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/multirec>++category: Generics+copyright: (c) 2009 Universiteit Utrecht+license: BSD3+license-file: LICENSE+author: Thomas van Noort,+ Alexey Rodriguez,+ Stefan Holdermans,+ Johan Jeuring,+ Bastiaan Heeren+maintainer: generics@haskell.org+stability: experimental+build-type: Custom+cabal-version: >= 1.2.1+tested-with: GHC == 6.10.1+extra-source-files: examples/Test.hs+++library+ hs-source-dirs: src+ exposed-modules: Generics.Regular+ Generics.Regular.Base+ Generics.Regular.Functions+ Generics.Regular.Constructor+ Generics.Regular.TH+ build-depends: base >= 4.0 && < 5, template-haskell >= 2.2 && < 2.4+ ghc-options: -Wall
+ src/Generics/Regular.hs view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular+-- Copyright : (c) 2008 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Top-level module for this library.+-- By importing this module, the user is able to use all the generic+-- functionality. The user is only required to provide an instance of+-- @Regular@ for the datatype.+--+-- Consider a datatype representing logical expressions:+--+-- > data Logic = Var String+-- > | Logic :->: Logic -- implication+-- > | Logic :<->: Logic -- equivalence+-- > | Logic :&&: Logic -- and (conjunction)+-- > | Logic :||: Logic -- or (disjunction)+-- > | Not Logic -- not+-- > | T -- true+-- > | F -- false+--+-- An instance of @Regular@ is derived with TH by invoking:+--+-- > $(deriveConstructors ''Logic)+-- > $(deriveRegular ''Logic "PFLogic")+-- > type instance PF Logic = PFLogic+-- +-----------------------------------------------------------------------------++module Generics.Regular (+ module Generics.Regular.Base,+ module Generics.Regular.Functions,+ module Generics.Regular.TH+ ) where++import Generics.Regular.Base+import Generics.Regular.Functions+import Generics.Regular.TH
+ src/Generics/Regular/Base.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Base+-- Copyright : (c) 2008 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Types for structural representation.+-----------------------------------------------------------------------------++module Generics.Regular.Base (++ -- * Functorial structural representation types+ K(..),+ I(..),+ U(..),+ (:+:)(..),+ (:*:)(..),+ C(..),+ Constructor(..), Fixity(..), Associativity(..),++ -- * Fixed-point type+ Fix (..),++ -- * Type class capturing the structural representation of a type and the corresponding embedding-projection pairs+ Regular (..), PF+ + ) where++import Generics.Regular.Constructor+++-----------------------------------------------------------------------------+-- Functorial structural representation types.+-----------------------------------------------------------------------------++-- | Structure type for constant values.+data K a r = K { unK :: a }++-- | Structure type for recursive values.+data I r = I { unI :: r }++-- | Structure type for empty constructors.+data U r = U++-- | Structure type for alternatives in a type.+data (f :+: g) r = L (f r) | R (g r)++-- | Structure type for fields of a constructor.+data (f :*: g) r = f r :*: g r++-- | Structure type to store the name of a constructor.+data C c f r = C { unC :: f r }++infixr 6 :+:+infixr 7 :*:++-----------------------------------------------------------------------------+-- Fixed-point type.+-----------------------------------------------------------------------------++-- | The well-known fixed-point type.+newtype Fix f = In (f (Fix f))+++-----------------------------------------------------------------------------+-- Type class capturing the structural representation of a type and the+-- corresponding embedding-projection pairs.+-----------------------------------------------------------------------------+-- | The type family @PF@ represents the pattern functor of a datatype.+-- +-- To be able to use the generic functions, the user is required to provide+-- an instance of this type family.+type family PF a :: * -> *++-- | The type class @Regular@ captures the structural representation of a +-- type and the corresponding embedding-projection pairs.+--+-- To be able to use the generic functions, the user is required to provide+-- an instance of this type class.+class Regular a where+ from :: a -> PF a a+ to :: PF a a -> a++-----------------------------------------------------------------------------+-- Functorial map function.+-----------------------------------------------------------------------------++instance Functor I where+ fmap f (I r) = I (f r)++instance Functor (K a) where+ fmap _ (K a) = K a++instance Functor U where+ fmap _ U = U++instance (Functor f, Functor g) => Functor (f :+: g) where+ fmap f (L x) = L (fmap f x)+ fmap f (R y) = R (fmap f y)++instance (Functor f, Functor g) => Functor (f :*: g) where+ fmap f (x :*: y) = fmap f x :*: fmap f y++instance Functor f => Functor (C c f) where+ fmap f (C r) = C (fmap f r)
+ src/Generics/Regular/Constructor.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE KindSignatures #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Constructor+-- Copyright : (c) 2008 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Representation for constructors.+-----------------------------------------------------------------------------++module Generics.Regular.Constructor (+ Constructor(..), Fixity(..), Associativity(..)+ ) where+++-- | Class for datatypes that represent data constructors.+-- For non-symbolic constructors, only 'conName' has to be defined.+-- The weird argument is supposed to be instantiated with 'C' from+-- base, hence the complex kind.+class Constructor c where+ conName :: t c (f :: * -> *) r -> String+ conFixity :: t c (f :: * -> *) r -> Fixity+ conFixity = const Prefix++-- | Datatype to represent the fixity of a constructor. An infix declaration+-- directly corresponds to an application of 'Infix'.+data Fixity = Prefix | Infix Associativity Int+ deriving (Eq, Show, Ord, Read)++data Associativity = LeftAssociative | RightAssociative | NotAssociative+ deriving (Eq, Show, Ord, Read)
+ src/Generics/Regular/Functions.hs view
@@ -0,0 +1,344 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.Functions+-- Copyright : (c) 2008 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Generic functionality for regular dataypes: mapM, flatten, zip,+-- equality, show, value generation and fold.+-----------------------------------------------------------------------------++module Generics.Regular.Functions (++ -- * Functorial map function+ Functor (..),+ + -- * Monadic functorial map function+ GMap (..),+ + -- * Crush right functions+ CrushR (..),+ flatten,++ -- * Zip functions+ Zip (..),+ fzip,+ fzip',++ -- * Equality function+ geq,++ -- * Show function+ GShow (..),+ gshow,+ + -- * Functions for generating values that are different on top-level+ LRBase (..),+ LR (..),+ left,+ right,+ + -- * Generic folding+ Alg, Algebra,+ Fold, alg,+ fold,+ (&) ++) where++import Control.Monad++import Generics.Regular.Base+++-----------------------------------------------------------------------------+-- Monadic functorial map function.+-----------------------------------------------------------------------------++-- | The @GMap@ class defines a monadic functorial map.+class GMap f where+ fmapM :: Monad m => (a -> m b) -> f a -> m (f b)++instance GMap I where+ fmapM f (I r) = liftM I (f r)++instance GMap (K a) where+ fmapM _ (K x) = return (K x)++instance GMap U where+ fmapM _ U = return U++instance (GMap f, GMap g) => GMap (f :+: g) where+ fmapM f (L x) = liftM L (fmapM f x)+ fmapM f (R x) = liftM R (fmapM f x)++instance (GMap f, GMap g) => GMap (f :*: g) where+ fmapM f (x :*: y) = liftM2 (:*:) (fmapM f x) (fmapM f y)++instance GMap f => GMap (C c f) where+ fmapM f (C x) = liftM C (fmapM f x)+++-----------------------------------------------------------------------------+-- CrushR functions.+-----------------------------------------------------------------------------++-- | The @CrushR@ class defines a right-associative crush on functorial values.+class CrushR f where+ crushr :: (a -> b -> b) -> b -> f a -> b++instance CrushR I where+ crushr op e (I x) = x `op` e++instance CrushR (K a) where+ crushr _ e _ = e++instance CrushR U where+ crushr _ e _ = e++instance (CrushR f, CrushR g) => CrushR (f :+: g) where+ crushr op e (L x) = crushr op e x+ crushr op e (R y) = crushr op e y++instance (CrushR f, CrushR g) => CrushR (f :*: g) where+ crushr op e (x :*: y) = crushr op (crushr op e y) x++instance CrushR f => CrushR (C c f) where+ crushr op e (C x) = crushr op e x++-- | Flatten a structure by collecting all the elements present.+flatten :: CrushR f => f a -> [a]+flatten = crushr (:) []+++-----------------------------------------------------------------------------+-- Zip functions.+-----------------------------------------------------------------------------++-- | The @Zip@ class defines a monadic zip on functorial values.+class Zip f where+ fzipM :: Monad m => (a -> b -> m c) -> f a -> f b -> m (f c)++instance Zip I where+ fzipM f (I x) (I y) = liftM I (f x y)++instance Eq a => Zip (K a) where+ fzipM _ (K x) (K y) + | x == y = return (K x)+ | otherwise = fail "fzipM: structure mismatch"++instance Zip U where+ fzipM _ U U = return U++instance (Zip f, Zip g) => Zip (f :+: g) where+ fzipM f (L x) (L y) = liftM L (fzipM f x y)+ fzipM f (R x) (R y) = liftM R (fzipM f x y)+ fzipM _ _ _ = fail "fzipM: structure mismatch"++instance (Zip f, Zip g) => Zip (f :*: g) where+ fzipM f (x1 :*: y1) (x2 :*: y2) = + liftM2 (:*:) (fzipM f x1 x2)+ (fzipM f y1 y2)++instance Zip f => Zip (C c f) where+ fzipM f (C x) (C y) = liftM C (fzipM f x y)++-- | Functorial zip with a non-monadic function, resulting in a monadic value.+fzip :: (Zip f, Monad m) => (a -> b -> c) -> f a -> f b -> m (f c)+fzip f = fzipM (\x y -> return (f x y))++-- | Partial functorial zip with a non-monadic function.+fzip' :: Zip f => (a -> b -> c) -> f a -> f b -> f c+fzip' f x y = maybe (error "fzip': structure mismatch") id (fzip f x y)+++-----------------------------------------------------------------------------+-- Equality function.+-----------------------------------------------------------------------------++-- | Equality on values based on their structural representation.+geq :: (b ~ PF a, Regular a, CrushR b, Zip b) => a -> a -> Bool+geq x y = maybe False (crushr (&&) True) (fzip geq (from x) (from y))+++-----------------------------------------------------------------------------+-- Show function.+-----------------------------------------------------------------------------++-- | The @GShow@ class defines a show on values.+class GShow f where+ gshowf :: (a -> ShowS) -> f a -> ShowS++instance GShow I where+ gshowf f (I r) = f r++instance Show a => GShow (K a) where+ gshowf _ (K x) = shows x++instance GShow U where+ gshowf _ U = id++instance (GShow f, GShow g) => GShow (f :+: g) where+ gshowf f (L x) = gshowf f x+ gshowf f (R x) = gshowf f x++instance (GShow f, GShow g) => GShow (f :*: g) where+ gshowf f (x :*: y) = gshowf f x . showChar ' ' . gshowf f y+++instance (Constructor c, GShow f) => GShow (C c f) where+ gshowf f cx@(C x) = + showParen True (showString (conName cx) . showChar ' ' . gshowf f x)+++gshow :: (Regular a, GShow (PF a)) => a -> ShowS+gshow x = gshowf gshow (from x)++-----------------------------------------------------------------------------+-- Functions for generating values that are different on top-level.+-----------------------------------------------------------------------------++-- | The @LRBase@ class defines two functions, @leftb@ and @rightb@, which +-- should produce different values.+class LRBase a where+ leftb :: a+ rightb :: a++instance LRBase Int where+ leftb = 0+ rightb = 1++instance LRBase Integer where+ leftb = 0+ rightb = 1++instance LRBase Char where+ leftb = 'L'+ rightb = 'R'+ +instance LRBase a => LRBase [a] where+ leftb = []+ rightb = [error "Should never be inspected"]++-- | The @LR@ class defines two functions, @leftf@ and @rightf@, which should +-- produce different functorial values.+class LR f where+ leftf :: a -> f a+ rightf :: a -> f a++instance LR I where+ leftf x = I x+ rightf x = I x++instance LRBase a => LR (K a) where+ leftf _ = K leftb+ rightf _ = K rightb++instance LR U where+ leftf _ = U+ rightf _ = U++instance (LR f, LR g) => LR (f :+: g) where+ leftf x = L (leftf x)+ rightf x = R (rightf x)++instance (LR f, LR g) => LR (f :*: g) where+ leftf x = leftf x :*: leftf x+ rightf x = rightf x :*: rightf x++instance LR f => LR (C c f) where+ leftf x = C (leftf x)+ rightf x = C (rightf x)++-- | Produces a value which should be different from the value returned by +-- @right@.+left :: (Regular a, LR (PF a)) => a+left = to (leftf left)++-- | Produces a value which should be different from the value returned by +-- @left@.+right :: (Regular a, LR (PF a)) => a+right = to (rightf right)+++-----------------------------------------------------------------------------+-- Folds+-----------------------------------------------------------------------------++type family Alg (f :: (* -> *)) + (r :: *) -- result type+ :: *++-- | For a constant, we take the constant value to a result.+type instance Alg (K a) r = a -> r++-- | For a unit, no arguments are available.+type instance Alg U r = r++-- | For an identity, we turn the recursive result into a final result.+type instance Alg I r = r -> r++-- | For a sum, the algebra is a pair of two algebras.+type instance Alg (f :+: g) r = (Alg f r, Alg g r)++-- | For a product where the left hand side is a constant, we+-- take the value as an additional argument.+type instance Alg (K a :*: g) r = a -> Alg g r++-- | For a product where the left hand side is an identity, we+-- take the recursive result as an additional argument.+type instance Alg (I :*: g) r = r -> Alg g r++-- | Constructors are ignored.+type instance Alg (C c f) r = Alg f r+++type Algebra a r = Alg (PF a) r++-- | The class fold explains how to convert an algebra+-- 'Alg' into a function from functor to result.+class Fold (f :: * -> *) where+ alg :: Alg f r -> f r -> r++instance Fold (K a) where+ alg f (K x) = f x++instance Fold U where+ alg f U = f++instance Fold I where+ alg f (I x) = f x++instance (Fold f, Fold g) => Fold (f :+: g) where+ alg (f, _) (L x) = alg f x+ alg (_, g) (R x) = alg g x++instance (Fold g) => Fold (K a :*: g) where+ alg f (K x :*: y) = alg (f x) y++instance (Fold g) => Fold (I :*: g) where+ alg f (I x :*: y) = alg (f x) y++instance (Fold f) => Fold (C c f) where+ alg f (C x) = alg f x++-- | Fold with convenient algebras.+fold :: (Regular a, Fold (PF a), Functor (PF a))+ => Algebra a r -> a -> r+fold f = alg f . fmap (\x -> fold f x) . from++-- Construction of algebras+infixr 5 &++-- | For constructing algebras it is helpful to use this pairing combinator.+(&) :: a -> b -> (a, b)+(&) = (,)
+ src/Generics/Regular/TH.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -w #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Regular.TH+-- Copyright : (c) 2008--2009 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- This module contains Template Haskell code that can be used to+-- automatically generate the boilerplate code for the regular+-- library.+--+-----------------------------------------------------------------------------++-- Adapted from Generics.Multirec.TH+module Generics.Regular.TH+ ( deriveConstructors,+ deriveRegular,+ derivePF+ ) where++import Generics.Regular.Base+import Generics.Regular.Constructor+import Language.Haskell.TH hiding (Fixity())+import Language.Haskell.TH.Syntax (Lift(..))+import Control.Monad++-- | Given a datatype name, derive datatypes and +-- instances of class 'Constructor'.++deriveConstructors :: Name -> Q [Dec]+deriveConstructors = constrInstance++-- | Given the type and the name (as string) for the+-- pattern functor to derive, generate the 'Regular'+-- instance.++deriveRegular :: Name -> String -> Q [Dec]+deriveRegular n pfn =+ do+ pf <- derivePF pfn n+ fam <- deriveInst n+ return $ pf ++ fam++-- | Derive only the 'PF' instance. Not needed if 'deriveRegular'+-- is used.++derivePF :: String -> Name -> Q [Dec]+derivePF pfn n =+ fmap (:[]) $+ tySynD (mkName pfn) [] (pfType n)++deriveInst :: Name -> Q [Dec]+deriveInst t =+ do+ fcs <- mkFrom t 1 0 t+ tcs <- mkTo t 1 0 t+ liftM (:[]) $+ instanceD (cxt []) (conT ''Regular `appT` conT t)+ [funD 'from fcs, funD 'to tcs]++constrInstance :: Name -> Q [Dec]+constrInstance n =+ do+ i <- reify n+ -- runIO (print i)+ let cs = case i of+ TyConI (DataD _ _ _ cs _) -> cs+ _ -> []+ ds <- mapM mkData cs+ is <- mapM mkInstance cs+ return $ ds ++ is++stripRecordNames :: Con -> Con+stripRecordNames (RecC n f) =+ NormalC n (map (\(_, s, t) -> (s, t)) f)+stripRecordNames c = c++mkData :: Con -> Q Dec+mkData (NormalC n _) =+ dataD (cxt []) (mkName (nameBase n)) [] [] [] +mkData r@(RecC _ _) =+ mkData (stripRecordNames r)+mkData (InfixC t1 n t2) =+ mkData (NormalC n [t1,t2])++instance Lift Fixity where+ lift Prefix = conE 'Prefix+ lift (Infix a n) = conE 'Infix `appE` [| a |] `appE` [| n |]++instance Lift Associativity where+ lift LeftAssociative = conE 'LeftAssociative+ lift RightAssociative = conE 'RightAssociative+ lift NotAssociative = conE 'NotAssociative++mkInstance :: Con -> Q Dec+mkInstance (NormalC n _) =+ instanceD (cxt []) (appT (conT ''Constructor) (conT $ mkName (nameBase n)))+ [funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []]]+mkInstance r@(RecC _ _) =+ mkInstance (stripRecordNames r)+mkInstance (InfixC t1 n t2) =+ do+ i <- reify n+ let fi = case i of+ DataConI _ _ _ f -> convertFixity f+ _ -> Prefix+ instanceD (cxt []) (appT (conT ''Constructor) (conT $ mkName (nameBase n)))+ [funD 'conName [clause [wildP] (normalB (stringE ("(" ++ (nameBase n) ++ ")"))) []],+ funD 'conFixity [clause [wildP] (normalB [| fi |]) []]]+ where+ convertFixity (Fixity n d) = Infix (convertDirection d) n+ convertDirection InfixL = LeftAssociative+ convertDirection InfixR = RightAssociative+ convertDirection InfixN = NotAssociative++pfType :: Name -> Q Type+pfType n =+ do+ -- runIO $ putStrLn $ "processing " ++ show n+ i <- reify n+ let b = case i of+ TyConI (DataD _ _ _ cs _) ->+ foldr1 sum (map (pfCon n) cs)+ TyConI (TySynD t _ _) ->+ conT ''K `appT` conT t+ _ -> error "unknown construct" + --appT b (conT $ mkName (nameBase n))+ b+ where+ sum :: Q Type -> Q Type -> Q Type+ sum a b = conT ''(:+:) `appT` a `appT` b++pfCon :: Name -> Con -> Q Type+pfCon ns (NormalC n []) =+ appT (appT (conT ''C) (conT $ mkName (nameBase n))) (conT ''U)+pfCon ns (NormalC n fs) =+ appT (appT (conT ''C) (conT $ mkName (nameBase n))) (foldr1 prod (map (pfField ns . snd) fs))+ where+ prod :: Q Type -> Q Type -> Q Type+ prod a b = conT ''(:*:) `appT` a `appT` b+pfCon ns r@(RecC _ _) =+ pfCon ns (stripRecordNames r)+pfCon ns (InfixC t1 n t2) =+ pfCon ns (NormalC n [t1,t2])++pfField :: Name -> Type -> Q Type+pfField ns t@(ConT n) | n == ns = conT ''I+pfField ns t = conT ''K `appT` return t++mkFrom :: Name -> Int -> Int -> Name -> Q [Q Clause]+mkFrom ns m i n =+ do+ -- runIO $ putStrLn $ "processing " ++ show n+ let wrapE e = lrE m i e+ i <- reify n+ let dn = mkName (nameBase n)+ let b = case i of+ TyConI (DataD _ _ _ cs _) ->+ zipWith (fromCon wrapE ns dn (length cs)) [0..] cs+ TyConI (TySynD t _ _) ->+ [clause [varP (field 0)] (normalB (wrapE $ conE 'K `appE` varE (field 0))) []]+ _ -> error "unknown construct"+ return b++mkTo :: Name -> Int -> Int -> Name -> Q [Q Clause]+mkTo ns m i n =+ do+ -- runIO $ putStrLn $ "processing " ++ show n+ let wrapP p = lrP m i p+ i <- reify n+ let dn = mkName (nameBase n)+ let b = case i of+ TyConI (DataD _ _ _ cs _) ->+ zipWith (toCon wrapP ns dn (length cs)) [0..] cs+ TyConI (TySynD t _ _) ->+ [clause [wrapP $ conP 'K [varP (field 0)]] (normalB $ varE (field 0)) []]+ _ -> error "unknown construct" + return b++fromCon :: (Q Exp -> Q Exp) -> Name -> Name -> Int -> Int -> Con -> Q Clause+fromCon wrap ns n m i (NormalC cn []) =+ clause+ [conP cn []]+ (normalB $ wrap $ lrE m i $ conE 'C `appE` (conE 'U)) []+fromCon wrap ns n m i (NormalC cn fs) =+ -- runIO (putStrLn ("constructor " ++ show ix)) >>+ clause+ [conP cn (map (varP . field) [0..length fs - 1])]+ (normalB $ wrap $ lrE m i $ conE 'C `appE` foldr1 prod (zipWith (fromField ns) [0..] (map snd fs))) []+ where+ prod x y = conE '(:*:) `appE` x `appE` y+fromCon wrap ns n m i r@(RecC _ _) =+ fromCon wrap ns n m i (stripRecordNames r)+fromCon wrap ns n m i (InfixC t1 cn t2) =+ fromCon wrap ns n m i (NormalC cn [t1,t2])++toCon :: (Q Pat -> Q Pat) -> Name -> Name -> Int -> Int -> Con -> Q Clause+toCon wrap ns n m i (NormalC cn []) =+ clause+ [wrap $ lrP m i $ conP 'C [conP 'U []]]+ (normalB $ conE cn) []+toCon wrap ns n m i (NormalC cn fs) =+ -- runIO (putStrLn ("constructor " ++ show ix)) >>+ clause+ [wrap $ lrP m i $ conP 'C [foldr1 prod (zipWith (toField ns) [0..] (map snd fs))]]+ (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []+ where+ prod x y = conP '(:*:) [x,y]+toCon wrap ns n m i r@(RecC _ _) =+ toCon wrap ns n m i (stripRecordNames r)+toCon wrap ns n m i (InfixC t1 cn t2) =+ toCon wrap ns n m i (NormalC cn [t1,t2])++fromField :: Name -> Int -> Type -> Q Exp+fromField ns nr t@(ConT n) | n == ns = conE 'I `appE` varE (field nr)+fromField ns nr t = conE 'K `appE` varE (field nr)++toField :: Name -> Int -> Type -> Q Pat+toField ns nr t@(ConT n) | n == ns = conP 'I [varP (field nr)]+toField ns nr t = conP 'K [varP (field nr)]++field :: Int -> Name+field n = mkName $ "f" ++ show n++lrP :: Int -> Int -> (Q Pat -> Q Pat)+lrP 1 0 p = p+lrP m 0 p = conP 'L [p]+lrP m i p = conP 'R [lrP (m-1) (i-1) p]++lrE :: Int -> Int -> (Q Exp -> Q Exp)+lrE 1 0 e = e+lrE m 0 e = conE 'L `appE` e+lrE m i e = conE 'R `appE` lrE (m-1) (i-1) e+