packages feed

runtime-instances (empty) → 1.0

raw patch · 8 files changed

+466/−0 lines, 8 filesdep +basedep +containersdep +runtime-instances

Dependencies added: base, containers, runtime-instances, sop-core, tasty, tasty-hunit, template-haskell, th-utilities, type-reflection

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for runtime-instances++## 1.0++* Initial release.
+ LICENSE view
@@ -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.
+ runtime-instances.cabal view
@@ -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,
+ src/Instance/Runtime.hs view
@@ -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
+ src/Instance/Runtime/TH.hs view
@@ -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
+ test/Class.hs view
@@ -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
+ test/HiddenInstanceTest.hs view
@@ -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"+  ]
+ test/Test.hs view
@@ -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+  ]