-- 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)))

{-# 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 o events
class EventNames a where
  eventNames :: Proxy a -> String -> String

-- EventNames: base case for induction on list of types. We start here because
-- *every* list will have EndOfList at the bottom.
instance EventNames EndOfList where
  eventNames _ s = s

-- A typeclass for types that can be named. Translates Event types to names.
class Named e where
  name :: Proxy e -> 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"

-- EventNames: induction step: (e, tail)
instance (Named e, EventNames tail) => EventNames (e, tail) where
  eventNames _ s =
    let tailProxy = Proxy :: Proxy tail
        eProxy    = Proxy :: Proxy e
     in eventNames tailProxy (name eProxy ++ ", " ++ s)

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

-- 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)

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

class HandleEvent events where
  type Out events :: *
  handleEvent :: Proxy events -> String -> String -> Either String (Out events)

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

instance (FromString e, Named e, HandleEvent tail) => HandleEvent (e, tail) where
  type Out (e, tail) = Either (Out tail) e
  handleEvent _ eventName payload =
    let handleNext = fmap Left (handleEvent (Proxy :: Proxy tail) eventName payload)
        headEventName = name (Proxy :: Proxy e)
     in if eventName == headEventName
           then case fromString payload of
                  Nothing -> Left ("Could not decode " ++ payload ++ " for event " ++ eventName)
                  Just a -> Right (Right a)
           else handleNext

main :: IO ()
main = do
  putStrLn (eventNames (Proxy :: Proxy Events) "")

  putStr "dynamic dispatch on click: "
  print (handleEvent (Proxy :: Proxy Events) "click" "lambdaworld\tpage/rules")

  putStr "dynamic dispatch on play: "
  print (handleEvent (Proxy :: Proxy Events) "play" "lambdaworld\t123")

  putStr "dynamic dispatch on pause: "
  print (handleEvent (Proxy :: Proxy Events) "pause" "lambdaworld\t123\t456")

  putStr "dynamic dispatch on play with (wrong id): "
  print (handleEvent (Proxy :: Proxy Events) "play" "lambdaworld\tnotanumber")

  putStr "dynamic dispatch on unknown event (\"lambda-world\"): "
  print (handleEvent (Proxy :: Proxy Events) "lambda-world" "lambdaworld\t123")