{-
    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 :: SharedOptions -> CF -> MkFiles ()
makeHaskellGadt SharedOptions
opts CF
cf = do
  let absMod :: String
absMod = SharedOptions -> String
absFileM SharedOptions
opts
      composOpMod :: String
composOpMod = SharedOptions -> String
composOpFileM SharedOptions
opts
      lexMod :: String
lexMod = SharedOptions -> String
alexFileM SharedOptions
opts
      parMod :: String
parMod = SharedOptions -> String
happyFileM SharedOptions
opts
      prMod :: String
prMod  = SharedOptions -> String
printerFileM SharedOptions
opts
      layMod :: String
layMod = SharedOptions -> String
layoutFileM SharedOptions
opts
      errMod :: String
errMod = SharedOptions -> String
errFileM SharedOptions
opts
  do
    String -> String -> MkFiles ()
forall c. FileContent c => String -> c -> MkFiles ()
mkHsFile (SharedOptions -> String
absFile SharedOptions
opts) (String -> MkFiles ()) -> String -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ TokenText -> String -> CF -> String -> String
cf2Abstract (SharedOptions -> TokenText
tokenText SharedOptions
opts) String
absMod CF
cf String
composOpMod
    String -> String -> MkFiles ()
forall c. FileContent c => String -> c -> MkFiles ()
mkHsFile (SharedOptions -> String
composOpFile SharedOptions
opts) (String -> MkFiles ()) -> String -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ String -> String
composOp String
composOpMod
    String -> String -> MkFiles ()
forall c. FileContent c => String -> c -> MkFiles ()
mkHsFileHint (SharedOptions -> String
alexFile SharedOptions
opts) (String -> MkFiles ()) -> String -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ String -> TokenText -> CF -> String
cf2alex3 String
lexMod (SharedOptions -> TokenText
tokenText SharedOptions
opts) CF
cf
    IO () -> MkFiles ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MkFiles ()) -> IO () -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"   (Use Alex 3 to compile.)"
    String -> String -> MkFiles ()
forall c. FileContent c => String -> c -> MkFiles ()
mkHsFileHint (SharedOptions -> String
happyFile SharedOptions
opts) (String -> MkFiles ()) -> String -> MkFiles ()
forall a b. (a -> b) -> a -> b
$
      String
-> String
-> String
-> HappyMode
-> TokenText
-> Bool
-> CF
-> String
cf2Happy String
parMod String
absMod String
lexMod (SharedOptions -> HappyMode
glr SharedOptions
opts) (SharedOptions -> TokenText
tokenText SharedOptions
opts) Bool
False CF
cf
    IO () -> MkFiles ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MkFiles ()) -> IO () -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"   (Tested with Happy 1.15 - 1.20)"
    String -> String -> MkFiles ()
forall c. FileContent c => String -> c -> MkFiles ()
mkHsFile (SharedOptions -> String
templateFile SharedOptions
opts) (String -> MkFiles ()) -> String -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ String -> String -> CF -> String
cf2Template (SharedOptions -> String
templateFileM SharedOptions
opts) String
absMod CF
cf
    String -> Doc -> MkFiles ()
forall c. FileContent c => String -> c -> MkFiles ()
mkHsFile (SharedOptions -> String
printerFile SharedOptions
opts)  (Doc -> MkFiles ()) -> Doc -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ TokenText -> Bool -> Bool -> String -> String -> CF -> Doc
cf2Printer TokenText
StringToken Bool
False Bool
True String
prMod String
absMod CF
cf
    Bool -> MkFiles () -> MkFiles ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CF -> Bool
hasLayout CF
cf) (MkFiles () -> MkFiles ()) -> MkFiles () -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ String -> String -> MkFiles ()
forall c. FileContent c => String -> c -> MkFiles ()
mkHsFile (SharedOptions -> String
layoutFile SharedOptions
opts) (String -> MkFiles ()) -> String -> MkFiles ()
forall a b. (a -> b) -> a -> b
$
      String -> String -> CF -> String
cf2Layout String
layMod String
lexMod CF
cf
    String -> String -> MkFiles ()
forall c. FileContent c => String -> c -> MkFiles ()
mkHsFile (SharedOptions -> String
tFile SharedOptions
opts)        (String -> MkFiles ()) -> String -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ SharedOptions -> CF -> String
Haskell.testfile SharedOptions
opts CF
cf
    String -> Doc -> MkFiles ()
forall c. FileContent c => String -> c -> MkFiles ()
mkHsFile (SharedOptions -> String
errFile SharedOptions
opts) (Doc -> MkFiles ()) -> Doc -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
mkErrM String
errMod
    SharedOptions -> (String -> Doc) -> MkFiles ()
Makefile.mkMakefile SharedOptions
opts ((String -> Doc) -> MkFiles ()) -> (String -> Doc) -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ SharedOptions -> CF -> String -> Doc
Haskell.makefile SharedOptions
opts CF
cf
    case SharedOptions -> Int
xml SharedOptions
opts of
      Int
2 -> SharedOptions -> Bool -> CF -> MkFiles ()
makeXML SharedOptions
opts Bool
True CF
cf
      Int
1 -> SharedOptions -> Bool -> CF -> MkFiles ()
makeXML SharedOptions
opts Bool
False CF
cf
      Int
_ -> () -> MkFiles ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
  mkHsFile :: String -> c -> MkFiles ()
mkHsFile String
x = String -> (String -> String) -> c -> MkFiles ()
forall c.
FileContent c =>
String -> (String -> String) -> c -> MkFiles ()
mkfile String
x String -> String
comment
  mkHsFileHint :: String -> c -> MkFiles ()
mkHsFileHint String
x = String -> (String -> String) -> c -> MkFiles ()
forall c.
FileContent c =>
String -> (String -> String) -> c -> MkFiles ()
mkfile String
x String -> String
commentWithEmacsModeHint

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