LambdaWorld 2016 & Typelevel Summit 2017 (Copenhagen): Type-Level DSLs // Typeclass induction

events.hs

-- Our goal is to create a type describing a list of events. This is our
-- type-level DSL.
-- We will then use typeclass resolution to "interpret" this type-level DSL
-- into two things:
-- 1. A comma-separated list of events
-- 2. A method that, when given an event name and a payload, will try to parse
--    that event type with the payload. A form of dynamic dispatching
--
-- To model a list of types we will use tuples. You can imagine the list of
-- types "Int, String, Char" to look like:
--
-- (Int, (String, (Char, EndOfList)))

-- | To begin, we need a few types and imports

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module Main where

import Data.Proxy (Proxy(Proxy))

{------------------------------------------------------------------------------
  ---------------- Part 0: Preliminary Definitions ----------------------------
  ----------------------------------------------------------------------------}



-- Our events
data Click = Click { clickUser :: String, clickPage :: String } deriving (Show)
data Play = Play { playUser :: String, playTrack :: Int } deriving (Show)
data Pause = Pause { pauseUser :: String, pauseTrack :: Int, pauseTime :: Int } deriving (Show)



-- Uninhabitted type for "end of list"
data EndOfList

instance Show EndOfList where
  show _ = "EndOfList"



-- Our list of events
type Events = (Click, (Play, (Pause, EndOfList)))





{------------------------------------------------------------------------------
  ---------------- Part 1: Extracting Event Names from Types ------------------
  ----------------------------------------------------------------------------}

-- A typeclass to extract names from a list of events
class Named a where
  name :: Proxy a -> String




-- Instances of Named for our events
instance Named Click where name _ = "click"
instance Named Play  where name _ = "play"
instance Named Pause where name _ = "pause"





-- Named: base case for Named
instance Named EndOfList where
  name _ = ""






-- Named: induction step for Named: (e, tail)
instance (Named e, Named tail) => Named (e, tail) where
  name _ = name (Proxy :: Proxy e) ++ ", " ++ name (Proxy :: Proxy tail)






{------------------------------------------------------------------------------
  ---------------- Part 2: Parsing Events / Dynamic Dispatch ------------------
  ----------------------------------------------------------------------------}




-- A Typeclass for dynamic-dispatch on events
class HandleEvent events where
  type Out events :: *
  handleEvent :: Proxy events -> String -> String -> Either String (Out events)






-- HandleEvent: base case.
instance HandleEvent EndOfList where
  type Out EndOfList = EndOfList
  handleEvent _ event payload = Left ("Could not decode " ++ event ++ " with payload " ++ payload)





-- A typeclass for types that can be parsed from strings.
class FromString a where
  fromString :: String -> Maybe a




-- A Helper for working with Strings
maybeRead :: Read a => String -> Maybe a
maybeRead s = case reads s of [(x, "")] -> Just x; _ -> Nothing

-- A helper for parsing strings
splitOn :: Eq a => a -> [a] -> [[a]]
splitOn a as =
  let recur a' h (interim, acc) =
        if a' == h then ([], interim : acc) else (h : interim, acc)
      concatTuple (x,y) = x : y
  in concatTuple (foldr (recur a) ([], []) as)

-- parser instances for our types
instance FromString Click where
  fromString s =
    case splitOn '\t' s of
      [user,page] -> Just (Click user page)
      _           -> Nothing

instance FromString Play where
  fromString s =
    case splitOn '\t' s of
      [user,trackId] -> Play user <$> maybeRead trackId
      _              -> Nothing
instance FromString Pause where
  fromString s =
    case splitOn '\t' s of
      [user,trackId,ts] -> Pause user <$> maybeRead trackId <*> maybeRead ts
      _                 -> Nothing





-- HandleEvent: induction step
instance (FromString e, Named e, HandleEvent tail) => HandleEvent (e, tail) where

  type Out (e, tail) = Either (Out tail) e

  handleEvent _ eventName payload =
    let headEventName = name (Proxy :: Proxy e)
     in if eventName == headEventName
           then case fromString payload of
                  Just a -> Right (Right a)
                  Nothing -> Left ("Could not decode " ++ payload ++ " for event " ++ eventName)
           else fmap Left (handleEvent (Proxy :: Proxy tail) eventName payload)





main :: IO ()
main = do
  putStrLn "\ntype Events = (Click, (Play, (Pause, EndOfList)))\n"
  putStr "1. event names:\n\tname (Proxy :: Proxy Events) = "
  putStrLn (name (Proxy :: Proxy Events))

  putStr "\n2. dynamic dispatch on click:\n\thandleEvent (Proxy :: Proxy Events) \"click\" \"lambdaworld\\tpage/rules\" =\n\t"
  print (handleEvent (Proxy :: Proxy Events) "click" "lambdaworld\tpage/rules")

  putStr "\n3. dynamic dispatch on play:\n\thandleEvent (Proxy :: Proxy Events) \"play\" \"lambdaworld\\t123\" =\n\t"
  print (handleEvent (Proxy :: Proxy Events) "play" "lambdaworld\t123")

  putStr "\n4. dynamic dispatch on pause:\n\thandleEvent (Proxy :: Proxy Events) =\n\t"
  print (handleEvent (Proxy :: Proxy Events) "pause" "lambdaworld\t123\t456")

  putStr "\n5. dynamic dispatch (wrong payload):\n\thandleEvent (Proxy :: Proxy Events) \"play\" \"lambdaworld\\tnotanumber\" =\n\t"
  print (handleEvent (Proxy :: Proxy Events) "play" "lambdaworld\tnotanumber")

  putStr "\n6. dynamic dispatch (wrong event):\n\thandleEvent (Proxy :: Proxy Events) \"lambda-world\" \"lambdaworld\\t123\" =\n\t"
  print (handleEvent (Proxy :: Proxy Events) "lambda-world" "lambdaworld\t123")

events.scala

object events {

  /****************************************************************************
   **************** Part 0: Preliminary Definitions ***************************
   ***************************************************************************/

  // Our events
  case class Click(user: String, page: String)
  case class Play(user: String, trackId: Long)
  case class Pause(user: String, trackId: Long, ts: Long)




  // A type alias for "end of the type-level list"
  type EndOfList = Unit




  // list of events
  type Events = (Click, (Play, (Pause, EndOfList)))




  /****************************************************************************
   **************** Part 1: Extracting Event Names from Types *****************
   ***************************************************************************/

  // A typeclass to extract names from a list of events.
  trait Named[E] {
    val name: String
  }




  // instances of Named for our events
  implicit val namedClick = new Named[Click] { val name: String = "click" }
  implicit val namedPlay  = new Named[Play]  { val name: String = "play"  }
  implicit val namedPause = new Named[Pause] { val name: String = "pause" }




  // Named: base case
  implicit val baseCaseNamed = new Named[EndOfList] {
    val name: String = ""
  }




  // Named induction step: (E, Tail)
  implicit def inductionStepNamed[E,Tail](
    implicit
    n: Named[E],
    tailNames: Named[Tail]
  ) = new Named[(E,Tail)] {

    val name: String = s"${n.name}, ${tailNames.name}"

  }

  // helper
  def getNamed[E](implicit names: Named[E]): String = names.name




  /****************************************************************************
   **************** Part 2: Parsing Events / Dynamic Dispatch *****************
   ***************************************************************************/



  // A Typeclass for dynamic-dispatch on events
  trait HandleEvents[Events] {
    type Out
    def handleEvent(eventName: String, payload: String): Either[String, Out]
  }




  // HandleEvents: base case
  implicit val baseCaseHandleEvents = new HandleEvents[EndOfList] {
    type Out = Nothing
    def handleEvent(eventName: String, payload: String) = Left(s"Did not find event $eventName")
  }




  // A typeclass for types that can be parsed from strings.
  trait FromString[E] {
    def fromString(s: String): Option[E]
  }




  // Parser instances for our types.
  implicit val clickFromstring = new FromString[Click] {
    def fromString(s: String) = s.split('\t').toList match {
      case user :: track :: Nil => Some(Click(user, track))
      case _ => None
    }}

  // A small helper
  def safeToLong(s: String): Option[Long] = try { Some(s.toLong) } catch { case _: java.lang.NumberFormatException => None }

  implicit val playFromString = new FromString[Play] {
    def fromString(s: String) = s.split('\t').toList match {
      case user :: track :: Nil => safeToLong(track).map(Play(user,_))
      case _ => None
  }}

  implicit val pauseFromString = new FromString[Pause] {
      def fromString(s: String) = s.split('\t').toList match {
        case user :: track :: ts :: Nil => safeToLong(track).flatMap { t => safeToLong(ts).map(Pause(user, t,_)) }
        case _ => None
  }}




  // HandleEvents: induction step (E, Tail)
  implicit def inductionStepHandleEvents[E, Tail](
    implicit
    namedEvent: Named[E],
    fromString: FromString[E],
    tailHandles: HandleEvents[Tail]
  ) = new HandleEvents[(E, Tail)] {

    type Out = Either[tailHandles.Out, E]

    def handleEvent(eventName: String, payload: String): Either[String, Out] = {
      if(eventName == namedEvent.name) {
        fromString.fromString(payload) match {
          case None => Left(s"""Could not decode event "$eventName" with payload "$payload"""")
          case Some(e) => Right(Right(e))
        }
      } else {
        tailHandles.handleEvent(eventName, payload) match {
          case Left(e) => Left(e)
          case Right(e) => Right(Left(e))
        }
      }
    }
  }




  // Helper.
  def handleEvent[Events](eventName: String, payload: String)(
    implicit
    names: HandleEvents[Events]
  ): Either[String, names.Out] = names.handleEvent(eventName, payload)


  /****************************************************************************
   **************** Part 3: Putting it all together ***************************
   ***************************************************************************/

  def main(args: Array[String]): EndOfList = {
    println(s"""\ntype Events = (Click, (Play, (Pause, EndOfList)))\n""")
    println(s"1. event names:\n\t getNamed[Events] = ${getNamed[Events]}\n")
    println(s"""2. dynamic dispatch on click:\n\thandleEvent[Events]("click", "lambdaworld\\tpage/rules") = ${handleEvent[Events]("click", "lambdaworld\tpage/rules")}\n""")
    println(s"""3. dynamic dispatch play:\n\thandleEvent[Events]("play", "lambdaworld\\t123") = ${handleEvent[Events]("play", "lambdaworld\t123")}\n""")
    println(s"""4. dynamic dispatch pause:\n\thandleEvent[Events]("pause", "lambdaworld\\t123\\t456") = ${handleEvent[Events]("pause", "lambdaworld\t123\t456")}\n""")
    println(s"""5. dynamic dispatch (wrong payload):\n\thandleEvents[Events]("play", "lambdaworld\\tnotanumber") = ${handleEvent[Events]("play", "lambdaworld\tnotanumber")}\n""")
    println(s"""6. dynamic dispatch (wrong event):\n\thandleEvents[Events]("lambda-world", "lambdaworld\\t123") = ${handleEvent[Events]("lambda-world", "lambdaworld\t123")}\n""")
  }

}