constraints-extras-0.4.0.0/0000755000000000000000000000000007346545000013715 5ustar0000000000000000constraints-extras-0.4.0.0/ChangeLog.md0000755000000000000000000000401707346545000016073 0ustar0000000000000000# Revision history for constraints-extras ## 0.4.0.0 - 2022-11-18 * Make `Has` from a type synonym into the class upon which everything else is based. Instances may define either `has` or `argDict` which are now both methods of `Has`. This should hopefully improve the readability of type errors involving the library a fair bit, as everything wanted to use `Has`, but it was defined in terms of the less commonly appearing `ArgDict` and `ConstraintsFor`. * The `ConstraintsFor` type family has been removed as it is now unnecessary, as instances of `Has` can simply be constrained directly. This has the added benefit of allowing `QuantifiedConstraints` in those instance heads that formerly would not have been allowed as part of the result of a type family. * The `ArgDict` class has also been removed, as it was also basically never used on its own. ## 0.3.2.1 - 2021-12-17 * Support GHC 9.2 ## 0.3.2.0 - 2021-10-28 * Provide `ArgDict` instances for sums of functors. ## 0.3.1.0 - 2021-03-24 * Allow deriving instances with `deriveArgDict` for data and newtype family instances by supplying the name of one of its constructors * Support GHC 9.0.1 ## 0.3.0.3 - 2020-06-22 * Update version bounds for GHC 8.10 ## 0.3.0.2 - 2019-09-30 * Update version bounds for GHC 8.8 ## 0.3.0.1 - 2019-05-17 * Drop markdown-unlit in favor of using regular "Bird"-style LHS to avoid some cross-compilation problems ## 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 ## 0.2.3.4 - 2019-03-22 * Added ChangeLog.md * Replaced some occurrences of <> in Data.Constraint.Extras.TH with ++ so that the module will hopefully build with GHC 8.0.2 and 8.2.2 without needing to import Data.Semigroup. constraints-extras-0.4.0.0/LICENSE0000644000000000000000000000300507346545000014720 0ustar0000000000000000Copyright (c) 2018, Obsidian Systems LLC All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Cale Gibbard, Ali Abrar nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. constraints-extras-0.4.0.0/README.lhs0000644000000000000000000000442207346545000015364 0ustar0000000000000000constraints-extras [![travis-ci](https://api.travis-ci.org/obsidiansystems/constraints-extras.svg?branch=develop)](https://travis-ci.org/obsidiansystems/constraints-extras) ================== Example usage: -------------- ```haskell > {-# LANGUAGE GADTs #-} > {-# LANGUAGE KindSignatures #-} > {-# LANGUAGE PolyKinds #-} > {-# LANGUAGE ScopedTypeVariables #-} > {-# LANGUAGE TemplateHaskell #-} > {-# LANGUAGE TypeApplications #-} > {-# LANGUAGE TypeFamilies #-} > {-# LANGUAGE FlexibleContexts #-} > {-# LANGUAGE ConstraintKinds #-} > {-# LANGUAGE FlexibleInstances #-} > {-# LANGUAGE MultiParamTypeClasses #-} > {-# LANGUAGE UndecidableInstances #-} > {-# LANGUAGE ExistentialQuantification #-} > {-# LANGUAGE TypeFamilies #-} > > import Data.Aeson > import Data.Constraint.Forall > import Data.Constraint.Extras > import Data.Constraint.Extras.TH > > data A :: * -> * where > A_a :: A Int > A_b :: Int -> A () > > deriveArgDict ''A > > data B :: * -> * where > B_a :: A a -> A a -> B a > B_x :: Int -> B Int > > deriveArgDict ''B > > data V :: (* -> *) -> * where > V_a :: A Int -> V A > > deriveArgDict ''V > > data family Fam a :: * -> * > data instance Fam () :: * -> * where > FI :: Fam () Int > FB :: Fam () Bool > > deriveArgDict 'FI > -- this derives an instance Has c (Fam ()) by looking up the associated data instance. > > data DSum k f = forall a. DSum (k a) (f a) > > -- Derive a ToJSON instance for our 'DSum' > instance forall k f. > ( Has' ToJSON k f -- Given a value of type (k a), we can obtain an instance (ToJSON (f a)) > , ForallF ToJSON k -- For any (a), we have an instance (ToJSON (k a)) > ) => ToJSON (DSum k f) where > toJSON (DSum (k :: k a) f) = toJSON > ( whichever @ToJSON @k @a $ toJSON k -- Use the (ForallF ToJSON k) constraint to obtain the (ToJSON (k a)) instance > , has' @ToJSON @f k $ toJSON f -- Use the (Has' ToJSON k f) constraint to obtain the (ToJSON (f a)) instance > ) > > data Some k = forall a. Some (k a) > > -- Derive a FromJSON instance for our 'DSum' > instance (FromJSON (Some f), Has' FromJSON f g) => FromJSON (DSum f g) where > parseJSON x = do > (jf, jg) <- parseJSON x > Some (f :: f a) <- parseJSON jf > g <- has' @FromJSON @g f (parseJSON jg) > return $ DSum f g > > main :: IO () > main = return () ``` constraints-extras-0.4.0.0/README.md0000755000000000000000000000442207346545000015201 0ustar0000000000000000constraints-extras [![travis-ci](https://api.travis-ci.org/obsidiansystems/constraints-extras.svg?branch=develop)](https://travis-ci.org/obsidiansystems/constraints-extras) ================== Example usage: -------------- ```haskell > {-# LANGUAGE GADTs #-} > {-# LANGUAGE KindSignatures #-} > {-# LANGUAGE PolyKinds #-} > {-# LANGUAGE ScopedTypeVariables #-} > {-# LANGUAGE TemplateHaskell #-} > {-# LANGUAGE TypeApplications #-} > {-# LANGUAGE TypeFamilies #-} > {-# LANGUAGE FlexibleContexts #-} > {-# LANGUAGE ConstraintKinds #-} > {-# LANGUAGE FlexibleInstances #-} > {-# LANGUAGE MultiParamTypeClasses #-} > {-# LANGUAGE UndecidableInstances #-} > {-# LANGUAGE ExistentialQuantification #-} > {-# LANGUAGE TypeFamilies #-} > > import Data.Aeson > import Data.Constraint.Forall > import Data.Constraint.Extras > import Data.Constraint.Extras.TH > > data A :: * -> * where > A_a :: A Int > A_b :: Int -> A () > > deriveArgDict ''A > > data B :: * -> * where > B_a :: A a -> A a -> B a > B_x :: Int -> B Int > > deriveArgDict ''B > > data V :: (* -> *) -> * where > V_a :: A Int -> V A > > deriveArgDict ''V > > data family Fam a :: * -> * > data instance Fam () :: * -> * where > FI :: Fam () Int > FB :: Fam () Bool > > deriveArgDict 'FI > -- this derives an instance Has c (Fam ()) by looking up the associated data instance. > > data DSum k f = forall a. DSum (k a) (f a) > > -- Derive a ToJSON instance for our 'DSum' > instance forall k f. > ( Has' ToJSON k f -- Given a value of type (k a), we can obtain an instance (ToJSON (f a)) > , ForallF ToJSON k -- For any (a), we have an instance (ToJSON (k a)) > ) => ToJSON (DSum k f) where > toJSON (DSum (k :: k a) f) = toJSON > ( whichever @ToJSON @k @a $ toJSON k -- Use the (ForallF ToJSON k) constraint to obtain the (ToJSON (k a)) instance > , has' @ToJSON @f k $ toJSON f -- Use the (Has' ToJSON k f) constraint to obtain the (ToJSON (f a)) instance > ) > > data Some k = forall a. Some (k a) > > -- Derive a FromJSON instance for our 'DSum' > instance (FromJSON (Some f), Has' FromJSON f g) => FromJSON (DSum f g) where > parseJSON x = do > (jf, jg) <- parseJSON x > Some (f :: f a) <- parseJSON jf > g <- has' @FromJSON @g f (parseJSON jg) > return $ DSum f g > > main :: IO () > main = return () ``` constraints-extras-0.4.0.0/Setup.hs0000644000000000000000000000005607346545000015352 0ustar0000000000000000import Distribution.Simple main = defaultMain constraints-extras-0.4.0.0/constraints-extras.cabal0000644000000000000000000000337407346545000020563 0ustar0000000000000000name: constraints-extras version: 0.4.0.0 synopsis: Utility package for constraints description: Convenience functions and TH for working with constraints. See for example usage. category: Constraints license: BSD3 license-file: LICENSE author: Cale Gibbard, Ali Abrar maintainer: maintainer@obsidian.systems homepage: https://github.com/obsidiansystems/constraints-extras bug-reports: https://github.com/obsidiansystems/constraints-extras/issues copyright: Obsidian Systems LLC build-type: Simple cabal-version: 2.0 tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1 || ==8.10.1 || ==9.0.1 || ==9.2.1 extra-source-files: README.md ChangeLog.md flag build-readme default: True library exposed-modules: Data.Constraint.Extras , Data.Constraint.Extras.TH , Data.Constraint.Compose , Data.Constraint.Flip other-extensions: LambdaCase , MultiParamTypeClasses , QuasiQuotes , TypeFamilies , TypeOperators , ConstraintKinds , TemplateHaskell build-depends: base >=4.9 && <4.18 , constraints >= 0.9 && < 0.14 , template-haskell >=2.11 && <2.20 hs-source-dirs: src default-language: Haskell2010 executable readme if !flag(build-readme) buildable: False build-depends: base , aeson , constraints , constraints-extras main-is: README.lhs ghc-options: -Wall -optL -q default-language: Haskell2010 source-repository head type: git location: git://github.com/obsidiansystems/constraints-extras.git constraints-extras-0.4.0.0/src/Data/Constraint/0000755000000000000000000000000007346545000017501 5ustar0000000000000000constraints-extras-0.4.0.0/src/Data/Constraint/Compose.hs0000644000000000000000000000071307346545000021443 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-} #endif module Data.Constraint.Compose ( ComposeC ) where import Data.Constraint -- | Composition for constraints. class p (f a) => ComposeC (p :: k2 -> Constraint) (f :: k1 -> k2) (a :: k1) instance p (f a) => ComposeC p f a constraints-extras-0.4.0.0/src/Data/Constraint/Extras.hs0000644000000000000000000001271507346545000021311 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} -- | Throughout this module, we use the following GADT and @ArgDict@ instance -- in our examples: -- -- > {-# LANGUAGE StandaloneDeriving #-} -- > -- > data Tag a where -- > I :: Tag Int -- > B :: Tag Bool -- > deriving instance Show (Tag a) -- > -- > $(deriveArgDict ''Tag) -- -- The constructors of @Tag@ mean that a type variable @a@ in @Tag a@ -- must come from the set { @Int@, @Bool@ }. We call this the "set of -- types @a@ that could be applied to @Tag@". module Data.Constraint.Extras ( -- * The Has typeclass Has(..) , argDict' , argDictV -- * Bringing instances into scope , Has' , has' , HasV , hasV , whichever -- * Misc , Implies1(..) ) where import Data.Constraint import Data.Constraint.Compose import Data.Constraint.Flip import Data.Constraint.Forall import Data.Functor.Sum (Sum(..)) import Data.Kind import GHC.Generics ((:+:)(..)) -- | The constraint @Has c f@ means that given any value of type @f a@, we can determine -- that there is an instance of @c a@. For example, @Has Show Tag@ means that given any -- @x :: Tag a@, we can conclude @Show a@. Most commonly, the type @f@ will be a GADT, -- where we can enumerate all the possible index types through pattern matching, and -- discover that there is an appropriate instance in each case. In this sort of -- situation, the @c@ can be left entirely polymorphic in the instance for @Has@, and -- this is the sort of instance that the provided Template Haskell code writes. -- It is also sometimes possible to hand-write instances of @Has c f@ for specific -- classes @c@ in cases where @f@ is a data type that packs an appropriate dictionary -- into its constructors. class Has c f where -- | Use the @f a@ to show that there is an instance of @c a@, and -- bring it into scope. -- -- The order of type variables is chosen to work -- with @-XTypeApplications@. -- -- > -- Hold a value of type a, along with a tag identifying the a. -- > data SomeTagged tag where -- > SomeTagged :: a -> tag a -> SomeTagged tag -- > -- > -- Use the stored tag to identify the thing we have, allowing us to call 'show'. Note that we -- > -- have no knowledge of the tag type. -- > showSomeTagged :: Has Show tag => SomeTagged tag -> String -- > showSomeTagged (SomeTagged a tag) = has @Show tag $ show a has :: forall a r. f a -> (c a => r) -> r has x r | Dict <- argDict @c x = r -- | Use an @f a@ to obtain a dictionary for @c a@ -- -- > argDict @Show I :: Dict (Show Int) argDict :: forall a. f a -> Dict (c a) argDict x = has @c x Dict {-# MINIMAL has | argDict #-} -- | @since 0.3.2.0 instance (Has c f, Has c g) => Has c (f :+: g) where argDict = \case L1 f -> argDict f R1 g -> argDict g -- | @since 0.3.2.0 instance (Has c f, Has c g) => Has c (Sum f g) where argDict = \case InL f -> argDict f InR g -> argDict g -- | The constraint @Has' c f g@ means that given a value of type @f a@, we can satisfy the constraint @c (g a)@. type Has' (c :: k -> Constraint) f (g :: k' -> k) = Has (ComposeC c g) f -- | The constraint @HasV c f g@ means that given a value of type @f v@, we can satisfy the constraint @c (v g)@. type HasV c f g = Has (FlipC (ComposeC c) g) f -- | Get a dictionary for @c (g a)@, using a value of type @f a@. -- -- > argDict' @Show @Identity B :: Dict (Show (Identity Bool)) argDict' :: forall c g f a. (Has' c f g) => f a -> Dict (c (g a)) argDict' x = has @(ComposeC c g) x Dict -- | Get a dictionary for @c (v g)@, using a value of type @f v@. argDictV :: forall f c g v. (HasV c f g) => f v -> Dict (c (v g)) argDictV x = has @(FlipC (ComposeC c) g) x Dict -- | Like 'has', but we get a @c (g a)@ instance brought into scope -- instead. Use @-XTypeApplications@ to specify @c@ and @g@. -- -- > -- From dependent-sum:Data.Dependent.Sum -- > data DSum tag f = forall a. !(tag a) :=> f a -- > -- > -- Show the value from a dependent sum. (We'll need 'whichever', discussed later, to show the key.) -- > showDSumVal :: forall tag f . Has' Show tag f => DSum tag f -> String -- > showDSumVal (tag :=> fa) = has' @Show @f tag $ show fa has' :: forall c g f a r. (Has' c f g) => f a -> (c (g a) => r) -> r has' k r = has @(ComposeC c g) k r -- | Similar to 'has', but given a value of type @f v@, we get a @c (v g)@ instance brought into scope instead. hasV :: forall c g f v r. (HasV c f g) => f v -> (c (v g) => r) -> r hasV k r = has @(FlipC (ComposeC c) g) k r -- | Given "forall a. @c (t a)@" (the @ForallF c t@ constraint), select a -- specific @a@, and bring @c (t a)@ into scope. Use @-XTypeApplications@ to -- specify @c@, @t@ and @a@. -- -- > -- Show the tag of a dependent sum, even though we don't know the tag type. -- > showDSumKey :: forall tag f . ForallF Show tag => DSum tag f -> String -- > showDSumKey ((tag :: tag a) :=> fa) = whichever @Show @tag @a $ show tag whichever :: forall c t a r. ForallF c t => (c (t a) => r) -> r whichever r = r \\ (instF :: ForallF c t :- c (t a)) -- | Allows explicit specification of constraint implication. class Implies1 c d where implies1 :: c a :- d a constraints-extras-0.4.0.0/src/Data/Constraint/Extras/0000755000000000000000000000000007346545000020747 5ustar0000000000000000constraints-extras-0.4.0.0/src/Data/Constraint/Extras/TH.hs0000644000000000000000000001104407346545000021616 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module Data.Constraint.Extras.TH (deriveArgDict, deriveArgDictV, gadtIndices) where import Data.Constraint import Data.Constraint.Extras import Data.Maybe import Control.Monad import Language.Haskell.TH deriveArgDict :: Name -> Q [Dec] deriveArgDict n = do (typeHead, constrs) <- getDeclInfo n c <- newName "c" ts <- gadtIndices c constrs let constraints = flip map ts $ \case Left t -> AppT (AppT (ConT ''Has) (VarT c)) t Right t -> (AppT (VarT c) t) ms <- matches c constrs 'argDict return [ InstanceD Nothing constraints (AppT (AppT (ConT ''Has) (VarT c)) typeHead) [ ValD (VarP 'argDict) (NormalB (LamCaseE ms)) [] ] ] {-# DEPRECATED deriveArgDictV "Just use 'deriveArgDict'" #-} deriveArgDictV :: Name -> Q [Dec] deriveArgDictV = deriveArgDict matches :: Name -> [Con] -> Name -> Q [Match] matches c constrs argDictName = do x <- newName "x" fmap concat . forM constrs $ \case GadtC [name] _ _ -> return $ [Match (RecP name []) (NormalB $ ConE 'Dict) []] ForallC _ _ (GadtC [name] bts (AppT _ (VarT b))) -> do ps <- forM bts $ \case (_, AppT t (VarT b')) | b == b' -> do hasArgDictInstance <- not . null <$> reifyInstances ''Has [VarT c, t] return $ if hasArgDictInstance then Just x else Nothing _ -> return Nothing return $ case catMaybes ps of [] -> [Match (RecP name []) (NormalB $ ConE 'Dict) []] (v:_) -> let patf = \v' rest done -> if done then WildP : rest done else case v' of Nothing -> WildP : rest done Just _ -> VarP v : rest True pat = foldr patf (const []) ps False in [Match (conPCompat name pat) (NormalB $ AppE (VarE argDictName) (VarE v)) []] ForallC _ _ (GadtC [name] _ _) -> return $ [Match (RecP name []) (NormalB $ ConE 'Dict) []] a -> error $ "deriveArgDict matches: Unmatched 'Dec': " ++ show a conPCompat :: Name -> [Pat] -> Pat conPCompat name = ConP name #if MIN_VERSION_template_haskell(2, 18, 0) [] #endif kindArity :: Kind -> Int kindArity = \case ForallT _ _ t -> kindArity t AppT (AppT ArrowT _) t -> 1 + kindArity t SigT t _ -> kindArity t ParensT t -> kindArity t _ -> 0 getDeclInfo :: Name -> Q (Type, [Con]) getDeclInfo n = reify n >>= \case TyConI (DataD _ _ ts mk constrs _) -> do let arity = fromMaybe 0 (fmap kindArity mk) + length ts tyVars <- replicateM (arity - 1) (newName "a") let typeHead = foldr (\v x -> AppT x (VarT v)) (ConT n) tyVars return (typeHead, constrs) DataConI _ (AppT typeHead _) parent -> handleParent typeHead parent DataConI _ (ForallT _ _ (AppT typeHead _)) parent -> handleParent typeHead parent a -> error $ "getDeclInfo: Unmatched 'Info': " ++ show a where handleParent typeHead parent = reify parent >>= \case FamilyI _ instances -> do let instCons :: InstanceDec -> [Con] instCons = \case DataInstD _ _ _ _ cons _ -> cons NewtypeInstD _ _ _ _ con _ -> [con] _ -> error $ "getDeclInfo: Expected a data or newtype family instance" conNames :: Con -> [Name] conNames = \case NormalC other _ -> [other] RecC other _ -> [other] InfixC _ other _ -> [other] ForallC _ _ con -> conNames con GadtC others _ _ -> others RecGadtC others _ _ -> others instHasThisConstructor i = any (== n) $ conNames =<< instCons i case filter instHasThisConstructor instances of [] -> error $ "getDeclInfo: Couldn't find data family instance for constructor " ++ show n l@(_:_:_) -> error $ "getDeclInfo: Expected one data family instance for constructor " ++ show n ++ " but found multiple: " ++ show l [i] -> return (typeHead, instCons i) a -> error $ "getDeclInfo: Unmatched parent of data family instance: " ++ show a gadtIndices :: Name -> [Con] -> Q [Either Type Type] gadtIndices c constrs = fmap concat $ forM constrs $ \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 ''Has [VarT c, t] return $ if hasArgDictInstance then [Left t] else [] _ -> return [] ForallC _ _ (GadtC _ _ (AppT _ typ)) -> return [Right typ] _ -> return [] constraints-extras-0.4.0.0/src/Data/Constraint/Flip.hs0000644000000000000000000000066207346545000020733 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE UndecidableSuperClasses #-} #endif module Data.Constraint.Flip ( FlipC ) where import Data.Constraint -- | Flip for constraints. class c h g => FlipC (c :: k -> k' -> Constraint) (g :: k') (h :: k) instance c h g => FlipC c g h