constraints-extras 0.2.3.5 → 0.3

raw patch · 6 files changed

+29/−19 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• README.lhs +2/−0
• README.md +2/−0
• constraints-extras.cabal +1/−1
• src/Data/Constraint/Extras.hs +10/−7
• src/Data/Constraint/Extras/TH.hs +10/−11

@@ -1,5 +1,9 @@ # Revision history for constraints-extras +## 0.3 - 2019-05-16++* Added a parameter for the type class, to allow for custom not-fully-polymorphic instances of ArgDict in cases where e.g. your key type contains dictionaries for specific classes. You will now need FlexibleInstances, MultiParamTypeClasses for the instances created by deriveArgDict.+ ## 0.2.3.5 - 2019-05-04  * Bumped version bounds on base and template-haskell to admit the versions from GHC 8.6.x

@@ -12,6 +12,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications  #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ExistentialQuantification #-} 

@@ -12,6 +12,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications  #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ExistentialQuantification #-} 

@@ -1,5 +1,5 @@ name: constraints-extras-version: 0.2.3.5+version: 0.3 synopsis: Utility package for constraints description: Convenience functions and TH for working with constraints. See <https://github.com/obsidiansystems/constraints-extras/blob/develop/README.md README.md> for example usage. category: Constraints

@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-}@@ -26,27 +27,29 @@ -- at the moment, it appears to require honest type level functions. (Closed type families which must be fully -- applied didn't quite cut it when I tried). Some symbolic type-level application could do the trick, but I didn't -- want to go quite that far at the time of writing.-class ArgDict f where++class ArgDict (c :: k -> Constraint) (f :: k -> *) where   type ConstraintsFor f (c :: k -> Constraint) :: Constraint   argDict :: ConstraintsFor f c => f a -> Dict (c a)  type ConstraintsFor' f (c :: k -> Constraint) (g :: k' -> k) = ConstraintsFor f (ComposeC c g) -argDict' :: forall f c g a. (ArgDict f, ConstraintsFor' f c g) => f a -> Dict (c (g a))+argDict' :: forall f c g a. (Has' c f g) => f a -> Dict (c (g a)) argDict' tag = case argDict tag of   (Dict :: Dict (ComposeC c g a)) -> Dict+ type ConstraintsForV (f :: (k -> k') -> *) (c :: k' -> Constraint) (g :: k) = ConstraintsFor f (FlipC (ComposeC c) g) -argDictV :: forall f c g v. (ArgDict f, ConstraintsForV f c g) => f v -> Dict (c (v g))+argDictV :: forall f c g v. (HasV c f g) => f v -> Dict (c (v g)) argDictV tag = case argDict tag of   (Dict :: Dict (FlipC (ComposeC c) g a)) -> Dict  {-# DEPRECATED ArgDictV "Just use 'ArgDict'" #-}-type ArgDictV f = ArgDict f+type ArgDictV f c = ArgDict f c -type Has (c :: k -> Constraint) f = (ArgDict f, ConstraintsFor f c)-type Has' (c :: k -> Constraint) f (g :: k' -> k) = (ArgDict f, ConstraintsFor' f c g)-type HasV c f g = (ArgDict f, ConstraintsForV f c g)+type Has (c :: k -> Constraint) f = (ArgDict c f, ConstraintsFor f c)+type Has' (c :: k -> Constraint) f (g :: k' -> k) = (ArgDict (ComposeC c g) f, ConstraintsFor' f c g)+type HasV c f g = (ArgDict (FlipC (ComposeC c) g) f, ConstraintsForV f c g)  has :: forall c f a r. (Has c f) => f a -> (c a => r) -> r has k r | (Dict :: Dict (c a)) <- argDict k = r

@@ -10,11 +10,10 @@ import Control.Monad import Language.Haskell.TH - deriveArgDict :: Name -> Q [Dec] deriveArgDict n = do-  ts <- gadtIndices n   c <- newName "c"+  ts <- gadtIndices c n   let xs = flip map ts $ \case         Left t -> AppT (AppT (ConT ''ConstraintsFor) t) (VarT c)         Right t -> (AppT (VarT c) t)@@ -23,16 +22,16 @@   arity <- tyConArity n   tyVars <- replicateM (arity - 1) (newName "a")   let n' = foldr (\v x -> AppT x (VarT v)) (ConT n) tyVars-  [d| instance ArgDict $(pure n') where+  [d| instance ArgDict $(varT c) $(pure n') where         type ConstraintsFor  $(pure n') $(varT c) = $(pure constraints)-        argDict = $(LamCaseE <$> matches n 'argDict)+        argDict = $(LamCaseE <$> matches c n 'argDict)     |]  {-# DEPRECATED deriveArgDictV "Just use 'deriveArgDict'" #-} deriveArgDictV = deriveArgDict -matches :: Name -> Name -> Q [Match]-matches n argDictName = do+matches :: Name -> Name -> Name -> Q [Match]+matches c n argDictName = do   x <- newName "x"   reify n >>= \case     TyConI (DataD _ _ _ _ cons _) -> fmap concat $ forM cons $ \case@@ -41,7 +40,7 @@       ForallC _ _ (GadtC [name] bts (AppT _ (VarT b))) -> do         ps <- forM bts $ \case           (_, AppT t (VarT b')) | b == b' -> do-            hasArgDictInstance <- not . null <$> reifyInstances ''ArgDict [t]+            hasArgDictInstance <- not . null <$> reifyInstances ''ArgDict [VarT c, t]             return $ if hasArgDictInstance               then Just x               else Nothing@@ -74,15 +73,15 @@    TyConI (DataD _ _ ts mk _ _) -> fromMaybe 0 (fmap kindArity mk) + length ts    _ -> error $ "tyConArity: Supplied name reified to something other than a data declaration: " ++ show n -gadtIndices :: Name -> Q [Either Type Type]-gadtIndices n = reify n >>= \case+gadtIndices :: Name -> Name -> Q [Either Type Type]+gadtIndices c n = reify n >>= \case   TyConI (DataD _ _ _ _ cons _) -> fmap concat $ forM cons $ \case     GadtC _ _ (AppT _ typ) -> return [Right typ]     ForallC _ _ (GadtC _ bts (AppT _ (VarT _))) -> fmap concat $ forM bts $ \case       (_, AppT t (VarT _)) -> do-        hasArgDictInstance <- fmap (not . null) $ reifyInstances ''ArgDict [t]+        hasArgDictInstance <- fmap (not . null) $ reifyInstances ''ArgDict [VarT c, t]         return $ if hasArgDictInstance then [Left t] else []       _ -> return []     ForallC _ _ (GadtC _ _ (AppT _ typ)) -> return [Right typ]     _ -> return []-  a -> error $ "gadtResults: Unmatched 'Info': " ++ show a+  a -> error $ "gadtIndices: Unmatched 'Info': " ++ show a