Builder.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module FFICXX.Generate.Builder where

import Control.Monad (void, when)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Char (toUpper)
import Data.Data (Data)
import Data.Digest.Pure.MD5 (md5)
import Data.Foldable (for_)
import qualified Data.List as List
import qualified Data.Text as T
import FFICXX.Generate.Code.Cabal (buildCabalFile, buildJSONFile)
import FFICXX.Generate.Config
  ( FFICXXConfig (..),
    SimpleBuilderConfig (..),
  )
import qualified FFICXX.Generate.ContentMaker as C
import FFICXX.Generate.Dependency
  ( findModuleUnitImports,
    mkPackageConfig,
  )
import FFICXX.Generate.Dependency.Graph
  ( constructDepGraph,
    findDepCycles,
    gatherHsBootSubmodules,
  )
import FFICXX.Generate.Type.Cabal
  ( AddCInc (..),
    AddCSrc (..),
    Cabal (..),
    CabalName (..),
  )
import FFICXX.Generate.Type.Class (hasProxy)
import FFICXX.Generate.Type.Module
  ( ClassImportHeader (..),
    ClassModule (..),
    PackageConfig (..),
    TemplateClassImportHeader (..),
    TemplateClassModule (..),
    TopLevelImportHeader (..),
  )
import FFICXX.Generate.Util (moduleDirFile)
import FFICXX.Generate.Util.GHCExactPrint (exactPrint)
import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..))
import qualified Language.Haskell.GHC.ExactPrint as Exact
import System.Directory
  ( copyFile,
    createDirectoryIfMissing,
    doesFileExist,
  )
import System.FilePath (splitExtension, (<.>), (</>))
import System.IO (IOMode (..), hPutStrLn, withFile)
import System.Process (readProcess)

macrofy :: String -> String
macrofy = map ((\x -> if x == '-' then '_' else x) . toUpper)

postProcess :: String -> String
postProcess txt = unlines ls'
  where
    ls = lines txt
    ls' = fmap process ls
    --
    process line =
      if "REPLACE_THIS_LINE" `List.isInfixOf` line
        then
          let (_, _ : xs) = List.break (== '|') line
              (ys, _) = List.span (/= '|') xs
           in ys
        else line

debugExactPrint :: (Exact.ExactPrint a, Data a) => a -> IO ()
debugExactPrint x = do
  putStrLn (Exact.showAst x)
  putStrLn "-------"
  putStrLn (exactPrint x)
  putStrLn "-------"

simpleBuilder :: FFICXXConfig -> SimpleBuilderConfig -> IO ()
simpleBuilder cfg sbc = do
  putStrLn "----------------------------------------------------"
  putStrLn "-- fficxx code generation for Haskell-C++ binding --"
  putStrLn "----------------------------------------------------"
  let SimpleBuilderConfig
        topLevelMod
        mumap
        cabal
        classes
        enums
        toplevelfunctions
        templates
        extralibs
        cxxopts
        extramods
        staticFiles =
          sbc
      pkgname = cabal_pkgname cabal
  putStrLn ("Generating " <> unCabalName pkgname)
  let workingDir = fficxxconfig_workingDir cfg
      installDir = fficxxconfig_installBaseDir cfg
      staticDir = fficxxconfig_staticFileDir cfg
      pkgconfig@(PkgConfig mods cihs tih tcms _tcihs _ _) =
        mkPackageConfig
          (pkgname, findModuleUnitImports mumap)
          (classes, toplevelfunctions, templates, extramods)
          (cabal_additional_c_incs cabal)
          (cabal_additional_c_srcs cabal)
      cabalFileName = unCabalName pkgname <.> "cabal"
      jsonFileName = unCabalName pkgname <.> "json"
      allClasses = fmap (Left . tcihTClass) templates ++ fmap Right classes
      depCycles =
        findDepCycles $
          constructDepGraph allClasses toplevelfunctions
      -- for now, put this function here
      -- This function is a little ad hoc, only for Interface.hs.
      -- But as of now, we support hs-boot for ordinary class only.
      mkHsBootCandidateList :: [ClassModule] -> [ClassModule]
      mkHsBootCandidateList ms =
        let hsbootSubmods = gatherHsBootSubmodules depCycles
         in filter (\c -> cmModule c <.> "Interface" `elem` hsbootSubmods) ms
      hsbootlst = mkHsBootCandidateList mods
  --
  createDirectoryIfMissing True workingDir
  createDirectoryIfMissing True installDir
  createDirectoryIfMissing True (installDir </> "src")
  createDirectoryIfMissing True (installDir </> "csrc")
  --
  putStrLn "Copying static files"
  mapM_ (\x -> copyFileWithMD5Check (staticDir </> x) (installDir </> x)) staticFiles
  --
  putStrLn "Generating Cabal file"
  buildCabalFile cabal topLevelMod pkgconfig extralibs cxxopts (workingDir </> cabalFileName)
  --
  putStrLn "Generating JSON file"
  buildJSONFile cabal topLevelMod pkgconfig extralibs cxxopts (workingDir </> jsonFileName)
  --
  putStrLn "Generating Header file"
  let gen :: FilePath -> String -> IO ()
      gen file str =
        let path = workingDir </> file in withFile path WriteMode (flip hPutStrLn str)
  gen (unCabalName pkgname <> "Type.h") (C.buildTypeDeclHeader (map cihClass cihs))
  for_ cihs $ \hdr ->
    gen
      (unHdrName (cihSelfHeader hdr))
      (C.buildDeclHeader (unCabalName pkgname) hdr)
  gen
    (tihHeaderFileName tih <.> "h")
    (C.buildTopLevelHeader (unCabalName pkgname) tih)
  putStrLn "Generating Cpp file"
  for_ cihs (\hdr -> gen (cihSelfCpp hdr) (C.buildDefMain hdr))
  gen (tihHeaderFileName tih <.> "cpp") (C.buildTopLevelCppDef tih)
  --
  putStrLn "Generating Additional Header/Source"
  for_ (cabal_additional_c_incs cabal) (\(AddCInc hdr txt) -> gen hdr txt)
  for_ (cabal_additional_c_srcs cabal) (\(AddCSrc hdr txt) -> gen hdr txt)
  --
  putStrLn "Generating Enum.hsc"
  gen
    (topLevelMod <.> "Enum" <.> "hsc")
    (exactPrint (C.buildEnumHsc (topLevelMod <> ".Enum") enums))
  --
  putStrLn "Generating RawType.hs"
  for_ mods $ \m ->
    gen
      (cmModule m <.> "RawType" <.> "hs")
      (exactPrint (C.buildRawTypeHs m))
  --
  putStrLn "Generating FFI.hsc"
  for_ mods $ \m ->
    gen
      (cmModule m <.> "FFI" <.> "hsc")
      (postProcess $ exactPrint (C.buildFFIHsc m))
  --
  putStrLn "Generating Interface.hs"
  for_ mods $ \m ->
    gen
      (cmModule m <.> "Interface" <.> "hs")
      (exactPrint (C.buildInterfaceHs mempty depCycles m))
  --
  putStrLn "Generating Cast.hs"
  for_ mods $ \m ->
    gen
      (cmModule m <.> "Cast" <.> "hs")
      (exactPrint (C.buildCastHs m))
  --
  putStrLn "Generating Implementation.hs"
  for_ mods $ \m ->
    gen
      (cmModule m <.> "Implementation" <.> "hs")
      (exactPrint (C.buildImplementationHs mempty m))
  --
  putStrLn "Generating Proxy.hs"
  for_ mods $ \m ->
    when (hasProxy . cihClass . cmCIH $ m) $ do
      gen
        (cmModule m <.> "Proxy" <.> "hs")
        (exactPrint (C.buildProxyHs m))
  --
  putStrLn "Generating Template.hs"
  for_ tcms $ \m ->
    gen
      (tcmModule m <.> "Template" <.> "hs")
      (exactPrint (C.buildTemplateHs m))
  --
  putStrLn "Generating TH.hs"
  for_ tcms $ \m ->
    gen
      (tcmModule m <.> "TH" <.> "hs")
      (exactPrint (C.buildTHHs m))
  --
  -- TODO: Template.hs-boot need to be generated as well
  putStrLn "Generating hs-boot file"
  -- This is a hack since haskell-src-exts always codegen () => instead of empty
  -- string for an empty context, which have different meanings in hs-boot file.
  -- Therefore, we get rid of them.
  let hsBootHackClearEmptyContexts = T.unpack . T.replace "() =>" "" . T.pack
  for_ hsbootlst $ \m -> do
    gen
      (cmModule m <.> "Interface" <.> "hs-boot")
      (hsBootHackClearEmptyContexts $ exactPrint (C.buildInterfaceHsBoot depCycles m))
  --
  putStrLn "Generating Module summary file"
  for_ mods $ \m ->
    gen
      (cmModule m <.> "hs")
      (exactPrint (C.buildModuleHs m))
  --
  putStrLn "Generating Top-level Ordinary Module"
  gen
    (topLevelMod <.> "Ordinary" <.> "hs")
    (postProcess $ exactPrint (C.buildTopLevelOrdinaryHs (topLevelMod <> ".Ordinary") (mods, tcms) tih))
  --
  putStrLn "Generating Top-level Template Module"
  gen
    (topLevelMod <.> "Template" <.> "hs")
    (exactPrint (C.buildTopLevelTemplateHs (topLevelMod <> ".Template") tih))
  --
  putStrLn "Generating Top-level TH Module"
  gen
    (topLevelMod <.> "TH" <.> "hs")
    (exactPrint (C.buildTopLevelTHHs (topLevelMod <> ".TH") tih))
  --
  putStrLn "Generating Top-level Module"
  gen
    (topLevelMod <.> "hs")
    (exactPrint (C.buildTopLevelHs topLevelMod (mods, tcms)))
  --
  putStrLn "Copying generated files to target directory"
  touch (workingDir </> "LICENSE")
  copyFileWithMD5Check (workingDir </> cabalFileName) (installDir </> cabalFileName)
  copyFileWithMD5Check (workingDir </> jsonFileName) (installDir </> jsonFileName)
  copyFileWithMD5Check (workingDir </> "LICENSE") (installDir </> "LICENSE")
  copyCppFiles workingDir (C.csrcDir installDir) (unCabalName pkgname) pkgconfig
  for_ mods (copyModule workingDir (C.srcDir installDir))
  for_ tcms (copyTemplateModule workingDir (C.srcDir installDir))
  putStrLn "Copying Ordinary"
  moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "Enum" <.> "hsc"
  moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "Ordinary" <.> "hs"
  moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "Template" <.> "hs"
  moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "TH" <.> "hs"
  moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "hs"
  putStrLn "----------------------------------------------------"
  putStrLn "-- Code generation has been completed. Enjoy!     --"
  putStrLn "----------------------------------------------------"

-- | some dirty hack. later, we will do it with more proper approcah.
touch :: FilePath -> IO ()
touch fp = void (readProcess "touch" [fp] "")

copyFileWithMD5Check :: FilePath -> FilePath -> IO ()
copyFileWithMD5Check src tgt = do
  b <- doesFileExist tgt
  if b
    then do
      srcmd5 <- md5 <$> L.readFile src
      tgtmd5 <- md5 <$> L.readFile tgt
      if srcmd5 == tgtmd5 then return () else copyFile src tgt
    else copyFile src tgt

copyCppFiles :: FilePath -> FilePath -> String -> PackageConfig -> IO ()
copyCppFiles wdir ddir cprefix (PkgConfig _ cihs tih _ _tcihs acincs acsrcs) = do
  let thfile = cprefix <> "Type.h"
      tlhfile = tihHeaderFileName tih <.> "h"
      tlcppfile = tihHeaderFileName tih <.> "cpp"
  copyFileWithMD5Check (wdir </> thfile) (ddir </> thfile)
  doesFileExist (wdir </> tlhfile)
    >>= flip when (copyFileWithMD5Check (wdir </> tlhfile) (ddir </> tlhfile))
  doesFileExist (wdir </> tlcppfile)
    >>= flip when (copyFileWithMD5Check (wdir </> tlcppfile) (ddir </> tlcppfile))
  for_ cihs $ \header -> do
    let hfile = unHdrName (cihSelfHeader header)
        cppfile = cihSelfCpp header
    copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile)
    copyFileWithMD5Check (wdir </> cppfile) (ddir </> cppfile)
  for_ acincs $ \(AddCInc header _) ->
    copyFileWithMD5Check (wdir </> header) (ddir </> header)
  for_ acsrcs $ \(AddCSrc csrc _) ->
    copyFileWithMD5Check (wdir </> csrc) (ddir </> csrc)

moduleFileCopy :: FilePath -> FilePath -> FilePath -> IO ()
moduleFileCopy wdir ddir fname = do
  let (fnamebody, fnameext) = splitExtension fname
      (mdir, mfile) = moduleDirFile fnamebody
      origfpath = wdir </> fname
      (mfile', _mext') = splitExtension mfile
      newfpath = ddir </> mdir </> mfile' <> fnameext
  b <- doesFileExist origfpath
  when b $ do
    createDirectoryIfMissing True (ddir </> mdir)
    copyFileWithMD5Check origfpath newfpath

copyModule :: FilePath -> FilePath -> ClassModule -> IO ()
copyModule wdir ddir m = do
  let modbase = cmModule m
  moduleFileCopy wdir ddir $ modbase <> ".hs"
  moduleFileCopy wdir ddir $ modbase <> ".RawType.hs"
  moduleFileCopy wdir ddir $ modbase <> ".FFI.hsc"
  moduleFileCopy wdir ddir $ modbase <> ".Interface.hs"
  moduleFileCopy wdir ddir $ modbase <> ".Cast.hs"
  moduleFileCopy wdir ddir $ modbase <> ".Implementation.hs"
  moduleFileCopy wdir ddir $ modbase <> ".Interface.hs-boot"
  when (hasProxy . cihClass . cmCIH $ m) $
    moduleFileCopy wdir ddir $
      modbase <> ".Proxy.hs"

copyTemplateModule :: FilePath -> FilePath -> TemplateClassModule -> IO ()
copyTemplateModule wdir ddir m = do
  let modbase = tcmModule m
  moduleFileCopy wdir ddir $ modbase <> ".Template.hs"
  moduleFileCopy wdir ddir $ modbase <> ".TH.hs"