singletons 0.8.5 → 0.8.6
raw patch · 9 files changed
+136/−53 lines, 9 files
Files
- CHANGES +5/−0
- Data/Singletons.hs +4/−4
- Data/Singletons/CustomStar.hs +1/−2
- Data/Singletons/Exports.hs +7/−7
- Data/Singletons/Promote.hs +71/−31
- Data/Singletons/Singletons.hs +26/−3
- Data/Singletons/TypeRepStar.hs +3/−3
- Data/Singletons/Util.hs +17/−1
- singletons.cabal +2/−2
CHANGES view
@@ -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 -----
Data/Singletons.hs view
@@ -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) (%:/=) = (%/=%)
Data/Singletons/CustomStar.hs view
@@ -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]
Data/Singletons/Exports.hs view
@@ -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
Data/Singletons/Promote.hs view
@@ -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
Data/Singletons/Singletons.hs view
@@ -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
Data/Singletons/TypeRepStar.hs view
@@ -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
Data/Singletons/Util.hs view
@@ -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
singletons.cabal view
@@ -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