DEV Community: Alex K

Consistently Logical

Alex K — Tue, 26 Feb 2019 17:23:04 +0000

In the recent 538 Riddler, a particular logical puzzle was posted which involves determining who is telling the truth if you assume their claims must all be consistent and that they meet an extra constraint that all liars are older than all truth-tellers. I'm going to show how we can proceed to solve this in code, and specifically using functional programming with Haskell.

Modelling the problem

The first place to start with any problem is deciding how to represent the information in the puzzle. Often the operations on these inputs flow naturally from the structures that we define.

The problem takes the form of a set of claims about the ages of other participants in the puzzle, where each claim states that the age of some person is a value, is not a value, is more than a value, or is less than a value. So lets represent the claims as a tuple of the operation and the value:

type Claim = (Op, Int)

We need to decide what the Op is. The most straightforward approach is a sum-type with a constructor for each of the four operations we need, so:

data Op = Is | Isnt | Gt | Lt deriving (Show, Eq)

However, when a claimant is lying, it is not that we gain no information, instead we can infer the inverse of the operator - for example if someone is lying that X is 17 then that is equivalent to someone telling the truth that X is not 17. The same goes for > and <, but with the caveat that these require the >= and <= operators to convey the inverses.

data Op = Is | Isnt | Gt | Gte | Lt | Lte deriving (Show, Eq, Ord)

invert :: Op -> Op
invert Is   = Isnt
invert Isnt = Is
invert Gt   = Lte
invert Gte  = Lt
invert Lt   = Gte
invert Lte  = Gt

Then we need to model the claimants themselves. For our purposes, each of the islanders is identified by a single letter, so we will use Chars for our islander-names:

type Islander = Char

And a claimant is an islander along with the set of their claims.

data Claimant = Claimant
  { claimantName   :: Islander
  , claimantClaims :: Set (Islander, Claim)
  } deriving (Show, Eq)

For example, if 'X says Y is more than 10 years old', we can encode this as:

Claimant 'X' (S.fromList [('Y', (Gt, 10))])

And this is all we need to encode the problem as specified in the 538 description, which, with a couple of helpers, we can do in such a way that it appears pretty similar to the problem statement itself.

-- the islanders in the problem, with their claims
islanders :: [Claimant]
islanders = ['a' `saysThat` ['b' ==> (Gt, 20)
                            ,'d' ==> (Gt, 16)
                            ]
            ,'b' `saysThat` ['c' ==> (Gt, 18)
                            ,'e' ==> (Lt, 20)
                            ]
            ,'c' `saysThat` ['d' ==> (Lt, 22)
                            ,'a' ==> (Is, 19)
                            ]
            ,'d' `saysThat` ['e' ==> (Isnt, 17)
                            ,'b' ==> (Is, 20)
                            ]
            ,'e' `saysThat` ['a' ==> (Gt, 21)
                            ,'c' ==> (Lt, 18)
                            ]
            ]
  where saysThat who cs = Claimant who (S.fromList cs)
        (==>) = (,)

What are you implying?

Once we know what each islander claims to be true, how can we find out whether their claims are mutually consistent. For example we can see that 'A' says that 'B is more than 20', but 'D' says that 'B is 20'. Clearly they cannot both be right, but how would we determine that algorithmically?

Well, we can look at what each claim implies. Each claim is equivalent to saying that a value lies in one or more range of values. For example Gt 10 is the same as saying 'in the range 11 ..', and Is 12 is the same as 'in the range 12 .. 12'. We can model Isnt as saying that a value must lie in one of two ranges, each of which excludes the value, so Isnt 12 means 'must lie in the range ..11, or in the range 13..'.

This gives us a concept of the implications of each claim, and how we can represent them:

data InclusiveRange = Maybe Int :..: Maybe Int
  deriving (Show, Eq)

newtype Implication = OneOf { ranges :: NonEmpty InclusiveRange }
  -- deriving Semigroup makes 'or'-ing ranges easy
  deriving (Show, Eq, Semigroup)

We can then go ahead and write smart constructors for the different implications of the various claims we can express:

-- helper that makes these functions tidier
inRange :: InclusiveRange -> Implication
inRange = OneOf . pure

is :: Int -> Implication
is x = inRange $ pure x :..: pure x

isnt :: Int -> Implication
isnt x = lt x <> gt x

gt :: Int -> Implication
gt x = inRange $ pure (x + 1) :..: Nothing

gte :: Int -> Implication
gte x = inRange $ pure x :..: Nothing

lt :: Int -> Implication
lt x = inRange $ Nothing :..: pure (x - 1)

lte :: Int -> Implication
lte x = inRange $ Nothing :..: pure x

And we can combine these in a single function from a claim to its implications:

implication :: Claim -> Implication
implication (op, age) = ($ age) $ case op of
  Is   -> is
  Isnt -> isnt
  Gt   -> gt
  Gte  -> gte
  Lt   -> lt
  Lte  -> lte

Making Inferences

The next step is to look at how we can combine two implications to get the logical consequent. For instance, from Gt 10 and Lt 15 we should be able to infer that the value lies in the range 11..14. This implies some kind of monoidal structure, where implications can be combined to create more detailed ones. In which case we need the mempty base case:

anything :: Implication
anything = inRange $ Nothing :..: Nothing

And as a first pass we will look at what we can infer from two implications:

-- apply a binary operation, taking lhs if rhs is Nothing, or rhs if
-- lhs is Nothing
safeBinOp :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
safeBinOp f ma mb = liftA2 f ma mb <|> ma <|> mb

infer :: Implication -> Implication -> Maybe Implication
infer (OneOf lhs) (OneOf rhs) = fmap OneOf . NE.nonEmpty . catMaybes
  $ liftA2 infer' (NE.toList lhs) (NE.toList rhs)
  where
    infer' (a :..: b) (a' :..: b') =
      let lb = safeBinOp max a a'
          ub = safeBinOp min b b'
       in if fromMaybe False (liftA2 (>) lb ub)
             then Nothing -- invalid, lb > ub
             else pure (lb :..: ub)

The inference from two implications is what we get by seeing what constraints each range applies to each range on the other side. Any ranges that are invalid as a result are removed by catMaybes, and if we don't get any ranges at all we can't return any implication, which means that the two statements are in contradiction.

Lets define a way to pretty print an implication, and then take this inference mechanism for a spin!

showImpl :: Implication -> String
showImpl = L.intercalate ";" . fmap showRange . NE.toList . ranges
  where
    showRange (Nothing :..: Just x) = ".." <> show x
    showRange (Just x :..: Nothing) = show x <> ".."
    showRange (Just x :..: Just y)  = if x == y
                                         then show x
                                         else show x <> ".." <> show y
    showRange _   = "anything"

-- Give a two-parameter kleisli arrow, apply it to two arguments
-- (hard to believe this isn't in Control.Monad tbh)
liftKleisli :: Monad m => (a -> b -> m c) -> m a -> m b -> m c
liftKleisli f a b = liftA2 (,) a b >>= uncurry f

Now we can play around with infer:

λ> let p = putStrLn . maybe "Contradiction" showImpl
λ> let inferAll = foldr (liftKleisli infer) (pure anything) . fmap pure
λ> p $ inferAll [anything]
anything
λ> p $ inferAll [gt 5, lt 10]
6..9
λ> p $ inferAll [gt 5, lt 10, isnt 7]
6;8..9
λ> p $ inferAll [gt 5, lt 10, isnt 7, isnt 8]
6;9
λ> p $ inferAll [gt 5, lt 10, isnt 7, isnt 8, isnt 6]
9
λ> p $ inferAll [gt 5, lt 12, isnt 8, isnt 10]
6..7;9;11
λ> p $ inferAll [gt 20, is 20]
Contradiction

Great, we seem to have a working inference engine. We can now wrap that up in a Monoid:

newtype Consequence = Consequence { getConsequence :: Maybe Implication }
  deriving (Show, Eq)

instance Semigroup Consequence where
  (Consequence ma) <> (Consequence mb) = Consequence (liftKleisli infer ma mb)

instance Monoid Consequence where
  mempty = Consequence (pure anything)
  mappend = (<>)

consequence :: Implication -> Consequence
consequence = Consequence . pure

Finding a solution

We now have a lot of the pieces we need to find a solution, and one way we can go about that is to enumerate all the possible arrangements of liars and truth-tellers on the island, checking to see which ones are internally consistent, and then checking that all the liars are older than the truth-tellers. In our case that is perfectly tractable, as we only have to consider 2^5, or 32, arrangements.

First of all we need to tag an islander as either a liar or a truth-teller, and while we can use a Bool for this, it is much better to use a specific data-type for our purposes:

data Honesty = Honest | Liar deriving (Eq, Show)

Then we need all 32 arrangements of these two values, eg:

Honest, Honest, Honest, Honest, Honest
Honest, Honest, Honest, Honest, Liar
Honest, Honest, Honest, Liar, Honest
and so on...

Lets create a small helper for that:

-- produce an arrangement of xs of size n
arrangement :: [a] -> Int -> [[a]]
arrangement _  0 = [[]]
arrangement xs n = xs >>= \x -> (x:) <$> arrangement xs (n - 1)

And we can quickly check that this does what we want:

λ> length $ arrangement ['a', 'b'] 5
32
λ> take 3 $ arrangement ['a', 'b'] 5
["aaaaa","aaaab","aaaba"]

Now we can generate all 32 potential solutions that we need to consider:

fmap (`zip` islanders) $ arrangement [Honest, Liar] (length islanders)

In order to find a solution, we need to combine all the claims about the islanders together, potentially inverting them if they come from liars, and then check to see if there were any contradictions, and whether it meets the age rule. First, lets define the types of solutions and their conclusions:

type Conclusions = Map Char Consequence
type Solution = [(Honesty, Claimant)]

We need a way to turn a solution into a conclusion about all its claims:

conclusions :: [(Honesty, S.Set (Char, Claim))] -> Conclusions
conclusions solution =
  M.fromListWith (<>)
  . fmap (fmap (consequence . implication))
  $ [(who, (trust h op, val)) | (h, cs) <- solution
                              , (who, (op, val)) <- S.toList cs
    ]
  where trust Liar = invert
        trust Honest = id

and a way to know if a set of conclusions contains any contradictions:

-- A set of conclusions is valid if there are no contradictions
viable :: Conclusions -> Bool
viable = all (isJust . getConsequence)

and a way to determine if it meets the age-limit rule, where we check that the oldest honest person is younger than the youngest liar - or in the language of ranges, that the highest lower bound on the age of the honest claimants is lower than the lowest upper bound on the ages of the liars.

meetsAgeLimitRule :: Solution -> Conclusions -> Bool
meetsAgeLimitRule claimants conc =
  let oldestHonest = getAge max lowerBound isHonest
      youngestLiar = getAge min upperBound (not . isHonest)
   in fromMaybe True (liftA2 (<) oldestHonest youngestLiar)
 where
   honest = S.fromList [who | (Honest, Claimant who _) <- claimants]
   isHonest = (`S.member` honest)

   lowerBound (OneOf cs) = let f (lb :..: _) = lb in safely min (f <$> cs)
   upperBound (OneOf cs) = let f (_ :..: ub) = ub in safely max (f <$> cs)

   getAge overall perPerson isRelevant
       = safely overall
       . fmap (getConsequence . snd >=> perPerson)
       . filter (isRelevant . fst)
       $ M.toList conc

-- safely apply a bin-op over a foldable of Maybes
safely :: (Foldable f, Ord a) => (a -> a -> a) -> f (Maybe a) -> Maybe a
safely f = foldr (safeBinOp f) Nothing

With that all in place, we can then proceed to search all the possible arrangements and print out the viable ones we find:

viables :: [(Solution, Conclusions)]
viables = filter (uncurry meetsAgeLimitRule)
        . filter (viable . snd)
        . fmap   (withConclusion . (`zip` islanders))
        $ arrangement [Honest, Liar] (length islanders)

withConclusion :: Solution -> (Solution, Conclusions)
withConclusion cs = (cs, conclusions (fmap claimantClaims <$> cs))

-- print out all the viable solutions
main :: IO ()
main = mapM_ printSolution (zip [1 ..] viables)
  where
    printSolution (n, (sol, conc)) = do
      putStrLn $ "Solution: " <> show n
      putStrLn $ replicate 15 '-'
      mapM_ (go conc) sol
      putStrLn ""
    go conc (h, c) = putStrLn
                   $ unwords [[claimantName c]
                             ,show h
                             ,maybe "" showImpl
                              (M.lookup (claimantName c) conc >>= getConsequence)
                             ]

TaDa!

There is just one solution:

Solution: 1
---------------
a Liar 19
b Liar 20
c Honest 18
d Honest ..16
e Liar 20..

And we can clearly see from the conclusions that this is internally consistent. Walking through the puzzle manually with this solution should be enough to convince you that the solution is sound, but to my mind the nicest part is how naturally it flows from observing the way the parts are stuctured, from seeing the idea of ranges just fall out of the claims, to the fact that we can just fold the claims together using their monoidal structure and then being able to read the conclusions back from the consequences we had calculated. Being able to define the solution clearly made proceeding through the solution that much easier.

Lying Brothers, a categorical solution

Alex K — Sun, 24 Feb 2019 17:56:02 +0000

The famous puzzle of the two lying brothers is a both well known and poorly understood:

There are two doors in front of you, each guarded by one of two brothers. One door leads to freedom, the other to certain doom. One of the brothers can only tell the truth, no matter what question you ask, and the other can only tell lies. You can only ask one yes-or-no question, directed at just one brother, and then you must choose one of the doors. What question do you ask?

It appears throughout popular culture (including in Labyrinth), but wherever it is found, the characters that encounter it typically react with the same mixture of confusion and half-remembered solutions that people in the real world have in their heads. Most people remember how to answer the puzzle, having been walked through it at some point, probably when they were a child.

They know that you are meant to ask one brother what the other one would say when asked if this door leads to freedom. And it is easy to convince someone that this is the case by walking through the truth table of how that brother would respond, case by case. But it is much less obvious why this is the answer, and how you would come to this solution from first principles.

It turns out that the reasoning here is extremely simple, and lets us use what we know about functions to find the right question (and thus, answer).

What we need to know

The puzzle is really asking us to determine one actual piece of information with the one yes-or-no question. Specifically:

Is this door the door to freedom?

The question:

Is this brother lying?

Seems to be essential to finding that out, since while we only care about where the door leads at the end of the day, we cannot determine that until we know if the brother is lying. So the first task is to find out if the brother is a liar.

Interrogation Techniques

We can proceed as per a police investigation, and interrogate the guard.

If we want to find out if we are being lied to, we can ask questions about known facts:

(def facts {:sky-is-blue true
            :water-is-wet true
            :black-is-white false
            :up-is-down false
            })

We can then ask about these known facts, and then see if the guard gives the correct answers. Let us say that guards are functions that take in a set of facts, and then answer questions about that set, e.g.:

(defn truth-teller [memory]
  (fn [question] (question memory)))

The truth teller is straightforward, just pulling a fact out of memory, and then passing that back to us.

(defn liar [memory]
  (fn [question] (not (question memory))))

A liar is exactly the same, except that after recalling a fact, they tell us the opposite of what they know to be true. So trying that out:

(let [a (truth-teller facts)
      b (liar facts)]
  (doseq [fact (keys facts)
          guard [a,b]]
    (println (str "Guard is telling the truth? "
                  (= (facts fact) (guard fact))))))

Since the only difference between the two guards is how they process the contents of their memory, we can refactor this out:

(def lying not)
(def truthfully identity)

(doseq [fact (keys facts)
        guard [lying truthfully]
       ]
    (println (str "Guard is telling the truth? "
                  (str (= (facts fact)
                          (guard (facts fact)))))))

So determining whether the guard is a liar is equivalent to asking if an unknown function is equal to identity or not, which we can do by looking at their outputs.

We don't care who you are, just tell us the (not) truth

So far we can detect the liar if we have a shared set of facts we can agree on, and then we can just compare outputs. Then we know if we have a not-guard or an identity-guard. But wouldn't it be nice if we could transform a not-guard into an identity-guard? Then we could trust our answers. Well, lets look at the opposite, turning an identity-guard into a not-guard.

If we remember the laws of function composition, identity is the neutral element:

id . a  === a
a  . id === a

or in the case of not:

id . not === not
not . id === not

This means that if we compose the two guards together, we can get a not-guard every time, and it doesn't matter which order they come in, we are guaranteed to get a not-guard back:

(defn not-guard [[a b]] (comp a b))

Well, what use is a not-guard? Not much when we don't know if they are one, but once we know for sure that is what they are, we can transform them into a truth-teller, since not . not === id. So this means that whether the guards are [liar truth-teller] or [truth-teller liar], we can get a truth-teller by applying these transformations:

(defn tell-the-truth [guards] (comp not (not-guard guards)))

Finding our way out

Happily, this means that given either order of guards, we can always fashion a truth-teller by composing them together, and use this composite guard to solve the puzzle:

(defn solve [guards door-a-leads-to-freedom]
  (let [truth-teller (tell-the-truth guards)]
    (if (truth-teller door-a-leads-to-freedom)
      :door-a
      :door-b)))

Which of course if a round-about way of saying:

doorA === (not . not . id) doorA
doorA === (id . id) doorA
doorA === id doorA
doorA === doorA

What does this mean in terms of the puzzle? Composing two functions means to thread an input through two functions, and the two brothers here are pure functions of facts, one being the identity function. Composing two respondents means asking one how the other answers. Whenever we have an identity function and something else, we eliminate the identity, and simplify to whatever that something else is, no matter the order of composition. Then we can proceed on the assumption we are dealing with that. In the case of the guards, that means no matter which is A and which is B, we treat each of them as the liar, and we know how to deal with lies.

In some ways this puzzle is like solving an equation by dividing by a common factor. When we know that one of the factors in 1 we don't even have to do that, since (x * 1) and (1 * x) both equal x, just as (f . id) and (id . f) both equal f. It is almost surprising that we can use such simple equational reasoning to reason about functions in the exact same way we reason about numbers, and is an example of laws are important.

Category Theoretical Post-Script

Some people may even have heard of the description of a Monad as a "Monoid in the Category of Endofunctors", well "A Monoid in the Category of Endofunctors" is amusingly exactly the situation at hand. The functions identity and not are Endofunctors, being functions from Bool -> Bool. And they form a category that composes with (.) and has the identity id, or equivalently, they are are a Monoid where mappend is (.) and mempty is id. So we can use either set of laws, to show that we can factor out the identity element, i.e. the truth-telling guard, leaving us with just the liar.

Image credits: XKCD, IMDB

Duck-typing with GHC Generics

Alex K — Thu, 21 Feb 2019 23:19:09 +0000

If you come to Haskell from a more run-of-the-mill programming background, some of the terminology can be downright obscure and cryptic. One piece of the Haskell (or specifically GHC) land-scape that is more confusing than cryptic is the GHC Generics system. Here I'm going to go through what this is, why you might want to use it, and how it can let you do things that would otherwise appear impossible within the constraints of the Haskell type system.

Generics /= Parametric Polymorphism

Unfortunately, the term 'Generics' is rather overloaded in the software development community. Starting with Java, the term has spread to many language communities (including perhaps the most influential and widespread type system in use today, TypeScript) with the meaning of 'parametric polymorphism', i.e. the ability to construct types that have one or more type parameters, and are thus generic in the sense that one structure can be inhabited by many different types. Examples of this ubiquitious in Haskell, including all the common suspects such as [a], Maybe a, Tree a, Map k v, (a,b) and even IO a.

So given these two types:

data A = A Int Bool Char
data B a b c = B a b c

A is monomorphic, i.e. it has only one inhabitant, and B is polymorphic, and can be inhabited by all kinds of different things, such as B Word Word Word, B String (Set Int) (IO ()) etc, even B Int Bool Char, which is isomorphic to A. We can also say that A is of kind * and B is of kind * -> * -> * -> *.

But even though A and B Int Bool Char have the same shape (1 constructor, 3 positional fields) and each of the their fields has the same shape, they are distinct types, and we cannot directly write a single function that can, say, extract the second position field as a Bool from either an A or a B Int Bool Char, not to mention a B a Int b, without writing some kind of type class.

Compare this with dynamically typed languages like Python, or Clojure, where it is straightforward to write such functions, that manipulate objects in terms of their structure, not their names:

def foo(x):
  print x.foo

(defn foo [x]
  (print (:foo x)))

This different approach to data-types, so called Structural typing, as opposed to nominal typing, is often referred to as Duck Typing, as in if it quacks like a duck, and looks like a duck, then to all intents and purposes, it is a duck. In structural typing terms, if it has a field of that name, and that field has that type, then as far as we are concerned, we can treat it as the same kind of thing (as though there was a HasFoo class).

GHC generics allow us to consider data in terms not of its names, but its shapes. And so we will see how we can go about bringing a python-like object system to Haskell.

What is an object, anyway?

That all requires some sense of what an object is. A python object is really just a mapping from names to fields, which are all dynamically typed. So that is what our objects will be too.

import qualified  Data.Map.Strict as Map

type Map = Map.Map

data Object = Object
  { objectMeta             :: Map String String
  , objectNamedFields      :: Map String Dynamic
  , objectPositionalFields :: [Dynamic]
  }
  deriving (Show, Typeable)

In addition to the named fields, we will also store special meta-data about the object, such as its type and its constructor. Fields either have names (as in records) or they are placed positionally.

We want to then extract fields and meta-data of course, so we need to say how to get fields out:

data Key a = Named String | Positional Int
  deriving (Show, Eq)

get :: Typeable a => Key a -> Object -> Maybe a
get (Named s) = getField s
get (Positional i) = getFieldAt i

getField :: Typeable a => String -> Object -> Maybe a
getField k (Object _ fs _) = Map.lookup k fs >>= fromDynamic

getFieldAt :: Typeable a => Int -> Object -> Maybe a
getFieldAt k (Object _ _ fs) = listToMaybe (drop k fs) >>= fromDynamic

getType :: Object -> Maybe String
getType (Object m _ _) = Map.lookup "__type" m

mkObject :: Typeable a => String -> a -> Object
mkObject k v = Object mempty (Map.singleton k (toDyn v)) []

This lets us fetch individual fields, where the user specifies the name and implicitly requires it to be of a specific type. We return it if we can.

Lets take these objects out for a spin:

let os = [mkObject "foo" 'a'
         ,mkObject "foo" (10 :: Int)
         ,mkObject "foo" 'b'
         ,mkObject "bar" 'c'
         ]
mapM_ print . catMaybes $ fmap (get (Named "foo" :: Key Char)) os
> 'a'
> 'b'

Notice we have to tell the compiler what we are expecting back, and we can do that by annotating the keys. We can even have a function like the useful get-in from clojure that walks a chain of fields to find the thing we want at the end:

getIn :: Typeable a => Key a -> [Key Object] -> Object -> Maybe a
getIn k ks o = foldr (\k mo -> mo >>= get k) (pure o) (reverse ks) >>= get k

Which works as follows:

let o = mkObject "a" (mkObject "b" (mkObject "c" (mkObject "d" True)))
print $ getIn (Named "d" :: Key Bool) [Named "a", Named "b", Named "c"] o
> Just True

Well that isn't very useful (yet)

So far all we have is a wonky map-based obejct system. It would be neither ergonomic nor practical to do any real programming using the Object type. Instead, we will want to use normal Haskell ADTs, and be able to transform them into Objects to be queried structurally.

This is where Generics come in handy. They are based on the observation that the algebra of Alegbraic Data Types means that we can identify a minimal subset of shapes we can use to represent all data types:

V1 - this is the data type without constructors. There aren't lots of these, but some examples include Void, and the phantom data types used as tags in some systems.
U1 - this is the value without any fields. This includes common things like True and False as well as enumerations like data XS = A | B | C. In this case the value being represented is True or A.
a :+: b is where there is a choice of two constructors. This includes things like Bool = True | False, or data Tree a = Tip | Branch (Tree a) (Tree a) or data Either a b = Left a | Right b. In this case the value being represented is a Bool, or Either an a or a b, not the side itself. Where there are more than two options, the expressions nest, as (a :+: b :+: c :+: ...) and so on.
a :*: b represents the combination of two things. This happens all the time when a value has more than one field, either named or positional. In data Foo = F Int Char Word there are three fields, and all are present, so this might be come as (int :*: (char :*: word)). The simplest example is (a,b), which is just that, at combination of two things.
K1 represents a leaf value itself.
M1 holds the meta-data This includes data-type name, constructor names, and field names. Rather than repeating this in several places, this is unified into one representation.

Our job then is to use the GHC Generics machinery to turn normal Haskell ADTs into these Generic data-types, and then transform these into Objects. Since all these six things are distinct types, we need a type-class to dispatch over them:

From Rep to Object

The normal pattern is to have two type classes, one for the normal Haskell ADTs, and one for the structural representation. We will call the two classes here ToObject and ToObject'

class ToObject a where
  object :: a -> Object
  default object :: (Generic a, ToObject' (Rep a)) => a -> Object
  object x = toObject (from x)

In the outer wrapper class, we allow types to specify a custom instance, but then say, well, if you can transform yourself into one of those types up above, then I can handle you myself, in a uniform, generic manner.

This implementation lives in Generic land, where every constructor has a phantom parameter, so we expect all the types in this class to be of kind * -> *. This means the structural type-class is:

class ToObject' f where
  toObject :: f p -> Object

Then we need to handle each of the six possible representations. The first few are entirely straightforward:

instance ToObject' V1 where
  toObject x = error "impossible"

For the uninhabited type, we will never be passed any instances, since they can never be constructed. We can just error out here.

instance ToObject' U1 where
  toObject U1 = Object Map.empty Map.empty []

For empty values, return an empty object.

instance ( ToObject' lhs , ToObject' rhs) => ToObject' (lhs :+: rhs) where
           toObject (L1 lhs) = toObject lhs
           toObject (R1 rhs) = toObject rhs

If we have a LHS, then handle that, otherwise handle the RHS.

instance ( ToObject' lhs
         , ToObject' rhs) => ToObject' (lhs :*: rhs) where
           toObject (lhs :*: rhs) = toObject lhs <> toObject rhs

If we have both a RHS and a LHS, then combine them in some way. To do this, it is helpful to define a Semigroup instance for our objects:

instance Semigroup Object where
  (Object m1 a fs) <> (Object m2 b fs') = Object (m1 <> m2) (a <> b) (fs <> fs')

Where it gets interesting is when we get down to values and names, so K1 and M1. For K1 we know the value, but we don't know its name, if it has one, so we will package it up into an object under a special key which is not a legal Haskell identifier, so we can detect it later. Also we want to be careful to distinguish between values like 10 :: Int, 'a' :: Char, which we want to stick in the object directly as as leaf, and ADTs like Tree a, which we want to decompose further if possible. So we will introduce a new type class here to dispatch between primitive and composite values:

class ToValue a where
  toVal :: a -> Dynamic

  default toVal :: (ToObject a) => a -> Dynamic
  toVal x = toDyn $ object x

instance (ToValue x) => ToObject' (K1 i x) where
  toObject (K1 x) = Object Map.empty (Map.singleton "$value" (toVal x)) []

Now when we get to the M1 nodes, we need to handle them differently based on whether they hold constructor, datatype or selector (field) names. Constructor and Datatype are simple - extract the names and tag the objects:

metaCon, metaType :: String
metaCon  = "tag"
metaType = "type"

instance (Constructor t, ToObject' f) => ToObject' (M1 C t f) where
  toObject m =
    let o = toObject (unM1 m)
     in o { objectMeta = Map.insert metaCon (conName m) (objectMeta o) }

instance (Datatype t, ToObject' f) => ToObject' (M1 D t f) where
  toObject m =
    let o = toObject (unM1 m)
     in o { objectMeta = Map.insert metaType (datatypeName m) (objectMeta o) }

When we get a selector, we need to behave slightly differently depending whether we get a leaf node (a value) or another kind of object and depending on whether the selector has a name (is a record field) or is empty (is positional):

instance (Selector t, ToObject' f) => ToObject' (M1 S t f) where
  toObject m =
    let val = toObject (unM1 m)
     in case Map.toList (objectNamedFields val) of
         [("$value", v)] -> case selName m of
                               [] -> val { objectNamedFields = mempty
                                         , objectPositionalFields = [v]
                                         }
                               k -> val { objectNamedFields = Map.singleton k v }
         _ -> case selName m of
                [] -> Object mempty mempty [toDyn val]
                k  -> Object mempty (Map.singleton k (toDyn val)) []

Putting this into action

So now we need some ADTs to use this with, for example:

data Foo = Foo { fooA :: Int, fooB :: Bool, fooC :: String }
  deriving (Show, Eq, Generic)

data Bar = Bar Double Int deriving (Show, Eq, Generic)

data WhatIDid = Veni | Vidi | Vici deriving (Show, Eq, Generic)

data Nested = N { nInt :: Int, nFoo :: Foo, nBar :: Bar }
  deriving (Show, Eq, Generic)

data Tree a = Tip | Branch { treeNode :: a, treeLHS :: (Tree a), treeRHS :: (Tree a) }
  deriving (Show, Eq, Generic)

For everything we want to handle structurally, we need to opt in to the ToObject and ToValue classes. Thankfully the implementations are not onerous, but they are a bit boilerplatey:

instance ToValue Int where toVal = toDyn
instance ToValue Double where toVal = toDyn
instance (Typeable a) => ToValue [a] where toVal = toDyn
instance ToValue Bool where toVal = toDyn
instance ToValue Char where toVal = toDyn

instance ToValue Foo
instance ToObject Foo

instance ToValue Bar
instance ToObject Bar

instance ToValue WhatIDid
instance ToObject WhatIDid

instance ToValue Nested
instance ToObject Nested

instance (Typeable a, ToValue a) => ToValue (Tree a)
instance (Typeable a, ToValue a) => ToObject (Tree a)

And we can give it a whirl:

let t_char = Branch 'a' Tip
                        (Branch 'b' (Branch 'e' Tip Tip)
                                    (Branch 'd' Tip Tip))
getIn (Named "treeNode" :: Key Char) [Named "treeRHS", Named "treeLHS"]
      (object t_char)
> Just 'e'

let t_bar = Branch (Bar 1.0 1)
                   Tip
                   (Branch (Bar 2.0 2)
                           (Branch (Bar pi 0) Tip Tip)
                           (Branch (Bar 42 3) Tip Tip))
getIn (Positional 0 :: Key Double) [Named "treeRHS", Named "treeLHS", Named "treeNode"]
      (object t_bar)
> Just 3.141592653589793

Wrapping it all up

This is not a serious example, necessarily, although it does point to the kinds of things that GHC Generics are good for. When you want to handle data according to its shape, not its meaning, then this is a good way to reduce duplicated effort, and allow 3rd party tools to opt-in. Examples of this are often to do with interacting with the outside world, such as JSON encoding/decoding, or binary serialization. You can write your own FromJSON and ToJSON instances, but if you don't have very finicky needs, why not get the compiler to write it for you? And then you ensure that you never forget to add a new field to the encoder.

Even this toy example has interesting applications, such as very lightweight reflection (there are better reflection tools, but the API here is dead simple), or it could describe in a configuration file the path through a graph of values to a configuration node. Obviously that is not a Haskelly approach, since it involves throwing away the type-safety of the nominal type system in return for the flexibility of structural typing, but it goes to show that with only a small amount of effort, Haskell has the same flexibility as even the most unityped language.

Abusing Monoids: Monoidal predicate combinators

Alex K — Wed, 05 Dec 2018 21:46:17 +0000

One of the nice things about the succinct ways we have in Haskell for writing functions is that our predicates can read very naturally:

filter (> 5) [0 .. 10]

We can compose a chain of functions that produce a Bool with normal function composition:

filter ((== 'c') . fst) [('a', 1), ('b', 2), ('c', 3)]

But often you want to compose predicates logically, with and, or and not, and while the syntax is lightweight, it still gets noisy enough to get in the way of our meaning. Imagine the decision process for deciding if a patron:

newtype Age = Age Int deriving (Show, Eq, Ord)
newtype BloodAlcohol = MgMl Double deriving (Show, Eq, Ord)
data Person = Person { age :: Age, bloodAlcohol :: BloodAlcohol }

Can be served a drink in a bar:

let drinkingAge = Age 18
    legalLimit  = MgMl 80.0
    isOldEnough = (drinkingAge <=) . age
    isDrunk     = (legalLimit  <=) . bloodAlcohol
 in filter (\patron -> isOldEnough patron && not (isDrunk patron))
           [ Person (Age 17) (MgMl 0.0)  -- too young
           , Person (Age 22) (MgMl 93.5) -- too drunk
           , Person (Age 20) (MgMl 62.1) -- fine (for now)
           ]

That is ok, but having the thread the patron argument to the two predicates and combine the results, well, it all feels a bit low level! Where is the abstraction? Can this not be more declarative? Perhaps our ideal syntax would be:

filter (isOldEnough <&> not' isDrunk) customers

So much nicer! And seriously, expressing intent like this means that logic is clearer, less obscured by the ceremony of argument passing, and hopefully easier to get right.

I remember searching in Hoogle for a function f :: (b -> c -> d) -> (a -> b) -> (a -> c) -> a -> c so that I could create (<&>) as f (&&), before realising that this could be done in a couple of different ways. The most obvious one (and the one that is used all the time in real code) is with Functors and Applicatives (see below for a brief discussion), which is natural given the 'fmappy' kind of thing we are trying to do here. While Hoogle still doesn't suggest the best answer for that query (we do get Data.Function.Tools.apply2Way though, which has precisely the type we need), there are several ways to solve this problem, and perhaps surprisingly, Monoids are a perfectly suitable (if slightly round-about) way forwards. This is surprising because Applicatives and Monoids have different kinds, * -> * vs *, and yet we can encode this little boolean algebra using either abstraction.

For this, we need to remind ourselves that monoids let us combine two similar things. Examples of this are concatenating two strings, unioning two sets, adding two numbers. The monoid class has the following methods:

class Monoid m where
  mappend :: m -> m -> m -- also called (<>), and technically belongs to Semigroup
  mempty :: m            -- gets us the empty element

We are trying to combine two similar things! Specifically, two predicates into a third either by way of (&&) or (||). We can be clear about this by naming that idea:

type Pred a = a -> Bool

Can we treat our Pred as a Monoid? Yes! And the key is that along with the obvious things, such as strings and sets and numbers, functions also form a monoid, as long as they produce a monoid (here written as lambdas to make it clear that we are taking and returning functions):

instance Monoid b => Monoid (a -> b) where
  mempty      = \a -> mempty
  mappend f g = \a -> f a <> g a

The mappend instance is particularly interesting: it enables us to compose two functions to produce a third, but not in serial as with (.), but in parallel.

Unfortunately our Pred a is not a Monoid yet, because there is no (one) Monoid instance for Bool. In fact there are two. The second piece of the puzzle is that because there are multiple monoid instances for some data types, their different instances are associated with newtypes, to allow us to specify which one we mean.

Numbers have Sum and Product, representing the monoids (+, 0) and (*, 1) respectively. Objects with orderings (members of the Ord) have the semigroup instances Min and Max (where (<>) is min and max) as well as Monoid instances if they are Bounded. Bools have All and Any, representing the monoids (&&, True) and (||, False). With this in mind we can create our little predicate combinators:

combine :: (Functor f, Monoid (f m)) => (a -> m) -> (m -> b) -> f a -> f a -> f b
combine into outof f g = fmap outof (fmap into f <> fmap into g)

The comb helper just encapsulates the common logic for mappending two Pred a, by allowing the isomorphic functions that select the monoid to be passed in. With this we get:

(<&>), (<?>) :: Pred a -> Pred a -> Pred a
(<&>) = combine All getAll
(<?>) = combine Any getAny

not' :: Pred a -> Pred a
not' = (not .) -- helps us avoid brackets

and now we can compose complex conditions in their own terms, producing a simple boolean DSL, capable of handling even complex nested conditions:

canDrink :: Pred Person
canDrink = isTheBoss `<?>` (hasValidId `<&>` isOldEnough `<&>` not' isDrunk)

While the higher kinded typeclasses of Functors and Applicatives are a more natural fit for functions, it is always satisfying to see that the same thing can be approached from different directions.

Postscript:

The (more obvious) Applicative solution:

Like with Monoids, it is helpful to remind ourselves of the Applicative and Functor instances for (->), the type of functions, here with the specialised signatures added for clarity, and reminding ourselves that (->) is written in infix notation, so that (->) a b and a -> b are equivalent:

instance Functor ((->) a) where
  fmap :: (b -> c) -> (a -> b) -> (a -> c)
  fmap f g = f . g

instance Applicative ((->) a) where
  pure :: b -> (a -> b)
  pure = const

  (<*>) :: (a -> b -> c) -> (a -> b) -> (a -> c)
  f <*> g = \x -> f x (g x)

While we don't see our andP here just yet, it is worth remembering that the type of pure (&&) <*> isOldEnough would be:

(Person -> (Bool -> Bool -> Bool)) -> (Person -> Bool) -> Person -> Bool -> Bool

and if we have a Person -> Bool -> Bool, we can use use <*> again on a second predicate:

let appAnd = pure (&&)
    isOlderAnd = appAnd <*> isOldEnough
 in isOlderAnd <*> (not . isDrunk)

or, more simply (and making use of <$>, the infix synonym for fmap:

(&&) <$> isOldEnough <*> (not . isDrunk)

When all the infix operators start making your eyes bleed, we can use liftA2 from the Applicative class, which does exactly this:

liftA2 (&&) isOldEnough (not . isDrunk)

which means (if we can be bothered considering how trivial this is), we can define (<&>) = liftA2 (&&)