Skip to content

Instantly share code, notes, and snippets.

@ocramz
Forked from phadej/existential-constraint.hs
Last active June 16, 2016 13:27
Show Gist options
  • Save ocramz/07ffa9c27ccadaae14f5fdc2b2b221d0 to your computer and use it in GitHub Desktop.
Save ocramz/07ffa9c27ccadaae14f5fdc2b2b221d0 to your computer and use it in GitHub Desktop.
This is short gist about problem I run today into, and its solution. It feels that probably I'm over engineering stuff, so: please comment!
#!/usr/bin/env stack
-- stack --resolver=lts-6.0 runghc --package constraints --package mtl --package lens --package text --package time
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ConstraintKinds, UndecidableInstances, ScopedTypeVariables, InstanceSigs, OverloadedStrings, TemplateHaskell #-}
-- This is short gist about problem I run today into,
-- and its solution. It feels that probably I'm over engineering stuff,
-- so: please comment!
import Control.Lens
import Control.Monad.Reader
import Control.Monad.State
import Data.Constraint
import Data.Proxy (Proxy (..))
import Data.Foldable (traverse_)
import Data.Functor.Identity
import Data.Text
import Data.Time
import GHC.TypeLits (Symbol)
-- Suppose we have a types we want to render, rendering happens in a monad
class Renderable' a where
render' :: Monad m => a -> m [String]
instance Renderable' () where
render' _ = return ["unit"]
-- Yet some types would need a bit more then just a monad,
-- for example some additional information like current date time!
class Renderable a where
type RenderableC a (m :: * -> *) :: Constraint
type RenderableC a m = ()
render :: (Monad m, RenderableC a m) => a -> m [String]
instance Renderable () where
render _ = return ["unit"]
newtype Created = Created UTCTime
instance Renderable Created where
type RenderableC Created m = MonadReader UTCTime m
render (Created x) = do
now <- ask
return ["Created " ++ show (diffUTCTime now x) ++ " ago"]
-- >>> createdExample
-- ["Created 0.00001s ago"]
createdExample :: IO ()
createdExample = do
cre <- getCurrentTime
now <- getCurrentTime
-- Using (->) UTCTime as MonadReader
print $ render (Created cre) now
-- And constraints compose!
instance (Renderable a, Renderable b) => Renderable (a, b) where
type RenderableC (a, b) m = (RenderableC a m, RenderableC b m)
render (a, b) = (++) <$> render a <*> render b
instance (Renderable a) => Renderable [a] where
type RenderableC [a] m = RenderableC a m
render = fmap mconcat . traverse render
-- >>> createdExample2
-- ["Created 0.000002ss ago","unit"]
createdExample2 :: IO ()
createdExample2 = do
cre <- getCurrentTime
now <- getCurrentTime
-- Using (->) UTCTime as MonadReader
print $ render (Created cre, ()) now
-- But MonadReader constraints don't compose that well, we cannot have e.g.
-- '(MonadReader UTCTime m, MonadReader Text m)' constraint.
-- We can use optics approach, by requiring specific pieces of reader environment:
class HasUTCTime env where
utcTime :: Lens' env UTCTime
instance HasUTCTime UTCTime where
utcTime = id
class HasText env where
text :: Lens' env Text
instance HasText Text where
text = id
-- Yet the problem is that we cannot use these as it in 'Renderable'
newtype C = C UTCTime
data T = T
-- @
--instance Renderable C where
-- type RenderableC C m = (MonadReader env m, HasUTCTime m)
-- render = undefined
-- @
--
-- fails with:
--
-- @
-- Not in scope: type variable ‘env’
-- @
--
-- We'd need some kind of existential constraints!
-- One solution would look like:
-- Non dependent class
class MonadReader' c m where
monadReaderConstraint :: MRE c m
data MRE c m where
MkMRE :: Dict (MonadReader env m, c env) -> MRE c m
-- We can even have generic constraint, because 'env' is determined by 'm' thru
-- 'MonadReader':
instance (MonadReader env m, c env) => MonadReader' c m where
monadReaderConstraint = MkMRE Dict
-- Let's try!
instance Renderable C where
type RenderableC C m = MonadReader' HasUTCTime m
render :: forall m. (Monad m, RenderableC C m) => C -> m [String]
render (C x) = case monadReaderConstraint :: MRE HasUTCTime m of
MkMRE Dict -> do
now <- view utcTime
return ["Created " ++ show (diffUTCTime now x) ++ " ago"]
instance Renderable T where
type RenderableC T m = MonadReader' HasText m
render :: forall m. (Monad m, RenderableC T m) => T -> m [String]
render T = case monadReaderConstraint :: MRE HasText m of
MkMRE Dict -> do
t <- view text
return [unpack t]
data Env = Env { _envUTCTime :: UTCTime, _envText :: Text }
makeLenses ''Env
instance HasUTCTime Env where
utcTime = envUTCTime
instance HasText Env where
text = envText
-- | and final example:
--
-- >>> example
-- "unit"
-- "foobar"
-- "Created 0.000001s ago"
example :: IO ()
example = do
c <- getCurrentTime
now <- getCurrentTime
let env = Env now "foobar"
let out = render ((), (T, C c)) env :: [String]
traverse_ print out
main :: IO ()
main = do
createdExample
createdExample2
example
-------------------------------------------------------------------------------
-- Follow-up:
-------------------------------------------------------------------------------
-- Renderable is then wrapped in a named container, which knows how to render
-- itself in any environment.
--
-- I could get away with newtypes, but as they all have the same structure: I
-- tag them with type level string, and can treat them uniformly. In other
-- words instead of writing 'Renderable' instance directly, I write
-- 'RenderableStuff'.
--
-- Yet there are other classes I want for 'Stuff', now I can write them once.
-- With newtype approach I'd need to write them, even I could autoderive them,
-- I'd need to remember to do that.
--
-- However: Whatever approach I chose here, I still would have problem with
-- existential type-classes.
data Stuff (sym :: Symbol) a b = Stuff a b
class Renderable b => RenderableStuff (sym :: Symbol) a b | sym -> a, sym -> b where
renderStuff :: Proxy sym -> a -> b -> [String]
instance RenderableStuff sym a b => Renderable (Stuff sym a b) where
render (Stuff a b) = return $ renderStuff (Proxy :: Proxy sym) a b
-- We can define helpers for simple Stuff
renderStuffInReader
:: (Renderable b, RenderableC b ((->) a))
=> a -> b -> [String]
renderStuffInReader a b =
render b a
renderStuffInReaderWithState
:: (Renderable b, RenderableC b (StateT s ((->) a)))
=> s -> a -> b -> [String]
renderStuffInReaderWithState s a b = evalStateT (render b) s a
-- -------------------------------------------------------------------------------
-- Bigger example:
-------------------------------------------------------------------------------
data X = X
class HasInt env where
int :: Lens' env Int
instance HasInt Int where
int = id
instance Renderable X where
type RenderableC X m = MonadState' HasInt m
render :: forall m. (Monad m, RenderableC X m) => X -> m [String]
render X = case monadStateConstraint :: MSE HasInt m of
MkMSE Dict -> do
i <- int <+= 1
return ["X: " ++ show i]
type Weird = (((), [X]), (T, C))
type ExampleStuff = Stuff "weird" Env Weird
instance RenderableStuff "weird" Env Weird where
renderStuff _ = renderStuffInReaderWithState (0 :: Int)
-- |
-- @
-- >>> exampleStuff
-- "unit"
-- "X: 1"
-- "X: 2"
-- "X: 3"
-- "X: 4"
-- "foobar"
-- "Created 0.000001s ago"
-- @
exampleStuff :: IO ()
exampleStuff = do
c <- getCurrentTime
now <- getCurrentTime
let env = Env now "foobar"
let weird = (((), [X, X, X, X]), (T, C c)) :: Weird
let stuff = Stuff env weird :: ExampleStuff
let out = runIdentity $ render stuff :: [String]
traverse_ print out
-------------------------------------------------------------------------------
-- MonadState'
-------------------------------------------------------------------------------
class MonadState' c m where
monadStateConstraint :: MSE c m
data MSE c m where
MkMSE :: Dict (MonadState s m, c s) -> MSE c m
instance (MonadState s m, c s) => MonadState' c m where
monadStateConstraint = MkMSE Dict
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment