2014-05-28-querying.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Querying where

import Control.Applicative
import Control.Monad
import Data.Functor.Compose
import Data.Monoid
import Data.Traversable (for)

data Querying :: (* -> *) -> [KV * *] -> * -> * where
  Querying :: KeyList kvs -> Compose m (ResultF kvs) a -> Querying m kvs a

instance Functor m => Functor (Querying m kvs) where
  fmap f (Querying kvs x) = Querying kvs (fmap f x)

instance (Applicative m, Applicative (ResultF kvs), Monoid (KeyList kvs)) => Applicative (Querying m kvs) where
  pure a = Querying mempty (pure a)
  (Querying kvs f) <*> (Querying kvs' x) = Querying (kvs <> kvs') (f <*> x)

data ResultF :: [KV * *] -> * -> * where
  ResultConst :: a -> ResultF '[] a
  ResultFunc :: ([(k, v)] -> ResultF kvs a) -> ResultF ('KV k v ': kvs) a

instance Functor (ResultF kvs) where
  fmap f (ResultConst x) = ResultConst (f x)
  fmap f (ResultFunc g) = ResultFunc (fmap f . g)

instance Applicative (ResultF '[]) where
  pure = ResultConst
  (ResultConst f) <*> (ResultConst x) = ResultConst (f x)

instance Applicative (ResultF kvs) => Applicative (ResultF ('KV k v ': kvs)) where
  pure x = ResultFunc (const (pure x))
  (ResultFunc f) <*> (ResultFunc x) = ResultFunc (\args -> f args <*> x args)

data KV k v  = KV k v

data KeyList :: [KV * *] -> * where
  Nil :: KeyList '[]
  Cons :: [k] -> KeyList kvs -> KeyList ('KV k v ': kvs)

data Where :: [KV * *] -> (KV * *) -> * where
  Here :: (Monoid (KeyList tail), IdentityResultF tail) => Where (kv ': tail) kv
  There :: Where kvs kv -> Where ('KV k v ': kvs) kv

class Somewhere (kvs :: [KV * *]) (kvs' :: [KV * *]) (kv :: (KV * *)) where
  somewhere :: Where kvs kv -> Where kvs' kv

instance (Monoid (KeyList kvs'), IdentityResultF kvs') => Somewhere ('KV k v ': kvs') ('KV k v ': kvs') ('KV k v) where
  somewhere _ = Here

instance Somewhere kvs kvs' kv => Somewhere kvs ('KV k v ': kvs') kv where
  somewhere = There . somewhere

instance Monoid (KeyList '[]) where
  mempty = Nil
  mappend _ _ = Nil

instance (Monoid (KeyList kvs)) => Monoid (KeyList ('KV k v ': kvs)) where
  mempty = Cons mempty mempty
  mappend (Cons l ls) (Cons r rs) = Cons (l ++ r) (mappend ls rs)

withQuery
  :: (IdentityResultF kvs, Monoid (KeyList kvs), Monad m)
  => ([k] -> m [(k, v)])
  -> (Where ('KV k v ': kvs) ('KV k v) -> Querying m ('KV k v ': kvs) a)
  -> Querying m kvs a
withQuery query k =
  case k Here of
    Querying (keys `Cons` kvs) (Compose m) ->
      Querying kvs $ Compose $ do
        ResultFunc f <- m
        results <- query keys
        return (f results)

ask :: (Eq k, Monad m, Somewhere kvs kvs' ('KV k v)) => Where kvs ('KV k v) -> k -> Querying m kvs' (Maybe v)
ask q k = Querying (mkKeyList (somewhere q) k) (Compose $ return (mkResultF (somewhere q) k))

mkKeyList :: Where kvs ('KV k v) -> k -> KeyList kvs
mkKeyList Here k = Cons [k] (mempty)
mkKeyList (There path) k = Cons [] (mkKeyList path k)

mkResultF :: (Eq k) => Where kvs ('KV k v) -> k -> ResultF kvs (Maybe v)
mkResultF Here k = ResultFunc (identityResultF . lookup k)
mkResultF (There path) k = ResultFunc (const (mkResultF path k))

class IdentityResultF (kvs :: [KV * *]) where
  identityResultF :: a -> ResultF kvs a

instance IdentityResultF '[] where
  identityResultF = ResultConst

instance IdentityResultF xs => IdentityResultF ('KV k v ': xs) where
  identityResultF a = ResultFunc (const (identityResultF a))

runQuerying :: Monad m => Querying m '[] a -> m a
runQuerying (Querying Nil (Compose m)) = liftM (\(ResultConst a) -> a) m

example :: IO [(Maybe Int, Maybe Int)]
example =
  runQuerying $
  withQuery getUserNameById $ \userNameById ->
  withQuery getUserAgeById $ \userAgeById ->
    for [1..10] $ \userId ->
      (,) <$> ask userNameById userId <*> ask userAgeById userId

  where
  getUserNameById :: [Int] -> IO [(Int, Int)]
  getUserNameById keys = do
    print keys
    return [(1, 42)]

  getUserAgeById :: [Int] -> IO [(Int, Int)]
  getUserAgeById = const (return [(1, 5)])

main :: IO ()
main = example >>= print