packages feed

constrained-dynamic (empty) → 0.1.0.0

raw patch · 9 files changed

+667/−0 lines, 9 filesdep +basedep +constrained-dynamicdep +tastysetup-changed

Dependencies added: base, constrained-dynamic, tasty, tasty-hunit

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2016 Julian Hall++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ constrained-dynamic.cabal view
@@ -0,0 +1,32 @@+name:                constrained-dynamic+version:             0.1.0.0+synopsis:            Dynamic typing with retained constraints+description:         Like Data.Dynamic, but extended to allow the specification+                     of arbitrary constraints using ConstraintKinds.+license:             MIT+license-file:        LICENSE+author:              Julian Hall+maintainer:          kindlangdev@googlemail.com+category:            Data+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Data.ConstrainedDynamic,+                       Data.MultiConstrainedDynamic,+                       Data.Type.HasClass,+                       Data.Type.HasClassPreludeInstances,+                       Data.Type.LTDict+  build-depends:       base >=4.8 && <5+  hs-source-dirs:      src+  default-language:    Haskell2010++test-suite constrained-dynamic-tests+  default-language:    Haskell2010+  hs-source-dirs:      tests+  type:                exitcode-stdio-1.0+  main-is:             Main.hs+  build-depends:       base >= 4.8 && <5,+                       constrained-dynamic,+                       tasty >= 0.10 && < 1,+                       tasty-hunit >= 0.9 && < 1
+ src/Data/ConstrainedDynamic.hs view
@@ -0,0 +1,112 @@+-- Copyright 2016 Julian Hall.  See LICENSE file at top level for details.++-- TODO - are we still using all of these extensions?+{-# LANGUAGE GADTs,ConstraintKinds,RankNTypes,FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables,KindSignatures #-}+{-# LANGUAGE TypeFamilies,MultiParamTypeClasses,UndecidableInstances #-}++-- | Provides a container type similar to "Data.Dynamic" but which retains+-- information about a typeclass (or other constraint) that is known to+-- be available for the type of the object contained inside.+module Data.ConstrainedDynamic (+                 -- * Types+                 ClassConstraint(..),ConstrainedDynamic,+                 -- * Functions that mirror functions in Data.Dynamic+                 toDyn,fromDynamic,fromDyn,dynTypeRep,+                 -- * Extended API for managing and using class constraints+                 dynConstraintType,applyClassFn,classCast+                 )+    where++import Data.Typeable+import GHC.Exts (Constraint)+import Unsafe.Coerce++-- fixme should we use kind polyorphism here?+-- note that this is not exported as a similar definition is often used elsewhere+data TDict :: (* -> Constraint) -> * -> * where+    TDict :: cs t => TDict cs t++-- | A type used to represent class constraints as values.  This exists+-- primarily so that @typeOf (ClassConstraint :: ClassConstraint cs)@ can be+-- used to obtain a 'TypeRep' that uniquely identifies a typeclass.+data ClassConstraint (cs :: * -> Constraint) = ClassConstraint++-- | A type that contains a value whose type is unknown at compile time,+-- except that it satisfies a given constraint.  For example, a value of+-- @ConstrainedDynamic Show@ could contain a value of any type for which an+-- instance of the typeclass 'Show' is available.+data ConstrainedDynamic (cs :: * -> Constraint) where+    ConsDyn :: (Typeable a, cs a, Typeable cs) =>+               a -> TDict cs a -> ConstrainedDynamic cs++--+-- functions that mirror the functions in Data.Dynamic+--++-- | Create a 'ConstrainedDynamic' for a given value.  Note that this+-- function must be used in a context where the required constraint+-- type can be determined, for example by explicitly identifying the+-- required type using the form @toDyn value :: ConstrainedDynamic TypeClass@.+toDyn :: (Typeable a, cs a, Typeable cs) => a -> ConstrainedDynamic cs+toDyn obj = ConsDyn obj TDict++-- | Extract a value 'ConstrainedDynamic' to a particular type if and only if+-- the value contained with in it has that type, returning @'Just' v@ if the+-- value @v@ has the correct type or @'Nothing'@ otherwise,+fromDynamic :: (Typeable a, cs a) => ConstrainedDynamic cs -> Maybe a+fromDynamic (ConsDyn obj _) = cast obj++-- | Extract a value 'ConstrainedDynamic' to a particular type if and only if+-- the value contained with in it has that type, returning the value if it has+-- the correct type or a default value otherwise.+fromDyn :: (Typeable a, cs a) => ConstrainedDynamic cs -> a -> a+fromDyn d def = maybe def id $ fromDynamic d++-- | Return the 'TypeRep' for the type of value contained within a+-- 'ConstrainedDynamic'.+dynTypeRep :: ConstrainedDynamic cs -> TypeRep+dynTypeRep (ConsDyn obj _) = typeOf obj++-- extended API for handling constraints++-- | Return a 'TypeRep' that uniquely identifies the type of constraint+-- used in the 'ConstrainedDynamic'.  The actual type whose representation+-- is returned is @ClassConstraint c@ where @c@ is the constraint.+dynConstraintType :: forall a . Typeable a => ConstrainedDynamic a -> TypeRep+dynConstraintType _ = typeOf (ClassConstraint :: ClassConstraint a)++-- | Apply a polymorphic function that accepts all values matching the+-- appropriate constraint to the value stored inside a 'ConstrainedDynamic'+-- and return its result.  Note that this *must* be a polymorphic function+-- with only a single argument that is constrained by the constrain, so+-- for example the function 'show' from the typeclass 'Show' is allowable,+-- but '==' from the typeclass 'Eq' would not work as it requires a+-- second argument that has the same type as the first, and it is not+-- possible to safely return the partially-applied function as its type is+-- not known in the calling context.+applyClassFn :: ConstrainedDynamic cs -> (forall a . cs a => a -> b) -> b+applyClassFn (ConsDyn obj TDict) f = f obj++-- fixme: what about subtypes?++-- | If a 'ConstrainedDynamic' has an unknown constraint variable, 'classCast'+-- can be used to convert it to a 'ConstrainedDynamic' with a known constraint.+-- For example, @classCast d :: Maybe (ConstrainedDynamic Show)@ returns+-- @'Just' d :: Maybe (ConstrainedDynamic Show)@ if @d@s constraint was 'Show'+-- or 'Nothing' if it was any other constraint.+classCast :: forall a b . (Typeable a, Typeable b) =>+             ConstrainedDynamic a -> Maybe (ConstrainedDynamic b)+classCast d+    | dynConstraintType d == typeOf(ClassConstraint :: ClassConstraint b)+         = Just (unsafeCoerce d)+    | otherwise+         = Nothing++-- | An instance of 'Show' for 'ConstrainedDynamic': delegates to the+-- contained value's definition of 'showsPrec' if the constraint is+-- 'Show', or shows the type of the contained value otherwise.+instance Typeable cs => Show (ConstrainedDynamic cs) where+    showsPrec i d = case classCast d :: Maybe (ConstrainedDynamic Show) of+                      Just (ConsDyn obj TDict) -> showsPrec i obj+                      Nothing                  -> showsPrec i (dynTypeRep d)
+ src/Data/MultiConstrainedDynamic.hs view
@@ -0,0 +1,146 @@+-- Copyright 2016 Julian Hall.  See LICENSE file at top level for details.++-- TODO - are we still using all of these extensions?+{-# LANGUAGE GADTs,ConstraintKinds,RankNTypes,FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables,KindSignatures,PolyKinds #-}+{-# LANGUAGE TypeFamilies,MultiParamTypeClasses,UndecidableInstances #-}+{-# LANGUAGE DataKinds,TypeOperators,FlexibleContexts #-}++-- | Provides a container type similar to "Data.Dynamic" but which retains+-- information about a list of typeclass (or other constraint) that are known to+-- be available for the type of the object contained inside.+module Data.MultiConstrainedDynamic (+                 -- * Types+                 ClassConstraint(..),MCDynamic,+                 -- * Functions that mirror functions in Data.Dynamic+                 toDyn,fromDynamic,fromDyn,dynTypeRep,+                 -- * Extended API for managing and using class constraints+                 dynConstraintTypes,dynAllConstraintTypes,+                 dynUnmatchedConstraintTypes,applyClassFn+                 )+    where++import Data.Typeable+import GHC.Exts (Constraint)+import Unsafe.Coerce+import Data.ConstrainedDynamic(ClassConstraint(..))+import Data.Type.HasClass+import Data.Type.LTDict++-- | A type that contains a value whose type is unknown at compile time,+-- but for which it is known whether or not it satisfies any of a list of+-- constraints, thus allowing operations to be performed when those+-- constraints are satisfied.+data MCDynamic (cs :: [* -> Constraint]) where+    ConsMCD :: (Typeable a, Typeable cs) =>+               a -> LTDict cs a -> MCDynamic cs++--+-- functions that mirror the functions in Data.Dynamic+--++-- | Create an 'MCDynamic' for a given value.  Note that this+-- function must be used in a context where the required list of constraint+-- types can be determined, for example by explicitly identifying the+-- required type using the form @toDyn value :: MCDynamic [TypeClass,...]@.+--+-- Additionally, there must be appropriate instances of the type class 'HasClass'+-- that describe instances available for type classes that are to be used+-- with the dynamic object and the type to be included in it.  In most+-- circumstances you should at least import @Data.Type.HasClassPreludeInstances@+-- to allow the use of instances of standard Prelude classes and types.+toDyn :: (Typeable a, Typeable cs, LTDictBuilder LTDict cs a) =>+         a -> MCDynamic (cs :: [* -> Constraint])+toDyn obj = ConsMCD obj buildLTDict++-- | Extract a value 'MCDynamic' to a particular type if and only if+-- the value contained with in it has that type, returning @'Just' v@ if the+-- value @v@ has the correct type or @'Nothing'@ otherwise,+fromDynamic :: Typeable a => MCDynamic css -> Maybe a+fromDynamic (ConsMCD obj _) = cast obj++-- | Extract a value 'MCDynamic' to a particular type if and only if+-- the value contained with in it has that type, returning the value if it has+-- the correct type or a default value otherwise.+fromDyn :: Typeable a => MCDynamic cs -> a -> a+fromDyn d def = maybe def id $ fromDynamic d++-- | Return the 'TypeRep' for the type of value contained within a+-- 'MCDynamic'.+dynTypeRep :: MCDynamic cs -> TypeRep+dynTypeRep (ConsMCD obj _) = typeOf obj++-- extended API for handling constraints++-- | Return a list of 'TypeRep's that uniquely identify the constraints+-- from an 'MCDynamic's type arguments that are satisfied by the value+-- contained inside the 'MCDynamic'.  The actual type whose representation+-- is returned for each constraint is is @ClassConstraint c@ where @c@ is+-- the constraint.+dynConstraintTypes :: LTDictConstraintLister a  => MCDynamic a -> [TypeRep]+dynConstraintTypes (ConsMCD _  ltd) = getMatchedConstraints ltd++-- | Return a list of 'TypeRep's that uniquely identify the constraints+-- from an 'MCDynamic's type arguments, whether or not they are satisfied by+-- the value contained inside the 'MCDynamic'.  The actual type whose+-- representation is returned for each constraint is is @ClassConstraint c@+-- where @c@ is the constraint.+dynAllConstraintTypes :: LTDictConstraintLister a => MCDynamic a -> [TypeRep]+dynAllConstraintTypes (ConsMCD _  ltd) = getAllConstraints ltd++-- | Return a list of 'TypeRep's that uniquely identify the constraints+-- from an 'MCDynamic's type arguments, that are not satisfied by+-- the value contained inside the 'MCDynamic'.  The actual type whose+-- representation is returned for each constraint is is @ClassConstraint c@+-- where @c@ is the constraint.+dynUnmatchedConstraintTypes :: LTDictConstraintLister a =>+                               MCDynamic a -> [TypeRep]+dynUnmatchedConstraintTypes (ConsMCD _  ltd) = getUnmatchedConstraints ltd+++-- | Apply a polymorphic function that accepts all values matching a+-- constraint to the value stored inside an 'MCDynamic' wherever possible.+-- If the constraint is satisfied, returns @'Just' r@, where r is the result+-- of the function.  If the constraint is not satisfied, returns 'Nothing'.+--+-- Note that the function *must* be a polymorphic function+-- with only a single argument that is constrained by the constraint, so+-- for example the function 'show' from the typeclass 'Show' is allowable,+-- but '==' from the typeclass 'Eq' would not work as it requires a+-- second argument that has the same type as the first, and it is not+-- possible to safely return the partially-applied function as its type is+-- not known in the calling context.+applyClassFn :: LTDictSearch css cs => MCDynamic css -> ClassConstraint cs ->+                (forall a . (cs a,Typeable a) => a -> b) -> Maybe b+applyClassFn (ConsMCD obj ltd) pcs f =+    case ltdSearch pcs ltd of+      JustHasClass -> Just $ f obj+      DoesNotHaveClass -> Nothing++-- To do: cast MCDynamics between different constraint lists++-- | An instance of 'Show' for 'MCDynamic': delegates to the+-- contained value's definition of 'showsPrec' if an instance of Show+-- is available, or displays the type of the item and its list of available+-- instances otherwise.+instance (LTDictSearch css Show, LTDictConstraintLister css) =>+    Show (MCDynamic css) where+        showsPrec i d@(ConsMCD obj ltd) =+            case ltdSearch (ClassConstraint :: ClassConstraint Show) ltd of+              JustHasClass -> showsPrec i obj+              DoesNotHaveClass -> showsPrec i (dynTypeRep d) .+                                  showString " " .+                                  showsPrec i (dynConstraintTypes d)++-- | An instance of 'Eq' for 'MCDynamic': unwrap the right hand side+-- to the same type as the left (if possible) and if it matches, delegate to the+-- left hand item's instance of 'Eq' if one is available.  If either condition+-- fails, return 'False'.+instance LTDictSearch css Eq => Eq (MCDynamic css) where+    (ConsMCD objL ltd) == (ConsMCD objR _) =+        case cast objR of+          Nothing    -> False+          Just objRT ->+              case ltdSearch (ClassConstraint :: ClassConstraint Eq) ltd of+                JustHasClass     -> objL == objRT+                DoesNotHaveClass -> False
+ src/Data/Type/HasClass.hs view
@@ -0,0 +1,40 @@+-- Copyright 2016 Julian Hall.  See LICENSE file at top level for details.++{-# LANGUAGE DataKinds,MultiParamTypeClasses,ConstraintKinds #-}+{-# LANGUAGE FunctionalDependencies,KindSignatures,TypeFamilies #-}+{-# LANGUAGE FlexibleInstances,PolyKinds,GADTs,UndecidableInstances #-}++module Data.Type.HasClass where++import GHC.Exts(Constraint)+import Data.Proxy++-- | Stores a constraint context.  When pattern matched upon, the compiler+-- knows the constraint is true.+data TDict (c :: k -> Constraint) (t :: k) where+    TDict :: c t => TDict c t++-- | Identifies whether or not a type has an instance of a type class,+-- and provides a standard means for capturing a context that allows them+-- to be used.+-- Unfortunately, because instances cannot be selected on the basis of+-- whether a context matches, instances of this class need to be listed manually+-- whenever we need to modify behaviour depending on whether an instance+-- of a class is available or not.  If a class @c@ has an instance for type @t@+-- there should be an @instance HasClass c t True where classDict _ _ _  = TDict@.+-- For cases where additional context is required, see examples in the+-- @Data.Type.HasClassPreludeInstances@ module.+class HasClass (c :: k -> Constraint) (t :: k) (b :: Bool) | c t -> b where+    classDict :: Proxy c -> Proxy t -> Proxy b -> TDict c t++-- | Default instance for types and classes that do not have an available+-- instance.+instance {-# OVERLAPPABLE #-} False ~ b => HasClass c t b where+    classDict _ _ _ = undefined++-- | Combine type level 'Bool's.  @And a b c@ has an instance @And a b True@+-- if and only if both @a@ and @b@ are 'True', and @And a b False@ otherwise.+class And (a :: Bool) (b :: Bool) (c :: Bool) | a b -> c+instance And True b b+instance And False b False+
+ src/Data/Type/HasClassPreludeInstances.hs view
@@ -0,0 +1,165 @@+-- Copyright 2016 Julian Hall.  See LICENSE file at top level for details.++{-# LANGUAGE DataKinds,FlexibleInstances,MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts,TypeFamilies,UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes,ScopedTypeVariables #-}++-- | Provides instances of the type class 'HasClass' for common+-- single-parameter type classes contained in the Prelude.  Note that+-- instances for tuple types are *not* currently included due to the very large+-- number of somewhat complex classes that would be required.++module Data.Type.HasClassPreludeInstances where++import Data.Type.HasClass+import Data.Proxy++instance HasClass Bounded Word True where classDict _ _ _ = TDict+instance HasClass Bounded Ordering True where classDict _ _ _ = TDict+instance HasClass Bounded Int True where classDict _ _ _ = TDict+instance HasClass Bounded Char True where classDict _ _ _ = TDict+instance HasClass Bounded Bool True where classDict _ _ _ = TDict++instance HasClass Enum Word True where classDict _ _ _ = TDict+instance HasClass Enum Ordering True where classDict _ _ _ = TDict+instance HasClass Enum Integer True where classDict _ _ _ = TDict+instance HasClass Enum Int True where classDict _ _ _ = TDict+instance HasClass Enum Char True where classDict _ _ _ = TDict+instance HasClass Enum Bool True where classDict _ _ _ = TDict+instance HasClass Enum () True where classDict _ _ _ = TDict+instance HasClass Enum Float True where classDict _ _ _ = TDict+instance HasClass Enum Double True where classDict _ _ _ = TDict++instance HasClass Eq a f1 => HasClass Eq [a] f1 where+    classDict peq _ _ =+        case classDict peq (Proxy :: Proxy a) (Proxy :: Proxy f1) of+          TDict -> TDict+instance HasClass Eq Word True where classDict _ _ _ = TDict+instance HasClass Eq Ordering True where  classDict _ _ _ = TDict+instance HasClass Eq Int True where  classDict _ _ _ = TDict+instance HasClass Eq Float True where  classDict _ _ _ = TDict+instance HasClass Eq Double True where  classDict _ _ _ = TDict+instance HasClass Eq Char True where  classDict _ _ _ = TDict+instance HasClass Eq Bool True where  classDict _ _ _ = TDict+instance HasClass Eq a f1 => HasClass Eq (Maybe a) f1 where+    classDict peq _ _ =+        case classDict peq (Proxy :: Proxy a) (Proxy :: Proxy f1) of+          TDict -> TDict+instance (HasClass Eq a f1, HasClass Eq b f2, And f1 f2 f3) =>+    HasClass Eq (Either a b) f3 where+        classDict peq _ _ =+            case classDict peq (Proxy :: Proxy a) (Proxy :: Proxy f1) of+              TDict ->+                  case classDict peq (Proxy :: Proxy b) (Proxy :: Proxy f2) of+                    TDict -> TDict++instance HasClass Fractional Float True where classDict _ _ _ = TDict+instance HasClass Fractional Double True where classDict _ _ _ = TDict++instance HasClass Floating Float True where classDict _ _ _ = TDict+instance HasClass Floating Double True where classDict _ _ _ = TDict++instance HasClass Integral Word True where classDict _ _ _ = TDict+instance HasClass Integral Integer True where classDict _ _ _ = TDict+instance HasClass Integral Int True where classDict _ _ _ = TDict++instance HasClass Monoid [a] True where classDict _ _ _ = TDict+instance HasClass Monoid Ordering True where classDict _ _ _ = TDict+instance HasClass Monoid a f1 => HasClass Monoid (Maybe a) f1 where+    classDict p _ _ =+        case classDict p (Proxy :: Proxy a) (Proxy :: Proxy f1) of+          TDict -> TDict+instance HasClass Monoid b f1 => HasClass Monoid (a -> b) f1 where+    classDict p _ _ =+        case classDict p (Proxy :: Proxy b) (Proxy :: Proxy f1) of+          TDict -> TDict++instance HasClass Num Word True where classDict _ _ _ = TDict+instance HasClass Num Integer True where classDict _ _ _ = TDict+instance HasClass Num Int True where classDict _ _ _ = TDict+instance HasClass Num Float True where classDict _ _ _ = TDict+instance HasClass Num Double True where classDict _ _ _ = TDict++instance HasClass Ord a f1 => HasClass Ord [a] f1 where+    classDict p _ _ =+        case classDict p (Proxy :: Proxy a) (Proxy :: Proxy f1) of+          TDict -> TDict+instance HasClass Ord Word True where classDict _ _ _ = TDict+instance HasClass Ord Ordering True where classDict _ _ _ = TDict+instance HasClass Ord Int True where classDict _ _ _ = TDict+instance HasClass Ord Float True where classDict _ _ _ = TDict+instance HasClass Ord Double True where classDict _ _ _ = TDict+instance HasClass Ord Char True where classDict _ _ _ = TDict+instance HasClass Ord Bool True where classDict _ _ _ = TDict+instance HasClass Ord Integer True where classDict _ _ _ = TDict+instance (HasClass Ord a f1, HasClass Ord b f2, And f1 f2 f3) =>+    HasClass Ord (Either a b) f3 where+        classDict p _ _ =+            case classDict p (Proxy :: Proxy a) (Proxy :: Proxy f1) of+              TDict ->+                  case classDict p (Proxy :: Proxy b) (Proxy :: Proxy f2) of+                    TDict -> TDict+instance HasClass Ord a f1 => HasClass Ord (Maybe a) f1 where+    classDict p _ _ =+        case classDict p (Proxy :: Proxy a) (Proxy :: Proxy f1) of+          TDict -> TDict++instance HasClass Read a f1 => HasClass Read [a] f1 where+    classDict p _ _ =+        case classDict p (Proxy :: Proxy a) (Proxy :: Proxy f1) of+          TDict -> TDict+instance HasClass Read Word True where classDict _ _ _ = TDict+instance HasClass Read Ordering True where classDict _ _ _ = TDict+instance HasClass Read a f1 => HasClass Read (Maybe a) f1 where+    classDict p _ _ =+        case classDict p (Proxy :: Proxy a) (Proxy :: Proxy f1) of+          TDict -> TDict+instance HasClass Read Integer True where classDict _ _ _ = TDict+instance HasClass Read Int True where classDict _ _ _ = TDict+instance HasClass Read Float True where classDict _ _ _ = TDict+instance HasClass Read Double True where classDict _ _ _ = TDict+instance HasClass Read Char True where classDict _ _ _ = TDict+instance HasClass Read Bool True where classDict _ _ _ = TDict+instance (HasClass Read a f1, HasClass Read b f2, And f1 f2 f3) =>+    HasClass Read (Either a b) f3 where+        classDict p _ _ =+            case classDict p (Proxy :: Proxy a) (Proxy :: Proxy f1) of+              TDict ->+                  case classDict p (Proxy :: Proxy b) (Proxy :: Proxy f2) of+                    TDict -> TDict++instance HasClass Real Word True where classDict _ _ _ = TDict+instance HasClass Real Integer True where classDict _ _ _ = TDict+instance HasClass Real Int True where classDict _ _ _ = TDict+instance HasClass Real Float True where classDict _ _ _ = TDict+instance HasClass Real Double True where classDict _ _ _ = TDict++instance HasClass RealFloat Float True where classDict _ _ _ = TDict+instance HasClass RealFloat Double True where classDict _ _ _ = TDict++instance HasClass RealFrac Float True where classDict _ _ _ = TDict+instance HasClass RealFrac Double True where classDict _ _ _ = TDict++instance HasClass Show a f1 => HasClass Show [a] f1 where+    classDict p _ _ =+        case classDict p (Proxy :: Proxy a) (Proxy :: Proxy f1) of+          TDict -> TDict+instance HasClass Show Word True where classDict _ _ _ = TDict+instance HasClass Show Ordering True where classDict _ _ _ = TDict+instance HasClass Show a f1 => HasClass Show (Maybe a) f1 where+    classDict p _ _ =+        case classDict p (Proxy :: Proxy a) (Proxy :: Proxy f1) of+          TDict -> TDict+instance HasClass Show Integer True where classDict _ _ _ = TDict+instance HasClass Show Int True where classDict _ _ _ = TDict+instance HasClass Show Float True where classDict _ _ _ = TDict+instance HasClass Show Double True where classDict _ _ _ = TDict+instance HasClass Show Char True where classDict _ _ _ = TDict+instance HasClass Show Bool True where classDict _ _ _ = TDict+instance (HasClass Show a f1, HasClass Show b f2, And f1 f2 f3) =>+    HasClass Show (Either a b) f3 where+        classDict p _ _ =+            case classDict p (Proxy :: Proxy a) (Proxy :: Proxy f1) of+              TDict ->+                  case classDict p (Proxy :: Proxy b) (Proxy :: Proxy f2) of+                    TDict -> TDict
+ src/Data/Type/LTDict.hs view
@@ -0,0 +1,111 @@+-- Copyright 2016 Julian Hall.  See LICENSE file at top level for details.++-- TODO - are we still using all of these extensions?+{-# LANGUAGE GADTs,ConstraintKinds,RankNTypes,FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables,KindSignatures,PolyKinds #-}+{-# LANGUAGE TypeFamilies,MultiParamTypeClasses,UndecidableInstances #-}+{-# LANGUAGE DataKinds,TypeOperators,FlexibleContexts #-}++-- | Provides a type for keeping a list of typeclass dictionaries that may or+-- may not exist for a given type, and utility functions for working with the+-- list.+module Data.Type.LTDict where++import GHC.Exts (Constraint)+import Data.ConstrainedDynamic(ClassConstraint(..))+import Data.Typeable+import Data.Type.HasClass++-- | Optionally provide a dictionary for a constraint and a type.+data MaybeHasClass :: (* -> Constraint) -> * -> * where+    JustHasClass     :: cs t => MaybeHasClass cs t+    DoesNotHaveClass :: MaybeHasClass cs t++-- | Maintain a list of dictionaries encapsulating many constraints+-- over a single type (where they are available).+data LTDict :: [* -> Constraint] -> * -> * where+    LTDCons :: MaybeHasClass cs t -> LTDict css t -> LTDict (cs ': css) t+    LTDNil  :: LTDict '[] t++class TypeConstraintBuilder mhctype (cs :: * -> Constraint) t (flag :: k) where+    buildTypeConstraint :: proxy flag -> mhctype cs t++instance (HasClass cs t True) =>+    TypeConstraintBuilder MaybeHasClass cs t True where+        buildTypeConstraint _ =+            case classDict (Proxy :: Proxy cs) (Proxy :: Proxy t)+                           (Proxy :: Proxy true) of+              TDict -> JustHasClass++instance {-# OVERLAPPABLE #-} f ~ False =>+    TypeConstraintBuilder MaybeHasClass cs t f where+        buildTypeConstraint _ = DoesNotHaveClass++-- | Produce an appropriate 'MaybeHasClass' value for the context.+-- Callers should ensure that appropriate 'HasClass' instances are in scope+-- at the point of calling, or declare them as part of their context.+checkClass :: forall cs t f .+              (HasClass cs t f, TypeConstraintBuilder MaybeHasClass cs t f) =>+              MaybeHasClass cs t+checkClass = buildTypeConstraint (Proxy :: Proxy f)++-- | A class for building objects that recurse over a list of constraints.+-- Instances are provided for building 'LTDict' values, but could be used+-- for other values too.+class LTDictBuilder dtype (css :: [(* -> Constraint)]) t where+    buildLTDict :: dtype css t++instance (HasClass cs t f,+          TypeConstraintBuilder MaybeHasClass cs t f,+          LTDictBuilder LTDict css t)+              => LTDictBuilder LTDict (cs ': css) t where+    buildLTDict = LTDCons checkClass (buildLTDict :: LTDict css t)++instance LTDictBuilder LTDict '[] t where+    buildLTDict = LTDNil++-- | Functions for extracting the list of constraints in an LTDict+-- as 'TypeRep's of 'ClassConstraint' types.+class LTDictConstraintLister (css :: [(* -> Constraint)]) where+    -- Return all constraints in the list+    getAllConstraints :: LTDict css a -> [TypeRep]+    -- Return only the matched constraints in the list+    getMatchedConstraints :: LTDict css a -> [TypeRep]+    -- Return only the unmatched constraints in the list+    getUnmatchedConstraints :: LTDict css a -> [TypeRep]++instance LTDictConstraintLister '[] where+    getAllConstraints _ = []+    getMatchedConstraints _ = []+    getUnmatchedConstraints _ = []++instance (Typeable cs, LTDictConstraintLister css) => LTDictConstraintLister (cs ': css) where+    getAllConstraints (LTDCons _ t) =+        typeOf (ClassConstraint :: ClassConstraint cs) :+               getAllConstraints t+    getMatchedConstraints (LTDCons JustHasClass t) =+        typeOf (ClassConstraint :: ClassConstraint cs) :+               getMatchedConstraints t+    getMatchedConstraints (LTDCons DoesNotHaveClass t) =+        getMatchedConstraints t+    getUnmatchedConstraints (LTDCons DoesNotHaveClass t) =+        typeOf (ClassConstraint :: ClassConstraint cs) :+               getUnmatchedConstraints t+    getUnmatchedConstraints (LTDCons JustHasClass t) =+        getUnmatchedConstraints t++-- | A class for handling searches for a specific single constraint in the+-- list.+class LTDictSearch (css :: [(* -> Constraint)]) (cs :: * -> Constraint) where+    ltdSearch :: proxy cs -> LTDict css a -> MaybeHasClass cs a++instance LTDictSearch '[] cs where+    ltdSearch _ _ = DoesNotHaveClass++instance LTDictSearch (cs ': css) cs where+    ltdSearch _ (LTDCons m _) = m++instance {-# OVERLAPPABLE #-} LTDictSearch css cs =>+    LTDictSearch (unmatched ': css) cs where+        ltdSearch p (LTDCons _ t) = ltdSearch p t+
+ tests/Main.hs view
@@ -0,0 +1,39 @@+-- Copyright 2016 Julian Hall.  See LICENSE file at top level for details.++-- | Tests for ConstrainedDynamic.+module Main where++import Test.Tasty+import Test.Tasty.HUnit+import Data.ConstrainedDynamic+import Data.Typeable++main :: IO ()+main = defaultMain tests++type CDShow = ConstrainedDynamic Show+type CDEq = ConstrainedDynamic Eq++tests :: TestTree+tests = testGroup "Tests" [+         testCase "Can convert a string to ConstrainedDynamic and back" $+                  fromDynamic (toDyn "hello" :: CDShow) @?= Just "hello",+         testCase "Can convert a bool to ConstrainedDynamic and back" $+                  fromDynamic (toDyn True :: CDShow) @?= Just True,+         testCase "Cannot convert string to CD and back to a bool" $+                  fromDynamic (toDyn "hello" :: CDShow) @?= (Nothing::Maybe Bool),+         testCase "Apply a function from a typeclass to a CD value" $+                  (toDyn True :: CDShow) `applyClassFn` show @?= "True",+         testCase "Valid classCast returns Just" $+                  maybe "cast failed" (const "cast OK")+                            (classCast (toDyn "hello" :: CDShow)+                             :: Maybe CDShow) @?= "cast OK",+         testCase "Invalid classCast returns Nothing" $+                  maybe "cast failed" (const "cast OK")+                             (classCast (toDyn "hello" ::CDShow)+                              :: Maybe CDEq) @?= "cast failed",+         testCase "Showing a 'ConstrainedDynamic Show' shows value" $+                  show (toDyn "hello" :: CDShow) @?= "\"hello\"",+         testCase "Showing a 'ConstrainedDynamic Eq' shows type" $+                  show (toDyn "hello" :: CDEq) @?= "[Char]"+        ]