Ch17.purs

module Ch17 where
( Age (..)
, FamilyAges(..)
, FamilyAgesRow
, Validation(..)
, Either(..)
, createFamilyAges
, test
) where

import Prelude
import Data.Newtype      (class Newtype)
import Data.Generic.Rep  (class Generic)
import Data.Show.Generic (genericShow)
import Data.Bifunctor    (class Bifunctor)
import Effect            (Effect)
import Effect.Console    (log)

-----------------------------------------
-- Writing Applicative Instance for Maybe
-----------------------------------------

-- Create the Maybe Type from scratch providing all of the prerequisites for Applicative:
-- Define the Type
data Maybe a = Nothing | Just a
-- Create a Show Instance using genericShow (for our test code)
derive instance genericMaybe :: Generic (Maybe a) _
instance showMaybe :: Show a => Show (Maybe a) where
  show = genericShow
-- Create a Functor Instance
instance functorMaybe :: Functor Maybe where
  map _ Nothing  = Nothing
  map f (Just a) = Just $ f a
-- Create an Apply Instance
instance applyMaybe :: Apply Maybe where
  apply (Just f) m  = f <$> m
  apply _        _  = Nothing
-- Create an Applicative Instance
instance applicativeMaybe :: Applicative Maybe where
  pure = Just

------------------------------------------
-- Writing Applicative Instance for Either
------------------------------------------

-- Instead of writing Eq and Functor, we’re going to derive it and let the compiler do some work for us.
-- Define the type
data Either a b = Left a | Right b
-- Derive Eq Instance
derive instance eqEither :: (Eq a, Eq b) => Eq (Either a b)
-- Derive Ord Instance (we’re going to need this later on)
derive instance ordEither :: (Ord a, Ord b) => Ord (Either a b)
-- Derive Functor Instance
derive instance functorEither :: Functor (Either a)
-- Create a Show Instance using genericShow (for our test code)
derive instance genericEither :: Generic (Either a b) _
instance showEither :: (Show a, Show b) => Show (Either a b) where
  show = genericShow
-- Create a Bifunctor Instance (we’re going to need this later on)
instance bifunctorEither :: Bifunctor Either where
  bimap f _ (Left  a) = Left  $ f a
  bimap _ g (Right b) = Right $ g b
-- Create an Apply Instance
instance applyEither :: Apply (Either a) where
  apply (Right f) r         = f <$> r
  apply (Left  f) _         = Left f
-- Create an Applicative Instance
instance applicativeEither :: Applicative (Either a) where
  pure = Right

-------------
-- Validation
-------------

-- We are simply just wrapping Either in a newtype. This will allow us to leverage Either’s implementation when
-- it suits us, i.e. when Validation’s behavior is identical to Either, we’ll tell the compiler to derive an
-- instance using newtype.
-- With a new Type we also have the option of overriding certain things we don’t like about Either, e.g. how
-- it short-circuits in apply.
newtype Validation err result = Validation (Either err result)

type FamilyAgesRow  r = ( fatherAge ::  Age,       motherAge  :: Age,       childAge  :: Age      | r )
type FamilyNamesRow r = ( fatherName :: FullName , motherName :: FullName , childName :: FullName | r)

newtype Age          = Age Int
newtype FullName     = FullName String
newtype Family       = Family     { | FamilyNamesRow (FamilyAgesRow ()) }
newtype FamilyAges   = FamilyAges { | FamilyAgesRow () }
newtype LowerAge     = LowerAge Int
newtype UpperAge     = UpperAge Int
data    FamilyMember = Father | Mother | Child

-- Derive a Newtype Instance
derive instance newtypeValidation :: Newtype (Validation err result) _
-- Derive Functor Instance
derive newtype instance functorValidation :: Functor (Validation err)
-- Derive Bifunctor Instance
derive newtype instance bifunctorValidation :: Bifunctor Validation
-- Derive Eq Instance
derive newtype instance eqValidation  :: (Eq err,  Eq result)  => Eq  (Validation err result)
derive newtype instance ordValidation :: (Ord err, Ord result) => Ord (Validation err result)
-- Create Apply Instance
-- Derive Ord Instance (override Either's default behavior; collect all errors!)
instance applyValidation :: (Semigroup err) => Apply (Validation err) where
  apply (Validation (Right f))  r                       = f <$> r
  apply (Validation (Left  e1)) (Validation (Left  e2)) = Validation $ Left (e1 <> e2)
  apply (Validation (Left  e))  _                       = Validation $ Left e
-- Create Applicative Instance
instance applicativeValidation :: (Semigroup err) => Applicative (Validation err) where
  pure = Validation <<< Right
-- Derive Show Instance
derive newtype instance showValidation :: (Show err, Show result) => Show (Validation err result)

-- Make Show instances for Age, FullName, Family, FamilyAges and FamilyMember
derive instance genericAge          :: Generic Age _
derive instance genericFullName     :: Generic FullName _
derive instance genericFamily       :: Generic Family _
derive instance genericFamilyAges   :: Generic FamilyAges _
derive instance genericFamilyMember :: Generic FamilyMember _

instance showAge          :: Show Age          where show = genericShow
instance showFullName     :: Show FullName     where show = genericShow
instance showFamily       :: Show Family       where show = genericShow
instance showFamilyAges   :: Show FamilyAges   where show = genericShow
instance showFamilyMember :: Show FamilyMember where show = genericShow

-- Write this function
validateAge :: LowerAge -> UpperAge -> Age -> FamilyMember -> Validation (Array String) Age
validateAge (LowerAge lage) (UpperAge uage) (Age age) fm | age > uage = Validation $ Left [show fm <> " is too old"]
                                                         | age < lage = Validation $ Left [show fm <> " is too young"]
                                                         | otherwise  = Validation $ Right $ Age age

-- Write this function
createFamilyAges :: { | FamilyAgesRow () } -> Validation (Array String) FamilyAges
createFamilyAges { fatherAge, motherAge, childAge } =
  FamilyAges <$> ({ fatherAge: _, motherAge: _, childAge: _}
             <$> validateAge (LowerAge 18) (UpperAge 100) fatherAge Father
             <*> validateAge (LowerAge 18) (UpperAge 100) motherAge Mother
             <*> validateAge (LowerAge 1)  (UpperAge 18)  childAge  Child)

test :: Effect Unit
test = do
  log "--------------------------------------------------"
  log "Ch. 17 Applicatives. Just follow the white rabbit."
  log "--------------------------------------------------"
  log "------------------------------"
  log "Applicative Instance for Maybe"
  log "------------------------------"
  log $ show $ (+) <$> Just 21 <*> Just 21                     -- (Just 42)
  log $ show $ (*) <$> pure 2 <*> (pure 21 :: Maybe Int)       -- (Just 42)
  log $ show $ pure (+) <*> Just 17 <*> Just 25                -- (Just 42)
  log "-------------------------------"
  log "Applicative Instance for Either"
  log "-------------------------------"
  -- Associative Composition Law: (<<<) <$> u <*> v <*> w = u <*> (v <*> w)
  log $ show $ ((<<<) <$> pure identity <*> pure identity <*> pure 1) == (pure identity <*> (pure identity <*> pure 1) :: Either Unit Int)
  -- Identity Law:                pure identity <*> x = x
  log $ show $ (pure identity <*> pure 1) == (pure 1 :: Either Unit Int)
  -- Homomorphism Law:            pure (f x) = pure f <*> pure x
  log $ show $ pure (negate 1) == (pure negate <*> pure 1 :: Either Unit Int)
  -- Interchange Law:             u <*> pure x = pure (_ $ x) <*> u
  log $ show $ (pure negate <*> pure 1) == (pure (_ $ 1) <*> pure negate :: Either Unit Int)
  log "----------"
  log "Validation"
  log "----------"
  log $ show $ createFamilyAges { fatherAge: Age 40,  motherAge: Age 30,  childAge: Age 10  }  -- (Validation (Right (FamilyAges { childAge: (Age 10), fatherAge: (Age 40), motherAge: (Age 30) })))
  log $ show $ createFamilyAges { fatherAge: Age 400, motherAge: Age 300, childAge: Age 0   }  -- (Validation (Left ["Father is too old", "Mother is too old", "Child is too young"]))
  log $ show $ createFamilyAges { fatherAge: Age 4,   motherAge: Age 3,   childAge: Age 10  }  -- (Validation (Left ["Father is too young", "Mother is too young"]))
  log $ show $ createFamilyAges { fatherAge: Age 40,  motherAge: Age 30,  childAge: Age 100 }  -- (Validation (Left ["Child is too old"]))
  log $ show $ createFamilyAges { fatherAge: Age 40,  motherAge: Age 3,   childAge: Age 0   }  -- (Validation (Left ["Mother is too young", "Child is too young"]))

spago.dhall

{ name = "my-project"
, dependencies = [ "console", "effect", "prelude", "psci-support", "bifunctors", "newtype" ]
, packages = ./packages.dhall
, sources = [ "src/**/*.purs", "test/**/*.purs" ]
}