universe-dependent-sum 1.1.0.1 → 1.2

raw patch · 5 files changed

+46/−375 lines, 5 filesdep +somedep +universe-somedep −template-haskelldep −th-abstractiondep −transformersdep ~basedep ~dependent-sumdep ~universe-basePVP ok

version bump matches the API change (PVP)

Dependencies added: some, universe-some

Dependencies removed: template-haskell, th-abstraction, transformers, transformers-compat, universe-dependent-sum

Dependency ranges changed: base, dependent-sum, universe-base

API changes (from Hackage documentation)

Files

• src/Data/Universe/DependentSum.hs +38/−0
• src/Data/Universe/Some.hs +0/−107
• src/Data/Universe/Some/TH.hs +0/−176
• test/Test.hs +0/−64
• universe-dependent-sum.cabal +8/−28

@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Universe.DependentSum () where++import Data.Universe.Class (Universe (..), Finite (..))+import Data.Universe.Some (UniverseSome (..), FiniteSome (..))+import Data.Universe.Helpers (Tagged (..), Natural, (+++))++import           "some"          Data.Some (Some (..), foldSome)+import qualified "dependent-sum" Data.Some as DS++-------------------------------------------------------------------------------+-- Helpers+-------------------------------------------------------------------------------++#if MIN_VERSION_dependent_sum(0,5,0)+mkSome :: f a -> DS.Some f+mkSome = DS.Some+#else+mkSome :: f a -> DS.Some f+mkSome = DS.This+#endif++-------------------------------------------------------------------------------+-- Instances for Some+-------------------------------------------------------------------------------++instance UniverseSome f => Universe (DS.Some f) where+  universe = map (foldSome mkSome) universeSome++instance FiniteSome f => Finite (DS.Some f) where+  universeF   = map (foldSome mkSome) universeFSome+  cardinality = retagSome cardinalitySome++retagSome :: Tagged (Some f) Natural -> Tagged (some f) Natural+retagSome (Tagged n) = Tagged n

@@ -1,107 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RankNTypes #-}-module Data.Universe.Some (-  UniverseSome (..),-  FiniteSome (..),-  ) where--import Data.Functor.Sum (Sum (..))-import Data.List (genericLength)-import Data.Some (Some (..))-import Data.Universe.Class (Universe (..), Finite (..))-import Data.Universe.Helpers (Tagged (..), Natural, (+++))--#if MIN_VERSION_base(4,7,0)-import Data.Type.Equality ((:~:) (..))-#else-import Data.GADT.Compare ((:=) (..))-#endif------------------------------------------------------------------------------------ Class------------------------------------------------------------------------------------ | Auxiliary class to power @'Universe' ('Some' f)@ instance.--- (There are no good reasons to use @FlexibleInstances@).------ Laws are induced via @'Universe' ('Some' f)@ instance. For example:------ @--- 'elem' x 'universe' ==> 'elem' ('Some' f) 'universeSome'--- @------ As 'Data.GADT.Compare.GEq' cannot be written for phantom 'Functor's, e.g.--- 'Control.Applicative.Const' or 'Data.Proxy.Proxy', they cannot have--- 'UniverseSome' instance either.----class UniverseSome f where-  universeSome :: [Some f]--class UniverseSome f => FiniteSome f where-  universeFSome :: [Some f]-  universeFSome = universeSome--  cardinalitySome :: Tagged (Some f) Natural-  cardinalitySome = Tagged (genericLength (universeFSome :: [Some f]))------------------------------------------------------------------------------------ Helpers----------------------------------------------------------------------------------#if MIN_VERSION_dependent_sum(0,5,0)-mkSome :: f a -> Some f-mkSome = Some--mapSome :: (forall x. f x -> g x) -> Some f -> Some g-mapSome nt (Some f) = Some (nt f)-#else-mkSome :: f a -> Some f-mkSome = This--mapSome :: (forall x. f x -> g x) -> Some f -> Some g-mapSome nt (This f) = This (nt f)-#endif------------------------------------------------------------------------------------ Instances for Some----------------------------------------------------------------------------------instance UniverseSome f => Universe (Some f) where-  universe = universeSome--instance FiniteSome f => Finite (Some f) where-  universeF   = universeFSome-  cardinality = cardinalitySome------------------------------------------------------------------------------------ Type equality is singleton----------------------------------------------------------------------------------#if MIN_VERSION_base(4,7,0)-instance UniverseSome ((:~:) a) where-  universeSome = [mkSome Refl]--instance FiniteSome ((:~:) a) where-  cardinalitySome = 1-#else-instance UniverseSome ((:=) a) where-  universeSome = [mkSome Refl]--instance FiniteSome ((:=) a) where-  cardinalitySome = 1-#endif------------------------------------------------------------------------------------ Functors----------------------------------------------------------------------------------instance (UniverseSome f, UniverseSome g) => UniverseSome (Sum f g) where-  universeSome = map (mapSome InL) universeSome +++ map (mapSome InR) universeSome--instance (FiniteSome f, FiniteSome g) => FiniteSome (Sum f g) where-  universeFSome = map (mapSome InL) universeFSome ++ map (mapSome InR) universeFSome---- Note: Product instance is tricky, we could for special cases.--- e.g. '(GEq f, f ~ g) => UnvierseSome (Product f g)', but this is boring--- instance as we'd 'Pair' equal instances only.

@@ -1,176 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE TemplateHaskellQuotes #-}-#else-{-# LANGUAGE TemplateHaskell #-}-#endif-module Data.Universe.Some.TH (-  DeriveUniverseSome (..),-  universeSomeQ,-  ) where--import Control.Monad (forM, mapM, unless)-import Data.Some (Some (..))-import Data.Universe.Class (Universe (..))-import Data.Universe.Some (UniverseSome (..))-import Data.Universe.Helpers (interleave, (<+*+>))-import Language.Haskell.TH-import Language.Haskell.TH.Datatype---- | Derive the @'UniverseSome' n@ instance.------ >>> :set -XGADTs -XTemplateHaskell -XStandaloneDeriving--- >>> import Data.Universe.Class (universe)--- >>> import Data.GADT.Show------ >>> data Tag b a where IntTag :: Tag b Int; BoolTag :: b -> Tag b Bool--- >>> deriving instance Show b => Show (Tag b a)--- >>> instance Show b => GShow (Tag b) where gshowsPrec = showsPrec------ >>> ; deriveUniverseSome ''Tag--- >>> universe :: [Some (Tag (Maybe Bool))]--- [Some IntTag,Some (BoolTag Nothing),Some (BoolTag (Just False)),Some (BoolTag (Just True))]------ 'deriveUniverseSome' variant taking a 'Name' guesses simple class constraints.--- If you need more specific, you can specify them:------ >>> ; deriveUniverseSome [d| instance Universe b => UniverseSome (Tag b) |]--- >>> universe :: [Some (Tag (Maybe Bool))]--- [Some IntTag,Some (BoolTag Nothing),Some (BoolTag (Just False)),Some (BoolTag (Just True))]----class DeriveUniverseSome a where-  deriveUniverseSome :: a -> DecsQ--instance DeriveUniverseSome a => DeriveUniverseSome [a] where-  deriveUniverseSome a = fmap concat (mapM deriveUniverseSome a)--instance DeriveUniverseSome a => DeriveUniverseSome (Q a) where-  deriveUniverseSome a = deriveUniverseSome =<< a--instance DeriveUniverseSome Name where-  deriveUniverseSome name = do-    di <- reifyDatatype name-    let DatatypeInfo { datatypeContext = ctxt-                     , datatypeName    = parentName-#if MIN_VERSION_th_abstraction(0,3,0)-                     , datatypeInstTypes = vars0-#else-                     , datatypeVars    = vars0-#endif-                     , datatypeCons    = cons-                     } = di--    case safeUnsnoc vars0 of-      Nothing -> fail "Datatype should have at least one type variable"-      Just (vars, var) -> do-        varNames <- forM vars $ \v -> case v of-#if MIN_VERSION_template_haskell(2,8,0)-          SigT (VarT n) StarT -> newName "x"-#else-          SigT (VarT n) StarK -> newName "x"-#endif-          _                   -> fail "Only arguments of kind Type are supported"--#if MIN_VERSION_template_haskell(2,10,0)-        let constrs :: [TypeQ]-            constrs = map (\n -> conT ''Universe `appT` varT n) varNames-#else-        let constrs :: [PredQ]-            constrs = map (\n -> classP ''Universe [varT n]) varNames-#endif-        let typ     = foldl (\c n -> c `appT` varT n) (conT parentName) varNames--        i <- instanceD (cxt constrs) (conT ''UniverseSome `appT` typ)-            [ instanceDecFor di-            ]--        return [i]--instanceDecFor :: DatatypeInfo -> Q Dec-instanceDecFor di = valD (varP 'universeSome) (normalB $ universeSomeQ' di) []--instance DeriveUniverseSome Dec where-#if MIN_VERSION_template_haskell(2,11,0)-  deriveUniverseSome (InstanceD overlaps c classHead []) = do-    let instanceFor = InstanceD overlaps c classHead-#else-  deriveUniverseSome (InstanceD c classHead []) = do-    let instanceFor = InstanceD c classHead-#endif-    case classHead of-      ConT u `AppT` t | u == ''UniverseSome -> do-        name <- headOfType t-        di <- reifyDatatype name-        i <- fmap instanceFor $ mapM id-            [ instanceDecFor di-            ]-        return [i]-      _ -> fail $ "deriveUniverseSome: expected an instance head like `UniverseSome (C a b ...)`, got " ++ show classHead-  deriveUniverseSome _ = fail "deriveUniverseSome: expected an empty instance declaration"---- | Derive the method for @:: ['Some' tag]@------ >>> :set -XGADTs -XTemplateHaskell -XStandaloneDeriving--- >>> import Data.GADT.Show------ >>> data Tag b a where IntTag :: Tag b Int; BoolTag :: b -> Tag b Bool--- >>> deriving instance Show b => Show (Tag b a)--- >>> instance Show b => GShow (Tag b) where gshowsPrec = showsPrec------ >>> $(universeSomeQ ''Tag) :: [Some (Tag Bool)]--- [Some IntTag,Some (BoolTag False),Some (BoolTag True)]----universeSomeQ :: Name -> ExpQ-universeSomeQ name = reifyDatatype name >>= universeSomeQ'--universeSomeQ' :: DatatypeInfo -> Q Exp-universeSomeQ' di = do-  let DatatypeInfo { datatypeContext = ctxt-                   , datatypeName    = parentName-#if MIN_VERSION_th_abstraction(0,3,0)-                   , datatypeInstTypes = vars0-#else-                   , datatypeVars    = vars0-#endif-                   , datatypeCons    = cons-                   } = di--  -- check-  unless (null ctxt) $ fail "Datatype context is not empty"--  case safeUnsnoc vars0 of-    Nothing -> fail "Datatype should have at least one type variable"-    Just (vars, var) -> do-      let universe'   = [| universe |]-      let uap         = [| (<+*+>) |]-      let interleave' = [| interleave |]-#if MIN_VERSION_dependent_sum(0,5,0)-      let mapSome'    = [| map Some |]-#else-      let mapSome'    = [| map This |]-#endif--      let sums = map (universeForCon mapSome' universe' uap) cons-      interleave' `appE` listE sums-  where-    universeForCon mapSome' universe' uap ci =-      let con     = listE [ conE (constructorName ci) ]-          nargs   = length (constructorFields ci)-          conArgs = foldl (\f x -> infixE (Just f) uap (Just universe')) con (replicate nargs universe')--      in mapSome' `appE` conArgs------------------------------------------------------------------------------------ helpers----------------------------------------------------------------------------------headOfType :: Type -> Q Name-headOfType (AppT t _) = headOfType t-headOfType (VarT n)   = return n-headOfType (ConT n)   = return n-headOfType t          = fail $ "headOfType: " ++ show t--safeUnsnoc :: [a] -> Maybe ([a], a)-safeUnsnoc xs = case reverse xs of-  []     -> Nothing-  (y:ys) -> Just (reverse ys, y)

@@ -1,64 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-module Main (main) where--import Data.Universe.Class (Universe (..))-import Data.Some (Some (..))-import Data.GADT.Show-import Data.Universe.Some (UniverseSome (..))-import Data.Universe.Some.TH------------------------------------------------------------------------------------ Name----------------------------------------------------------------------------------data Tag b a where-  IntTag  :: Tag b Int-  BoolTag :: b -> Tag b Bool--deriving instance Show b => Show (Tag b a)-instance Show b => GShow (Tag b) where gshowsPrec = showsPrec--deriveUniverseSome ''Tag------------------------------------------------------------------------------------- Dec----------------------------------------------------------------------------------data Tag2 b a where-  IntTag2  :: Tag2 b Int-  BoolTag2 :: b -> Tag2 b Bool--deriving instance Show b => Show (Tag2 b a)-instance Show b => GShow (Tag2 b) where gshowsPrec = showsPrec--deriveUniverseSome [d| instance Universe b => UniverseSome (Tag2 b) |]------------------------------------------------------------------------------------ Manual----------------------------------------------------------------------------------data Tag3 b a where-  IntTag3  :: Tag3 b Int-  BoolTag3 :: b -> Tag3 b Bool--deriving instance Show b => Show (Tag3 b a)-instance Show b => GShow (Tag3 b) where gshowsPrec = showsPrec---- to separate splices-$(return [])--instance Universe b => UniverseSome (Tag3 b) where-    universeSome = $(universeSomeQ ''Tag3)------------------------------------------------------------------------------------ Main----------------------------------------------------------------------------------main :: IO ()-main = do-  print (universe :: [Some (Tag (Maybe Bool)) ])-  print (universe :: [Some (Tag2 (Maybe Bool)) ])-  print (universe :: [Some (Tag3 (Maybe Bool)) ])

@@ -1,5 +1,5 @@ name:          universe-dependent-sum-version:       1.1.0.1+version:       1.2 synopsis:      Universe instances for types from dependent-sum description:   A class for finite and recursively enumerable types and some helper functions for enumerating them@@ -29,7 +29,7 @@ build-type:    Simple cabal-version: >=1.10 tested-with:-  GHC ==8.8.1 || ==8.6.4 || ==8.4.4 || ==8.2.2 || ==8.0.2 || ==7.10.3 || ==7.8.4 || ==7.6.3 || ==7.4.2 || ==7.0.4+  GHC ==8.8.1 || ==8.6.5 || ==8.4.4 || ==8.2.2 || ==8.0.2 || ==7.10.3 || ==7.8.4 || ==7.6.3 || ==7.4.2 || ==7.0.4  source-repository head   type:     git@@ -44,31 +44,11 @@   default-language: Haskell2010   hs-source-dirs:   src   exposed-modules:-    Data.Universe.Some-    Data.Universe.Some.TH+    Data.Universe.DependentSum    build-depends:-      base              >=4.3      && <4.13-    , dependent-sum     >=0.3.2.2  && <0.6-    , template-haskell  >=2.5      && <2.15-    , th-abstraction    >=0.2.11.0 && <0.4-    , transformers      >=0.3.0.0  && <0.6-    , universe-base     >=1.1      && <1.1.1--  if impl(ghc >=7.10.3)-    build-depends: transformers >=0.4.2.0--  if !impl(ghc >=7.10.3)-    build-depends: transformers-compat >=0.6.1 && <0.7--test-suite th-test-  type:             exitcode-stdio-1.0-  default-language: Haskell2010-  hs-source-dirs:   test-  main-is:          Test.hs-  build-depends:-      base-    , dependent-sum-    , template-haskell-    , universe-base-    , universe-dependent-sum+      base              >=4.3      && <4.14+    , dependent-sum     >=0.3.2.2  && <0.7+    , some              >=1        && <1.1+    , universe-base     >=1.1      && <1.1.2+    , universe-some     >=1.2      && <1.3