module Development.Shake.ATS.Rules ( atsLex
                                   , cleanATS
                                   , cabalExport
                                   , getSubdirs
                                   , genATS
                                   , genLinks
                                   ) where

import           Control.Monad
import           Data.Semigroup                 (Semigroup (..))
import qualified Data.Text.Lazy                 as TL
import           Development.Shake              hiding (doesDirectoryExist)
import           Development.Shake.ATS.Generate
import           Development.Shake.ATS.Type     hiding (ATSTarget (..))
import           Development.Shake.Cabal
import           Development.Shake.FilePath
import           Development.Shake.Version
import           Language.ATS.Generate
import           System.Directory

-- | Given a plain Haskell source file, generate a @.sats@ file containing
-- the equivalent types.
genATS :: FilePath -- ^ Haskell source
       -> FilePattern -- ^ @.sats@ file to generate
       -> Bool -- ^ Whether to call cpphs preprocessor
       -> Rules ()
genATS :: FilePath -> FilePath -> Bool -> Rules ()
genATS FilePath
src' FilePath
target Bool
cpphs' =
    FilePath
target Located => FilePath -> (FilePath -> Action ()) -> Rules ()
FilePath -> (FilePath -> Action ()) -> Rules ()
%> \FilePath
out -> IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
out)
        FilePath -> FilePath -> Bool -> IO ()
genATSTypes FilePath
src' FilePath
out Bool
cpphs'

genLinks :: FilePath -> FilePath -> Rules ()
genLinks :: FilePath -> FilePath -> Rules ()
genLinks FilePath
dats FilePath
link =
    FilePath
link Located => FilePath -> (FilePath -> Action ()) -> Rules ()
FilePath -> (FilePath -> Action ()) -> Rules ()
%> \FilePath
out -> IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ do
        FilePath
contents <- FilePath -> IO FilePath
readFile FilePath
dats
        let proc :: Either ATSError FilePath
proc = FilePath -> Either ATSError FilePath
generateLinks FilePath
contents
        FilePath -> FilePath -> IO ()
writeFile FilePath
out ((ATSError -> FilePath)
-> (FilePath -> FilePath) -> Either ATSError FilePath -> FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ATSError -> FilePath
forall a. Located => a
undefined FilePath -> FilePath
forall a. a -> a
id Either ATSError FilePath
proc)

-- | Get subdirectories recursively.
getSubdirs :: FilePath -> IO [FilePath]
getSubdirs :: FilePath -> IO [FilePath]
getSubdirs FilePath
p = do
    [FilePath]
ds <- FilePath -> IO [FilePath]
listDirectory FilePath
p
    case [FilePath]
ds of
        [] -> [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        [FilePath]
xs -> do
            [FilePath]
ds' <- (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesDirectoryExist (((FilePath
p FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/") FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>) (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
xs)
            [[FilePath]]
ss <- (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO [FilePath]
getSubdirs [FilePath]
ds'
            [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath]
ds' [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [[FilePath]] -> [FilePath]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [[FilePath]]
ss

-- | These rules take a @.cabal@ file and the @.o@ file to be produced from
-- them, building the @.o@ file.
cabalExport :: ForeignCabal -> Rules ()
cabalExport :: ForeignCabal -> Rules ()
cabalExport (ForeignCabal Maybe Text
cbp' Text
cf' Text
obf') = do

    let cf :: FilePath
cf = Text -> FilePath
TL.unpack Text
cf'
        cbp :: FilePath
cbp = FilePath -> (Text -> FilePath) -> Maybe Text -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
cf Text -> FilePath
TL.unpack Maybe Text
cbp'
        obf :: FilePath
obf = Text -> FilePath
TL.unpack Text
obf'
        obfDir :: FilePath
obfDir = FilePath -> FilePath
takeDirectory (FilePath
obf FilePath -> FilePath -> FilePath
-<.> FilePath
"hs")
        libName :: FilePath
libName = FilePath -> FilePath
takeBaseName FilePath
cf

    (Version
v, [FilePath]
trDeps) <- IO (Version, [FilePath]) -> Rules (Version, [FilePath])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Version, [FilePath]) -> Rules (Version, [FilePath]))
-> IO (Version, [FilePath]) -> Rules (Version, [FilePath])
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Version, [FilePath])
getCabalDeps FilePath
cf
    FilePath
obf Located => FilePath -> (FilePath -> Action ()) -> Rules ()
FilePath -> (FilePath -> Action ()) -> Rules ()
%> \FilePath
out -> do

        Located => [FilePath] -> Action ()
[FilePath] -> Action ()
need (FilePath
cf FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath
obfDir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/") FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>) [FilePath]
trDeps)
        Located => [CmdOption] -> FilePath -> [FilePath] -> Action ()
[CmdOption] -> FilePath -> [FilePath] -> Action ()
command_ [FilePath -> CmdOption
Cwd FilePath
obfDir] FilePath
"cabal" [FilePath
"new-build", FilePath
"all"]

        -- TODO move this to the @shake-ext@ package?
        FilePath
ghcV <- Action FilePath -> Action FilePath
forall a. Action a -> Action a
quietly Action FilePath
ghcVersion
        let subdir :: FilePath
subdir = FilePath -> FilePath
takeDirectory FilePath
cbp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/"
            correctDir :: FilePath -> Bool
correctDir = (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"build")
            endsBuild :: FilePath -> Bool
endsBuild = FilePath -> Bool
correctDir (FilePath -> Bool) -> (FilePath -> FilePath) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
forall a. [a] -> a
last ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
splitPath
            pkgDir :: FilePath
pkgDir = FilePath
subdir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"dist-newstyle/build/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
platform FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/ghc-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
ghcV FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
libName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow Version
v FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/"

        [FilePath]
dir <- (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
endsBuild ([FilePath] -> [FilePath])
-> Action [FilePath] -> Action [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [FilePath] -> Action [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO [FilePath]
getSubdirs FilePath
pkgDir)
        let obj :: FilePath
obj = [FilePath] -> FilePath
forall a. [a] -> a
head [FilePath]
dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
takeFileName FilePath
obf
        IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
copyFile FilePath
obj FilePath
out

        let hdr :: FilePath
hdr = FilePath -> FilePath
dropExtension FilePath
obj FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_stub.h"
        IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
copyFile FilePath
hdr (FilePath -> FilePath
takeDirectory FilePath
out FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
takeFileName FilePath
hdr)

-- | Build a @.lats@ file.
atsLex :: FilePath -- ^ Filepath of @.lats@ file
       -> FilePattern -- ^ File pattern for generated output
       -> Rules ()
atsLex :: FilePath -> FilePath -> Rules ()
atsLex FilePath
latsIn FilePath
fp =
    FilePath
fp Located => FilePath -> (FilePath -> Action ()) -> Rules ()
FilePath -> (FilePath -> Action ()) -> Rules ()
%> \FilePath
out -> do
        FilePath
lats <- IO FilePath -> Action FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> Action FilePath) -> IO FilePath -> Action FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile FilePath
latsIn
        (Stdout FilePath
contents) <- [CmdOption] -> FilePath -> [FilePath] -> Action (Stdout FilePath)
forall r.
(Located, CmdResult r) =>
[CmdOption] -> FilePath -> [FilePath] -> Action r
command [FilePath -> CmdOption
Stdin FilePath
lats] FilePath
"atslex" []
        IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
writeFile FilePath
out FilePath
contents

-- | Clean up after an ATS build.
cleanATS :: Action ()
cleanATS :: Action ()
cleanATS =
    (FilePath -> [FilePath] -> Action ())
-> [FilePath] -> [[FilePath]] -> Action ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ FilePath -> [FilePath] -> Action ()
removeFilesAfter
        [FilePath
".", FilePath
".atspkg", FilePath
"ats-deps"]
        [[FilePath
"//*.c", FilePath
"//*_lats.dats", FilePath
"//tags"], [FilePath
"//*"], [FilePath
"//*"]]