{-
    BNF Converter: Haskell main file
    Copyright (C) 2004-2005  Author:  Markus Forsberg, Peter Gammie,
                                      Aarne Ranta, Björn Bringert

-}

module BNFC.Backend.HaskellGADT (makeHaskellGadt) where


-- import Utils
import BNFC.Options
import BNFC.Backend.Base hiding (Backend)
import BNFC.Backend.Haskell.HsOpts
import BNFC.Backend.Haskell.Utils (comment, commentWithEmacsModeHint)
import BNFC.CF
import BNFC.Backend.Haskell.CFtoHappy
import BNFC.Backend.Haskell.CFtoAlex3
import BNFC.Backend.HaskellGADT.CFtoAbstractGADT
import BNFC.Backend.HaskellGADT.CFtoTemplateGADT
import BNFC.Backend.Haskell.CFtoPrinter
import BNFC.Backend.Haskell.CFtoLayout
import BNFC.Backend.XML (makeXML)
import BNFC.Backend.Haskell.MkErrM
import qualified BNFC.Backend.Common.Makefile as Makefile
import qualified BNFC.Backend.Haskell as Haskell

import Control.Monad(when)


makeHaskellGadt :: SharedOptions -> CF -> MkFiles ()
makeHaskellGadt opts cf = do
  let absMod = absFileM opts
      composOpMod = composOpFileM opts
      lexMod = alexFileM opts
      parMod = happyFileM opts
      prMod  = printerFileM opts
      layMod = layoutFileM opts
      errMod = errFileM opts
  do
    mkHsFile (absFile opts) $ cf2Abstract (tokenText opts) absMod cf composOpMod
    mkHsFile (composOpFile opts) $ composOp composOpMod
    mkHsFileHint (alexFile opts) $ cf2alex3 lexMod (tokenText opts) cf
    liftIO $ putStrLn "   (Use Alex 3 to compile.)"
    mkHsFileHint (happyFile opts) $
      cf2Happy parMod absMod lexMod (glr opts) (tokenText opts) False cf
    liftIO $ putStrLn "   (Tested with Happy 1.15 - 1.20)"
    mkHsFile (templateFile opts) $ cf2Template (templateFileM opts) absMod cf
    mkHsFile (printerFile opts)  $ cf2Printer StringToken False True prMod absMod cf
    when (hasLayout cf) $ mkHsFile (layoutFile opts) $
      cf2Layout layMod lexMod cf
    mkHsFile (tFile opts)        $ Haskell.testfile opts cf
    mkHsFile (errFile opts) $ mkErrM errMod
    Makefile.mkMakefile (optMake opts) $ Haskell.makefile opts cf
    case xml opts of
      2 -> makeXML opts True cf
      1 -> makeXML opts False cf
      _ -> return ()
  where
  mkHsFile x = mkfile x comment
  mkHsFileHint x = mkfile x commentWithEmacsModeHint

composOp :: String -> String
composOp composOpMod = unlines
    [
     "{-# LANGUAGE Rank2Types, PolyKinds #-}",
     "module " ++ composOpMod ++ " (Compos(..),composOp,composOpM,composOpM_,composOpMonoid,",
     "                 composOpMPlus,composOpFold) where",
     "",
     "import Prelude",
     "",
     "import Control.Monad",
     "import Data.Functor.Identity",
     "",
     "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)",
     "",
     "composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c",
     "composOp f = runIdentity . composOpM (Identity . f)",
     "",
     "composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)",
     "composOpM = compos return ap",
     "",
     "composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()",
     "composOpM_ = composOpFold (return ()) (>>)",
     "",
     "composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m",
     "composOpMonoid = composOpFold mempty mappend",
     "",
     "composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b",
     "composOpMPlus = composOpFold mzero mplus",
     "",
     "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)",
     "",
     "newtype C b a = C { unC :: b }"
    ]
