Implicit Parameter Experiments

implicit-parameter.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ConstraintKinds #-}

import GHC.Exts

-- A handler holds a function that takes in any a that
-- satisfies constraint p. Note that we are simply returning
-- string in here for the sake of simplifying the demo.
data Handler p a = Handler (p => a -> String)

-- callHandler unboxes a handler and apply it to an a
-- that satisfies constraint p.
callHandler :: forall p a. p => Handler p a -> a -> String
callHandler (Handler h) = h

-- fooHandler can take in any object containing a foo of type
-- string, as given by implicit parameter.
fooHandler :: forall a. Handler (?getFoo :: a -> String) a
fooHandler = Handler $ \x -> "(foo " ++ (?getFoo x) ++ ")"

-- barHandler can take in any object containing a bar of type
-- string, as given by implicit parameter.
barHandler :: forall a. Handler (?getBar :: a -> String) a
barHandler = Handler $ \x -> "(bar " ++ (?getBar x) ++ ")"

-- Two example config types that we can pass to foo and bar handler
data Config = Config { foo :: String, bar :: String }
data Config2 = Config2 { foo2 :: String, bar2 :: String, baz :: String }

-- Example instances of the config
config :: Config
config = Config { foo = "foo", bar = "bar" }

config2 :: Config2
config2 = setBaz config "baz"

-- A demo of how we can compose handler functions while still
-- keep track and propogate the constraints.
composeHandler :: forall a p q. Handler p a -> Handler q a -> Handler (p, q) a
composeHandler (Handler f) (Handler g) = Handler $ \x ->
  "(composed " ++ (f x) ++ " " ++ (g x) ++ ")"

-- type of composedHandler can be automatically inferred, as compared to
-- naive function composition.
-- composedHandler :: Handler (?getFoo::a -> String, ?getBar::a -> String) a
composedHandler = composeHandler fooHandler barHandler

-- Type synonyms for the combined constraints we have
type FooBarConstraint a = (
  (?getFoo :: a -> String),
  (?getBar :: a -> String))

type FooBarBazConstraint a = (
  (?getFoo :: a -> String),
  (?getBar :: a -> String),
  (?getBaz :: a -> String))

-- runConfig takes in universally quantified functions that
-- may require the given constraints, and populate the
-- implicit parameters before invoking the functions.
runConfig :: forall b.
  (forall a. (FooBarConstraint a) => a -> b)
  -> Config -> b
runConfig f config =
  let
    ?getFoo = foo
    ?getBar = bar
  in f config

runConfig2 :: forall b.
  (forall a. (FooBarBazConstraint a => a -> b))
  -> Config2 -> b
runConfig2 f config =
  let
    ?getFoo = foo2
    ?getBar = bar2
    ?getBaz = baz
  in f config

-- We can partially apply with any handler functions
-- that requires the same or less constraints.
-- For example fooHandler don't require the ?getBar constraint,
-- but we can still run it with the additional constraint given.
-- In a way this is a limited form of subtyping through constraints.
fooHandler2 = runConfig $ callHandler fooHandler
composedHandler2 = runConfig2 $ callHandler composedHandler

-- The partially applied functions become simple functions that take in
-- the corresponding concrete config types. We have effective wrap
-- abstract handler functions into concrete functions!

-- "(foo foo)"
fooResult = fooHandler2 config

-- "(composed (foo foo) (bar bar))"
composedResult = composedHandler2 config2

-- applyConfig takes in the boxed handler object itself and inject the
-- implicit parameter constraints using runConfig.
applyConfig ::
  (forall a. Handler (FooBarConstraint a) a)
  -> Config -> String
applyConfig handler config = runConfig (callHandler handler) config

-- "(composed (foo foo) (bar bar))"
composedResult2 = applyConfig composedHandler config

-- Although applyConfig looks almost identical to runConfig,
-- it unfortunately cannot give us the free "subtyping" we have
-- in runConfig. The handler passed to applyConfig must have the
-- exact same set of constraints and no less. For example, running:

--  barResult = applyConfig barHandler config

-- give us the following error:
--
-- • Couldn't match type ‘?getBar::a -> String’
--                  with ‘(?getFoo::a -> String, ?getBar::a -> String)’
--   Expected type: Handler (FooBarConstraint a) a
--     Actual type: Handler (?getBar::a -> String) a
-- • In the first argument of ‘applyConfig’, namely ‘barHandler’
--   In the expression: applyConfig barHandler config
--   In an equation for ‘barResult’:
--       barResult = applyConfig barHandler config

-- Additionally, runConfig and runConfig2 cannot be passed as
-- argument to other function as an higher order function.
-- Haskell's lack of support for impredicative polymorphism
-- makes it difficult for us to write a universal runConfig
-- function that can be applied to any config type.

--- Work in Progress ---

-- A filter takes a handler and return a new handler that
-- accepts different type and constraint.
data Filter p a q b = Filter ((Handler q b) -> (Handler p a))

-- Apply a filter on a handler by unboxing the functions and applying them.
applyFilter :: forall p q a b. Filter p a q b -> Handler q b -> Handler p a
applyFilter (Filter f) h = f h

setBaz :: Config -> String -> Config2
setBaz (Config foo bar) val = Config2 { foo2 = foo, bar2 = bar, baz = val }

setBaz2 :: Config2 -> String -> Config2
setBaz2 config val = config { baz = val }

-- bazFilter is a filter that sets the baz value and pass the modified
-- argument to the inner handler.
bazFilter :: forall a b q. Filter
  ((?getBar :: a -> String),
   (?setBaz :: a -> String -> b),
   (?applyHandler :: Handler q b -> b -> String))
  a q b
bazFilter =
  Filter $ \h ->
    Handler $ \x ->
      ?applyHandler h (?setBaz x ("beer with " ++ (?getBar x)))

-- We can apply bazFilter on the composed handler and it will
-- keep track of the new constraints
filteredHandler = applyFilter bazFilter composedHandler

type SetFooBarConstraint a b = (
  (?getFoo :: a -> String),
  (?getBar :: a -> String),
  (?setBaz :: a -> String -> b),
  (?applyHandler :: Handler (FooBarBazConstraint b) b -> b -> String))

--- Existential Experiment ---

class Constrainable f where
  type Context f a :: Constraint

  wrap :: forall a. Context f a => a -> f a
  unwrap :: forall r a. f a -> (forall b. Context f b => b -> r) -> r

data EncapFooBar a = FooBarConstraint a => EncapFooBar a

instance Constrainable EncapFooBar where
  type Context EncapFooBar a = FooBarConstraint a

  wrap = EncapFooBar
  unwrap (EncapFooBar x) k = k x

data Exist f = forall a. Constrainable f => Exist (f a)

pack :: forall f a. (Constrainable f, Context f a) => a -> Exist f
pack x = Exist (wrap x)

unpack :: forall f r. Constrainable f => Exist f -> (forall a. Context f a => a -> r) -> r
unpack m k = case m of
  Exist x ->
    unwrap x k

encapConfig :: Config -> Exist EncapFooBar
encapConfig config =
  let
    ?getFoo = foo
    ?getBar = bar
  in
    pack config

config3 = encapConfig config

unpackResult = unpack config3 $ \x ->
  callHandler composedHandler x