diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,6 +1,11 @@ Changelog for singletons project ================================ +0.8.6 +----- + +Make compatible with GHC HEAD, but HEAD reports core lint errors sometimes. + 0.8.5 ----- diff --git a/Data/Singletons.hs b/Data/Singletons.hs --- a/Data/Singletons.hs +++ b/Data/Singletons.hs @@ -19,7 +19,7 @@ -- We make unused bindings for (||), (&&), and not. module Data.Singletons ( - OfKind(..), Sing(..), SingI(..), SingE(..), SingRep, KindOf, Demote, + KindIs(..), Sing(..), SingI(..), SingE(..), SingRep, KindOf, Demote, Any, (:==), (:==:), SingInstance(..), SingKind(singInstance), @@ -69,16 +69,16 @@ type a :/= b = a :/=: b -- the singleton analogue of @Eq@ -class (kparam ~ KindParam) => SEq (kparam :: OfKind k) where +class (kparam ~ KindParam) => SEq (kparam :: KindIs k) where (%==%) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :==: b) (%/=%) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/=: b) a %/=% b = sNot (a %==% b) -(%:==) :: forall (a :: k) (b :: k). SEq (KindParam :: OfKind k) +(%:==) :: forall (a :: k) (b :: k). SEq (KindParam :: KindIs k) => Sing a -> Sing b -> Sing (a :==: b) (%:==) = (%==%) -(%:/=) :: forall (a :: k) (b :: k). SEq (KindParam :: OfKind k) +(%:/=) :: forall (a :: k) (b :: k). SEq (KindParam :: KindIs k) => Sing a -> Sing b -> Sing (a :/=: b) (%:/=) = (%/=%) diff --git a/Data/Singletons/CustomStar.hs b/Data/Singletons/CustomStar.hs --- a/Data/Singletons/CustomStar.hs +++ b/Data/Singletons/CustomStar.hs @@ -28,8 +28,7 @@ [mkName "Eq", mkName "Show", mkName "Read"] fakeCtors <- zipWithM (mkCtor False) names kinds #if __GLASGOW_HASKELL__ >= 707 - eqInstance <- mkEqTypeInstance StarT fakeCtors - let eqInstances = [eqInstance] + eqInstances <- mkEqTypeInstance StarT fakeCtors #else eqInstances <- mapM mkEqTypeInstance [(c1, c2) | c1 <- fakeCtors, c2 <- fakeCtors] diff --git a/Data/Singletons/Exports.hs b/Data/Singletons/Exports.hs --- a/Data/Singletons/Exports.hs +++ b/Data/Singletons/Exports.hs @@ -12,29 +12,29 @@ CPP #-} module Data.Singletons.Exports ( - OfKind(..), Sing, SingI(..), SingE(..), SingRep, KindOf, Demote, + KindIs(..), Sing, SingI(..), SingE(..), SingRep, KindOf, Demote, SingInstance(..), SingKind(..), If, Head, Tail ) where #if __GLASGOW_HASKELL__ >= 707 -import GHC.TypeLits ( OfKind(..), Sing, SingI(..), SingE(..), +import GHC.TypeLits ( KindIs(..), Sing, SingI(..), SingE(..), SingRep, KindOf, Demote ) #else -- Kind-level proxy -data OfKind (k :: *) = KindParam +data KindIs (k :: *) = KindParam -- Access the kind of a type variable -type KindOf (a :: k) = (KindParam :: OfKind k) +type KindOf (a :: k) = (KindParam :: KindIs k) -- Declarations of singleton structures data family Sing (a :: k) class SingI (a :: k) where sing :: Sing a -class (kparam ~ KindParam) => SingE (kparam :: OfKind k) where +class (kparam ~ KindParam) => SingE (kparam :: KindIs k) where type DemoteRep kparam :: * fromSing :: Sing (a :: k) -> DemoteRep kparam @@ -43,13 +43,13 @@ instance (SingI a, SingE (KindOf a)) => SingRep (a :: k) -- Abbreviation for DemoteRep -type Demote (a :: k) = DemoteRep (KindParam :: OfKind k) +type Demote (a :: k) = DemoteRep (KindParam :: KindIs k) #endif data SingInstance (a :: k) where SingInstance :: SingRep a => SingInstance a -class (kparam ~ KindParam) => SingKind (kparam :: OfKind k) where +class (kparam ~ KindParam) => SingKind (kparam :: KindIs k) where singInstance :: forall (a :: k). Sing a -> SingInstance a -- type-level conditional diff --git a/Data/Singletons/Promote.hs b/Data/Singletons/Promote.hs --- a/Data/Singletons/Promote.hs +++ b/Data/Singletons/Promote.hs @@ -23,11 +23,12 @@ import Control.Monad.Writer hiding (Any) import Data.List -anyTypeName, falseName, trueName, andName, tyEqName, repName, ifName, +anyTypeName, falseName, trueName, boolName, andName, tyEqName, repName, ifName, headName, tailName :: Name anyTypeName = ''Any falseName = 'False trueName = 'True +boolName = ''Bool andName = mkName "&&" tyEqName = mkName ":==:" repName = mkName "Rep" @@ -41,6 +42,9 @@ trueTy :: Type trueTy = promoteDataCon trueName +boolTy :: Type +boolTy = ConT boolName + andTy :: Type andTy = promoteVal andName @@ -166,12 +170,16 @@ promoteDecs decls = do checkForRepInDecls decls let vartbl = Map.empty - (newDecls, numArgsTable) <- evalForPair $ mapM (promoteDec vartbl) decls - (declss, namess) <- mapAndUnzipM (promoteDec' numArgsTable) decls + (newDecls, table) <- evalForPair $ mapM (promoteDec vartbl) decls + (declss, namess) <- mapAndUnzipM (promoteDec' table) decls let moreNewDecls = concat declss names = concat namess noTypeSigs = Set.toList $ Set.difference (Map.keysSet $ - Map.filter (>= 0) numArgsTable) +#if __GLASGOW_HASKELL__ >= 707 + Map.filter ((>= 0) . fst) table) +#else + Map.filter (>= 0) table) +#endif (Set.fromList names) noTypeSigsPro = map promoteValName noTypeSigs newDecls' = foldl (\decls name -> @@ -194,8 +202,8 @@ vars <- replicateM (length _tvbs) (newName "k") let tyvars = map VarT vars kind = foldType (ConT name) tyvars - inst <- mkEqTypeInstance kind cons - return [inst] + inst_decs <- mkEqTypeInstance kind cons + return inst_decs #else let pairs = [(c1, c2) | c1 <- cons, c2 <- cons] mapM mkEqTypeInstance pairs @@ -203,10 +211,24 @@ #if __GLASGOW_HASKELL__ >= 707 --- produce the branched type instance for (:==:) over the given list of ctors -mkEqTypeInstance :: Kind -> [Con] -> Q Dec +-- produce a closed type family helper and the instance +-- for (:==:) over the given list of ctors +mkEqTypeInstance :: Kind -> [Con] -> Q [Dec] mkEqTypeInstance kind cons = do - tySynInstD tyEqName (map mk_branch cons ++ [false_case]) + helperName <- newUniqueName "Equals" + aName <- newName "a" + bName <- newName "b" + closedFam <- closedTypeFamilyKindD helperName + [ KindedTV aName kind + , KindedTV bName kind ] + boolTy + (map mk_branch cons ++ [false_case]) + let eqInst = TySynInstD tyEqName (TySynEqn [ SigT (VarT aName) kind + , SigT (VarT bName) kind ] + (foldType (ConT helperName) + [VarT aName, VarT bName])) + return [closedFam, eqInst] + where mk_branch :: Con -> Q TySynEqn mk_branch con = do let (name, numArgs) = extractNameArgs con @@ -267,15 +289,20 @@ #endif -- keeps track of the number of non-uniform parameters to promoted values -type NumArgsTable = Map.Map Name Int -type NumArgsQ = QWithAux NumArgsTable +-- and all of the instance equations for those values +#if __GLASGOW_HASKELL__ >= 707 +type PromoteTable = Map.Map Name (Int, [TySynEqn]) +#else +type PromoteTable = Map.Map Name Int +#endif +type PromoteQ = QWithAux PromoteTable -- used when a type is declared as a type synonym, not a type family -- no need to declare "type family ..." for these typeSynonymFlag :: Int typeSynonymFlag = -1 -promoteDec :: TypeTable -> Dec -> NumArgsQ [Dec] +promoteDec :: TypeTable -> Dec -> PromoteQ [Dec] promoteDec vars (FunD name clauses) = do let proName = promoteValName name vars' = Map.insert name (promoteVal name) vars @@ -283,10 +310,11 @@ -- Haskell requires all clauses to have the same number of parameters (eqns, instDecls) <- lift $ evalForPair $ mapM (promoteClause vars' proName) clauses - addBinding name numArgs -- remember the number of parameters #if __GLASGOW_HASKELL__ >= 707 - return $ (TySynInstD proName eqns) : instDecls + addBinding name (numArgs, eqns) -- remember the number of parameters and the eqns + return instDecls #else + addBinding name numArgs -- remember the number of parameters return $ eqns ++ instDecls #endif where getNumPats :: Clause -> Int @@ -299,12 +327,14 @@ (rhs, decls) <- lift $ evalForPair $ promoteBody vars body (lhss, decls') <- lift $ evalForPair $ promoteTopLevelPat pat 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) -> mkTyFamInst nm [] (hole rhs)) lhss) ++ - decls ++ decls' + then -- definition is recursive. This means an infinite value. + fail "Promotion of infinite terms not yet supported" else do -- definition is not recursive; just use "type" decls +#if __GLASGOW_HASKELL__ >= 707 + mapM (flip addBinding (typeSynonymFlag, [])) (map lhsRawName lhss) +#else mapM (flip addBinding typeSynonymFlag) (map lhsRawName lhss) +#endif return $ (map (\(LHS _ nm hole) -> TySynD nm [] (hole rhs)) lhss) ++ decls ++ decls' promoteDec vars (DataD cxt name tvbs ctors derivings) = @@ -332,7 +362,9 @@ 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) = +promoteDec _vars (ClosedTypeFamilyD _name _tvs _mkind _eqns) = + fail "Promotion of closed type families not yet supported" +promoteDec _vars (TySynInstD _name _eqn) = #else promoteDec _vars (TySynInstD _name _lhs _rhs) = #endif @@ -340,14 +372,14 @@ -- only need to check if the datatype derives Eq. The rest is automatic. promoteDataD :: TypeTable -> Cxt -> Name -> [TyVarBndr] -> [Con] -> - [Name] -> NumArgsQ [Dec] -promoteDataD _vars _cxt name tvbs ctors derivings = + [Name] -> PromoteQ [Dec] +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] + kvs <- replicateM (length _tvbs) (lift $ newName "k") + inst_decs <- lift $ mkEqTypeInstance (foldType (ConT _name) (map VarT kvs)) ctors + return inst_decs #else let pairs = [ (c1, c2) | c1 <- ctors, c2 <- ctors ] lift $ mapM mkEqTypeInstance pairs @@ -357,10 +389,14 @@ -- second pass through declarations to deal with type signatures -- returns the new declarations and the list of names that have been -- processed -promoteDec' :: NumArgsTable -> Dec -> Q ([Dec], [Name]) -promoteDec' nat (SigD name ty) = case Map.lookup name nat of +promoteDec' :: PromoteTable -> Dec -> Q ([Dec], [Name]) +promoteDec' tab (SigD name ty) = case Map.lookup name tab of Nothing -> fail $ "Type declaration is missing its binding: " ++ (show name) - Just numArgs -> +#if __GLASGOW_HASKELL__ >= 707 + Just (numArgs, eqns) -> +#else + Just numArgs -> +#endif -- if there are no args, then use a type synonym, not a type family -- in the type synonym case, we ignore the type signature if numArgs == typeSynonymFlag then return $ ([], [name]) else do @@ -369,10 +405,17 @@ (argKs, resultKs) = splitAt numArgs ks -- divide by uniformity resultK <- ravel resultKs -- rebuild the arrow kind tyvarNames <- mapM newName (replicate (length argKs) "a") +#if __GLASGOW_HASKELL__ >= 707 + return ([ClosedTypeFamilyD (promoteValName name) + (zipWith KindedTV tyvarNames argKs) + (Just resultK) + eqns], [name]) +#else return ([FamilyD TypeFam (promoteValName name) (zipWith KindedTV tyvarNames argKs) (Just resultK)], [name]) +#endif where unravel :: Kind -> [Kind] -- get argument kinds from an arrow kind unravel (AppT (AppT ArrowT k1) k2) = let ks = unravel k2 in k1 : ks @@ -436,11 +479,8 @@ (show pats) kind <- lift $ promoteType ctorType argKinds <- lift $ mapM promoteType argTypes - extractorNamesRaw <- lift $ replicateM (length pats) (newName "Extract") + extractorNames <- lift $ replicateM (length pats) (newUniqueName "Extract") - -- TH doesn't allow "newName"s to work at the top-level, so we have to - -- do this trick to ensure the Extract functions are unique - let extractorNames = map (mkName . show) extractorNamesRaw varName <- lift $ newName "a" zipWithM (\nm arg -> addElement $ FamilyD TypeFam nm diff --git a/Data/Singletons/Singletons.hs b/Data/Singletons/Singletons.hs --- a/Data/Singletons/Singletons.hs +++ b/Data/Singletons/Singletons.hs @@ -55,7 +55,7 @@ sIfName = mkName "sIf" undefinedName = 'undefined kindParamName = 'KindParam -ofKindName = ''OfKind +ofKindName = ''KindIs mkTupleName :: Int -> Name mkTupleName n = mkName $ "STuple" ++ (show n) @@ -171,7 +171,7 @@ -- smart constructor type signature smartConType <- lift $ conTypesToFunType indexNames args kinds (AppT singFamily (foldType pCon indices)) - addElement $ SigD (smartConName name) smartConType + addElement $ SigD (smartConName name) (liftOutForalls smartConType) -- smart constructor let vars = map VarE indexNames @@ -276,6 +276,8 @@ singDec (NewtypeInstD _cxt _name _tys _ctor _derivings) = fail "Singling of newtype instances not yet supported" #if __GLASGOW_HASKELL__ >= 707 +singDec (ClosedTypeFamilyD _name _tvs _mkind _eqns) = + fail "Singling of closed type families not yet supported" singDec (TySynInstD _name _eqns) = #else singDec (TySynInstD _name _lhs _rhs) = @@ -441,7 +443,28 @@ -- the first parameter is whether or not this type occurs in a positive position singType :: Bool -> Type -> Q TypeFn -singType = singTypeRec [] +singType pos ty = do -- replace with singTypeRec [] pos ty after GHC bug #??? is fixed + sTypeFn <- singTypeRec [] pos ty + return $ \inner_ty -> liftOutForalls $ sTypeFn inner_ty + + -- the lifts all foralls to the top-level +liftOutForalls :: Type -> Type +liftOutForalls = + go [] [] [] + where + go tyvars cxt args (ForallT tyvars1 cxt1 t1) + = go (reverse tyvars1 ++ tyvars) (reverse cxt1 ++ cxt) args t1 + go tyvars cxt args (SigT t1 _kind) -- ignore these kind annotations, which have to be * + = go tyvars cxt args t1 + go tyvars cxt args (AppT (AppT ArrowT arg1) res1) + = go tyvars cxt (arg1 : args) res1 + go [] [] args t1 + = mk_fun_ty (reverse args) t1 + go tyvars cxt args t1 + = ForallT (reverse tyvars) (reverse cxt) (mk_fun_ty (reverse args) t1) + + mk_fun_ty [] res = res + mk_fun_ty (arg1:args) res = AppT (AppT ArrowT arg1) (mk_fun_ty args res) -- the first parameter is the list of types the current type is applied to -- the second parameter is whether or not this type occurs in a positive position diff --git a/Data/Singletons/TypeRepStar.hs b/Data/Singletons/TypeRepStar.hs --- a/Data/Singletons/TypeRepStar.hs +++ b/Data/Singletons/TypeRepStar.hs @@ -24,8 +24,8 @@ instance Typeable a => SingI (a :: *) where sing = STypeRep -instance SingE (KindParam :: OfKind *) where - type DemoteRep (KindParam :: OfKind *) = TypeRep +instance SingE (KindParam :: KindIs *) where + type DemoteRep (KindParam :: KindIs *) = TypeRep fromSing (STypeRep :: Sing a) = typeOf (undefined :: a) -instance SingKind (KindParam :: OfKind *) where +instance SingKind (KindParam :: KindIs *) where singInstance STypeRep = SingInstance diff --git a/Data/Singletons/Util.hs b/Data/Singletons/Util.hs --- a/Data/Singletons/Util.hs +++ b/Data/Singletons/Util.hs @@ -23,11 +23,19 @@ mkTyFamInst :: Name -> [Type] -> Type -> Dec mkTyFamInst name lhs rhs = #if __GLASGOW_HASKELL__ >= 707 - TySynInstD name [TySynEqn lhs rhs] + TySynInstD name (TySynEqn lhs rhs) #else TySynInstD name lhs rhs #endif +-- like newName, but even more unique (unique across different splices) +-- TH doesn't allow "newName"s to work at the top-level, so we have to +-- do this trick to ensure the Extract functions are unique +newUniqueName :: String -> Q Name +newUniqueName str = do + n <- newName str + return $ mkName $ show n + -- reify a declaration, warning the user about splices if the reify fails reifyWithWarning :: Name -> Q Info reifyWithWarning name = recover @@ -122,11 +130,19 @@ extractTvbName :: TyVarBndr -> Name extractTvbName (PlainTV n) = n extractTvbName (KindedTV n _) = n +#if __GLASGOW_HASKELL__ >= 707 +extractTvbName (RoledTV n _) = n +extractTvbName (KindedRoledTV n _ _) = n +#endif -- extract the kind from a TyVarBndr. Returns '*' by default. extractTvbKind :: TyVarBndr -> Kind extractTvbKind (PlainTV _) = StarT -- FIXME: This seems wrong. extractTvbKind (KindedTV _ k) = k +#if __GLASGOW_HASKELL__ >= 707 +extractTvbKind (RoledTV _ _) = StarT -- FIXME: This seems wrong. +extractTvbKind (KindedRoledTV _ k _) = k +#endif -- apply a type to a list of types foldType :: Type -> [Type] -> Type diff --git a/singletons.cabal b/singletons.cabal --- a/singletons.cabal +++ b/singletons.cabal @@ -1,5 +1,5 @@ name: singletons -version: 0.8.5 +version: 0.8.6 cabal-version: >= 1.8 synopsis: A framework for generating singleton types homepage: http://www.cis.upenn.edu/~eir/packages/singletons @@ -28,7 +28,7 @@ source-repository this type: git location: https://github.com/goldfirere/singletons.git - tag: v0.8.5 + tag: v0.8.6 subdir: devel library