{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.GADT.ComposOp where

import BNFC.Backend.Common.Utils

import BNFC.Prelude

import Data.String (fromString)

import Prettyprinter

composOp :: ModuleName -> String
composOp composOpModuleName = docToString defaultLayoutOptions $ composOpDoc composOpModuleName

composOpDoc :: ModuleName -> Doc ()
composOpDoc composOpModuleName = vsep
  [ "{-# LANGUAGE Rank2Types, PolyKinds #-}"
  , "module" <+> fromString composOpModuleName <+> "(Compos(..),composOp,composOpM,composOpM_,composOpMonoid,"
  , "                 composOpMPlus,composOpFold) where"
  , emptyDoc
  , "import Prelude"
  , emptyDoc
  , "import Control.Monad.Identity"
  , emptyDoc
  , "class Compos t where"
  , "  compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)"
  , "         -> (forall a. t a -> m (t a)) -> t c -> m (t c)"
  , emptyDoc
  , "composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c"
  , "composOp f = runIdentity . composOpM (Identity . f)"
  , emptyDoc
  , "composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)"
  , "composOpM = compos return ap"
  , emptyDoc
  , "composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()"
  , "composOpM_ = composOpFold (return ()) (>>)"
  , emptyDoc
  , "composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m"
  , "composOpMonoid = composOpFold mempty mappend"
  , emptyDoc
  , "composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b"
  , "composOpMPlus = composOpFold mzero mplus"
  , emptyDoc
  , "composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b"
  , "composOpFold z c f = unC . compos (\\_ -> C z) (\\(C x) (C y) -> C (c x y)) (C . f)"
  , emptyDoc
  , "newtype C b a = C { unC :: b }"
  ]