Classes.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}

module Classes where

import Data.Functor.Identity (Identity (..))
import Control.Applicative (Const (..))
import Data.Maybe (fromMaybe)
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import qualified Data.Text as T

infixl 4  <<$
--infixl 4 <<*>>, <<*, *>>
infixr 2 ==>, ==>>

type Trafo (f :: k -> *) (g :: k -> *)
    = forall (a :: k). f a -> g a

type f ==> g = Trafo f g

newtype TrafoComp f g a
    = TrafoComp { unTrafoComp :: f a -> g a }

type (==>>) f g = TrafoComp f g

class Functor1 (rec :: (k -> *) -> *) where
  fmap1 :: (f ==> g) -> rec f -> rec g

  -- | Replace all locations in the input with the same value.
  -- The default definition is @'fmap' . 'const'@, but this may be
  -- overridden with a more efficient version.
  (<<$) :: (forall a. g a) -> rec f -> rec g
  x <<$ r = fmap1 (const x) r

(<<$>>) :: Functor1 rec => (f ==> g) -> rec f -> rec g
(<<$>>) = fmap1

class Functor1 rec => Applicative1 (rec :: (k -> *) -> *) where
  pure1 :: (forall (a :: k). f a) -> rec f
  (<<*>>) :: rec (f ==>> g) -> rec f -> rec g

  (*>>) :: rec f -> rec g -> rec g
  s *>> t = (wrap1 id <<$ s) <<*>> t
  (<<*) :: rec f -> rec g -> rec f
  (<<*) = liftAA2 const

wrap1
  :: (f a -> g a)
  -> (f ==>> g) a
wrap1 = TrafoComp

wrap2
  :: (f a -> g a -> h a)
  -> (f ==>> g ==>> h) a
wrap2 f = TrafoComp (wrap1 <$> f)

wrap3
  :: (f a -> g a -> h a -> k a)
  -> (f ==>> g ==>> h ==>> k) a
wrap3 f = TrafoComp (wrap2 <$> f)

wrap4
  :: (f a -> g a -> h a -> i a -> j a)
  -> (f ==>> g ==>> h ==>> i ==>> j) a
wrap4 f = TrafoComp (wrap3 <$> f)

wrap5
  :: (f a -> g a -> h a -> i a -> j a -> k a)
  -> (f ==>> g ==>> h ==>> i ==>> j ==>> k) a
wrap5 f = TrafoComp (wrap4 <$> f)

wrap6
  :: (f a -> g a -> h a -> i a -> j a -> k a -> l a)
  -> (f ==>> g ==>> h ==>> i ==>> j ==>> k ==>> l) a
wrap6 f = TrafoComp (wrap5 <$> f)

wrap7
  :: (f a -> g a -> h a -> i a -> j a -> k a -> l a -> m a)
  -> (f ==>> g ==>> h ==>> i ==>> j ==>> k ==>> l ==>> m) a
wrap7 f = TrafoComp (wrap6 <$> f)

wrap8
  :: (f a -> g a -> h a -> i a -> j a -> k a -> l a -> m a -> n a)
  -> (f ==>> g ==>> h ==>> i ==>> j ==>> k ==>> l ==>> m ==>> n) a
wrap8 f = TrafoComp (wrap7 <$> f)

liftAA1
  :: Functor1 r
  => (forall a. f a -> g a)
  -> r f -> r g
liftAA1 = fmap1

liftAA2
  :: Applicative1 r
  => (forall a. f a -> g a -> h a)
  -> r f -> r g -> r h
liftAA2 f s t = (wrap1 <$> f) <<$>> s <<*>> t

liftAA3
  :: Applicative1 r
  => (forall a. f a -> g a -> h a -> i a)
  -> r f -> r g -> r h -> r i
liftAA3 f s t u = (wrap2 <$> f) <<$>> s <<*>> t <<*>> u

liftAA4
  :: Applicative1 r
  => (forall a. f a -> g a -> h a -> i a -> j a)
  -> r f -> r g -> r h -> r i -> r j
liftAA4 f s t u v = (wrap3 <$> f) <<$>> s <<*>> t <<*>> u <<*>> v

liftAA5
  :: Applicative1 r
  => (forall a. f a -> g a -> h a -> i a -> j a -> k a)
  -> r f -> r g -> r h -> r i -> r j -> r k
liftAA5 f s t u v w = (wrap4 <$> f) <<$>> s <<*>> t <<*>> u <<*>> v <<*>> w

liftAA6
  :: Applicative1 r
  => (forall a. f a -> g a -> h a -> i a -> j a -> k a -> l a)
  -> r f -> r g -> r h -> r i -> r j -> r k -> r l
liftAA6 f s t u v w x =
  (wrap5 <$> f) <<$>> s <<*>> t <<*>> u <<*>> v <<*>> w <<*>> x

liftAA7
  :: Applicative1 r
  => (forall a. f a -> g a -> h a -> i a -> j a -> k a -> l a -> m a)
  -> r f -> r g -> r h -> r i -> r j -> r k -> r l -> r m
liftAA7 f s t u v w x y =
  (wrap6 <$> f) <<$>> s <<*>> t <<*>> u <<*>> v <<*>> w <<*>> x <<*>> y

liftAA8
  :: Applicative1 r
  => (forall a. f a -> g a -> h a -> i a -> j a -> k a -> l a -> m a -> n a)
  -> r f -> r g -> r h -> r i -> r j -> r k -> r l -> r m -> r n
liftAA8 f s t u v w x y z =
  (wrap7 <$> f) <<$>> s <<*>> t <<*>> u <<*>> v <<*>> w <<*>> x <<*>> y <<*>> z


{-
-- TODO: generalize to `rec :: (k -> *) -> *` using a better definition of `Const`
class RecFoldable (rec :: (* -> *) -> *) where
  {-# MINIMAL recFoldMap | recFoldr #-}

  -- | Combine the elements of a structure using a monoid.
  recFold :: Monoid m => rec (Const m) -> m
  recFold = recFoldMap getConst

  -- | Map each element of the structure to a monoid,
  -- and combine the results.
  recFoldMap :: Monoid m => (forall a. f a -> m) -> rec f -> m
  -- foldMap f = foldr (mappend . f) mempty

  -- | Right-associative fold of a structure.
  --
  -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@
  recFoldr :: (a -> b -> b) -> b -> t a -> b
  recFoldr f z t = appEndo (foldMap (Endo #. f) t) z
-}

class Functor1 rec => RecTraversable (rec :: (* -> *) -> *) where
  {-# MINIMAL recTraverse | recSequenceA #-}
  recTraverse :: Applicative g => (f ==> g) -> rec f -> g (rec Identity)
  recTraverse f = recSequenceA . fmap1 f
  recSequenceA :: Applicative f => rec f -> f (rec Identity)
  recSequenceA = recTraverse id
  -- TODO: more functions

recFoldMap
  :: (Monoid m, RecTraversable rec)
  => (forall a. f a -> m) -> rec f -> m
recFoldMap f = getConst . recTraverse (Const . f)

recFold
  :: (Monoid m, RecTraversable rec)
  => rec (Const m) -> m
recFold = getConst . recSequenceA

recToList
  :: RecTraversable rec
  => rec (Const a) -> [a]
recToList = recFoldMap (pure . getConst)

-- TODO: more functions analog to Foldable

-------------
-- Example --
-------------

data FooF f
  = FooF
  { fieldInt :: f Int
  , fieldBool :: f Bool
  , fieldString :: f String
  }

deriving instance Show (FooF Identity)
deriving instance Eq (FooF Identity)

instance Functor1 FooF where
  fmap1 f rec =
    FooF
    { fieldInt = f (fieldInt rec)
    , fieldBool = f (fieldBool rec)
    , fieldString = f (fieldString rec)
    }

instance Applicative1 FooF where
  pure1 x =
    FooF
    { fieldInt = x
    , fieldBool = x
    , fieldString = x
    }
  x <<*>> y =
    FooF
    { fieldInt = unTrafoComp (fieldInt x) (fieldInt y)
    , fieldBool = unTrafoComp (fieldBool x) (fieldBool y)
    , fieldString = unTrafoComp (fieldString x) (fieldString y)
    }

instance RecTraversable FooF where
  recSequenceA rec =
    FooF
      <$> (Identity <$> fieldInt rec)
      <*> (Identity <$> fieldBool rec)
      <*> (Identity <$> fieldString rec)

-- example (half-pseudo-code):
--
--   FooF Nothing (Just False) (Just "hallo") `overrides` FooF 3 True "welt"
-- = FooF 3 False "hallo"
overrides :: Applicative1 rec => rec Maybe -> rec Identity -> rec Identity
overrides = liftAA2 flippedFromMaybe'
  where
    flippedFromMaybe' (Just x) _ = Identity x
    flippedFromMaybe' Nothing y = y

----------
-- JSON --
----------

data BidirJson a
  = BidirJson
  { bidirEncodeJson :: a -> A.Value
  , bidirDecodeJson :: A.Value -> A.Parser a
  }

dfltBidir :: (A.FromJSON a, A.ToJSON a) => BidirJson a
dfltBidir = BidirJson A.toJSON A.parseJSON

parseBoolLiberally :: BidirJson Bool
parseBoolLiberally =
  BidirJson
  { bidirEncodeJson = A.toJSON
  , bidirDecodeJson =
      \case
        A.Bool b -> pure b
        A.String (T.toLower -> t)
          | t == "yes" -> pure True
          | t == "true" -> pure True
          | t == "no" -> pure False
          | t == "false" -> pure False
        _ ->
          fail $
            "Could not parse bool. Expected either a bool value or one of the"
            ++ "strings 'yes', 'no', 'true', 'false'."
  }

data BidirJsonField a
  = BidirJsonField
  { bidirFieldName :: T.Text
  , bidirFieldBidir :: BidirJson a
  }

dfltField :: (A.FromJSON a, A.ToJSON a) => T.Text -> BidirJsonField a
dfltField name = BidirJsonField name dfltBidir

bidirFooF :: FooF BidirJsonField
bidirFooF =
  FooF
  { fieldInt = dfltField "int"
  , fieldString = dfltField "string"
  , fieldBool = BidirJsonField "bool" parseBoolLiberally
  }

bidirRecord
  :: (Applicative1 rec, RecTraversable rec)
  => rec BidirJsonField -> BidirJson (rec Identity)
bidirRecord fieldDescriptors =
  BidirJson { bidirEncodeJson = encodeObj, bidirDecodeJson = decodeObj }
  where
    encodeObj = A.object . recToList . liftAA2 encodeJsonField fieldDescriptors
    encodeJsonField bjf (Identity fieldVal) =
      Const (bidirFieldName bjf A..= bidirEncodeJson (bidirFieldBidir bjf) fieldVal)
    decodeObj =
      A.withObject "expected an object" $ \obj ->
        recSequenceA (decodeJsonField obj <<$>> fieldDescriptors)
    decodeJsonField obj bjf =
      (obj A..: bidirFieldName bjf) >>= bidirDecodeJson (bidirFieldBidir bjf)