reid.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}

module Main where

class FinalExpr a where
    intThing :: Int -> a
    stringThing :: String -> a

data Final = Final { _getFinal :: forall a. FinalExpr a => a }

instance FinalExpr Final where
    intThing i = Final $ intThing i
    stringThing s = Final $ stringThing s

instance (FinalExpr a, FinalExpr b) => FinalExpr (a, b) where
    intThing i = (intThing i, intThing i)
    stringThing s = (stringThing s, stringThing s)

instance FinalExpr Int where
    intThing = id
    stringThing s = read s

newtype JSON = JSON String deriving (Show)

instance FinalExpr JSON where
    intThing i = JSON $ show i
    stringThing s = JSON s

toInt' :: Int -> Int
toInt' = id

toJson' :: JSON -> JSON
toJson' = id

instance FinalExpr repr => FinalExpr ((repr -> a) -> a) where
    intThing i f = f $ intThing i
    stringThing s f = f $ stringThing s

instance FinalExpr a => FinalExpr (IO a) where
    intThing i = return $ intThing i
    stringThing s = return $ stringThing s

runIO :: IO () -> IO ()
runIO = id

cpsMain :: Final -> IO ()
cpsMain fin = do
    print . toInt' $ _getFinal fin
    print . toJson' $ _getFinal fin

main :: IO ()
main = do
    runIO $ intThing 99 cpsMain
    runIO $ stringThing "111" cpsMain