diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/constrained-dynamic.cabal b/constrained-dynamic.cabal new file mode 100644 --- /dev/null +++ b/constrained-dynamic.cabal @@ -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 diff --git a/src/Data/ConstrainedDynamic.hs b/src/Data/ConstrainedDynamic.hs new file mode 100644 --- /dev/null +++ b/src/Data/ConstrainedDynamic.hs @@ -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) diff --git a/src/Data/MultiConstrainedDynamic.hs b/src/Data/MultiConstrainedDynamic.hs new file mode 100644 --- /dev/null +++ b/src/Data/MultiConstrainedDynamic.hs @@ -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 diff --git a/src/Data/Type/HasClass.hs b/src/Data/Type/HasClass.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/HasClass.hs @@ -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 + diff --git a/src/Data/Type/HasClassPreludeInstances.hs b/src/Data/Type/HasClassPreludeInstances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/HasClassPreludeInstances.hs @@ -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 diff --git a/src/Data/Type/LTDict.hs b/src/Data/Type/LTDict.hs new file mode 100644 --- /dev/null +++ b/src/Data/Type/LTDict.hs @@ -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 + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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]" + ]