{-# 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.Digest.Pure.MD5 (md5)
import Data.Foldable (for_)
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.Runtime.CodeGen.Cxx (HeaderName (..))
import Language.Haskell.Exts.Pretty (prettyPrint)
import System.Directory
  ( copyFile,
    createDirectoryIfMissing,
    doesFileExist,
  )
import System.FilePath (splitExtension, (<.>), (</>))
import System.IO (IOMode (..), hPutStrLn, withFile)
import System.Process (readProcess)

macrofy :: String -> String
macrofy :: FilePath -> FilePath
macrofy = (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map ((\Char
x -> if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' then Char
'_' else Char
x) (Char -> Char) -> (Char -> Char) -> Char -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toUpper)

simpleBuilder :: FFICXXConfig -> SimpleBuilderConfig -> IO ()
simpleBuilder :: FFICXXConfig -> SimpleBuilderConfig -> IO ()
simpleBuilder FFICXXConfig
cfg SimpleBuilderConfig
sbc = do
  FilePath -> IO ()
putStrLn FilePath
"----------------------------------------------------"
  FilePath -> IO ()
putStrLn FilePath
"-- fficxx code generation for Haskell-C++ binding --"
  FilePath -> IO ()
putStrLn FilePath
"----------------------------------------------------"
  let SimpleBuilderConfig
        FilePath
topLevelMod
        ModuleUnitMap
mumap
        Cabal
cabal
        [Class]
classes
        [TopLevel]
toplevelfunctions
        [TemplateClassImportHeader]
templates
        [FilePath]
extralibs
        [FilePath]
cxxopts
        [(FilePath, [FilePath])]
extramods
        [FilePath]
staticFiles =
          SimpleBuilderConfig
sbc
      pkgname :: CabalName
pkgname = Cabal -> CabalName
cabal_pkgname Cabal
cabal
  FilePath -> IO ()
putStrLn (FilePath
"Generating " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> CabalName -> FilePath
unCabalName CabalName
pkgname)
  let workingDir :: FilePath
workingDir = FFICXXConfig -> FilePath
fficxxconfig_workingDir FFICXXConfig
cfg
      installDir :: FilePath
installDir = FFICXXConfig -> FilePath
fficxxconfig_installBaseDir FFICXXConfig
cfg
      staticDir :: FilePath
staticDir = FFICXXConfig -> FilePath
fficxxconfig_staticFileDir FFICXXConfig
cfg
      pkgconfig :: PackageConfig
pkgconfig@(PkgConfig [ClassModule]
mods [ClassImportHeader]
cihs TopLevelImportHeader
tih [TemplateClassModule]
tcms [TemplateClassImportHeader]
_tcihs [AddCInc]
_ [AddCSrc]
_) =
        (CabalName, ModuleUnit -> ModuleUnitImports)
-> ([Class], [TopLevel], [TemplateClassImportHeader],
    [(FilePath, [FilePath])])
-> [AddCInc]
-> [AddCSrc]
-> PackageConfig
mkPackageConfig
          (CabalName
pkgname, ModuleUnitMap -> ModuleUnit -> ModuleUnitImports
findModuleUnitImports ModuleUnitMap
mumap)
          ([Class]
classes, [TopLevel]
toplevelfunctions, [TemplateClassImportHeader]
templates, [(FilePath, [FilePath])]
extramods)
          (Cabal -> [AddCInc]
cabal_additional_c_incs Cabal
cabal)
          (Cabal -> [AddCSrc]
cabal_additional_c_srcs Cabal
cabal)
      cabalFileName :: FilePath
cabalFileName = CabalName -> FilePath
unCabalName CabalName
pkgname FilePath -> FilePath -> FilePath
<.> FilePath
"cabal"
      jsonFileName :: FilePath
jsonFileName = CabalName -> FilePath
unCabalName CabalName
pkgname FilePath -> FilePath -> FilePath
<.> FilePath
"json"
      allClasses :: [Either TemplateClass Class]
allClasses = (TemplateClassImportHeader -> Either TemplateClass Class)
-> [TemplateClassImportHeader] -> [Either TemplateClass Class]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TemplateClass -> Either TemplateClass Class
forall a b. a -> Either a b
Left (TemplateClass -> Either TemplateClass Class)
-> (TemplateClassImportHeader -> TemplateClass)
-> TemplateClassImportHeader
-> Either TemplateClass Class
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TemplateClassImportHeader -> TemplateClass
tcihTClass) [TemplateClassImportHeader]
templates [Either TemplateClass Class]
-> [Either TemplateClass Class] -> [Either TemplateClass Class]
forall a. [a] -> [a] -> [a]
++ (Class -> Either TemplateClass Class)
-> [Class] -> [Either TemplateClass Class]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Class -> Either TemplateClass Class
forall a b. b -> Either a b
Right [Class]
classes
      depCycles :: DepCycles
depCycles =
        ([FilePath], [(Int, [Int])]) -> DepCycles
findDepCycles (([FilePath], [(Int, [Int])]) -> DepCycles)
-> ([FilePath], [(Int, [Int])]) -> DepCycles
forall a b. (a -> b) -> a -> b
$
          [Either TemplateClass Class]
-> [TopLevel] -> ([FilePath], [(Int, [Int])])
constructDepGraph [Either TemplateClass Class]
allClasses [TopLevel]
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 :: [ClassModule] -> [ClassModule]
mkHsBootCandidateList [ClassModule]
ms =
        let hsbootSubmods :: [FilePath]
hsbootSubmods = DepCycles -> [FilePath]
gatherHsBootSubmodules DepCycles
depCycles
         in (ClassModule -> Bool) -> [ClassModule] -> [ClassModule]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ClassModule
c -> ClassModule -> FilePath
cmModule ClassModule
c FilePath -> FilePath -> FilePath
<.> FilePath
"Interface" FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
hsbootSubmods) [ClassModule]
ms
      hsbootlst :: [ClassModule]
hsbootlst = [ClassModule] -> [ClassModule]
mkHsBootCandidateList [ClassModule]
mods
  --
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
workingDir
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
installDir
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath
installDir FilePath -> FilePath -> FilePath
</> FilePath
"src")
  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath
installDir FilePath -> FilePath -> FilePath
</> FilePath
"csrc")
  --
  FilePath -> IO ()
putStrLn FilePath
"Copying static files"
  (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\FilePath
x -> FilePath -> FilePath -> IO ()
copyFileWithMD5Check (FilePath
staticDir FilePath -> FilePath -> FilePath
</> FilePath
x) (FilePath
installDir FilePath -> FilePath -> FilePath
</> FilePath
x)) [FilePath]
staticFiles
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating Cabal file"
  Cabal
-> FilePath
-> PackageConfig
-> [FilePath]
-> [FilePath]
-> FilePath
-> IO ()
buildCabalFile Cabal
cabal FilePath
topLevelMod PackageConfig
pkgconfig [FilePath]
extralibs [FilePath]
cxxopts (FilePath
workingDir FilePath -> FilePath -> FilePath
</> FilePath
cabalFileName)
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating JSON file"
  Cabal
-> FilePath
-> PackageConfig
-> [FilePath]
-> [FilePath]
-> FilePath
-> IO ()
buildJSONFile Cabal
cabal FilePath
topLevelMod PackageConfig
pkgconfig [FilePath]
extralibs [FilePath]
cxxopts (FilePath
workingDir FilePath -> FilePath -> FilePath
</> FilePath
jsonFileName)
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating Header file"
  let gen :: FilePath -> String -> IO ()
      gen :: FilePath -> FilePath -> IO ()
gen FilePath
file FilePath
str =
        let path :: FilePath
path = FilePath
workingDir FilePath -> FilePath -> FilePath
</> FilePath
file in FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
path IOMode
WriteMode ((Handle -> FilePath -> IO ()) -> FilePath -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> FilePath -> IO ()
hPutStrLn FilePath
str)
  FilePath -> FilePath -> IO ()
gen (CabalName -> FilePath
unCabalName CabalName
pkgname FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"Type.h") ([Class] -> FilePath
C.buildTypeDeclHeader ((ClassImportHeader -> Class) -> [ClassImportHeader] -> [Class]
forall a b. (a -> b) -> [a] -> [b]
map ClassImportHeader -> Class
cihClass [ClassImportHeader]
cihs))
  [ClassImportHeader] -> (ClassImportHeader -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ClassImportHeader]
cihs ((ClassImportHeader -> IO ()) -> IO ())
-> (ClassImportHeader -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ClassImportHeader
hdr ->
    FilePath -> FilePath -> IO ()
gen
      (HeaderName -> FilePath
unHdrName (ClassImportHeader -> HeaderName
cihSelfHeader ClassImportHeader
hdr))
      (FilePath -> ClassImportHeader -> FilePath
C.buildDeclHeader (CabalName -> FilePath
unCabalName CabalName
pkgname) ClassImportHeader
hdr)
  FilePath -> FilePath -> IO ()
gen
    (TopLevelImportHeader -> FilePath
tihHeaderFileName TopLevelImportHeader
tih FilePath -> FilePath -> FilePath
<.> FilePath
"h")
    (FilePath -> TopLevelImportHeader -> FilePath
C.buildTopLevelHeader (CabalName -> FilePath
unCabalName CabalName
pkgname) TopLevelImportHeader
tih)
  FilePath -> IO ()
putStrLn FilePath
"Generating Cpp file"
  [ClassImportHeader] -> (ClassImportHeader -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ClassImportHeader]
cihs (\ClassImportHeader
hdr -> FilePath -> FilePath -> IO ()
gen (ClassImportHeader -> FilePath
cihSelfCpp ClassImportHeader
hdr) (ClassImportHeader -> FilePath
C.buildDefMain ClassImportHeader
hdr))
  FilePath -> FilePath -> IO ()
gen (TopLevelImportHeader -> FilePath
tihHeaderFileName TopLevelImportHeader
tih FilePath -> FilePath -> FilePath
<.> FilePath
"cpp") (TopLevelImportHeader -> FilePath
C.buildTopLevelCppDef TopLevelImportHeader
tih)
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating Additional Header/Source"
  [AddCInc] -> (AddCInc -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Cabal -> [AddCInc]
cabal_additional_c_incs Cabal
cabal) (\(AddCInc FilePath
hdr FilePath
txt) -> FilePath -> FilePath -> IO ()
gen FilePath
hdr FilePath
txt)
  [AddCSrc] -> (AddCSrc -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Cabal -> [AddCSrc]
cabal_additional_c_srcs Cabal
cabal) (\(AddCSrc FilePath
hdr FilePath
txt) -> FilePath -> FilePath -> IO ()
gen FilePath
hdr FilePath
txt)
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating RawType.hs"
  [ClassModule] -> (ClassModule -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ClassModule]
mods ((ClassModule -> IO ()) -> IO ())
-> (ClassModule -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ClassModule
m ->
    FilePath -> FilePath -> IO ()
gen
      (ClassModule -> FilePath
cmModule ClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"RawType" FilePath -> FilePath -> FilePath
<.> FilePath
"hs")
      (Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (ClassModule -> Module ()
C.buildRawTypeHs ClassModule
m))
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating FFI.hsc"
  [ClassModule] -> (ClassModule -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ClassModule]
mods ((ClassModule -> IO ()) -> IO ())
-> (ClassModule -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ClassModule
m ->
    FilePath -> FilePath -> IO ()
gen
      (ClassModule -> FilePath
cmModule ClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"FFI" FilePath -> FilePath -> FilePath
<.> FilePath
"hsc")
      (Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (ClassModule -> Module ()
C.buildFFIHsc ClassModule
m))
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating Interface.hs"
  [ClassModule] -> (ClassModule -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ClassModule]
mods ((ClassModule -> IO ()) -> IO ())
-> (ClassModule -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ClassModule
m ->
    FilePath -> FilePath -> IO ()
gen
      (ClassModule -> FilePath
cmModule ClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"Interface" FilePath -> FilePath -> FilePath
<.> FilePath
"hs")
      (Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (AnnotateMap -> DepCycles -> ClassModule -> Module ()
C.buildInterfaceHs AnnotateMap
forall a. Monoid a => a
mempty DepCycles
depCycles ClassModule
m))
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating Cast.hs"
  [ClassModule] -> (ClassModule -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ClassModule]
mods ((ClassModule -> IO ()) -> IO ())
-> (ClassModule -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ClassModule
m ->
    FilePath -> FilePath -> IO ()
gen
      (ClassModule -> FilePath
cmModule ClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"Cast" FilePath -> FilePath -> FilePath
<.> FilePath
"hs")
      (Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (ClassModule -> Module ()
C.buildCastHs ClassModule
m))
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating Implementation.hs"
  [ClassModule] -> (ClassModule -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ClassModule]
mods ((ClassModule -> IO ()) -> IO ())
-> (ClassModule -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ClassModule
m ->
    FilePath -> FilePath -> IO ()
gen
      (ClassModule -> FilePath
cmModule ClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"Implementation" FilePath -> FilePath -> FilePath
<.> FilePath
"hs")
      (Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (AnnotateMap -> ClassModule -> Module ()
C.buildImplementationHs AnnotateMap
forall a. Monoid a => a
mempty ClassModule
m))
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating Proxy.hs"
  [ClassModule] -> (ClassModule -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ClassModule]
mods ((ClassModule -> IO ()) -> IO ())
-> (ClassModule -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ClassModule
m ->
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Class -> Bool
hasProxy (Class -> Bool) -> (ClassModule -> Class) -> ClassModule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassImportHeader -> Class
cihClass (ClassImportHeader -> Class)
-> (ClassModule -> ClassImportHeader) -> ClassModule -> Class
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassModule -> ClassImportHeader
cmCIH (ClassModule -> Bool) -> ClassModule -> Bool
forall a b. (a -> b) -> a -> b
$ ClassModule
m) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> FilePath -> IO ()
gen (ClassModule -> FilePath
cmModule ClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"Proxy" FilePath -> FilePath -> FilePath
<.> FilePath
"hs") (Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (ClassModule -> Module ()
C.buildProxyHs ClassModule
m))
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating Template.hs"
  [TemplateClassModule] -> (TemplateClassModule -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TemplateClassModule]
tcms ((TemplateClassModule -> IO ()) -> IO ())
-> (TemplateClassModule -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TemplateClassModule
m ->
    FilePath -> FilePath -> IO ()
gen
      (TemplateClassModule -> FilePath
tcmModule TemplateClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"Template" FilePath -> FilePath -> FilePath
<.> FilePath
"hs")
      (Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (TemplateClassModule -> Module ()
C.buildTemplateHs TemplateClassModule
m))
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating TH.hs"
  [TemplateClassModule] -> (TemplateClassModule -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TemplateClassModule]
tcms ((TemplateClassModule -> IO ()) -> IO ())
-> (TemplateClassModule -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TemplateClassModule
m ->
    FilePath -> FilePath -> IO ()
gen
      (TemplateClassModule -> FilePath
tcmModule TemplateClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"TH" FilePath -> FilePath -> FilePath
<.> FilePath
"hs")
      (Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (TemplateClassModule -> Module ()
C.buildTHHs TemplateClassModule
m))
  --
  -- TODO: Template.hs-boot need to be generated as well
  FilePath -> IO ()
putStrLn FilePath
"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 :: FilePath -> FilePath
hsBootHackClearEmptyContexts = Text -> FilePath
T.unpack (Text -> FilePath) -> (FilePath -> Text) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"() =>" Text
"" (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
  [ClassModule] -> (ClassModule -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ClassModule]
hsbootlst ((ClassModule -> IO ()) -> IO ())
-> (ClassModule -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ClassModule
m -> do
    FilePath -> FilePath -> IO ()
gen
      (ClassModule -> FilePath
cmModule ClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"Interface" FilePath -> FilePath -> FilePath
<.> FilePath
"hs-boot")
      (FilePath -> FilePath
hsBootHackClearEmptyContexts (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (DepCycles -> ClassModule -> Module ()
C.buildInterfaceHsBoot DepCycles
depCycles ClassModule
m))
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating Module summary file"
  [ClassModule] -> (ClassModule -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ClassModule]
mods ((ClassModule -> IO ()) -> IO ())
-> (ClassModule -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ClassModule
m ->
    FilePath -> FilePath -> IO ()
gen
      (ClassModule -> FilePath
cmModule ClassModule
m FilePath -> FilePath -> FilePath
<.> FilePath
"hs")
      (Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (ClassModule -> Module ()
C.buildModuleHs ClassModule
m))
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating Top-level Ordinary Module"
  FilePath -> FilePath -> IO ()
gen (FilePath
topLevelMod FilePath -> FilePath -> FilePath
<.> FilePath
"Ordinary" FilePath -> FilePath -> FilePath
<.> FilePath
"hs") (Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (FilePath
-> ([ClassModule], [TemplateClassModule])
-> TopLevelImportHeader
-> Module ()
C.buildTopLevelOrdinaryHs (FilePath
topLevelMod FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".Ordinary") ([ClassModule]
mods, [TemplateClassModule]
tcms) TopLevelImportHeader
tih))
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating Top-level Template Module"
  FilePath -> FilePath -> IO ()
gen
    (FilePath
topLevelMod FilePath -> FilePath -> FilePath
<.> FilePath
"Template" FilePath -> FilePath -> FilePath
<.> FilePath
"hs")
    (Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (FilePath -> TopLevelImportHeader -> Module ()
C.buildTopLevelTemplateHs (FilePath
topLevelMod FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".Template") TopLevelImportHeader
tih))
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating Top-level TH Module"
  FilePath -> FilePath -> IO ()
gen
    (FilePath
topLevelMod FilePath -> FilePath -> FilePath
<.> FilePath
"TH" FilePath -> FilePath -> FilePath
<.> FilePath
"hs")
    (Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (FilePath -> TopLevelImportHeader -> Module ()
C.buildTopLevelTHHs (FilePath
topLevelMod FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".TH") TopLevelImportHeader
tih))
  --
  FilePath -> IO ()
putStrLn FilePath
"Generating Top-level Module"
  FilePath -> FilePath -> IO ()
gen
    (FilePath
topLevelMod FilePath -> FilePath -> FilePath
<.> FilePath
"hs")
    (Module () -> FilePath
forall a. Pretty a => a -> FilePath
prettyPrint (FilePath -> ([ClassModule], [TemplateClassModule]) -> Module ()
C.buildTopLevelHs FilePath
topLevelMod ([ClassModule]
mods, [TemplateClassModule]
tcms)))
  --
  FilePath -> IO ()
putStrLn FilePath
"Copying generated files to target directory"
  FilePath -> IO ()
touch (FilePath
workingDir FilePath -> FilePath -> FilePath
</> FilePath
"LICENSE")
  FilePath -> FilePath -> IO ()
copyFileWithMD5Check (FilePath
workingDir FilePath -> FilePath -> FilePath
</> FilePath
cabalFileName) (FilePath
installDir FilePath -> FilePath -> FilePath
</> FilePath
cabalFileName)
  FilePath -> FilePath -> IO ()
copyFileWithMD5Check (FilePath
workingDir FilePath -> FilePath -> FilePath
</> FilePath
jsonFileName) (FilePath
installDir FilePath -> FilePath -> FilePath
</> FilePath
jsonFileName)
  FilePath -> FilePath -> IO ()
copyFileWithMD5Check (FilePath
workingDir FilePath -> FilePath -> FilePath
</> FilePath
"LICENSE") (FilePath
installDir FilePath -> FilePath -> FilePath
</> FilePath
"LICENSE")
  FilePath -> FilePath -> FilePath -> PackageConfig -> IO ()
copyCppFiles FilePath
workingDir (FilePath -> FilePath
C.csrcDir FilePath
installDir) (CabalName -> FilePath
unCabalName CabalName
pkgname) PackageConfig
pkgconfig
  [ClassModule] -> (ClassModule -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ClassModule]
mods (FilePath -> FilePath -> ClassModule -> IO ()
copyModule FilePath
workingDir (FilePath -> FilePath
C.srcDir FilePath
installDir))
  [TemplateClassModule] -> (TemplateClassModule -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TemplateClassModule]
tcms (FilePath -> FilePath -> TemplateClassModule -> IO ()
copyTemplateModule FilePath
workingDir (FilePath -> FilePath
C.srcDir FilePath
installDir))
  FilePath -> IO ()
putStrLn FilePath
"Copying Ordinary"
  FilePath -> FilePath -> FilePath -> IO ()
moduleFileCopy FilePath
workingDir (FilePath -> FilePath
C.srcDir FilePath
installDir) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
topLevelMod FilePath -> FilePath -> FilePath
<.> FilePath
"Ordinary" FilePath -> FilePath -> FilePath
<.> FilePath
"hs"
  FilePath -> FilePath -> FilePath -> IO ()
moduleFileCopy FilePath
workingDir (FilePath -> FilePath
C.srcDir FilePath
installDir) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
topLevelMod FilePath -> FilePath -> FilePath
<.> FilePath
"Template" FilePath -> FilePath -> FilePath
<.> FilePath
"hs"
  FilePath -> FilePath -> FilePath -> IO ()
moduleFileCopy FilePath
workingDir (FilePath -> FilePath
C.srcDir FilePath
installDir) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
topLevelMod FilePath -> FilePath -> FilePath
<.> FilePath
"TH" FilePath -> FilePath -> FilePath
<.> FilePath
"hs"
  FilePath -> FilePath -> FilePath -> IO ()
moduleFileCopy FilePath
workingDir (FilePath -> FilePath
C.srcDir FilePath
installDir) (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
topLevelMod FilePath -> FilePath -> FilePath
<.> FilePath
"hs"
  FilePath -> IO ()
putStrLn FilePath
"----------------------------------------------------"
  FilePath -> IO ()
putStrLn FilePath
"-- Code generation has been completed. Enjoy!     --"
  FilePath -> IO ()
putStrLn FilePath
"----------------------------------------------------"

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

copyFileWithMD5Check :: FilePath -> FilePath -> IO ()
copyFileWithMD5Check :: FilePath -> FilePath -> IO ()
copyFileWithMD5Check FilePath
src FilePath
tgt = do
  Bool
b <- FilePath -> IO Bool
doesFileExist FilePath
tgt
  if Bool
b
    then do
      MD5Digest
srcmd5 <- ByteString -> MD5Digest
md5 (ByteString -> MD5Digest) -> IO ByteString -> IO MD5Digest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
L.readFile FilePath
src
      MD5Digest
tgtmd5 <- ByteString -> MD5Digest
md5 (ByteString -> MD5Digest) -> IO ByteString -> IO MD5Digest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
L.readFile FilePath
tgt
      if MD5Digest
srcmd5 MD5Digest -> MD5Digest -> Bool
forall a. Eq a => a -> a -> Bool
== MD5Digest
tgtmd5 then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () else FilePath -> FilePath -> IO ()
copyFile FilePath
src FilePath
tgt
    else FilePath -> FilePath -> IO ()
copyFile FilePath
src FilePath
tgt

copyCppFiles :: FilePath -> FilePath -> String -> PackageConfig -> IO ()
copyCppFiles :: FilePath -> FilePath -> FilePath -> PackageConfig -> IO ()
copyCppFiles FilePath
wdir FilePath
ddir FilePath
cprefix (PkgConfig [ClassModule]
_ [ClassImportHeader]
cihs TopLevelImportHeader
tih [TemplateClassModule]
_ [TemplateClassImportHeader]
_tcihs [AddCInc]
acincs [AddCSrc]
acsrcs) = do
  let thfile :: FilePath
thfile = FilePath
cprefix FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"Type.h"
      tlhfile :: FilePath
tlhfile = TopLevelImportHeader -> FilePath
tihHeaderFileName TopLevelImportHeader
tih FilePath -> FilePath -> FilePath
<.> FilePath
"h"
      tlcppfile :: FilePath
tlcppfile = TopLevelImportHeader -> FilePath
tihHeaderFileName TopLevelImportHeader
tih FilePath -> FilePath -> FilePath
<.> FilePath
"cpp"
  FilePath -> FilePath -> IO ()
copyFileWithMD5Check (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
thfile) (FilePath
ddir FilePath -> FilePath -> FilePath
</> FilePath
thfile)
  FilePath -> IO Bool
doesFileExist (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
tlhfile)
    IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> FilePath -> IO ()
copyFileWithMD5Check (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
tlhfile) (FilePath
ddir FilePath -> FilePath -> FilePath
</> FilePath
tlhfile))
  FilePath -> IO Bool
doesFileExist (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
tlcppfile)
    IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> FilePath -> IO ()
copyFileWithMD5Check (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
tlcppfile) (FilePath
ddir FilePath -> FilePath -> FilePath
</> FilePath
tlcppfile))
  [ClassImportHeader] -> (ClassImportHeader -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ClassImportHeader]
cihs ((ClassImportHeader -> IO ()) -> IO ())
-> (ClassImportHeader -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ClassImportHeader
header -> do
    let hfile :: FilePath
hfile = HeaderName -> FilePath
unHdrName (ClassImportHeader -> HeaderName
cihSelfHeader ClassImportHeader
header)
        cppfile :: FilePath
cppfile = ClassImportHeader -> FilePath
cihSelfCpp ClassImportHeader
header
    FilePath -> FilePath -> IO ()
copyFileWithMD5Check (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
hfile) (FilePath
ddir FilePath -> FilePath -> FilePath
</> FilePath
hfile)
    FilePath -> FilePath -> IO ()
copyFileWithMD5Check (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
cppfile) (FilePath
ddir FilePath -> FilePath -> FilePath
</> FilePath
cppfile)
  [AddCInc] -> (AddCInc -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [AddCInc]
acincs ((AddCInc -> IO ()) -> IO ()) -> (AddCInc -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(AddCInc FilePath
header FilePath
_) ->
    FilePath -> FilePath -> IO ()
copyFileWithMD5Check (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
header) (FilePath
ddir FilePath -> FilePath -> FilePath
</> FilePath
header)
  [AddCSrc] -> (AddCSrc -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [AddCSrc]
acsrcs ((AddCSrc -> IO ()) -> IO ()) -> (AddCSrc -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(AddCSrc FilePath
csrc FilePath
_) ->
    FilePath -> FilePath -> IO ()
copyFileWithMD5Check (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
csrc) (FilePath
ddir FilePath -> FilePath -> FilePath
</> FilePath
csrc)

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

copyModule :: FilePath -> FilePath -> ClassModule -> IO ()
copyModule :: FilePath -> FilePath -> ClassModule -> IO ()
copyModule FilePath
wdir FilePath
ddir ClassModule
m = do
  let modbase :: FilePath
modbase = ClassModule -> FilePath
cmModule ClassModule
m
  FilePath -> FilePath -> FilePath -> IO ()
moduleFileCopy FilePath
wdir FilePath
ddir (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
modbase FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".hs"
  FilePath -> FilePath -> FilePath -> IO ()
moduleFileCopy FilePath
wdir FilePath
ddir (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
modbase FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".RawType.hs"
  FilePath -> FilePath -> FilePath -> IO ()
moduleFileCopy FilePath
wdir FilePath
ddir (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
modbase FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".FFI.hsc"
  FilePath -> FilePath -> FilePath -> IO ()
moduleFileCopy FilePath
wdir FilePath
ddir (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
modbase FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".Interface.hs"
  FilePath -> FilePath -> FilePath -> IO ()
moduleFileCopy FilePath
wdir FilePath
ddir (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
modbase FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".Cast.hs"
  FilePath -> FilePath -> FilePath -> IO ()
moduleFileCopy FilePath
wdir FilePath
ddir (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
modbase FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".Implementation.hs"
  FilePath -> FilePath -> FilePath -> IO ()
moduleFileCopy FilePath
wdir FilePath
ddir (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
modbase FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".Interface.hs-boot"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Class -> Bool
hasProxy (Class -> Bool) -> (ClassModule -> Class) -> ClassModule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassImportHeader -> Class
cihClass (ClassImportHeader -> Class)
-> (ClassModule -> ClassImportHeader) -> ClassModule -> Class
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassModule -> ClassImportHeader
cmCIH (ClassModule -> Bool) -> ClassModule -> Bool
forall a b. (a -> b) -> a -> b
$ ClassModule
m) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> FilePath -> FilePath -> IO ()
moduleFileCopy FilePath
wdir FilePath
ddir (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath
modbase FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".Proxy.hs"

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