Skip to content

Instantly share code, notes, and snippets.

@i-am-tom
Created December 23, 2019 13:39
Show Gist options
  • Save i-am-tom/23d36a0598936572407794883548c900 to your computer and use it in GitHub Desktop.
Save i-am-tom/23d36a0598936572407794883548c900 to your computer and use it in GitHub Desktop.
Replacing function arguments with `MonadReader` calls.
-----------------------------------------------------------
-- HOW TO ASK FOR HELP AND AVOID ARGUMENTS.
--
-- When we want to use an externally-provided package (such as logging,
-- database connections, etc) in our work code, it might require some initial
-- config that we traditionally store in our environment.
--
-- We might even require something like a database connection or file handler
-- /throughout/ the lifetime of the code, in order to make queries or similar.
--
-- Inevitably, we end up repeating the same chunk of code (with a little help
-- from 'generic-lens'):
--
-- @
-- whatever = do
-- connection <- fmap (getTyped @Connection) ask
-- query connection "SELECT * FROM users WHERE name = ''; drop table users --' LIMIT 1"
-- ...
-- @
--
-- This is fine, but starts to make a mess when we have many instances of this,
-- or even multiple connections to track. So, like good programmers, we write
-- some application-specific helper functions:
--
-- @
-- query :: String -> IO ()
-- query body = do
-- connection <- fmap (getTyped @Connection) ask
-- query connection body
-- @
--
-- The @read@ function below is for exactly this: we pass to 'read' a
-- __list__ of the types we want to provide through 'MonadReader', along with
-- the function, and we get back the updated function. So, in this contrived
-- example:
--
-- @
-- query :: String -> IO ()
-- query = read @'[Connection]
-- @
--
-- The code below also doesn't care /where/ in the function we encounter the
-- types mentioned, or in what order! As long as the final result is wrapped in
-- some 'm' for which 'MonadReader r m' and 'HasType ThingThatIWant r' hold,
-- we're all good!
--
-- /NB: this really isn't how you should actually write SQL./
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Read where
import Data.Kind (Type)
import Control.Applicative ((<|>), empty)
import Data.List (permutations, tails)
import Control.Monad.Reader.Class (MonadReader, ask)
import Data.Generics.Product (HasType (..))
import Data.Semigroup (Sum (..))
import Prelude hiding (Read, read)
-- | The @read@ function takes a __type-applied__ list of the arguments to
-- supply from the 'MonadReader' instance, along with the function, and returns
-- the function with those arguments removed.
--
-- The functional dependencies are here to help with type inference: if I know
-- the function's type and the arguments for which I want to defer to
-- 'MonadReader', I can uniquely determine the resulting function. This is
-- lucky, because it otherwise wouldn't be clear to GHC what the result of this
-- function would be!
class Read (xs :: [Type]) (m :: Type -> Type) (i :: Type) (o :: Type)
| i xs -> o, i -> m, o -> m where
read :: i -> o
-- | This is the @elem@ function, but lifted to a type family. If @x@ exists in
-- @xs@, it will return @True@. Otherwise, it will return @False@.
type family (x :: Type) `Elem` (xs :: [Type]) :: Bool where
x `Elem` '[ ] = 'False
x `Elem` (x ': xs) = 'True
x `Elem` (y ': xs) = x `Elem` xs
-- | Assuming our input is a /function/, we figure out whether the input is
-- something we care about, and pass the decision to the 'Read'' class.
instance Read' (x `Elem` xs) xs m (x -> b) output
=> Read xs m (x -> b) output where
read = read' @(x `Elem` xs) @xs @m
-- | If our input /isn't/ a function (and we /really/ only want GHC to pick
-- this instance when the above instance has been proven definitely
-- irrelevant), then, assuming the result is indeed 'm whatever', we're done
-- and all is well. Note that we /need/ to match 'input' to 'm whatever' here
-- to tell GHC that the 'm' (to which we've slowly been attaching all our
-- 'MonadReader' constraints) is indeed the same 'm' as the one around the
-- answer. If we don't know that's true, we don't know that we can 'ask' for
-- parameters!
--
-- If you're wondering why we need the @INCOHERENT@ here, try uncommenting the
-- following. Then, change the @INCOHERENT@ to @OVERLAPPABLE@. It's worth
-- reading the relevant documentation on the difference between these two at
-- https://downloads.haskell.org/ghc/latest/docs/html/users_guide/glasgow_exts.html#instance-overlap
--
-- test :: _
-- test = read @'[Int] (undefined :: String -> Int -> m Bool)
instance {-# INCOHERENT #-} (input ~ m whatever, input ~ output)
=> Read xs m input output where
read = id
-- | This class is identical to 'Read', but for one extra parameter: a @flag@,
-- telling us whether the current parameter in question is one of the ones to
-- move to the @m@ via 'MonadReader'.
class Read' (flag :: Bool) (xs :: [Type]) (m :: Type -> Type) (i :: Type) (o :: Type)
| i xs flag -> o, i -> m, o -> m where
read' :: i -> o
-- | If the parameter we're seeing is /not/ a parameter of interest, we
-- carry on and look at the output (shown below as @b@ that becomes @c@).
instance (input ~ (a -> b), output ~ (a -> c), Read xs m b c)
=> Read' 'False xs m input output where
read' a2b = \a -> read @xs @m (a2b a)
-- | If it /is/ a parameter of interest, we 'push' it into the 'm', and carry
-- on.
instance (input ~ (a -> b), output ~ c, Read xs m b c, Push a b)
=> Read' 'True xs m input output where
read' = read @xs . push
-- | Unlike the above, 'Push' makes no "decision". It takes the first parameter
-- of a function, and "removes" it by "pushing it into the @m@".
class Push (input :: Type) (output :: Type) where
push :: (input -> output) -> output
-- | When we deal with a function like @input -> x -> output@, and we're trying
-- to push @input@, the result is @x -> output@. So, we 'flip' the arguments to
-- make @x -> input -> output@, and then 'push' @input -> output@, which gives
-- us our recursion.
instance Push input output => Push input (x -> output) where
push f = \x -> push \i -> f i x
-- | When we reach the end, we'll have something like @input -> m output@, and
-- we'll want to land at @m output@. Now we know we have exactly one argument,
-- we can 'ask' for it, and pass it to the function.
instance {-# INCOHERENT #-}
( MonadReader r m
, HasType input r
, output ~ m something
) => Push input output where
push f = ask >>= f . getTyped
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment