discover-instances (empty) → 0.1.0.0

raw patch · 7 files changed

+370/−0 lines, 7 filesdep +basedep +discover-instancesdep +some-dict-ofsetup-changed

Dependencies added: base, discover-instances, some-dict-of, template-haskell, th-compat

Files

• ChangeLog.md +7/−0
• LICENSE +30/−0
• README.md +3/−0
• Setup.hs +2/−0
• discover-instances.cabal +55/−0
• src/DiscoverInstances.hs +248/−0
• test/Spec.hs +25/−0

@@ -0,0 +1,7 @@+# Changelog for discover-instances++## Unreleased changes++## 0.1.0.0++- Initial Release

@@ -0,0 +1,30 @@+Copyright Matt Parsons (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Matt Parsons nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,3 @@+# discover-instances++A Haskell package that defines a `TemplateHaskell` helper for discovering and working with instances of a type class.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,55 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           discover-instances+version:        0.1.0.0+description:    Please see the README on GitHub at <https://github.com/parsonsmatt/discover-instances#readme>+homepage:       https://github.com/parsonsmatt/discover-instances#readme+bug-reports:    https://github.com/parsonsmatt/discover-instances/issues+author:         Matt Parsons+maintainer:     parsonsmatt@gmail.com+copyright:      Matt Parsons+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/parsonsmatt/discover-instances++library+  exposed-modules:+      DiscoverInstances+  other-modules:+      Paths_discover_instances+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.12 && <5+    , some-dict-of+    , template-haskell+    , th-compat+  default-language: Haskell2010++test-suite discover-instances-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_discover_instances+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.12 && <5+    , discover-instances+    , some-dict-of+    , template-haskell+    , th-compat+  default-language: Haskell2010

@@ -0,0 +1,248 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++-- | Generally speaking, this module is only useful to discover instances+-- of unary type classes where the instance is unconstrained.+--+-- That is to say - not all that useful in libraries.+--+-- However, this has ended up being super useful to me in a bunch of+-- application contexts. Consider @persistent-discover@, which grabs all+-- the @PersistEntity@ instances in scope and makes the @[EntityDef]@ for+-- them. Or consider a front-end types generating module, which needs to+-- import a ton of modules, and then call @toSomeFrontEndClass :: SomeClass+-- a => Proxy a -> SomeThing@ on each thing.+--+-- This library can simplify that process.+--+-- @since 0.1.0.0+module DiscoverInstances+    (+    -- * The main interface+      discoverInstances+    -- * Using the results of 'discoverInstances'+    -- $using+    , withInstances+    , forInstances+    , module SomeDictOf+    -- * Re-exports+    , module Data.Proxy+    ) where++import Data.Proxy+import Data.Typeable+import Language.Haskell.TH hiding (cxt)+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax.Compat+import SomeDictOf++-- | This TemplateHaskell function accepts a type and splices in a list of+-- 'SomeDict's that provide evidence that the type is an instance of+-- the class that you asked for.+--+-- There are some limitations.+--+-- * The class can only accept a single parameter.+-- * The instances returned do not have a context.+--+-- Example Use:+--+-- @+-- eq :: ['SomeDict' Eq]+-- eq = $$(discoverInstances)+-- @+--+-- This function uses typed @TemplateHaskell@, which means you don't need to+-- provide a type annotation directly. However, you can pass a type directly.+--+-- @+-- ord :: ['SomeDict' 'Ord']+-- ord = $$(discoverInstances @Ord)+-- @+--+-- GHC supports using the @$$@ syntax without parentheses if the expression is+-- a single term. So you can also write this:+--+-- @+-- functor :: ['SomeDict' 'Functor']+-- functor = $$discoverInstances+-- @+--+-- But you'll get an error if you type-apply like that.+--+-- @since 0.1.0.0+discoverInstances :: forall (c :: _ -> Constraint) . (Typeable c) => SpliceQ [SomeDict c]+discoverInstances = liftSplice $ do+    let+        className =+            show (typeRep (Proxy @c))+    instanceDecs <- reifyInstances (mkName className) [VarT (mkName "a")]++    dicts <- fmap listTE $ traverse decToDict instanceDecs++    examineSplice [|| concat $$(liftSplice $ pure dicts) ||]++-- $using+--+-- Once you've acquired a @'SomeDict' c@ for some type class @c@ that you care+-- about, it's not entirely clear how you might use it.+--+-- The "SomeDictOf" module contains functions for working with these, but the+-- simplest thing to do is probably pattern match on them directly. The use case+-- that this library was designed to support is iterating over all the visible+-- instances of a class and performing some operation on the class.+--+-- Consider the @persistent@ database library. The @PersistEntity@ type class+-- defines a method @entityDef :: PersistEntity a => proxy a -> EntityDef@,+-- where the @EntityDef@ type contains information that relates the type to the+-- database encoding for the type. Let's get all the @EntityDef@s for the types+-- in scope:+--+-- @+-- entityDefs :: [EntityDef]+-- entityDefs =+--      'map'+--          (\\('SomeDictOf' proxy) -> entityDef proxy)+--          $$('discoverInstances' \@PersistEntity)+-- @+--+-- The @EntityDef@ for an entity include the documentation comments written for+-- the entity. So we can print out all the documentation for the database+-- tables.+--+-- Another intended use is to render generated code. We use the+-- @aeson-typescript@ library to generate TypeScript code for our API. Without+-- this library, we maintain a list of types to generate code for. This list is+-- duplicated in the imports, as well as the data declarations.+--+-- @+-- import Model.Foo+-- import Model.Bar+-- import Model.Baz+-- import Model.Quux+--+-- renderTypeScript :: IO ()+-- renderTypeScript = do+--     writeToFile $ concat+--         [ writeType \@Foo+--         , writeType \@Bar+--         , writeType \@Baz+--         , writeType \@Quux+--         ]+-- @+--+-- With 'discoverInstances', we can skip a lot of this work.+--+-- @+-- import Model.Foo+-- import Model.Bar+-- import Model.Baz+-- import Model.Quux+--+-- renderTypeScript :: IO ()+-- renderTypeScript = do+--     writeToFile $ concat+--         $ flip map $$('discoverInstances' \@TypeScript)+--         $ \\('SomeDictOf' ('Proxy' :: 'Proxy' ty) ->+--             writeType \@ty+-- @+--+-- The above two patterns are encapsulated in 'withInstances'. We can rewrite+-- them like this:+--+-- @+-- entityDefs =+--     'withInstances'+--         $$(discoverInstances \@PersistEntity)+--         $ \\proxy -> entityDef proxy+--+-- renderTypeScript :: IO ()+-- renderTypeScript = do+--     writeToFile $ concat+--         $ 'withInstances' $$('discoverInstances' \@TypeScript)+--         $ \\('Proxy' :: 'Proxy' ty) ->+--             writeType \@ty+-- @+--+-- Another use case is to load all models out of the database, to ensure that+-- serialization and deserialization logic works. 'forInstances' is useful for+-- operating over instances effectfully.+--+-- @+--loadAllModels :: SqlPersistM ()+--loadAllModels = do+--    'forInstances' $$('discoverInstances' \@PersistEntity) \\('Proxy' :: 'Proxy' a) -> do+--        selectList [] []  :: SqlPersistM [Entity a]+-- @++-- | An alias for the pattern:+--+-- @+-- flip map $$discoverInstances $ \\('SomeDictOf' p) -> f p+-- @+--+-- @since 0.1.0.0+withInstances+    :: Functor f+    => f (SomeDict c) -> (forall a. c a => Proxy a -> r) -> f r+withInstances dicts f =+    fmap (\(SomeDictOf p) -> f p) dicts++-- | An alias for the pattern:+--+-- @+-- for $$discoverInstances $ \\('SomeDictOf' p) -> do+--     f p+-- @+--+-- @since 0.1.0.0+forInstances+    :: (Traversable t, Applicative f)+    => t (SomeDict c)+    -> (forall a. c a => Proxy a -> f r)+    -> f (t r)+forInstances dicts f =+    traverse (\(SomeDictOf p) -> f p) dicts++listTE :: [TExp a] -> TExp [a]+listTE = TExp . ListE . map unType++decToDict :: forall k (c :: k -> Constraint). InstanceDec -> Q (TExp [SomeDict c])+decToDict = \case+    InstanceD _moverlap cxt typ _decs ->+        case cxt of+            [] -> do+                let+                    t =+                        case typ of+                            AppT _ t' ->+                               stripSig t'+                            _ ->+                                t+                    stripSig (SigT a _) =+                        a+                    stripSig x =+                        x+                    proxy =+                        [| Proxy :: Proxy $(pure t) |]+                unsafeTExpCoerce [| [ SomeDictOf $proxy ] |]+            _ -> do+                -- reportWarning $+                --     "I haven't figured out how to put constrained instances on here, so I'm skipping the type: "+                --     <> show typ+                --     <> ", context: "+                --     <> show cxt+                examineSplice [|| [] ||]++    _ -> do+        reportWarning $+            "discoverInstances called on 'reifyInstances' somehow returned something that wasn't a type class instance."+        examineSplice [|| [] ||]

@@ -0,0 +1,25 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -ddump-splices #-}++import Data.Foldable+import Data.Proxy+import Data.Typeable+import DiscoverInstances++show :: [SomeDict Show]+show = $$(discoverInstances @Show)++eq :: [SomeDict Eq]+eq = $$(discoverInstances)++functor :: [SomeDict Functor]+functor = $$discoverInstances++main :: IO ()+main = do+    for_ functor $ \(SomeDictOf p@(Proxy :: Proxy t)) -> do+        print 1234