{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeOperators #-}

-- | A replacement for the basic machinery in
-- [Compdata](https://hackage.haskell.org/package/compdata).
--
-- = Differences and limitations
--
-- === Deriving of type classes for base functors
--
-- Compdata's macros for deriving are replaced by similar macros from
-- [deriving-compat](https://hackage.haskell.org/package/deriving-compat). See
-- the documentation for 'defaultEqualF' and similar functions in the same
-- section.
--
-- === Co-products and injections
--
-- Compdata and Fixplate use different names for equivalent things. For this
-- reason, we export type and pattern synonyms to make the interface as similar
-- to Compdata's as possible.
--
-- Unfortunately, ':+:' is defined as left-associative in Fixplate, which means
-- that injections will look differently. For example, consider a compound base
-- functor @F `:+:` G `:+:` H@. Elements from @G@ are injected differently in
-- the two libraries:
--
-- @
-- Inr (Inl ...) -- Compdata
-- `InL` (`InR` ...) -- Fixplate
-- @
--
-- (Note also the difference in capitalization.)
--
-- === Smart constructors
--
-- There are no TemplateHaskell macros for making smart constructors, but the
-- operators from "Data.Composition" (re-exported by this module) take us a long
-- way towards the same goal. Consider the following base functors:
--
-- > data Add a        = Add a a          deriving (Functor)
-- > data IfThenElse a = IfThenElse a a a deriving (Functor)
--
-- Smart versions of these constructors can now be defined as follows:
--
-- @
-- (|+|) :: Add `:<:` f => `Term` f -> `Term` f -> `Term` f
-- (|+|) = `inject` `.:` Add
--
-- ite :: IfThenElse `:<:` f => `Term` f -> `Term` f -> `Term` f -> `Term` f
-- ite = `inject` `.:.` IfThenElse
-- @

module Data.Comp.Fixplate
  ( -- * Basic classes and operations on functors
    Eq1, EqF (..)
  , Show1, ShowF (..)
  , deriveEq1
  , deriveShow1
  , defaultEqualF
  , defaultShowsPrecF
  , eqMod

    -- * Compositional data types
  , Term
  , pattern Term
  , unTerm
  , (:&:)
  , pattern (:&:)
  , (:+:) (..)
  , (:<:) (..)
  , inject
  , project

    -- * Rendering
  , HideInj -- Just the type, because it shows up in some class contexts
  , showTerm
  , showTermU
  , drawTerm
  , drawTermU

    -- * Making smart constructors
  , (.:)
  , (.:.)
  , (.::)
  , (.::.)
  , (.:::)
  ) where

import Data.Composition ((.:), (.:.), (.::), (.::.), (.:::))
import Data.Eq.Deriving (deriveEq1)
import Data.Foldable (toList)
import Data.Functor.Classes (Eq1 (..), Show1 (..), eq1, showsPrec1)
import Data.Generics.Fixplate.Base
  ( Ann(..)
  , EqF(..)
  , Hole(..)
  , Mu(..)
  , ShowF(..)
  , showF
  )
import qualified Data.Generics.Fixplate.Draw as Fixplate
import Data.Generics.Fixplate.Functor ((:+:) (..))
import Data.Generics.Fixplate.Morphisms (cata)
import Data.Generics.Fixplate.Traversals (restructure)
import Data.Tree (Tree (..))
import qualified Data.Tree.View as TreeView
import Text.Show.Deriving (deriveShow1)



--------------------------------------------------------------------------------
-- * Basic classes and operations on functors
--------------------------------------------------------------------------------

-- | Default implementation of 'equalF'
--
-- Use as follows:
--
-- @
-- data F = ...
--
-- `deriveEq1` ''F -- Requires TemplateHaskell
-- instance `EqF` F where `equalF` = `defaultEqualF`
-- @
defaultEqualF :: (Eq1 f, Eq a) => f a -> f a -> Bool
defaultEqualF = eq1

-- | Default implementation of 'showsPrecF'
--
-- Use as follows:
--
-- @
-- data F = ...
--
-- `deriveShow1` ''F -- Requires TemplateHaskell
-- instance `ShowF` F where `showsPrecF` = `defaultShowsPrecF`
-- @
defaultShowsPrecF :: (Show1 f, Show a) => Int -> f a -> ShowS
defaultShowsPrecF = showsPrec1

eqMod :: (EqF f, Functor f, Foldable f) => f a -> f b -> Maybe [(a, b)]
eqMod t u
  | fmap (const ()) t `equalF` fmap (const ()) u = Just args
  | otherwise = Nothing
  where
    args = toList t `zip` toList u



--------------------------------------------------------------------------------
-- * Compositional data types
--------------------------------------------------------------------------------

type Term = Mu

pattern Term :: f (Term f) -> Term f
pattern Term f = Fix f

unTerm :: Term f -> f (Term f)
unTerm (Term f) = f

type f :&: a = Ann f a

pattern (:&:) :: f b -> a -> (f :&: a) b
pattern f :&: a = Ann a f

class f :<: g where
  inj :: f a -> g a
  prj :: g a -> Maybe (f a)

infix 7 :<:

instance {-# OVERLAPPABLE #-} f :<: f where
  inj = id
  prj = Just

instance {-# OVERLAPPING #-} f :<: f => f :<: (g :+: f) where
  inj = InR
  prj (InL _) = Nothing
  prj (InR f) = Just f

-- | Unlike standard Data Types à la Carte, this instance recurses into the left
-- term. This is due to the left-associativity of ':+:' in Fixplate.
instance {-# OVERLAPS #-} f :<: h => f :<: (h :+: g) where
  inj = InL . inj
  prj (InL h) = prj h
  prj (InR _) = Nothing

inject :: f :<: g => f (Term g) -> Term g
inject = Fix . inj

project :: f :<: g => Term g -> Maybe (f (Term g))
project = prj . unTerm



--------------------------------------------------------------------------------
-- * Tree rendering
--------------------------------------------------------------------------------

-- | Convert a 'Term' to a 'Tree'
toTree :: (Functor f, Foldable f) => Term f -> Tree (f Hole)
toTree = cata $ \f -> Node (const Hole <$> f) $ toList f

-- | Wrapper type with a 'ShowF' instance that does not show injections ('InL',
-- 'InR')
newtype HideInj f a = HideInj {unHideInj :: f a}
  deriving (Foldable, Functor, Traversable)

instance {-# OVERLAPPABLE #-}  ShowF f => ShowF (HideInj f) where
  showsPrecF p = showsPrecF p . unHideInj

instance {-# OVERLAPPING #-} (ShowF (HideInj f), ShowF (HideInj g)) =>
                             ShowF (HideInj (f :+: g)) where
  showsPrecF p (HideInj (InL f)) = showsPrecF p (HideInj f)
  showsPrecF p (HideInj (InR g)) = showsPrecF p (HideInj g)

data Hole' = Hole'

instance Show Hole' where
  show Hole' = "_"

-- | Represent a 'Term' as an ASCII drawing
showTerm :: (Functor f, Foldable f, ShowF (HideInj f)) => Term f -> String
showTerm = Fixplate.showTree . restructure HideInj

-- | Represent a 'Term' as a Unicode drawing
showTermU :: (Functor f, Foldable f, ShowF (HideInj f)) => Term f -> String
showTermU =
  TreeView.showTree . fmap (showF . HideInj . fmap (const Hole')) . toTree

-- | Display a 'Term' as an ASCII drawing
drawTerm :: (Functor f, Foldable f, ShowF (HideInj f)) => Term f -> IO ()
drawTerm = Fixplate.drawTree . restructure HideInj

-- | Display a 'Term' as a Unicode drawing
drawTermU :: (Functor f, Foldable f, ShowF (HideInj f)) => Term f -> IO ()
drawTermU = putStrLn . showTermU