diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,6 +1,13 @@ Changelog for singletons project ================================ +0.8.5 +----- + +Bug fix to make singletons compatible with GHC 7.6.1. + +Added git info to cabal file. + 0.8.4 ----- diff --git a/Data/Singletons/CustomStar.hs b/Data/Singletons/CustomStar.hs --- a/Data/Singletons/CustomStar.hs +++ b/Data/Singletons/CustomStar.hs @@ -8,7 +8,7 @@ Haskell types themselves. This is still very experimental, so expect unusual results! -} -{-# LANGUAGE DataKinds, TypeFamilies, KindSignatures #-} +{-# LANGUAGE DataKinds, TypeFamilies, KindSignatures, CPP #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Data.Singletons.CustomStar where @@ -27,11 +27,17 @@ let repDecl = DataD [] repName [] ctors [mkName "Eq", mkName "Show", mkName "Read"] fakeCtors <- zipWithM (mkCtor False) names kinds +#if __GLASGOW_HASKELL__ >= 707 eqInstance <- mkEqTypeInstance StarT fakeCtors + let eqInstances = [eqInstance] +#else + eqInstances <- mapM mkEqTypeInstance + [(c1, c2) | c1 <- fakeCtors, c2 <- fakeCtors] +#endif singletonDecls <- singDataD True [] repName [] fakeCtors [mkName "Eq", mkName "Show", mkName "Read"] return $ repDecl : - eqInstance : + eqInstances ++ singletonDecls where -- get the kinds of the arguments to the tycon with the given name getKind :: Name -> Q [Kind] diff --git a/Data/Singletons/Exports.hs b/Data/Singletons/Exports.hs --- a/Data/Singletons/Exports.hs +++ b/Data/Singletons/Exports.hs @@ -7,8 +7,9 @@ package. These are all re-exported in Data/Singletons.hs -} -{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies, RankNTypes, - TypeOperators, GADTs, CPP #-} +{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies, RankNTypes, FlexibleContexts, + FlexibleInstances, UndecidableInstances, TypeOperators, GADTs, + CPP #-} module Data.Singletons.Exports ( OfKind(..), Sing, SingI(..), SingE(..), SingRep, KindOf, Demote, diff --git a/Data/Singletons/Promote.hs b/Data/Singletons/Promote.hs --- a/Data/Singletons/Promote.hs +++ b/Data/Singletons/Promote.hs @@ -7,7 +7,7 @@ type level. It is an internal module to the singletons package. -} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, CPP #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Data.Singletons.Promote where @@ -189,13 +189,20 @@ -- produce instance for (:==:) from the given type promoteEqInstance :: Name -> Q [Dec] promoteEqInstance name = do - (tvbs, cons) <- getDataD "I cannot make an instance of (:==:) for it." name - vars <- replicateM (length tvbs) (newName "k") + (_tvbs, cons) <- getDataD "I cannot make an instance of (:==:) for it." name +#if __GLASGOW_HASKELL__ >= 707 + vars <- replicateM (length _tvbs) (newName "k") let tyvars = map VarT vars kind = foldType (ConT name) tyvars inst <- mkEqTypeInstance kind cons return [inst] +#else + let pairs = [(c1, c2) | c1 <- cons, c2 <- cons] + mapM mkEqTypeInstance pairs +#endif +#if __GLASGOW_HASKELL__ >= 707 + -- produce the branched type instance for (:==:) over the given list of ctors mkEqTypeInstance :: Kind -> [Con] -> Q Dec mkEqTypeInstance kind cons = do @@ -224,6 +231,41 @@ tyAll [one] = one tyAll (h:t) = foldType andTy [h, (tyAll t)] +#else + +-- produce the type instance for (:==:) for the given pair of constructors +mkEqTypeInstance :: (Con, Con) -> Q Dec +mkEqTypeInstance (c1, c2) = + if c1 == c2 + then do + let (name, numArgs) = extractNameArgs c1 + lnames <- replicateM numArgs (newName "a") + rnames <- replicateM numArgs (newName "b") + let lvars = map VarT lnames + rvars = map VarT rnames + return $ TySynInstD + tyEqName + [foldType (PromotedT name) lvars, + foldType (PromotedT name) rvars] + (tyAll (zipWith (\l r -> foldType (ConT tyEqName) [l, r]) + lvars rvars)) + else do + let (lname, lNumArgs) = extractNameArgs c1 + (rname, rNumArgs) = extractNameArgs c2 + lnames <- replicateM lNumArgs (newName "a") + rnames <- replicateM rNumArgs (newName "b") + return $ TySynInstD + tyEqName + [foldType (PromotedT lname) (map VarT lnames), + foldType (PromotedT rname) (map VarT rnames)] + falseTy + where tyAll :: [Type] -> Type -- "all" at the type level + tyAll [] = trueTy + tyAll [one] = one + tyAll (h:t) = foldType andTy [h, (tyAll t)] + +#endif + -- keeps track of the number of non-uniform parameters to promoted values type NumArgsTable = Map.Map Name Int type NumArgsQ = QWithAux NumArgsTable @@ -240,9 +282,13 @@ numArgs = getNumPats (head clauses) -- count the parameters -- Haskell requires all clauses to have the same number of parameters (eqns, instDecls) <- lift $ evalForPair $ - mapM (promoteClause vars') clauses + mapM (promoteClause vars' proName) clauses addBinding name numArgs -- remember the number of parameters +#if __GLASGOW_HASKELL__ >= 707 return $ (TySynInstD proName eqns) : instDecls +#else + return $ eqns ++ instDecls +#endif where getNumPats :: Clause -> Int getNumPats (Clause pats _ _) = length pats promoteDec vars (ValD pat body decs) = do @@ -255,7 +301,7 @@ if any (flip containsName rhs) (map lhsName lhss) then do -- definition is recursive. use type families & require ty sigs mapM (flip addBinding 0) (map lhsRawName lhss) - return $ (map (\(LHS _ nm hole) -> TySynInstD nm [TySynEqn [] (hole rhs)]) lhss) ++ + return $ (map (\(LHS _ nm hole) -> mkTyFamInst nm [] (hole rhs)) lhss) ++ decls ++ decls' else do -- definition is not recursive; just use "type" decls mapM (flip addBinding typeSynonymFlag) (map lhsRawName lhss) @@ -285,7 +331,11 @@ fail "Promotion of data instances not yet supported" promoteDec _vars (NewtypeInstD _cxt _name _tys _ctors _derivings) = fail "Promotion of newtype instances not yet supported" +#if __GLASGOW_HASKELL__ >= 707 promoteDec _vars (TySynInstD _name _eqns) = +#else +promoteDec _vars (TySynInstD _name _lhs _rhs) = +#endif fail "Promotion of type synonym instances not yet supported" -- only need to check if the datatype derives Eq. The rest is automatic. @@ -294,9 +344,14 @@ promoteDataD _vars _cxt name tvbs ctors derivings = if any (\n -> (nameBase n) == "Eq") derivings then do +#if __GLASGOW_HASKELL__ >= 707 kvs <- replicateM (length tvbs) (lift $ newName "k") inst <- lift $ mkEqTypeInstance (foldType (ConT name) (map VarT kvs)) ctors return [inst] +#else + let pairs = [ (c1, c2) | c1 <- ctors, c2 <- ctors ] + lift $ mapM mkEqTypeInstance pairs +#endif else return [] -- the actual promotion is automatic -- second pass through declarations to deal with type signatures @@ -331,15 +386,23 @@ return $ (AppT (AppT ArrowT h) k) promoteDec' _ _ = return ([], []) -promoteClause :: TypeTable -> Clause -> QWithDecs TySynEqn -promoteClause vars (Clause pats body []) = do +#if __GLASGOW_HASKELL__ >= 707 +promoteClause :: TypeTable -> Name -> Clause -> QWithDecs TySynEqn +#else +promoteClause :: TypeTable -> Name -> Clause -> QWithDecs Dec +#endif +promoteClause vars _name (Clause pats body []) = do -- promoting the patterns creates variable bindings. These are passed -- to the function promoted the RHS (types, vartbl) <- lift $ evalForPair $ mapM promotePat pats let vars' = Map.union vars vartbl ty <- promoteBody vars' body +#if __GLASGOW_HASKELL__ >= 707 return $ TySynEqn types ty -promoteClause _ (Clause _ _ (_:_)) = +#else + return $ TySynInstD _name types ty +#endif +promoteClause _ _ (Clause _ _ (_:_)) = fail "A <> clause in a function definition is not yet supported" -- the LHS of a top-level expression is a name and "type with hole" @@ -386,11 +449,10 @@ extractorNames argKinds componentNames <- lift $ replicateM (length pats) (newName "a") zipWithM (\extractorName componentName -> - addElement $ TySynInstD extractorName - [TySynEqn - [foldType (promoteDataCon name) - (map VarT componentNames)] - (VarT componentName)]) + addElement $ mkTyFamInst extractorName + [foldType (promoteDataCon name) + (map VarT componentNames)] + (VarT componentName)) extractorNames componentNames -- now we have the extractor families. Use the appropriate families diff --git a/Data/Singletons/Singletons.hs b/Data/Singletons/Singletons.hs --- a/Data/Singletons/Singletons.hs +++ b/Data/Singletons/Singletons.hs @@ -6,7 +6,7 @@ This file contains functions to refine constructs to work with singleton types. It is an internal module to the singletons package. -} -{-# LANGUAGE PatternGuards, TemplateHaskell #-} +{-# LANGUAGE PatternGuards, TemplateHaskell, CPP #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Data.Singletons.Singletons where @@ -275,7 +275,11 @@ fail "Singling of data instances not yet supported" singDec (NewtypeInstD _cxt _name _tys _ctor _derivings) = fail "Singling of newtype instances not yet supported" +#if __GLASGOW_HASKELL__ >= 707 singDec (TySynInstD _name _eqns) = +#else +singDec (TySynInstD _name _lhs _rhs) = +#endif fail "Singling of type family instances not yet supported" -- create instances of SEq for each type in the list @@ -378,12 +382,11 @@ let singEInst = InstanceD [] (AppT (ConT forgettableName) (kindParam k)) - [TySynInstD demoteName - [TySynEqn - [kindParam k] - (foldType (ConT name) - (map (\kv -> AppT demote (kindParam (VarT kv))) - tvbNames))], + [mkTyFamInst demoteName + [kindParam k] + (foldType (ConT name) + (map (\kv -> AppT demote (kindParam (VarT kv))) + tvbNames)), FunD forgetName forgetClauses] diff --git a/Data/Singletons/Util.hs b/Data/Singletons/Util.hs --- a/Data/Singletons/Util.hs +++ b/Data/Singletons/Util.hs @@ -7,6 +7,7 @@ Users of the package should not need to consult this file. -} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module Data.Singletons.Util where @@ -18,6 +19,14 @@ import Control.Monad.Writer import qualified Data.Map as Map import Data.Generics + +mkTyFamInst :: Name -> [Type] -> Type -> Dec +mkTyFamInst name lhs rhs = +#if __GLASGOW_HASKELL__ >= 707 + TySynInstD name [TySynEqn lhs rhs] +#else + TySynInstD name lhs rhs +#endif -- reify a declaration, warning the user about splices if the reify fails reifyWithWarning :: Name -> Q Info diff --git a/singletons.cabal b/singletons.cabal --- a/singletons.cabal +++ b/singletons.cabal @@ -1,11 +1,12 @@ name: singletons -version: 0.8.4 +version: 0.8.5 cabal-version: >= 1.8 synopsis: A framework for generating singleton types homepage: http://www.cis.upenn.edu/~eir/packages/singletons category: Dependent Types author: Richard Eisenberg maintainer: Richard Eisenberg +bug-reports: https://github.com/goldfirere/singletons/issues stability: experimental extra-source-files: README, CHANGES license: BSD3 @@ -23,6 +24,12 @@ and produce documentation. Hence, all of the documentation is in the README file distributed with the package. This README is also accessible from the project home page. + +source-repository this + type: git + location: https://github.com/goldfirere/singletons.git + tag: v0.8.5 + subdir: devel library build-depends: