{-
    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.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
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 :: [Char]
absMod = SharedOptions -> [Char]
absFileM SharedOptions
opts
      composOpMod :: [Char]
composOpMod = SharedOptions -> [Char]
composOpFileM SharedOptions
opts
      lexMod :: [Char]
lexMod = SharedOptions -> [Char]
alexFileM SharedOptions
opts
      parMod :: [Char]
parMod = SharedOptions -> [Char]
happyFileM SharedOptions
opts
      prMod :: [Char]
prMod  = SharedOptions -> [Char]
printerFileM SharedOptions
opts
      layMod :: [Char]
layMod = SharedOptions -> [Char]
layoutFileM SharedOptions
opts
      errMod :: [Char]
errMod = SharedOptions -> [Char]
errFileM SharedOptions
opts
  do
    [Char] -> [Char] -> MkFiles ()
forall c. FileContent c => [Char] -> c -> MkFiles ()
mkfile (SharedOptions -> [Char]
absFile SharedOptions
opts) ([Char] -> MkFiles ()) -> [Char] -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ TokenText -> [Char] -> CF -> [Char] -> [Char]
cf2Abstract (SharedOptions -> TokenText
tokenText SharedOptions
opts) [Char]
absMod CF
cf [Char]
composOpMod
    [Char] -> [Char] -> MkFiles ()
forall c. FileContent c => [Char] -> c -> MkFiles ()
mkfile (SharedOptions -> [Char]
composOpFile SharedOptions
opts) ([Char] -> MkFiles ()) -> [Char] -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
composOp [Char]
composOpMod
    case SharedOptions -> AlexVersion
alexMode SharedOptions
opts of
      AlexVersion
Alex3 -> do
        [Char] -> [Char] -> MkFiles ()
forall c. FileContent c => [Char] -> c -> MkFiles ()
mkfile (SharedOptions -> [Char]
alexFile SharedOptions
opts) ([Char] -> MkFiles ()) -> [Char] -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TokenText -> CF -> [Char]
cf2alex3 [Char]
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
$ [Char] -> IO ()
putStrLn [Char]
"   (Use Alex 3 to compile.)"
    [Char] -> [Char] -> MkFiles ()
forall c. FileContent c => [Char] -> c -> MkFiles ()
mkfile (SharedOptions -> [Char]
happyFile SharedOptions
opts) ([Char] -> MkFiles ()) -> [Char] -> MkFiles ()
forall a b. (a -> b) -> a -> b
$
      [Char]
-> [Char]
-> [Char]
-> HappyMode
-> TokenText
-> Bool
-> CF
-> [Char]
cf2Happy [Char]
parMod [Char]
absMod [Char]
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
$ [Char] -> IO ()
putStrLn [Char]
"   (Tested with Happy 1.15 - 1.20)"
    [Char] -> [Char] -> MkFiles ()
forall c. FileContent c => [Char] -> c -> MkFiles ()
mkfile (SharedOptions -> [Char]
templateFile SharedOptions
opts) ([Char] -> MkFiles ()) -> [Char] -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> CF -> [Char]
cf2Template (SharedOptions -> [Char]
templateFileM SharedOptions
opts) [Char]
absMod CF
cf
    [Char] -> Doc -> MkFiles ()
forall c. FileContent c => [Char] -> c -> MkFiles ()
mkfile (SharedOptions -> [Char]
printerFile SharedOptions
opts)  (Doc -> MkFiles ()) -> Doc -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ TokenText -> Bool -> Bool -> [Char] -> [Char] -> CF -> Doc
cf2Printer TokenText
StringToken Bool
False Bool
True [Char]
prMod [Char]
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
$ [Char] -> [Char] -> MkFiles ()
forall c. FileContent c => [Char] -> c -> MkFiles ()
mkfile (SharedOptions -> [Char]
layoutFile SharedOptions
opts) ([Char] -> MkFiles ()) -> [Char] -> MkFiles ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> [Char] -> CF -> [Char]
cf2Layout [Char]
layMod [Char]
lexMod CF
cf
    [Char] -> [Char] -> MkFiles ()
forall c. FileContent c => [Char] -> c -> MkFiles ()
mkfile (SharedOptions -> [Char]
tFile SharedOptions
opts)        ([Char] -> MkFiles ()) -> [Char] -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ SharedOptions -> CF -> [Char]
Haskell.testfile SharedOptions
opts CF
cf
    [Char] -> Doc -> MkFiles ()
forall c. FileContent c => [Char] -> c -> MkFiles ()
mkfile (SharedOptions -> [Char]
errFile SharedOptions
opts) (Doc -> MkFiles ()) -> Doc -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
mkErrM [Char]
errMod
    SharedOptions -> ([Char] -> Doc) -> MkFiles ()
Makefile.mkMakefile SharedOptions
opts (([Char] -> Doc) -> MkFiles ()) -> ([Char] -> Doc) -> MkFiles ()
forall a b. (a -> b) -> a -> b
$ SharedOptions -> CF -> [Char] -> 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 ()

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