Named arguments in Haskell

DashDashArguments.hs

-- in response to https://twitter.com/int_index/status/1059430673193275392
{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, TypeOperators #-}
module DashDashArguments where

import GHC.TypeLits
import Test.DocTest


-- The challenge is to implement named arguments in this style:
--
--     foldr --f (+) --start 0 --xs [1..10]
--
-- That exact syntax obviously won't work because "--" starts a comment, so I
-- will spell out "--" as "dashDash". Also, in order to avoid getting
-- distracted by the polymorphism of @foldr@, I will work on a much simpler
-- function, @greet@.


-- |
-- First, let's implement a boring version which uses ordinary positional
-- parameters.
--
-- >>> greetPositional "hello" "world"
-- "hello, world!"
greetPositional :: {- greeting -} String
                -> {- target   -} String
                -> String
greetPositional greeting target
  = greeting ++ ", " ++ target ++ "!"


-- There are two arguments, "greeting" and "target", which we would like to
-- specify using @dashDashGreeting@ and @dashDashTarget@. Since we'll be using
-- some type-level magic, we'll need those two labels to have different types.

data DashDashGreeting = DashDashGreeting

dashDashGreeting :: DashDashGreeting
dashDashGreeting = DashDashGreeting

data DashDashTarget = DashDashTarget

dashDashTarget :: DashDashTarget
dashDashTarget = DashDashTarget


-- We want both
--
--     greetNamed dashDashGreeting "hello" dashDashTarget "world"
--
-- and
--
--     greetNamed dashDashTarget "world" dashDashGreeting "hello"
--
-- to be valid calls, so we need 'greetNamed' to have two different types:
--
--     greetNamed :: DashDashGreeting -> String
--                -> DashDashTarget -> String
--                -> String
--
-- and
--
--     greetNamed :: DashDashTarget -> String
--                -> DashDashGreeting -> String
--                -> String
--
-- So let's define a typeclass which has instances for both of those types. We
-- will also need to keep track of which parameters have and haven't already
-- been filled by a named argument, so we'll use a typeclass with two type
-- parameters, @g@ and @r@.
--
-- @g@ always has the form @a -> b -> String@, where @a@ and @b@ are either
-- '()' if the parameter has already been filled, or 'String' if it hasn't.
--
-- @r@ always has the form
--
--     ( DashDashFoo -> String
--    -> DashDashBar -> String
--    -> ...
--    -> String
--     )
--
-- and lists all the named arguments which have not yet been applied.
class GreetPartial g r where
  greetPartial :: g -> r

-- Let's start dancing! At the beginning, none of the named arguments have been
-- applied, so @a@ and @b@ are both 'String'. @r@ has to be one of the types we
-- have listed for 'greetNamed' above, otherwise no 'GreetPartial' instance
-- will be found.
greetNamed :: GreetPartial (String -> String -> String) r => r
greetNamed = greetPartial greetPositional

-- If @r@ begins with @DashDashGreeting -> String -> ...@, we expect @a@ to
-- still be 'String', and we want to replace it with '()'.
instance ( a ~ String
         , GreetPartial (() -> b -> String) r
         )
        => GreetPartial (String -> b -> String) (DashDashGreeting -> a -> r)
        where
  greetPartial greet DashDashGreeting a = greetPartial (\() b -> greet a b)

-- If @r@ begins with @DashDashTarget -> String -> ...@, we expect @b@ to
-- still be 'String', and we want to replace it with '()'.
instance ( b ~ String
         , GreetPartial (a -> () -> String) r
         )
        => GreetPartial (a -> String -> String) (DashDashTarget -> b -> r)
        where
  greetPartial greet DashDashTarget b = greetPartial (\a () -> greet a b)

-- If @r@ is @String@, we expect both @a@ and be to be '()'.
instance GreetPartial (() -> () -> String) String where
  greetPartial greet = greet () ()


-- |
-- Let's test that it works! We have to give a type annotation, otherwise the
-- typeclass machinery can't know whether it should be expecting more arguments
-- or not.
--
-- >>> greetNamed dashDashGreeting "hello" dashDashTarget "world" :: String
-- "hello, world!"
--
-- >>> greetNamed dashDashTarget "world" dashDashGreeting "hello" :: String
-- "hello, world!"

-- |
-- When calling 'greetNamed' with too many or too few arguments, however, all
-- we get is an error message saying there is no instance for some
-- 'GreetPartial' constraint.
--
-- In particular, if we forgot to provide an argument, the missing instance
-- will be for a case in which either @a@ or @b@ is still 'String', and in
-- which @r@ is 'String'. So we can write that instance and ask ghc to print a
-- nicer error message if that instance is ever needed!
--
-- >>> greetNamed :: String
-- ...
-- ... named argument dashDashGreeting is missing
-- ...
--
-- >>> greetNamed dashDashGreeting "hello" :: String
-- ...
-- ... named argument dashDashTarget is missing
-- ...
--
-- >>> greetNamed dashDashTarget "world" :: String
-- ...
-- ... named argument dashDashGreeting is missing
-- ...

instance TypeError ('Text "named argument dashDashGreeting is missing")
      => GreetPartial (String -> b -> String) String
      where
  greetPartial = error "unreachable"

instance TypeError ('Text "named argument dashDashTarget is missing")
      => GreetPartial (() -> String -> String) String
      where
  greetPartial = error "unreachable"


-- |
-- Another way in which 'greetNamed' can be called incorrectly is by attempting
-- to provide the same named argument more than once. In that case, the missing
-- instance will be for a case in which we expect, say, @a@ to still be a
-- 'String', when it is '()' instead. So we can again write that instance in
-- order to provide a better error message.
--
-- >>> greetNamed dashDashGreeting "hello" dashDashGreeting "howdy" :: String
-- ...
-- ... named argument dashDashGreeting is repeated twice
-- ...
--
-- >>> greetNamed dashDashGreeting "hello" dashDashTarget "world" dashDashTarget "universe" :: String
-- ...
-- ... named argument dashDashTarget is repeated twice
-- ...

instance TypeError ('Text "named argument dashDashGreeting is repeated twice")
      => GreetPartial (() -> b -> String) (DashDashGreeting -> a -> r)
         where
  greetPartial = error "unreachable"

instance TypeError ('Text "named argument dashDashTarget is repeated twice")
      => GreetPartial (a -> () -> String) (DashDashTarget -> b -> r)
         where
  greetPartial = error "unreachable"


main :: IO ()
main = doctest ["DashDashArguments.hs"]