Dict Typing - Duck Typing in Haskell using dictionaries and implicits

dict-typing.hs

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

import GHC.Exts

-- Dict Typing - Duck Typing in Haskell using dictionaries and implicits
--
-- This demo demonstrates how to do duck typing in Haskell by packing
-- implicit constraints inside dictionaries.

-- Dict and :- are blatantly copied from Data.Constraint
data Dict :: Constraint -> * where
  Dict :: p => Dict p

-- This is the same as the entailment operator (:-) in Data.Constraint.
-- We call it Cast here as we are mainly using it for casting
data Cast p q = Cast (p => Dict q)

-- Merge two dicts together and product a new dict with witness
-- for both constraints
mergeDict :: forall p q. Dict p -> Dict q -> Dict (p, q)
mergeDict Dict Dict = Dict

-- Given an entailment from p to q, we can cast a dict from
-- Dict p to Dict q. This is the same as mapDict in Data.Constraint.
castDict :: forall p q. Dict p -> Cast p q -> Dict q
castDict Dict (Cast x) = x

-- We are using castDict mainly to cast between different subsets and
-- permutations of the constraints in a dict. This is required because
-- for example Dict (Foo a, Bar a), Dict (Bar a, Foo a),
-- Dict (Foo a), and Dict (Bar a) are all recognized by Haskell as
-- distinct types.

infixr 8 &-&
(&-&) = mergeDict

infixr 7 <->
(<->) = castDict

-- If we want to pass for example an instance of Dict (Foo a, Bar a)
-- to a function that accepts a Dict (Bar a), we can cast it as follow:
-- barDict = (fooBarDict <-> (Cast Dict))
--
-- The casting operation is a bit verbose, but Haskell does most of the
-- work for us recognizing that it is always safe to cast different
-- subsets and permutations of the same set of constraints.

-- Here we have two example types that we are going to use for duck typing.
-- Both Args and Args2 have the foo and bar fields. Note that we are
-- naming the fields in Args as foo2 and bar2 to avoid ambiguous field
-- accessor errors.
data Args = Args { foo :: String, bar :: String }
data Args2 = Args2 { foo2 :: String, bar2 :: String, baz :: String }

-- We define the duck-typable fields as implicit parameter constraints
-- In practice these fields can be lenses then we can get both
-- getter and setter together.
type FooConstraint a = (?getFoo :: a -> String)
type BarConstraint a = (?getBar :: a -> String)
type BazConstraint a = (?getBaz :: a -> String)

-- Constraint synomyms to help us specify that a function require
-- multiple fields to be present.
type FooBarConstraint a = (FooConstraint a, BarConstraint a)
type FooBarBazConstraint a = (FooConstraint a, BarConstraint a, BazConstraint a)

-- Just like normal constraints, we can bind the values of implicit
-- parameters inside Dict. By combining the two, we are essentially
-- capturing implicit parameters inside a row-polymorphic-like
-- environment, which is the context, and pass them around freely!
fooDict :: Dict (FooConstraint Args)
fooDict = let ?getFoo = foo in Dict

barDict :: Dict (BarConstraint Args)
barDict = let ?getBar = bar in Dict

fooDict2 :: Dict (FooConstraint Args2)
fooDict2 = let ?getFoo = foo2 in Dict

barDict2 :: Dict (BarConstraint Args2)
barDict2 = let ?getBar = bar2 in Dict

bazDict :: Dict (BazConstraint Args2)
bazDict = let ?getBaz = baz in Dict

-- Using the merge operator, we can merge multiple dicts
-- into a larger dict containing all implicit parameters.
fooBarDict :: Dict (FooBarConstraint Args)
fooBarDict = fooDict &-& barDict

-- To merge 3 dicts, we have to use cast to "flatten"
-- the structure of the dict, because otherwise we get
-- Dict (FooConstraint Args2, (BarConstraint Args2, BazConstraint Args2))
-- which is not the same as
-- Dict (FooConstraint Args2, BarConstraint Args2, BazConstraint Args2)
-- (note the parenthesis)
fooBarBazDict :: Dict (FooBarBazConstraint Args2)
fooBarBazDict = fooDict2 &-& barDict2 &-& bazDict <-> (Cast Dict)

-- Create two example arguments
args :: Args
args = Args { foo = "foo", bar = "bar" }

args2 :: Args2
args2 = Args2 { foo2 = "foo2", bar2 = "bar2", baz = "baz2" }

-- A handler is a polymorphic function accepts a duck type a,
-- with a dict that contains implicit parameters that give
-- access to the required fields. For simplicity we use
-- String as the return type as we want to focus on
-- duck typing the argument for now.
data Handler p a = Handler (Dict p -> a -> String)

-- Given an a and the accompanying dict, we can call a
-- handler and get back the result.
callHandler :: forall p a. Handler p a -> Dict p -> a -> String
callHandler (Handler h) dict = h dict

-- Similar to casting dicts, we can cast handlers into
-- different permutations of its constraints.
castHandler :: forall p q a. Handler q a -> Cast p q -> Handler p a
castHandler h cast = Handler $ \dict ->
  callHandler h (castDict dict cast)

-- With the handler abstraction, we can easily compose them
-- without too much trouble fighting with Haskell's automatic
-- constraint resolution.

-- The demo compose handler takes in two handlers and return a
-- handler that requires a dict that satisfy constraints from both
-- inner handlers. Note that we have to cast the dicts before
-- passing to the inner handlers.
composeHandler :: forall p q r a. Handler p a -> Handler q a -> Handler (p, q) a
composeHandler f g = Handler $ \dict x ->
  let Dict = dict in
    "(composed: " ++ (callHandler f (dict <-> (Cast Dict)) x) ++
    " " ++ (callHandler g (dict <-> (Cast Dict)) x) ++ ")"

-- fooHandler only requires a foo field to be present
fooHandler :: forall a. Handler (FooConstraint a) a
fooHandler = Handler $ \Dict x -> "(foo: " ++ (?getFoo x) ++ ")"

-- barHandler only requries a barField to be present
barHandler :: forall a. Handler (BarConstraint a) a
barHandler = Handler $ \Dict x -> "(bar: " ++ (?getBar x) ++ ")"

-- fooBarHandler is a composition of fooHandler and barHandler
-- fooBarHandler :: Handler (FooConstraint a, BarConstraint a) a
fooBarHandler = composeHandler fooHandler barHandler

-- We can pass args to fooHandler and barHandler, with some verbose
-- casting if we are passing the combined dict.

-- fooResult = "(foo: foo)"
fooResult = callHandler fooHandler (fooBarDict <-> (Cast Dict)) args

-- barResult = "(bar: bar)"
barResult = callHandler barHandler (fooBarDict <-> (Cast Dict)) args

-- We can also pass args 2 to any of the handlers as they also have both fields

-- fooBarResult = "(composed: (foo: foo2) (bar: bar2))"
fooBarResult = callHandler fooBarHandler (fooBarBazDict <-> (Cast Dict)) args2

-- Going in a little more interesting, we introduce bazSetter, which either
-- modifies an existing baz field or adds a baz field to a type by returning
-- another type.
type SetBazConstraint a b = (?setBaz :: a -> String -> b)
type SetFooBarConstraint a b = (FooBarConstraint a, SetBazConstraint a b)
type SetFooBarBazConstraint a = (FooBarBazConstraint a, SetBazConstraint a a)

-- If we setBaz on Args, it becomes an Args2.
setBaz :: Args -> String -> Args2
setBaz (Args foo bar) value = Args2 { foo2 = foo, bar2 = bar, baz = value}

-- Setting baz on Args2 also returns Args2 as Args2 already has a baz field.
setBaz2 :: Args2 -> String -> Args2
setBaz2 (Args2 foo bar _) value = Args2 { foo2 = foo, bar2 = bar, baz = value}

setBazDict :: Dict (SetBazConstraint Args Args2)
setBazDict = let ?setBaz = setBaz in Dict

setBazDict2 :: Dict (SetBazConstraint Args2 Args2)
setBazDict2 = let ?setBaz = setBaz2 in Dict

setFooBarDict :: Dict (SetFooBarConstraint Args Args2)
setFooBarDict = fooBarDict &-& setBazDict

setFooBarBazDict :: Dict (SetFooBarBazConstraint Args2)
setFooBarBazDict = fooBarBazDict &-& setBazDict2

-- A filter takes in a handler and its required dict, and return a new
-- handler that takes in a different type and constraints.
data Filter p a q b = Filter (Dict q -> (Handler q b) -> (Handler p a))

applyFilter :: forall p q a b. Filter p a q b -> Dict q -> Handler q b -> Handler p a
applyFilter (Filter f) inDict h = f inDict h

-- If we expect the filter to not change the type of its argument,
-- we can use applyFilter' which applies a filter on handler accepting
-- the same argument type.
applyFilter' :: forall p q a. Filter p a q a -> Handler q a -> Handler (p, q) a
applyFilter' (Filter f) h = Handler $ \dict ->
  callHandler (f (dict <-> (Cast Dict)) h) (dict <-> (Cast Dict))

-- A baz filter injects a value to the baz field, overriding any
-- existing value. It only requires that baz is settable in a
-- and it can read bar from a.
bazFilter :: forall p a b. Filter
  (SetBazConstraint a b, BarConstraint a)
  a p b
bazFilter =
  Filter $ \inDict h ->
    Handler $ \Dict x ->
      let
        y = ?setBaz x ("baz with " ++ (?getBar x))
      in
        callHandler h inDict y

-- Define a handler that requires all 3 foo bar baz fields
-- and print out their values.
fooBarBazHandler :: forall a. Handler (FooBarBazConstraint a) a
fooBarBazHandler = Handler $ \Dict x ->
  "((foo: " ++ (?getFoo x) ++
  ") (bar: " ++ (?getBar x) ++
  ") (baz: " ++ (?getBaz x) ++ "))"

-- We can partially apply bazFilter with fooBarBazHandler
-- without settling on a concrete type yet.

-- makeFilteredHandler :: forall p a b
--   . Dict (FooBarBazConstraint b)
--   -> Handler (SetBazConstraint a b, BarConstraint a) a
makeFilteredHandler dict = applyFilter bazFilter dict fooBarBazHandler

-- Specialize the filtered handler to require the result of set baz
-- to be an Args2.

-- filteredHandler :: forall a.
--   Handler (SetBazConstraint a Args2, BarConstraint a) a
filteredHandler = makeFilteredHandler fooBarBazDict

-- We can call filteredHandler with both args and args2.

-- filteredResult = "((foo: foo) (bar: bar) (baz: baz with bar))"
filteredResult = callHandler filteredHandler (setFooBarDict <-> (Cast Dict)) args

-- Notice that by explicitly passing dictionaries around, we can
-- have two definitions of implicits for Args and Args2 isolated
-- in separate dictionaries. When calling the inner handler,
-- fooBarBazDict is used to reference implicits such as ?getFoo.
-- This wouldn't have been possible when using implicits in normal
-- context, as we can't define two implicits of the same name
-- for different types.

-- We can also use applyFilter' to require the filter and handler
-- both accepts the same argument type.

-- filteredHandler2 :: Handler
--   ((SetBazConstraint a a, BarConstraint a),
--    FooBarBazConstraint a)
--   a
filteredHandler2 = applyFilter' bazFilter fooBarBazHandler

-- In this case it would not be possible to apply filteredHandler2
-- to args, as args do not implements a SetBazConstraint that
-- returns Args.

-- filteredResult2 = "((foo: foo2) (bar: bar2) (baz: baz with bar2))"
filteredResult2 = callHandler filteredHandler2 (setFooBarBazDict <-> (Cast Dict)) args2

-- Conclusion
--
-- In summary this snippet demonstrates how we can achieve duck typing
-- in Haskell using dictionaries and implicit parameters, albeit with
-- some verbosity. It would be great if there is way to cast types
-- that are parameterized by constraints to one another without the
-- boilerplates we have here.
--
-- I have tried many other approaches to achieve duck typing or
-- row polymorphism in Haskell, but most of them fail one way or
-- another due to restrictions in Haskell's type inference.
-- For example, a naive type class based approach for the setBaz
-- constraint would require functional dependency but also
-- have severe restriction on nested duck typing. Existentials
-- work up to certain extend but requires significant hacks
-- to implement existential implicits and work around the lack
-- of impredicative polymorphism in Haskell.
--
-- I am still very new to Haskell and would appreciate if anyone
-- can show a simpler way of implementing duck typing in Haskell.
-- Otherwise I hope you enjoy the dict typing pattern I presented here!


-- Prototype Inheritence using Dict Typing
-- In Progress

data Prototype (p :: Constraint) e a where
  Prototype :: ((a -> e) -> Dict p) -> Prototype p e a

chainProto :: forall p1 p2 e1 e2 a.
  Prototype p1 e1 a
  -> Prototype p2 e2 a
  -> Prototype (p1, p2) (e1, e2) a
chainProto (Prototype makeDict1) (Prototype makeDict2) =
  Prototype $ \getElement ->
    (makeDict1 (fst . getElement)) &-&
    (makeDict2 (snd . getElement))

infixr 8 =&=
(=&=) = chainProto

runProto :: forall p e. Prototype p e e -> Dict p
runProto (Prototype makeDict) = makeDict id

fooBarProto :: forall a. Prototype (FooBarConstraint a) Args a
fooBarProto = Prototype $ \getArg ->
  let
    ?getFoo = foo . getArg
    ?getBar = bar . getArg
  in
    Dict

fooBazProto :: forall a. Prototype (FooConstraint a, BazConstraint a) Args2 a
fooBazProto = Prototype $ \getArg ->
  let
    ?getFoo = foo2 . getArg
    ?getBaz = baz . getArg
  in
    Dict

-- chainedProto :: forall a. Prototype
--   (FooBarConstraint a, (FooConstraint a, BazConstraint a))
--   (Args, Args2)
--   a
chainedProto = fooBarProto =&= fooBazProto

-- fooBarBazDict3 :: Dict
--   (FooBarConstraint (Args, Args2),
--   (FooConstraint (Args, Args2), BazConstraint (Args, Args2)))
fooBarBazDict3 = runProto chainedProto

-- result3 = "((foo: foo) (bar: bar) (baz: baz2))"
result3 = callHandler fooBarBazHandler (fooBarBazDict3 <-> (Cast Dict)) (args, args2)

bazProto :: forall a. Prototype (BazConstraint a) String a
bazProto = Prototype $ \getBaz ->
  let ?getBaz = getBaz in Dict

-- chainedProto2 :: forall a. Prototype
--   (BazConstraint a, FooBarConstraint a)
--   (String, Args)
--   a
chainedProto2 = chainProto bazProto fooBarProto

-- fooBarBazDict4 :: Dict
--   (BazConstraint (String, Args), FooBarConstraint (String, Args))
fooBarBazDict4 = runProto chainedProto2

-- result4 = "((foo: foo) (bar: bar) (baz: injected-baz))"
result4 = callHandler fooBarBazHandler (fooBarBazDict4 <-> (Cast Dict)) ("injected-baz", args)