First as Applicative

First.hs

{-# OPTIONS -Wall -Werror #-}

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

import Control.Applicative ((<|>))
import Control.Monad       (void)
import Test.QuickCheck
import Text.Show.Functions ()

newtype First a b = First (Maybe a) deriving (Arbitrary, Eq, Functor, Show)

continue :: First a b
continue = First Nothing

result :: a -> First a b
result a = First $ Just a

instance Applicative (First a) where
    pure _ = First Nothing
    First ma <*> First mb = First (ma <|> mb)

-- instance Monad (First a) where
--     First ma >>= f = _

prop_Functor_id :: First A B -> Bool
prop_Functor_id s = fmap id s == s

prop_Functor_compose :: (C -> D) -> (B -> C) -> First A B -> Bool
prop_Functor_compose f g s = fmap (f . g) s == (fmap f . fmap g) s

prop_Applicative_identity :: First A B -> Bool
prop_Applicative_identity v = (pure id <*> v) == v

prop_Applicative_composition
    :: First A (B -> C) -> First A (D -> B) -> First A D -> Bool
prop_Applicative_composition u v w =
    (pure (.) <*> u <*> v <*> w) == (u <*> (v <*> w))

prop_Applicative_homomorphism :: (A -> B) -> A -> Bool
prop_Applicative_homomorphism f x =
    (pure f <*> pure x :: First C B) == pure (f x)

prop_Applicative_interchange :: First A (B -> C) -> B -> Bool
prop_Applicative_interchange u y = (u <*> pure y) == (pure ($ y) <*> u)

-- prop_Monad_leftIdentity :: A -> (A -> First B C) -> Bool
-- prop_Monad_leftIdentity a k = (return a >>= k) == k a
--
-- prop_Monad_rightIdentity :: First A B -> Bool
-- prop_Monad_rightIdentity m = (m >>= return) == m
--
-- prop_Monad_composition
--     :: First A B -> (B -> First A C) -> (C -> First A D) -> Bool
-- prop_Monad_composition m k h = (m >>= (\x -> k x >>= h)) == ((m >>= k) >>= h)

type A = Int
type B = Bool
type C = Char
type D = Float

pure []

main :: IO ()
main = void $quickCheckAll