Sample.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DictionaryApplications #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Sample where

import DictPrelude
import ToDict


import Data.Set (Set)
import qualified Data.Set as Set


-- 1: Expose type-class dictionary records:

{-

The following class:

class Class a where
    method1 :: a -> a
    method2 :: a -> Int

Generates the following dictionary record:

data Class.Dict a = Class.Dict
    { method1 :: a -> a
    , method2 :: a -> Int
    }
-}



eqOn :: Eq b => (a -> b) -> Eq.Dict a
eqOn f = Eq.Dict
    { (==) = (==) `on` f
    , (/=) = (/=) `on` f
    }

--


-- mkMonoidDict :: a -> (a -> a -> a) -> Monoid.Dict a
-- mkMonoidDict mempty mappend = Monoid.Dict {..}
--   where
--     mconcat = foldr mappend mempty


sumMonoid :: Num a => Monoid.Dict a
sumMonoid = mkMonoidDict 0 (+)

prodMonoid :: Num a => Monoid.Dict a
prodMonoid = mkMonoidDict 1 (*)

sumModMonoid :: Integral a => a -> Monoid.Dict a
sumModMonoid n = mkMonoidDict 0 $ \x y -> x + y `mod` n

modMonoid :: Integral a => a -> Monoid.Dict a -> Monoid.Dict a
modMonoid n Monoid.Dict { mappend = mapp, mempty = memp } =
    mkMonoidDict memp $ \x y -> (x `mapp` y) `mod` n





-- 2: Add syntax for explicit dictionary application:

{-
Proposed syntax:

  e @{e_dict}


Currently implemented as:

  e ((e_dict))

-}

sum1to10 :: Int
sum1to10 = mconcat ((sumMonoid)) [1..10]

prod1to10 :: Int
prod1to10 = mconcat ((prodMonoid)) [1..10]

prod1to10Mod100 :: Int
prod1to10Mod100 = mconcat ((modMonoid 1000 prodMonoid)) [1..10]


--

data Person = Person
    { personId :: Int
    , personName :: String
    }

sameName :: Bool
sameName = (==) ((eqOn personName)) (Person 1 "John") (Person 2 "John")


--

-- Set.insert :: Ord a => a -> Set a -> Set a
-- Set.empty :: Set a

reverseOrd :: Ord a => Ord.Dict a
reverseOrd = mkOrdDict (flip compare)

ohno :: Set Int
ohno = Set.empty
     & Set.insert 2
     & Set.insert 1
     -- & Set.insert ((reverseOrd)) 1
-- fromList [1,2,1]


-- Newtype translation:

newtype Rev a = Rev a deriving Eq

instance Ord a => Ord (Rev a) where
    compare = flip compare

-- revInsert :: forall a. Ord a => a -> Set a -> Set a
-- revInsert x set = coerce $ insertRev (coerce x) (coerce set)
--   where           ^^^^^^                         ^^^^^^
--     insertRev :: Ord a => Rev a -> Set (Rev a) -> Set (Rev a)
--     insertRev = coerce (Set.insert @a)
--                 ^^^^^^

ohno' :: Set Int
ohno' = Set.empty
      & Set.insert 2
      & Set.insert 1
      -- & revInsert 1
-- fromList [1,2,1]

{-
Role criterion:

The type variable occurring in the type-class constaint, must have a role
<= representational in the remainder of the monotype (excluding the other
constraints)


For example: Ord a => a -> Set a -> Set a
                 ^
a has role nominal because it occurs in (Set a)
-> explicit dictionary application DISallowed

Another example: Ord a => a -> [a] -> [a]
                     ^
a has role representational
-> explicit dictionary application allowed

-}



{-
Sometimes an annotation is needed:

Proposed syntax:

  e @{e_dict as C a}

Currently implemented as:

  e ((e_dict :: C a))

-}

eqTuple :: (Eq a, Eq b) => (a, b) -> (a, b) -> Bool
eqTuple = (==)


sameConstaintTwice :: Bool
sameConstaintTwice =
    eqTuple ((dict1 :: Eq a))
            ((dict2 :: Eq b))
            (11 :: Int, "foo")
            (21, "bar")
  where
    dict1 = eqOn (`mod` 10)
    dict2 = mkEqDict (\_ _ -> True)



-- 3: Dictionary instances

{-

instance [<ctxt> =>]? <C> <tvs> = <dict>

-}


instance Eq Person = eqOn personId

sameId :: Bool
sameId = Person 1 "John" == Person 1 "Ian"



--

functorFromMonad :: Monad m => Functor.Dict m
functorFromMonad = mkFunctorDict liftM

applicativeFromMonad :: Monad m => Applicative.Dict m
applicativeFromMonad = mkApplicativeDict functorFromMonad return ap


newtype MyState s a = MyState (s -> (s, a))

runMyState :: s -> MyState s a -> (s, a)
runMyState s (MyState st) = st s

instance Monad (MyState s) where
    return a = MyState $ \s -> (s, a)
    MyState st >>= f = MyState $ \s0 ->
        let !(s1, a) = st s0
            !(MyState st') = f a
        in st' s1

instance MonadState s (MyState s) where
    get = MyState $ \s -> (s, s)
    put s' = MyState $ \_ -> (s', ())

instance Functor (MyState s) = functorFromMonad

instance Applicative (MyState s) = applicativeFromMonad


--


applicativeMonoid :: (Applicative f, Monoid a) => Monoid.Dict (f a)
applicativeMonoid = mkMonoidDict (pure mempty) (liftA2 mappend)

instance Monoid a => Monoid (ST s a) = applicativeMonoid


--

numMod :: forall a. (Integral a, Num a) => a -> Num.Dict a
numMod a = Num.Dict
    { (+) = mod2 (+)
    , (-) = mod2 (-)
    , (*) = mod2 (*)
    , negate = mod1 negate
    , abs = mod1 abs
    , signum = mod1 signum
    , fromInteger = mod1 fromInteger
    }
  where
    mod1 f x = f x `mod` a
    mod2 f x y = f x y `mod` a

applicativeNum :: (Applicative f, Num a) => Num.Dict (f a)
applicativeNum = Num.Dict
    { (+) = liftA2 (+)
    , (-) = liftA2 (-)
    , (*) = liftA2 (*)
    , negate = liftA negate
    , abs = liftA abs
    , signum = liftA signum
    , fromInteger = pure . fromInteger
    }

instance Num (IO Int) = applicativeNum @IO ((numMod 10))

testNumIOInt :: IO Int
testNumIOInt = pure 9 + pure 9
-- 8



--


newtype Duration = Duration Int -- in seconds
    deriving (Eq, Ord, Num, Show)

-- instance Arbitrary Duration = coerce (arbitraryDict @(NonNegative Int))
-- instance Arbitrary Duration = coerce (arbitraryDict @(NonNegative (Large Int)))
instance Arbitrary Duration =
    coerce (getDict @(Arbitrary (NonNegative (Large Int))))

-- sample (arbitrary :: Gen Duration)



--

data Weekday = Mo | Tu | We | Th | Fr | Sa | Su
    deriving (Enum, Bounded, Show)

instance Arbitrary Weekday = mkArbitraryDict arbitraryBoundedEnum


--


between :: Random a => a -> a -> Arbitrary.Dict a
between lower upper = mkArbitraryDict $ choose (lower, upper)

newtype Year = Year Integer
    deriving (Show)

instance Arbitrary Year = coerce (between @Integer 1900 2100)


--


showListNewlines :: Show a => Show.Dict [a]
showListNewlines = mkShowDict (unlines . map show)

test :: IO ()
test = print ((showListNewlines)) ["foo", "bar", "baz"]


--


someStateComputation :: MonadState Int m => m ()
someStateComputation = replicateM_ 123456 $
                       modify succ


runMonadStateST :: forall s a. s -> (forall m. MonadState s m => m a) -> (s, a)
runMonadStateST initState m = runST $ do
    ref <- newSTRef initState
    let dict = MonadState.Dict
            { parent1 = getDict @(Monad _)
            , get = readSTRef ref
            , put = writeSTRef ref
            , state = \f -> do
                  s <- readSTRef ref
                  let !(a, s') = f s
                  writeSTRef ref s'
                  return a
            }
    a <- m ((dict))
    s <- readSTRef ref
    return (s, a)


runMonadStateIO :: forall s a. s -> (forall m. MonadState s m => m a) -> IO (s, a)
runMonadStateIO initState m = do
    ref <- newIORef initState
    let dict = MonadState.Dict
            { parent1 = getDict @(Monad IO)
            , get = readIORef ref
            , put = writeIORef ref
            , state = \f -> do
                  s <- readIORef ref
                  let !(a, s') = f s
                  writeIORef ref s'
                  return a
            }
    a <- m ((dict))
    s <- readIORef ref
    return (s, a)

runConcurrent :: forall s a. s -> (forall m. MonadState s m => m a) -> IO (s, a, a)
runConcurrent initState m = do
    ref <- newTVarIO initState
    let dict = MonadState.Dict
            { parent1 = getDict @(Monad IO)
            , get = readTVarIO ref
            , put = atomically . writeTVar ref
            , state = \f -> atomically $ do
                  s <- readTVar ref
                  let !(a, s') = f s
                  writeTVar ref s'
                  return a
            }
    (a1, a2) <- concurrently (m ((dict))) (m ((dict)))
    s <- readTVarIO ref
    return (s, a1, a2)