constraints-extras-0.3.0.2/0000755000000000000000000000000013544535330013720 5ustar0000000000000000constraints-extras-0.3.0.2/README.md0000644000000000000000000000371113544535330015201 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 FlexibleInstances #-} > {-# LANGUAGE MultiParamTypeClasses #-} > {-# LANGUAGE UndecidableInstances #-} > {-# LANGUAGE ExistentialQuantification #-} > > 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 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.3.0.2/LICENSE0000644000000000000000000000300513544535330014723 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.3.0.2/constraints-extras.cabal0000644000000000000000000000337013544535330020562 0ustar0000000000000000name: constraints-extras version: 0.3.0.2 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 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 other-modules: Data.Constraint.Flip other-extensions: LambdaCase , MultiParamTypeClasses , QuasiQuotes , TypeFamilies , TypeOperators , ConstraintKinds , TemplateHaskell build-depends: base >=4.9 && <4.14 , constraints >= 0.9 && < 0.12 , template-haskell >=2.11 && <2.16 hs-source-dirs: src default-language: Haskell2010 executable readme if !flag(build-readme) buildable: False build-depends: base >=4.9 && <4.14 , aeson , constraints >= 0.9 && < 0.12 , 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.3.0.2/Setup.hs0000644000000000000000000000005613544535330015355 0ustar0000000000000000import Distribution.Simple main = defaultMain constraints-extras-0.3.0.2/ChangeLog.md0000644000000000000000000000156313544535330016076 0ustar0000000000000000# Revision history for constraints-extras ## 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.3.0.2/README.lhs0000644000000000000000000000371113544535330015367 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 FlexibleInstances #-} > {-# LANGUAGE MultiParamTypeClasses #-} > {-# LANGUAGE UndecidableInstances #-} > {-# LANGUAGE ExistentialQuantification #-} > > 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 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.3.0.2/src/0000755000000000000000000000000013544535330014507 5ustar0000000000000000constraints-extras-0.3.0.2/src/Data/0000755000000000000000000000000013544535330015360 5ustar0000000000000000constraints-extras-0.3.0.2/src/Data/Constraint/0000755000000000000000000000000013544535330017504 5ustar0000000000000000constraints-extras-0.3.0.2/src/Data/Constraint/Compose.hs0000644000000000000000000000071313544535330021446 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.3.0.2/src/Data/Constraint/Flip.hs0000644000000000000000000000066213544535330020736 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 constraints-extras-0.3.0.2/src/Data/Constraint/Extras.hs0000644000000000000000000000572513544535330021317 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} module Data.Constraint.Extras where import Data.Constraint import Data.Constraint.Compose import Data.Constraint.Flip import Data.Constraint.Forall -- | Morally, this class is for GADTs whose indices can be finitely enumerated. It provides operations which will -- select the appropriate type class dictionary from among a list of contenders based on a value of the type. -- There are a few different variations of this which we'd like to be able to support, and they're all implemented -- in the same fashion at the term level, by pattern matching on the constructors of the GADT, and producing Dict -- as the result. -- It would be nice to have some way to stop the proliferation of these variants and unify the existing ones, but -- 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 (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. (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. (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 c = ArgDict f c 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 has' :: forall c g f a r. (Has' c f g) => f a -> (c (g a) => r) -> r has' k r | (Dict :: Dict (c (g a))) <- argDict' k = r hasV :: forall c g f v r. (HasV c f g) => f v -> (c (v g) => r) -> r hasV k r | (Dict :: Dict (c (v g))) <- argDictV k = r 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.3.0.2/src/Data/Constraint/Extras/0000755000000000000000000000000013544535330020752 5ustar0000000000000000constraints-extras-0.3.0.2/src/Data/Constraint/Extras/TH.hs0000644000000000000000000000662113544535330021626 0ustar0000000000000000{-# 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 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) l = length xs constraints = foldl AppT (TupleT l) xs arity <- tyConArity n tyVars <- replicateM (arity - 1) (newName "a") let n' = foldr (\v x -> AppT x (VarT v)) (ConT n) tyVars [d| instance ArgDict $(varT c) $(pure n') where type ConstraintsFor $(pure n') $(varT c) = $(pure constraints) argDict = $(LamCaseE <$> matches c n 'argDict) |] {-# DEPRECATED deriveArgDictV "Just use 'deriveArgDict'" #-} deriveArgDictV :: Name -> Q [Dec] deriveArgDictV = deriveArgDict matches :: Name -> Name -> Name -> Q [Match] matches c n argDictName = do x <- newName "x" reify n >>= \case TyConI (DataD _ _ _ _ constrs _) -> 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 ''ArgDict [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 (ConP 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 a -> error $ "deriveArgDict matches: Unmatched 'Info': " ++ show a 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 tyConArity :: Name -> Q Int tyConArity n = reify n >>= return . \case 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 -> Name -> Q [Either Type Type] gadtIndices c n = reify n >>= \case TyConI (DataD _ _ _ _ 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 ''ArgDict [VarT c, t] return $ if hasArgDictInstance then [Left t] else [] _ -> return [] ForallC _ _ (GadtC _ _ (AppT _ typ)) -> return [Right typ] _ -> return [] a -> error $ "gadtIndices: Unmatched 'Info': " ++ show a