diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,9 @@ +0.4 9 August 2016 + + * Add support for GHC 8.0.1. Unfortunately, the price to pay for this is + that the TH module is now gone. GHC 8 broke it in a bunch of places and I don't + remember how it works or have the will to fix it. + 0.3.4.2 16 June 2015 * fix compilation error diff --git a/Math/Combinatorics/Species.hs b/Math/Combinatorics/Species.hs --- a/Math/Combinatorics/Species.hs +++ b/Math/Combinatorics/Species.hs @@ -106,10 +106,6 @@ , newtonRaphsonRec , newtonRaphson - -- * Template Haskell - , deriveDefaultSpecies - , deriveSpecies - ) where import Math.Combinatorics.Species.AST @@ -120,7 +116,6 @@ import Math.Combinatorics.Species.NewtonRaphson import Math.Combinatorics.Species.Simplify import Math.Combinatorics.Species.Structures -import Math.Combinatorics.Species.TH import Math.Combinatorics.Species.Unlabeled -- $DSL diff --git a/Math/Combinatorics/Species/TH.hs b/Math/Combinatorics/Species/TH.hs deleted file mode 100644 --- a/Math/Combinatorics/Species/TH.hs +++ /dev/null @@ -1,480 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -{- Refactoring plan: - - * need function to compute a (default) species from a Struct. - - currently have structToSp :: Struct -> Q Exp. - - [X] refactor it into two pieces, Struct -> SpeciesAST and SpeciesAST -> Q Exp. - - * should really go through and add some comments to things! - Unfortunately I wasn't good about that when I wrote the code... =P - - * Maybe need to do a similar refactoring of the structToTy stuff? - - * make version of deriveSpecies that takes a SpeciesAST as an argument, - and use Struct -> SpeciesAST to generate default - - * deriveSpecies should pass the SpeciesAST to... other things that - currently just destruct the Struct to decide what to do. Will have to - pattern-match on both the species and the Struct now and make sure - that they match, which is a bit annoying, but can't really be helped. - --} - ------------------------------------------------------------------------------ --- | --- Module : Math.Combinatorics.Species.CycleIndex --- Copyright : (c) Brent Yorgey 2010 --- License : BSD-style (see LICENSE) --- Maintainer : byorgey@cis.upenn.edu --- Stability : experimental --- --- Use Template Haskell to automatically derive species instances for --- user-defined data types. --- ------------------------------------------------------------------------------ - -module Math.Combinatorics.Species.TH - ( deriveDefaultSpecies - , deriveSpecies - ) where - -#if MIN_VERSION_numeric_prelude(0,2,0) -import NumericPrelude hiding (cycle) -#else -import NumericPrelude -import PreludeBase hiding (cycle) -#endif - -import Math.Combinatorics.Species.AST -import Math.Combinatorics.Species.AST.Instances () -import Math.Combinatorics.Species.Class -import Math.Combinatorics.Species.Enumerate -import Math.Combinatorics.Species.Structures - -import Control.Applicative (Applicative (..), - (<$>), (<*>)) -import Control.Arrow (first, (***)) -import Control.Monad (zipWithM) -import Data.Char (toLower) -import Data.Maybe (isJust) - -import Data.Typeable - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax (lift) - ------------------------------------------------------------- --- Preliminaries ----------------------------------------- ------------------------------------------------------------- - --- | Report a fatal error and stop processing in the 'Q' monad. -errorQ :: String -> Q a -errorQ msg = reportError msg >> error msg - ------------------------------------------------------------- --- Parsing type declarations ----------------------------- ------------------------------------------------------------- - --- XXX possible improvement: add special cases to Struct for things --- like Bool, Either, and (,) - --- | A data structure to represent data type declarations. -data Struct = SId - | SList - | SConst Type -- ^ for types of kind * - | SEnum Type -- ^ for Enumerable type constructors of kind (* -> *) - | SSumProd [(Name, [Struct])] -- ^ sum-of-products - | SComp Struct Struct -- ^ composition - | SSelf -- ^ recursive occurrence - deriving Show - --- | Extract the relevant information about a type constructor into a --- 'Struct'. -nameToStruct :: Name -> Q Struct -nameToStruct nm = reify nm >>= infoToStruct - where infoToStruct (TyConI d) = decToStruct nm d - infoToStruct _ = errorQ (show nm ++ " is not a type constructor.") - --- XXX do something with contexts? Later extension... - --- | Extract the relevant information about a data type declaration --- into a 'Struct', given the name of the type and the declaraion. -decToStruct :: Name -> Dec -> Q Struct -decToStruct _ (DataD _ nm [bndr] cons _) - = SSumProd <$> mapM (conToStruct nm (tyVarNm bndr)) cons -decToStruct _ (NewtypeD _ nm [bndr] con _) - = SSumProd . (:[]) <$> conToStruct nm (tyVarNm bndr) con -decToStruct _ (TySynD nm [bndr] ty) - = tyToStruct nm (tyVarNm bndr) ty -decToStruct nm _ - = errorQ $ "Processing " ++ show nm ++ ": Only type constructors of kind * -> * are supported." - --- | Throw away kind annotations to extract the type variable name. -tyVarNm :: TyVarBndr -> Name -tyVarNm (PlainTV n) = n -tyVarNm (KindedTV n _) = n - --- | Extract relevant information about a data constructor. The first --- two arguments are the name of the type constructor, and the name --- of its type argument. Returns the name of the data constructor --- and a list of descriptions of its arguments. -conToStruct :: Name -> Name -> Con -> Q (Name, [Struct]) -conToStruct nm var (NormalC cnm tys) - = (,) cnm <$> mapM (tyToStruct nm var) (map snd tys) -conToStruct nm var (RecC cnm tys) - = (,) cnm <$> mapM (tyToStruct nm var) (map thrd tys) - where thrd (_,_,t) = t -conToStruct nm var (InfixC ty1 cnm ty2) - = (,) cnm <$> mapM (tyToStruct nm var) [snd ty1, snd ty2] - - -- XXX do something with ForallC? - --- XXX check this... --- | Extract a 'Struct' describing an arbitrary type. -tyToStruct :: Name -> Name -> Type -> Q Struct -tyToStruct nm var (VarT v) | v == var = return SId - | otherwise = errorQ $ "Unknown variable " ++ show v -tyToStruct nm var ListT = return SList -tyToStruct nm var t@(ConT b) - | b == ''[] = return SList - | otherwise = return $ SConst t - -tyToStruct nm var (AppT t (VarT v)) -- F `o` TX === F - | v == var && t == (ConT nm) = return $ SSelf -- recursive occurrence - | v == var = return $ SEnum t -- t had better be Enumerable - | otherwise = errorQ $ "Unknown variable " ++ show v -tyToStruct nm var (AppT t1 t2@(AppT _ _)) -- composition - = SComp <$> tyToStruct nm var t1 <*> tyToStruct nm var t2 -tyToStruct nm vars t@(AppT _ _) - = return $ SConst t - --- XXX add something to deal with tuples? --- XXX add something to deal with things that are actually OK like Either a [a] --- and so on --- XXX deal with arrow types? - ------------------------------------------------------------- --- Misc Struct utilities --------------------------------- ------------------------------------------------------------- - --- | Decide whether a type is recursively defined, given its --- description. -isRecursive :: Struct -> Bool -isRecursive (SSumProd cons) = any isRecursive (concatMap snd cons) -isRecursive (SComp s1 s2) = isRecursive s1 || isRecursive s2 -isRecursive SSelf = True -isRecursive _ = False - ------------------------------------------------------------- --- Generating default species ---------------------------- ------------------------------------------------------------- - --- | Convert a 'Struct' into a default corresponding species. -structToSp :: Struct -> SpeciesAST -structToSp SId = X -structToSp SList = L -structToSp (SConst (ConT t)) - | t == ''Bool = N 2 - | otherwise = error $ "structToSp: unrecognized type " ++ show t ++ " in SConst" -structToSp (SEnum t) = error "SEnum in structToSp" -structToSp (SSumProd []) = Zero -structToSp (SSumProd ss) = foldl1 (+) $ map conToSp ss -structToSp (SComp s1 s2) = structToSp s1 `o` structToSp s2 -structToSp SSelf = Omega - --- | Convert a data constructor and its arguments into a default --- species. -conToSp :: (Name, [Struct]) -> SpeciesAST -conToSp (_,[]) = One -conToSp (_,ps) = foldl1 (*) $ map structToSp ps - ------------------------------------------------------------- --- Generating things from species ------------------------ ------------------------------------------------------------- - --- | Given a name to use in recursive occurrences, convert a species --- AST into an actual splice-able expression of type Species s => s. -spToExp :: Name -> SpeciesAST -> Q Exp -spToExp self = spToExp' - where - spToExp' Zero = [| 0 |] - spToExp' One = [| 1 |] - spToExp' (N n) = lift n - spToExp' X = [| singleton |] - spToExp' E = [| set |] - spToExp' C = [| cycle |] - spToExp' L = [| linOrd |] - spToExp' Subset = [| subset |] - spToExp' (KSubset k) = [| ksubset $(lift k) |] - spToExp' Elt = [| element |] - spToExp' (f :+ g) = [| $(spToExp' f) + $(spToExp' g) |] - spToExp' (f :* g) = [| $(spToExp' f) * $(spToExp' g) |] - spToExp' (f :. g) = [| $(spToExp' f) `o` $(spToExp' g) |] - spToExp' (f :>< g) = [| $(spToExp' f) >< $(spToExp' g) |] - spToExp' (f :@ g) = [| $(spToExp' f) @@ $(spToExp' g) |] - spToExp' (Der f) = [| oneHole $(spToExp' f) |] - spToExp' (OfSize _ _) = error "Can't reify general size predicate into code" - spToExp' (OfSizeExactly f k) = [| $(spToExp' f) `ofSizeExactly` $(lift k) |] - spToExp' (NonEmpty f) = [| nonEmpty $(spToExp' f) |] - spToExp' (Rec _) = [| wrap $(varE self) |] - spToExp' Omega = [| wrap $(varE self) |] - --- | Generate the structure type for a given species. -spToTy :: Name -> SpeciesAST -> Q Type -spToTy self = spToTy' - where - spToTy' Zero = [t| Void |] - spToTy' One = [t| Unit |] - spToTy' (N n) = [t| Const Integer |] -- was finTy n, but that - -- doesn't match up with the - -- type annotation on TSpeciesAST - spToTy' X = [t| Id |] - spToTy' E = [t| Set |] - spToTy' C = [t| Cycle |] - spToTy' L = [t| [] |] - spToTy' Subset = [t| Set |] - spToTy' (KSubset _) = [t| Set |] - spToTy' Elt = [t| Id |] - spToTy' (f :+ g) = [t| $(spToTy' f) :+: $(spToTy' g) |] - spToTy' (f :* g) = [t| $(spToTy' f) :*: $(spToTy' g) |] - spToTy' (f :. g) = [t| $(spToTy' f) :.: $(spToTy' g) |] - spToTy' (f :>< g) = [t| $(spToTy' f) :*: $(spToTy' g) |] - spToTy' (f :@ g) = [t| $(spToTy' f) :.: $(spToTy' g) |] - spToTy' (Der f) = [t| Star $(spToTy' f) |] - spToTy' (OfSize f _) = spToTy' f - spToTy' (OfSizeExactly f _) = spToTy' f - spToTy' (NonEmpty f) = spToTy' f - spToTy' (Rec _) = varT self - spToTy' Omega = varT self - -{- --- | Generate a finite type of a given size, using a binary scheme. -finTy :: Integer -> Q Type -finTy 0 = [t| Void |] -finTy 1 = [t| Unit |] -finTy 2 = [t| Const Bool |] -finTy n | even n = [t| Prod (Const Bool) $(finTy $ n `div` 2) |] - | otherwise = [t| Sum Unit $(finTy $ pred n) |] --} - ------------------------------------------------------------- --- Code generation --------------------------------------- ------------------------------------------------------------- - --- Enumerable ---------------- - --- | Generate an instance of the Enumerable type class, i.e. an --- isomorphism from the user's data type and the structure type --- corresponding to the chosen species (or to the default species if --- the user did not specify one). --- --- If the third argument is @Nothing@, generate a normal --- non-recursive instance. If the third argument is @Just code@, --- then the instance is for a recursive type with the given code. -mkEnumerableInst :: Name -> SpeciesAST -> Struct -> Maybe Name -> Q Dec -mkEnumerableInst nm sp st code = do - clauses <- mkIsoClauses (isJust code) sp st - let stTy = case code of - Just cd -> [t| Mu $(conT cd) |] - Nothing -> spToTy undefined sp -- undefined is OK, it isn't recursive - -- so won't use that argument - instanceD (return []) (appT (conT ''Enumerable) (conT nm)) --- [ tySynInstD ''StructTy [conT nm] stTy - [ tySynInstD ''StructTy (tySynEqn [conT nm] stTy) - , return $ FunD 'iso clauses - ] - --- | Generate the clauses for the definition of the 'iso' method in --- the 'Enumerable' instance, which translates from the structure --- type of the species to the user's data type. The first argument --- indicates whether the type is recursive. -mkIsoClauses :: Bool -> SpeciesAST -> Struct -> Q [Clause] -mkIsoClauses isRec sp st = (fmap.map) (mkClause isRec) (mkIsoMatches sp st) - where mkClause False (pat, exp) = Clause [pat] (NormalB $ exp) [] - mkClause True (pat, exp) = Clause [ConP 'Mu [pat]] (NormalB $ exp) [] - -mkIsoMatches :: SpeciesAST -> Struct -> Q [(Pat, Exp)] -mkIsoMatches _ SId = newName "x" >>= \x -> - return [(ConP 'Id [VarP x], VarE x)] -mkIsoMatches _ (SConst t) - | t == ConT ''Bool = return [(ConP 'Const [LitP $ IntegerL 1], ConE 'False) - ,(ConP 'Const [LitP $ IntegerL 2], ConE 'True)] - | otherwise = error "mkIsoMatches: unrecognized type in SConst case" -mkIsoMatches _ (SEnum t) = newName "x" >>= \x -> - return [(VarP x, AppE (VarE 'iso) (VarE x))] -mkIsoMatches _ (SSumProd []) = return [] -mkIsoMatches sp (SSumProd [con]) = mkIsoConMatches sp con -mkIsoMatches sp (SSumProd cons) = addInjs 0 <$> zipWithM mkIsoConMatches (terms sp) cons - where terms (f :+ g) = terms f ++ [g] - terms f = [f] - - addInjs :: Int -> [[(Pat, Exp)]] -> [(Pat, Exp)] - addInjs n [ps] = map (addInj (n-1) 'Inr) ps - addInjs n (ps:pss) = map (addInj n 'Inl) ps ++ addInjs (n+1) pss - addInj 0 c = first (ConP c . (:[])) - addInj n c = first (ConP 'Inr . (:[])) . addInj (n-1) c - --- XXX the below is not correct... --- should really do iso1 . fmap iso2 where iso1 = ... iso2 = ... --- which are obtained from recursive calls. -mkIsoMatches _ (SComp s1 s2) = newName "x" >>= \x -> - return [ (ConP 'Comp [VarP x] - , AppE (VarE 'iso) (AppE (AppE (VarE 'fmap) (VarE 'iso)) (VarE x))) ] -mkIsoMatches _ SSelf = newName "s" >>= \s -> - return [(VarP s, AppE (VarE 'iso) (VarE s))] - -mkIsoConMatches :: SpeciesAST -> (Name, [Struct]) -> Q [(Pat, Exp)] -mkIsoConMatches _ (cnm, []) = return [(ConP 'Unit [], ConE cnm)] -mkIsoConMatches sp (cnm, ps) = map mkProd . sequence <$> zipWithM mkIsoMatches (factors sp) ps - where factors (f :* g) = factors f ++ [g] - factors f = [f] - - mkProd :: [(Pat, Exp)] -> (Pat, Exp) - mkProd = (foldl1 (\x y -> (ConP '(:*:) [x, y])) *** foldl AppE (ConE cnm)) - . unzip - --- Species definition -------- - --- | Given a name n, generate the declaration --- --- > n :: Species s => s --- -mkSpeciesSig :: Name -> Q Dec -mkSpeciesSig nm = sigD nm [t| Species s => s |] - --- XXX can this use quasiquoting? --- | Given a name n and a species, generate a declaration for it of --- that name. The third parameter indicates whether the species is --- recursive, and if so what the name of the code is. -mkSpecies :: Name -> SpeciesAST -> Maybe Name -> Q Dec -mkSpecies nm sp (Just code) = valD (varP nm) (normalB (appE (varE 'rec) (conE code))) [] -mkSpecies nm sp Nothing = valD (varP nm) (normalB (spToExp undefined sp)) [] - -{- -structToSpAST :: Name -> Struct -> Q Exp -structToSpAST _ SId = [| TX |] -structToSpAST _ (SConst t) = error "SConst in structToSpAST?" -structToSpAST self (SEnum t) = typeToSpAST self t -structToSpAST _ (SSumProd []) = [| TZero |] -structToSpAST self (SSumProd ss) = foldl1 (\x y -> [| annI $x :+ annI $y |]) - $ map (conToSpAST self) ss -structToSpAST self (SComp s1 s2) = [| annI $(structToSpAST self s1) :. annI $(structToSpAST self s2) |] -structToSpAST self SSelf = varE self - -conToSpAST :: Name -> (Name, [Struct]) -> Q Exp -conToSpAST _ (_,[]) = [| TOne |] -conToSpAST self (_,ps) = foldl1 (\x y -> [| annI $x :* annI $y |]) $ map (structToSpAST self) ps - -typeToSpAST :: Name -> Type -> Q Exp -typeToSpAST _ ListT = [| TL |] -typeToSpAST self (ConT c) | c == ''[] = [| TL |] - | otherwise = nameToStruct c >>= structToSpAST self -- XXX this is wrong! Need to do something else for recursive types? -typeToSpAST _ _ = error "non-constructor in typeToSpAST?" --} - ------------------------------------------------------------- --- Putting it all together ------------------------------- ------------------------------------------------------------- - --- XXX need to add something to check whether the type and given --- species are compatible. - --- | Generate default species declarations for the given user-defined --- data type. To use it: --- --- > {-# LANGUAGE TemplateHaskell, --- > TypeFamilies, --- > DeriveDataTypeable, --- > FlexibleInstances, --- > UndecidableInstances #-} --- > --- > data MyType = ... --- > --- > $(deriveDefaultSpecies ''MyType) --- --- Yes, you really do need all those extensions. And don't panic --- about the @UndecidableInstances@; the instances generated --- actually are decidable, but GHC just can't tell. --- --- This is what you get: --- --- * An 'Enumerable' instance for @MyType@ (and various other --- supporting things like a code and an 'ASTFunctor' instance if --- your data type is recursive) --- --- * A declaration of @myType :: Species s => s@ (the same name as --- the type constructor but with the first letter lowercased) --- --- You can then use @myType@ in any species expression, or as input --- to any function expecting a species. For example, to count your --- data type's distinct shapes, you can do --- --- > take 10 . unlabeled $ myType --- -deriveDefaultSpecies :: Name -> Q [Dec] -deriveDefaultSpecies nm = do - st <- nameToStruct nm - deriveSpecies nm (structToSp st) - --- | Like 'deriveDefaultSpecies', except that you specify the species --- expression that your data type should be isomorphic to. Note: this --- is currently experimental (read: bug-ridden). -deriveSpecies :: Name -> SpeciesAST -> Q [Dec] -deriveSpecies nm sp = do - st <- nameToStruct nm - let spNm = mkName . map toLower . nameBase $ nm - if (isRecursive st) - then mkEnumerableRec nm spNm st sp - else mkEnumerableNonrec nm spNm st sp - where - mkEnumerableRec nm spNm st sp = do - codeNm <- newName (nameBase nm) - self <- newName "self" - - let declCode = DataD [] codeNm [] [NormalC codeNm []] [''Typeable] - - [showCode] <- [d| instance Show $(conT codeNm) where - show _ = $(lift (nameBase nm)) - |] - - [interpCode] <- [d| type instance Interp $(conT codeNm) $(varT self) - = $(spToTy self sp) - |] - - applyBody <- NormalB <$> [| unwrap $(spToExp self sp) |] - let astFunctorInst = InstanceD [] (AppT (ConT ''ASTFunctor) (ConT codeNm)) - [FunD 'apply [Clause [WildP, VarP self] applyBody []]] - - [showMu] <- [d| instance Show a => Show (Mu $(conT codeNm) a) where - show = show . unMu - |] - - enum <- mkEnumerableInst nm sp st (Just codeNm) - sig <- mkSpeciesSig spNm - spD <- mkSpecies spNm sp (Just codeNm) - - return $ [ declCode - , showCode - , interpCode - , astFunctorInst - , showMu - , enum - , sig - , spD - ] - - mkEnumerableNonrec nm spNm st sp = - sequence - [ mkEnumerableInst nm sp st Nothing - , mkSpeciesSig spNm - , mkSpecies spNm sp Nothing - ] diff --git a/species.cabal b/species.cabal --- a/species.cabal +++ b/species.cabal @@ -1,10 +1,10 @@ name: species -version: 0.3.4.2 +version: 0.4 license: BSD3 license-file: LICENSE build-type: Simple cabal-version: >= 1.10 -tested-with: GHC == 7.8.4, GHC == 7.10.1 +tested-with: GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1 author: Brent Yorgey maintainer: Brent Yorgey bug-reports: https://github.com/byorgey/species/issues @@ -20,7 +20,7 @@ location: https://github.com/byorgey/species Library - build-depends: base >= 4.7 && < 4.9, + build-depends: base >= 4.7 && < 4.10, numeric-prelude >= 0.3 && < 0.5, np-extras >= 0.3 && < 0.4, containers >= 0.2 && < 0.6, @@ -37,7 +37,6 @@ Math.Combinatorics.Species.AST.Instances Math.Combinatorics.Species.Structures Math.Combinatorics.Species.Enumerate - Math.Combinatorics.Species.TH Math.Combinatorics.Species.Util.Interval Math.Combinatorics.Species.NewtonRaphson Math.Combinatorics.Species.Simplify