Replacing function arguments with `MonadReader` calls.

Read.hs

-----------------------------------------------------------
-- 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