{-# 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 :: ModuleName -> ModuleName
composOp ModuleName
composOpModuleName = LayoutOptions -> Doc () -> ModuleName
docToString LayoutOptions
defaultLayoutOptions (Doc () -> ModuleName) -> Doc () -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModuleName -> Doc ()
composOpDoc ModuleName
composOpModuleName

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