singletons 0.8.4 → 0.8.5
raw patch · 7 files changed
+120/−25 lines, 7 filesdep ~base
Dependency ranges changed: base
Files
- CHANGES +7/−0
- Data/Singletons/CustomStar.hs +8/−2
- Data/Singletons/Exports.hs +3/−2
- Data/Singletons/Promote.hs +75/−13
- Data/Singletons/Singletons.hs +10/−7
- Data/Singletons/Util.hs +9/−0
- singletons.cabal +8/−1
CHANGES view
@@ -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 -----
Data/Singletons/CustomStar.hs view
@@ -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]
Data/Singletons/Exports.hs view
@@ -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,
Data/Singletons/Promote.hs view
@@ -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 <<where>> 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
Data/Singletons/Singletons.hs view
@@ -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]
Data/Singletons/Util.hs view
@@ -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
singletons.cabal view
@@ -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 <eir@cis.upenn.edu> maintainer: Richard Eisenberg <eir@cis.upenn.edu>+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: