diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for runtime-instances + +## 1.0 + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2022 Richard Eisenberg + +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/runtime-instances.cabal b/runtime-instances.cabal new file mode 100644 --- /dev/null +++ b/runtime-instances.cabal @@ -0,0 +1,56 @@ +cabal-version: 2.4 +name: runtime-instances +version: 1.0 +synopsis: Look up class instances at runtime. + +description: + This package allows clients to build a database of class instances, + queryable at runtime. Accordingly, this allows runtime class instance + lookup. Template Haskell utility functions are provided for creating + the instance database from the set of instances in scope at a given + point in your program. +homepage: https://github.com/goldfirere/runtime-instances + +bug-reports: https://github.com/goldfirere/runtime-instances/issues +license: MIT +license-file: LICENSE +author: Richard Eisenberg +maintainer: rae@richarde.dev + +copyright: Richard Eisenberg +-- category: +extra-source-files: CHANGELOG.md + +library + exposed-modules: Instance.Runtime + Instance.Runtime.TH + + other-modules: + -- other-extensions: + build-depends: base >= 4.16 && < 5, + containers >= 0.5, + sop-core >= 0.5, + type-reflection >= 1.0, + template-haskell >= 2.18, + th-utilities >= 0.2 + hs-source-dirs: src + default-language: GHC2021 + + default-extensions: + +test-suite test + default-language: GHC2021 + ghc-options: -Wno-missing-home-modules + + type: exitcode-stdio-1.0 + hs-source-dirs: test + + main-is: Test.hs + other-modules: Class + HiddenInstanceTest + + build-depends: base >= 4.16 && < 5, + runtime-instances, + type-reflection >= 0.1, + tasty >= 1.4.2, + tasty-hunit >= 0.10, diff --git a/src/Instance/Runtime.hs b/src/Instance/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Instance/Runtime.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE AllowAmbiguousTypes, DataKinds, GADTs, QuantifiedConstraints, CPP #-} + +{-| +Description : Find a class instance at runtime +Copyright : Richard Eisenberg +License : MIT +Maintainer : rae@richarde.dev +Stability : experimental + +The key innovation in this library is the 'Instances' type, which is a database +of instances that can be queried at runtime. More specifically, an @'Instances' tt c@ +is a mapping from elements of type @tt@ to instances of class @c@. + +It is expected +that @tt@ be an instance of the 'TypeText' class, which controls how types are rendered +into text. A good initial choice for @tt@ is 'Unqualified', which will render all types +as unqualified names. This is simple, but potentially ambiguous, if you have multiple +types with the same name (declared in different modules). See "Type.Reflection.Name" +for other alternatives. + +An important restriction is that 'Instances' can hold only /ground/ instances: instances +with no type variables or type families. Maybe we can accommodate non-ground instances +in the future, but not today. (There seems to be no fundamental reason we cannot support +non-ground instances, but doing so would be a good deal harder than ground instances.) +The instance declarations may have variables, even though +the 'Instances' database will hold those instances' instantiations. For example, while +we have @instance Eq a => Eq (Maybe a)@, that polymorphic instance cannot be stored in +'Instances'. Instead, you can build an @'Instances' 'Unqualified' 'Eq'@ +with, say, @Eq (Maybe Int)@, @Eq (Maybe Bool)@, and @Eq (Maybe Double)@. Looking up +@Maybe Int@, @Maybe Bool@, and @Maybe Double@ will all succeed, but looking up @Maybe Char@ +would fail. + +To create an `Instances`, use the @instancesFor...@ functions. The @Invisible@ variants +accept a type argument specifying the (ground) types which should be used to populate the +`Instances` database. The @TypeRep@ variant expects a 'TypeRep'. In the future, we expect +to offer a @instancesFor@ function which will use [visible dependent quantification](https://github.com/ghc-proposals/ghc-proposals/pull/281) to accept the list of types. Note that 'Instances' +is a 'Monoid', so you can combine the results of several calls. + +In order to build an 'Instances' containing all instances in scope, see "Instance.Runtime.TH". + +To use an 'Instances', use the 'withInstanceProxy' function. This function looks up an instance +in the database and, if successful, passes that instance to a callback function. In the future, +once we have the ability to [bind type variables in a lambda](https://github.com/ghc-proposals/ghc-proposals/pull/448), we expect 'withInstance' to be a better interface. +-} + +module Instance.Runtime ( + Instances, + + -- ** Creation + + instanceForTypeRep, instanceForInvisible, + instancesForInvisible, + + -- ** Usage + + withInstance, withInstanceProxy, withInstanceTypeRep, + + -- ** Folding + + foldInstances, + ) where + +import qualified Data.Map.Lazy as M +import Data.SOP.NP +import Data.SOP.Constraint ( All ) + +import Type.Reflection.List +import Type.Reflection.Name + +import Data.Proxy +import Data.Kind +import Type.Reflection +import Data.Functor + +#if __GLASGOW_HASKELL__ < 904 +import Unsafe.Coerce +#endif + +-- | A database of instances available for runtime queries. An @Instances tn c@ contains +-- instances of the class @c@, indexed by type names rendered according to the rules for @tn@. +type Instances :: forall k. Type -> (k -> Constraint) -> Type +newtype Instances type_namer c = MkInstances (M.Map type_namer (EDict c)) + deriving (Semigroup, Monoid) + +-- | for debugging only +instance (Show type_namer, Typeable c) => Show (Instances type_namer c) where + show (MkInstances m) = "(Instances for " ++ show (typeRep @c) ++ " for types " ++ show (M.keys m) ++ ")" + +type EDict :: forall k. (k -> Constraint) -> Type +data EDict c where + PackDict :: forall x c. c x => EDict c + +-- | Create an 'Instances' for a type denoted by the given 'TypeRep'. +instanceForTypeRep :: + forall {k} (x :: k) (c :: k -> Constraint) tn. + c x => + TypeText tn => + TypeRep x -> + Instances tn c +instanceForTypeRep tr = MkInstances (M.singleton (renderTypeRep tr) (PackDict @x)) + +-- | Create an 'Instances' for a type passed invisibly. Example: @instanceForInvisible @Int@. +instanceForInvisible :: + forall {k} (x :: k) (c :: k -> Constraint) tn. + Typeable x => + c x => + TypeText tn => + Instances tn c +instanceForInvisible = instanceForTypeRep (typeRep @x) + +-- | Create an 'Instances' for a list of types passed invisibly. +-- Example: @instancesForInvisible @[Int, Bool, Double]@. +instancesForInvisible :: + forall {k} (xs :: [k]) (c :: k -> Constraint) tn. + Typeable xs => + All c xs => + TypeText tn => + Instances tn c +instancesForInvisible = go all_trs + where + tr_xs = typeRep @xs + all_trs = typeRepList tr_xs + + go :: forall (inner_xs :: [k]). All c inner_xs => NP TypeRep inner_xs -> Instances tn c + go (tr :* trs) = instanceForTypeRep tr <> go trs + go Nil = mempty + +-- | Look up an instance in 'Instances', making the instance available for use in the continuation +-- function. If the lookup fails, this returns Nothing. Until https://github.com/ghc-proposals/ghc-proposals/pull/448 +-- is implemented, there is no way to bind a type variable to the found type, so this function is likely +-- impossible to use well. For now, see 'withInstanceProxy' instead. +withInstance :: Ord tn => Instances tn c -> tn -> (forall x. c x => r) -> Maybe r +withInstance inst_db type_name f = withInstanceProxy inst_db type_name (\ (_ :: Proxy x) -> f @x) + +-- | Look up an instance in 'Instances', making the instance available for use in the continuation +-- function. If the lookup fails, this returns Nothing. If https://github.com/ghc-proposals/ghc-proposals/pull/448 +-- has been implemented in your GHC, you may prefer 'withInstance'. +withInstanceProxy :: Ord tn => Instances tn c -> tn -> (forall x. c x => Proxy x -> r) -> Maybe r +withInstanceProxy (MkInstances mapping) type_name f = + M.lookup type_name mapping <&> \ (PackDict @_ @x) -> f (Proxy @x) + -- The @_ in PackDict above is a GHC bug (GitLab is wonky at the moment, so I can't search for + -- ticket #, but I'm pretty sure I remember this one and that it's fixed in HEAD) + +-- | Look up an instance in 'Instances', when you already have a 'TypeRep' for the type to look up. +-- To use this function, the class @c@ used in your @Instances@ must imply 'Typeable'; the 'Typeable' +-- instance is used to check that the retrieved type is actually the one you want. If it's not, +-- this function throws an exception (this really shouldn't happen). +-- (In GHCs before 9.4, this check is skipped, because of a bug around 'Typeable' and quantified +-- constraints.) +-- If the lookup fails, this returns Nothing. +withInstanceTypeRep :: + forall t c tn r. + TypeText tn => +#if __GLASGOW_HASKELL__ >= 904 + (forall x. c x => Typeable x) => +#endif + Instances tn c -> TypeRep t -> (c t => r) -> Maybe r +withInstanceTypeRep instances type_rep action = + withInstanceProxy instances (renderTypeRep type_rep) $ \ (_ :: Proxy t') -> + let + type_rep' :: TypeRep t' +#if __GLASGOW_HASKELL__ >= 904 + type_rep' = typeRep +#else + type_rep' = unsafeCoerce type_rep +#endif + in + case type_rep `eqTypeRep` type_rep' of + Just HRefl -> action + Nothing -> error $ "Retrieved type " ++ show type_rep' ++ + " different from expected type " ++ show type_rep ++ "." + +-- | Perform a computation for each instance in the database, accumulating results +-- in a monoid. Your monoid should be commutative, because there is no predictable +-- order of instances in the 'Instances'. +foldInstances :: + Monoid m => + Instances tn c -> + (forall x. c x => Proxy x -> m) -> + m +foldInstances (MkInstances mapping) action = + foldMap (\ (PackDict @_ @x) -> action @x Proxy) mapping diff --git a/src/Instance/Runtime/TH.hs b/src/Instance/Runtime/TH.hs new file mode 100644 --- /dev/null +++ b/src/Instance/Runtime/TH.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +{-| +Description : Build a runtime-instance database of all instances in scope +Copyright : Richard Eisenberg +License : MIT +Maintainer : rae@richarde.dev +Stability : experimental + +TODO: write description + +-} + +module Instance.Runtime.TH ( + allGroundInstances, allGroundInstanceTypes, + + -- * Utilities + promotedList, + ) where + +import Instance.Runtime + +import TH.Utilities +import Language.Haskell.TH +import Data.List ( uncons ) + +-- | Build an 'Instances' containing all in-scope ground instances for the given +-- class. A /ground instance/ is one that includes no type variables. Example +-- usage: +-- +-- > instanceDatabase :: Instances Unqualified MyClass +-- > instanceDatabase = $(allGroundInstances [t| MyClass |]) +-- +-- It is an infelicity in the design of Template Haskell that requires repeating +-- the @MyClass@ part; it should be inferrable. +-- +-- Note that this just looks at instance declarations to determine whether an +-- instance is ground. So it would not pick up, e.g. @Eq (Maybe Int)@, because +-- the instance declaration looks like @Eq (Maybe a)@. +-- +-- Due to a limitation of Template Haskell, this will find only instances declared +-- in other modules or before a declaration splice in the current module. +-- If you want to find instances declared in the current module, you can add a line +-- +-- > $(pure []) +-- +-- above the use of 'allGroundInstances' in the file. This line forces GHC to finish +-- processing everything above the line before looking at anything below the line, +-- so those instances declared above the line are available below it. +allGroundInstances :: Q Type -- ^ The class whose instances to include. + -- This type must have the kind @k -> Constraint@ for some @k@ + -- and include no variables. + -> Q Exp +allGroundInstances q_constraint = do + constraint <- q_constraint + ground_instance_types <- allGroundInstanceTypes constraint + let ty_list = foldr (\ h t -> PromotedConsT `AppT` h `AppT` t) PromotedNilT ground_instance_types + return (VarE 'instancesForInvisible `AppTypeE` ty_list) + +-- | Returns a list of ground (= no variables) types that satisfy the given constraint. +-- The passed-in 'Type' must have kind @k -> Constraint@ for some @k@; all the returned +-- types will then have kind @k@. +-- +-- This finds only types that appear in ground instances. So if you look for @Eq@, you'll +-- get @Int@, and @Double@, but not @Maybe Int@, even though @Maybe Int@ is a ground type: +-- it comes from @instance ... => Eq (Maybe a)@, which is not a ground instance. +-- +-- See also 'allGroundInstances', for more usage information. +allGroundInstanceTypes :: Type -> Q [Type] +allGroundInstanceTypes constraint = do + (class_name, ct_args) <- case typeToNamedCon constraint of + Nothing -> fail (show (ppr constraint) ++ " is not headed by a class.") + Just (nm, args) -> return (nm, args) + mapM_ checkForVariables ct_args + + instances <- reifyInstances class_name (ct_args ++ [VarT (mkName "a")]) + return [ ty + | InstanceD _ _ instance_ty _ <- instances + , Just (_, args) <- pure (typeToNamedCon instance_ty) + , Just (ty, _) <- pure (uncons (reverse args)) + , hasNoVariables ty + ] + +-- | Issues an error if the type provided has any variables. Never fails. +checkForVariables :: Type -> Q () +checkForVariables ty + | hasNoVariables ty = return () + | otherwise = reportError ("`" ++ show (ppr ty) ++ "' has variables; this is not allowed.") + +-- | Checks whether a 'Type' has no variables. +hasNoVariables :: Type -> Bool +hasNoVariables (ForallT {}) = False +hasNoVariables (ForallVisT {}) = False +hasNoVariables (AppT ty1 ty2) = hasNoVariables ty1 && hasNoVariables ty2 +hasNoVariables (AppKindT ty1 ki2) = hasNoVariables ty1 && hasNoVariables ki2 +hasNoVariables (SigT ty ki) = hasNoVariables ty && hasNoVariables ki +hasNoVariables (VarT {}) = False +hasNoVariables (ConT {}) = True +hasNoVariables (PromotedT {}) = True +hasNoVariables (InfixT ty1 _ ty2) = hasNoVariables ty1 && hasNoVariables ty2 +hasNoVariables (UInfixT ty1 _ ty2) = hasNoVariables ty1 && hasNoVariables ty2 +hasNoVariables (ParensT ty) = hasNoVariables ty +hasNoVariables (TupleT {}) = True +hasNoVariables (UnboxedTupleT {}) = True +hasNoVariables (UnboxedSumT {}) = True +hasNoVariables ArrowT = True +hasNoVariables MulArrowT = True +hasNoVariables EqualityT = True +hasNoVariables ListT = True +hasNoVariables (PromotedTupleT {}) = True +hasNoVariables PromotedConsT = True +hasNoVariables PromotedNilT = True +hasNoVariables StarT = True +hasNoVariables ConstraintT = True +hasNoVariables (LitT {}) = True +hasNoVariables WildCardT = True +hasNoVariables (ImplicitParamT _ ty) = hasNoVariables ty + +------------------------------------ +-- Utilities + +-- | Constructs a promoted list type from a list of types. Useful for +-- synthesizing calls to 'instancesForInvisible' using Template Haskell. +promotedList :: [Type] -> Type +promotedList = foldr (\h t -> PromotedConsT `AppT` h `AppT` t) PromotedNilT diff --git a/test/Class.hs b/test/Class.hs new file mode 100644 --- /dev/null +++ b/test/Class.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Class ( + ReadShowEq, ReadShowEq2, + ) where + +class (Read a, Show a, Eq a) => ReadShowEq a +instance (Read a, Show a, Eq a) => ReadShowEq a + +-- this one has concrete instances, for allGroundInstances +class (Read a, Show a, Eq a) => ReadShowEq2 a diff --git a/test/HiddenInstanceTest.hs b/test/HiddenInstanceTest.hs new file mode 100644 --- /dev/null +++ b/test/HiddenInstanceTest.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HiddenInstanceTest where + +import Test.Tasty +import Test.Tasty.HUnit + +import Control.Monad ( join ) +import Data.Proxy +import Type.Reflection.Name + +import Instance.Runtime +import Class +import Util + +tests1 :: Instances Unqualified ReadShowEq -> TestTree +tests1 instances = testGroup "hidden1" + [ testCase "read" $ + join $ + assertJust "withInstance" $ + withInstanceProxy instances "T" $ \ (_ :: Proxy t) -> + read @t "MkT 1" @?= read "MkT 0x1" + , testCase "show" $ + join $ + assertJust "withInstance" $ + withInstanceProxy instances "T" $ \ (_ :: Proxy t) -> + show (read @t " MkT 0002") @?= "MkT 2" + , testCase "read T3" $ + join $ + assertJust "withInstance" $ + withInstanceProxy instances "T3" $ \ (_ :: Proxy t) -> + read @t "MkT3 3.14" @?= read "MkT3 3.1400" + ] + +tests2 :: Instances Unqualified ReadShowEq2 -> TestTree +tests2 instances = testGroup "hidden2" + [ testCase "read" $ + join $ + assertJust "withInstance" $ + withInstanceProxy instances "T" $ \ (_ :: Proxy t) -> + read @t "MkT 1" @?= read "MkT 0x1" + , testCase "show" $ + join $ + assertJust "withInstance" $ + withInstanceProxy instances "T" $ \ (_ :: Proxy t) -> + show (read @t " MkT 0002") @?= "MkT 2" + , testCase "read T3" $ + join $ + assertJust "withInstance" $ + withInstanceProxy instances "T3" $ \ (_ :: Proxy t) -> + read @t "MkT3 3.14" @?= read "MkT3 3.1400" + ] diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,15 @@ +module Main where + +import Test.Tasty + +import qualified HiddenInstances +import qualified HiddenInstanceTest + +main :: IO () +main = defaultMain all_tests + +all_tests :: TestTree +all_tests = testGroup "All" + [ HiddenInstanceTest.tests1 HiddenInstances.t_instances + , HiddenInstanceTest.tests2 HiddenInstances.all_t_instances + ]