{-# LANGUAGE CPP #-}
module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook,
                                       uuagcUserHook',
                                       uuagc,
                                       uuagcLibUserHook,
                                       uuagcFromString
                                      ) where

-- import Distribution.Simple.BuildPaths (autogenComponentModulesDir)
import Debug.Trace
import Distribution.Simple
import Distribution.Simple.PreProcess
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
import Distribution.Simple.Setup
import Distribution.PackageDescription hiding (Flag)
import Distribution.Simple.UUAGC.AbsSyn( AGFileOption(..)
                                         , AGFileOptions
                                         , AGOptionsClass(..)
                                         , lookupFileOptions
                                         , fileClasses
                                         )
import Distribution.Simple.UUAGC.Parser
import Options hiding (verbose)
import Distribution.Verbosity
import System.Process( readProcessWithExitCode )
import System.Directory(getModificationTime
                       ,doesFileExist
                       ,removeFile)
import System.FilePath(pathSeparators,
                       (</>),
                       takeFileName,
                       normalise,
                       joinPath,
                       dropFileName,
                       addExtension,
                       dropExtension,
                       replaceExtension,
                       splitDirectories)

import System.Exit (ExitCode(..))
import System.IO( openFile, IOMode(..),
                  hFileSize,
                  hSetFileSize,
                  hClose,
                  hGetContents,
                  hFlush,
                  Handle(..), stderr, hPutStr, hPutStrLn)
import System.Exit(exitFailure)
import Control.Exception (throwIO)
import Control.Monad (liftM, when, guard, forM_, forM)
import Control.Arrow ((&&&), second)
import Data.Maybe (maybeToList)
import Data.Either (partitionEithers)
import Data.List (nub,intersperse)
import Data.Map (Map)
import qualified Data.Map as Map

#if MIN_VERSION_Cabal(3,6,0)
import Distribution.Utils.Path (getSymbolicPath, PackageDir, SourceDir, SymbolicPath)
#endif

{-# DEPRECATED uuagcUserHook, uuagcUserHook', uuagc "Use uuagcLibUserHook instead" #-}

-- | 'uuagc' returns the name of the uuagc compiler
uuagcn :: String
uuagcn = String
"uuagc"

-- | 'defUUAGCOptions' returns the default names of the uuagc options
defUUAGCOptions :: String
defUUAGCOptions :: String
defUUAGCOptions = String
"uuagc_options"

-- | File used to store de classes defined in the cabal file.
agClassesFile :: String
agClassesFile :: String
agClassesFile = String
"ag_file_options"

-- | The prefix used for the cabal file optionsw
agModule :: String
agModule :: String
agModule = String
"x-agmodule"

-- | The prefix used for the cabal file options used for defining classes
agClass :: String
agClass :: String
agClass  = String
"x-agclass"

-- | Deprecated userhook
uuagcUserHook :: UserHooks
uuagcUserHook :: UserHooks
uuagcUserHook = String -> UserHooks
uuagcUserHook' String
uuagcn

-- | Deprecated userhook
uuagcUserHook' :: String -> UserHooks
uuagcUserHook' :: String -> UserHooks
uuagcUserHook' String
uuagcPath = ([String] -> String -> IO (ExitCode, [String])) -> UserHooks
uuagcLibUserHook (String -> [String] -> String -> IO (ExitCode, [String])
uuagcFromString String
uuagcPath)

-- | Create uuagc function using shell (old method)
uuagcFromString :: String -> [String] -> FilePath -> IO (ExitCode, [FilePath])
uuagcFromString :: String -> [String] -> String -> IO (ExitCode, [String])
uuagcFromString String
uuagcPath [String]
args String
file = do
  (ExitCode
ec,String
out,String
err) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
uuagcPath ([String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
file]) String
""
  case ExitCode
ec of
    ExitCode
ExitSuccess ->
      do Handle -> String -> IO ()
hPutStr Handle
stderr String
err
         (ExitCode, [String]) -> IO (ExitCode, [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ExitSuccess, String -> [String]
words String
out)
    (ExitFailure Int
exc) ->
      do Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
uuagcPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
exc)
         Handle -> String -> IO ()
hPutStr Handle
stderr String
out
         Handle -> String -> IO ()
hPutStr Handle
stderr String
err
         (ExitCode, [String]) -> IO (ExitCode, [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
exc, [])

-- | Main hook, argument should be uuagc function
uuagcLibUserHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> UserHooks
uuagcLibUserHook :: ([String] -> String -> IO (ExitCode, [String])) -> UserHooks
uuagcLibUserHook [String] -> String -> IO (ExitCode, [String])
uuagc = UserHooks
hooks where
  hooks :: UserHooks
hooks = UserHooks
simpleUserHooks { hookedPreProcessors = ("ag", ag):("lag",ag):knownSuffixHandlers
                          , buildHook = uuagcBuildHook uuagc
--                          , sDistHook = uuagcSDistHook uuagc
                          }
  ag :: BuildInfo
-> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
ag = ([String] -> String -> IO (ExitCode, [String]))
-> BuildInfo
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> PreProcessor
uuagc' [String] -> String -> IO (ExitCode, [String])
uuagc

originalPreBuild :: [String] -> BuildFlags -> IO HookedBuildInfo
originalPreBuild  = UserHooks -> [String] -> BuildFlags -> IO HookedBuildInfo
preBuild UserHooks
simpleUserHooks
originalBuildHook :: PackageDescription
-> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()
originalBuildHook = UserHooks
-> PackageDescription
-> LocalBuildInfo
-> UserHooks
-> BuildFlags
-> IO ()
buildHook UserHooks
simpleUserHooks
--originalSDistHook = sDistHook simpleUserHooks

putErrorInfo :: Handle -> IO ()
putErrorInfo :: Handle -> IO ()
putErrorInfo Handle
h = Handle -> IO String
hGetContents Handle
h IO String -> (String -> 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
>>= Handle -> String -> IO ()
hPutStr Handle
stderr

-- | 'updateAGFile' search into the uuagc options file for a list of all
-- AG Files and theirs file dependencies in order to see if the latters
-- are more updated that the formers, and if this is the case to
-- update the AG File
updateAGFile :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))
             -> Map FilePath (Options, Maybe (FilePath, [String]))
             -> (FilePath, (Options, Maybe (FilePath, [String])))
             -> IO ()
updateAGFile :: ([String] -> String -> IO (ExitCode, [String]))
-> Map String (Options, Maybe (String, [String]))
-> (String, (Options, Maybe (String, [String])))
-> IO ()
updateAGFile [String] -> String -> IO (ExitCode, [String])
_ Map String (Options, Maybe (String, [String]))
_ (String
_,(Options
_,Maybe (String, [String])
Nothing)) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
updateAGFile [String] -> String -> IO (ExitCode, [String])
uuagc Map String (Options, Maybe (String, [String]))
newOptions (String
file,(Options
opts,Just (String
gen,[String]
sp))) = do
  Bool
hasGen <- String -> IO Bool
doesFileExist String
gen
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasGen (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    (ExitCode
ec, [String]
files) <- [String] -> String -> IO (ExitCode, [String])
uuagc (Options -> [String]
optionsToString (Options -> [String]) -> Options -> [String]
forall a b. (a -> b) -> a -> b
$ Options
opts { genFileDeps = True, searchPath = sp }) String
file
    case ExitCode
ec of
      ExitCode
ExitSuccess -> do
        let newOpts :: Options
            newOpts :: Options
newOpts = Options
-> ((Options, Maybe (String, [String])) -> Options)
-> Maybe (Options, Maybe (String, [String]))
-> Options
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Options
noOptions (Options, Maybe (String, [String])) -> Options
forall a b. (a, b) -> a
fst (Maybe (Options, Maybe (String, [String])) -> Options)
-> Maybe (Options, Maybe (String, [String])) -> Options
forall a b. (a -> b) -> a -> b
$ String
-> Map String (Options, Maybe (String, [String]))
-> Maybe (Options, Maybe (String, [String]))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
file Map String (Options, Maybe (String, [String]))
newOptions
            optRebuild :: Bool
optRebuild = Options -> [String]
optionsToString Options
newOpts [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= Options -> [String]
optionsToString Options
opts
        Bool
modRebuild <-
          if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
files
          then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          else do
            [UTCTime]
flsmt <- (String -> IO UTCTime) -> [String] -> IO [UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO UTCTime
getModificationTime [String]
files
            let maxModified :: UTCTime
maxModified = [UTCTime] -> UTCTime
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [UTCTime]
flsmt
            UTCTime
fmt <- String -> IO UTCTime
getModificationTime String
gen
            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ UTCTime
maxModified UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> UTCTime
fmt
        -- When some dependency is newer or options have changed, we should regenerate
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
optRebuild Bool -> Bool -> Bool
|| Bool
modRebuild) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
gen
      ex :: ExitCode
ex@(ExitFailure Int
_) -> ExitCode -> IO ()
forall e a. Exception e => e -> IO a
throwIO ExitCode
ex

getAGFileOptions :: [(String, String)] -> IO AGFileOptions
getAGFileOptions :: [(String, String)] -> IO AGFileOptions
getAGFileOptions [(String, String)]
extra = do
  AGFileOptions
cabalOpts <- ((String, String) -> IO AGFileOption)
-> [(String, String)] -> IO AGFileOptions
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> IO AGFileOption
parseOptionAG (String -> IO AGFileOption)
-> ((String, String) -> String)
-> (String, String)
-> IO AGFileOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> b
snd) ([(String, String)] -> IO AGFileOptions)
-> [(String, String)] -> IO AGFileOptions
forall a b. (a -> b) -> a -> b
$ ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
agModule) (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
extra
  Bool
usesOptionsFile <- String -> IO Bool
doesFileExist String
defUUAGCOptions
  if Bool
usesOptionsFile
       then do Either ParserError AGFileOptions
r <- String -> IO (Either ParserError AGFileOptions)
parserAG' String
defUUAGCOptions
               case Either ParserError AGFileOptions
r of
                 Left ParserError
e -> String -> IO AGFileOptions
forall a. String -> IO a
dieNoVerbosity (ParserError -> String
forall a. Show a => a -> String
show ParserError
e)
                 Right AGFileOptions
a -> AGFileOptions -> IO AGFileOptions
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AGFileOptions -> IO AGFileOptions)
-> AGFileOptions -> IO AGFileOptions
forall a b. (a -> b) -> a -> b
$ AGFileOptions
cabalOpts AGFileOptions -> AGFileOptions -> AGFileOptions
forall a. [a] -> [a] -> [a]
++ AGFileOptions
a
       else AGFileOptions -> IO AGFileOptions
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AGFileOptions
cabalOpts

getAGClasses :: [(String, String)] -> IO [AGOptionsClass]
getAGClasses :: [(String, String)] -> IO [AGOptionsClass]
getAGClasses = ((String, String) -> IO AGOptionsClass)
-> [(String, String)] -> IO [AGOptionsClass]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> IO AGOptionsClass
parseClassAG (String -> IO AGOptionsClass)
-> ((String, String) -> String)
-> (String, String)
-> IO AGOptionsClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> b
snd) ([(String, String)] -> IO [AGOptionsClass])
-> ([(String, String)] -> [(String, String)])
-> [(String, String)]
-> IO [AGOptionsClass]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> Bool)
-> [(String, String)] -> [(String, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
agClass) (String -> Bool)
-> ((String, String) -> String) -> (String, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst)

writeFileOptions :: FilePath -> Map FilePath (Options, Maybe (FilePath,[String])) -> IO ()
writeFileOptions :: String -> Map String (Options, Maybe (String, [String])) -> IO ()
writeFileOptions String
classesPath Map String (Options, Maybe (String, [String]))
opts  = do
  Handle
hClasses <- String -> IOMode -> IO Handle
openFile String
classesPath IOMode
WriteMode
  Handle -> String -> IO ()
hPutStr Handle
hClasses (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Map String ([String], Maybe (String, [String])) -> String
forall a. Show a => a -> String
show (Map String ([String], Maybe (String, [String])) -> String)
-> Map String ([String], Maybe (String, [String])) -> String
forall a b. (a -> b) -> a -> b
$ ((Options, Maybe (String, [String]))
 -> ([String], Maybe (String, [String])))
-> Map String (Options, Maybe (String, [String]))
-> Map String ([String], Maybe (String, [String]))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\(Options
opt,Maybe (String, [String])
gen) -> (Options -> [String]
optionsToString Options
opt, Maybe (String, [String])
gen)) Map String (Options, Maybe (String, [String]))
opts
  Handle -> IO ()
hFlush  Handle
hClasses
  Handle -> IO ()
hClose  Handle
hClasses

readFileOptions :: FilePath -> IO (Map FilePath (Options, Maybe (FilePath,[String])))
readFileOptions :: String -> IO (Map String (Options, Maybe (String, [String])))
readFileOptions String
classesPath = do
  Bool
isFile <- String -> IO Bool
doesFileExist String
classesPath
  if Bool
isFile
    then do Handle
hClasses <- String -> IOMode -> IO Handle
openFile String
classesPath IOMode
ReadMode
            String
sClasses <- Handle -> IO String
hGetContents Handle
hClasses
            Map String ([String], Maybe (String, [String]))
classes <- String -> IO (Map String ([String], Maybe (String, [String])))
forall a. Read a => String -> IO a
readIO String
sClasses :: IO (Map FilePath ([String], Maybe (FilePath,[String])))
            Handle -> IO ()
hClose Handle
hClasses
            Map String (Options, Maybe (String, [String]))
-> IO (Map String (Options, Maybe (String, [String])))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map String (Options, Maybe (String, [String]))
 -> IO (Map String (Options, Maybe (String, [String]))))
-> Map String (Options, Maybe (String, [String]))
-> IO (Map String (Options, Maybe (String, [String])))
forall a b. (a -> b) -> a -> b
$ (([String], Maybe (String, [String]))
 -> (Options, Maybe (String, [String])))
-> Map String ([String], Maybe (String, [String]))
-> Map String (Options, Maybe (String, [String]))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\([String]
opt,Maybe (String, [String])
gen) -> let (Options
opt',[String]
_,[String]
_) = [String] -> (Options, [String], [String])
getOptions [String]
opt in (Options
opt', Maybe (String, [String])
gen)) Map String ([String], Maybe (String, [String]))
classes
    else    Map String (Options, Maybe (String, [String]))
-> IO (Map String (Options, Maybe (String, [String])))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map String (Options, Maybe (String, [String]))
forall k a. Map k a
Map.empty

getOptionsFromClass :: [(String, Options)] -> AGFileOption -> ([String], Options)
getOptionsFromClass :: [(String, Options)] -> AGFileOption -> ([String], Options)
getOptionsFromClass [(String, Options)]
classes AGFileOption
fOpt =
    ([Options] -> Options)
-> ([String], [Options]) -> ([String], Options)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Options -> Options -> Options) -> Options -> [Options] -> Options
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Options -> Options -> Options
combineOptions (AGFileOption -> Options
opts AGFileOption
fOpt))
    (([String], [Options]) -> ([String], Options))
-> ([Either String Options] -> ([String], [Options]))
-> [Either String Options]
-> ([String], Options)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either String Options] -> ([String], [Options])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either String Options] -> ([String], Options))
-> [Either String Options] -> ([String], Options)
forall a b. (a -> b) -> a -> b
$ do
                       String
fClass <- AGFileOption -> [String]
fileClasses AGFileOption
fOpt
                       case String
fClass String -> [(String, Options)] -> Maybe Options
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, Options)]
classes of
                         Just Options
x  -> Either String Options -> [Either String Options]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Options -> [Either String Options])
-> Either String Options -> [Either String Options]
forall a b. (a -> b) -> a -> b
$ Options -> Either String Options
forall a b. b -> Either a b
Right Options
x
                         Maybe Options
Nothing -> Either String Options -> [Either String Options]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Options -> [Either String Options])
-> Either String Options -> [Either String Options]
forall a b. (a -> b) -> a -> b
$ String -> Either String Options
forall a b. a -> Either a b
Left (String -> Either String Options)
-> String -> Either String Options
forall a b. (a -> b) -> a -> b
$ String
"Warning: The class "
                                                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
fClass
                                                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not defined."

-- uuagcSDistHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))
--      -> PackageDescription
--      -> Maybe LocalBuildInfo
--      -> UserHooks
--      -> SDistFlags
--      -> IO ()
-- uuagcSDistHook uuagc pd mbLbi uh df = do
--   {-
--   case mbLbi of
--     Nothing -> warn normal "sdist: the local buildinfo was not present. Skipping AG initialization. Dist may fail."
--     Just lbi -> let classesPath = buildDir lbi </> agClassesFile
--                 in commonHook uuagc classesPath pd lbi (sDistVerbosity df)
--   originalSDistHook pd mbLbi uh df
--   -}
--   originalSDistHook pd mbLbi (uh { hookedPreProcessors = ("ag", nouuagc):("lag",nouuagc):knownSuffixHandlers }) df  -- bypass preprocessors

uuagcBuildHook
  :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))
     -> PackageDescription
     -> LocalBuildInfo
     -> UserHooks
     -> BuildFlags
     -> IO ()
uuagcBuildHook :: ([String] -> String -> IO (ExitCode, [String]))
-> PackageDescription
-> LocalBuildInfo
-> UserHooks
-> BuildFlags
-> IO ()
uuagcBuildHook [String] -> String -> IO (ExitCode, [String])
uuagc PackageDescription
pd LocalBuildInfo
lbi UserHooks
uh BuildFlags
bf = do
  let classesPath :: String
classesPath = LocalBuildInfo -> String
buildDir LocalBuildInfo
lbi String -> String -> String
</> String
agClassesFile
  ([String] -> String -> IO (ExitCode, [String]))
-> String
-> PackageDescription
-> LocalBuildInfo
-> Flag Verbosity
-> IO ()
commonHook [String] -> String -> IO (ExitCode, [String])
uuagc String
classesPath PackageDescription
pd LocalBuildInfo
lbi (BuildFlags -> Flag Verbosity
buildVerbosity BuildFlags
bf)
  PackageDescription
-> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()
originalBuildHook PackageDescription
pd LocalBuildInfo
lbi UserHooks
uh BuildFlags
bf

commonHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))
     -> FilePath
     -> PackageDescription
     -> LocalBuildInfo
     -> Flag Verbosity
     -> IO ()
commonHook :: ([String] -> String -> IO (ExitCode, [String]))
-> String
-> PackageDescription
-> LocalBuildInfo
-> Flag Verbosity
-> IO ()
commonHook [String] -> String -> IO (ExitCode, [String])
uuagc String
classesPath PackageDescription
pd LocalBuildInfo
lbi Flag Verbosity
fl = do
  let verbosity :: Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal Flag Verbosity
fl
  Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"commonHook: Assuming AG classesPath: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
classesPath
  Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (LocalBuildInfo -> String
buildDir LocalBuildInfo
lbi)
  -- Read already existing options
  -- Map FilePath (Options, Maybe (FilePath,[String]))
  Map String (Options, Maybe (String, [String]))
oldOptions <- String -> IO (Map String (Options, Maybe (String, [String])))
readFileOptions String
classesPath
  -- Read options from cabal and settings file
  let lib :: Maybe Library
lib    = PackageDescription -> Maybe Library
library PackageDescription
pd
      exes :: [Executable]
exes   = PackageDescription -> [Executable]
executables PackageDescription
pd
      bis :: [BuildInfo]
bis    = (Library -> BuildInfo) -> [Library] -> [BuildInfo]
forall a b. (a -> b) -> [a] -> [b]
map Library -> BuildInfo
libBuildInfo (Maybe Library -> [Library]
forall a. Maybe a -> [a]
maybeToList Maybe Library
lib) [BuildInfo] -> [BuildInfo] -> [BuildInfo]
forall a. [a] -> [a] -> [a]
++ (Executable -> BuildInfo) -> [Executable] -> [BuildInfo]
forall a b. (a -> b) -> [a] -> [b]
map Executable -> BuildInfo
buildInfo [Executable]
exes
  [(String, Options)]
classes <- (AGOptionsClass -> (String, Options))
-> [AGOptionsClass] -> [(String, Options)]
forall a b. (a -> b) -> [a] -> [b]
map (AGOptionsClass -> String
className (AGOptionsClass -> String)
-> (AGOptionsClass -> Options)
-> AGOptionsClass
-> (String, Options)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& AGOptionsClass -> Options
opts') ([AGOptionsClass] -> [(String, Options)])
-> IO [AGOptionsClass] -> IO [(String, Options)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ([(String, String)] -> IO [AGOptionsClass]
getAGClasses ([(String, String)] -> IO [AGOptionsClass])
-> (PackageDescription -> [(String, String)])
-> PackageDescription
-> IO [AGOptionsClass]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDescription -> [(String, String)]
customFieldsPD (PackageDescription -> IO [AGOptionsClass])
-> PackageDescription -> IO [AGOptionsClass]
forall a b. (a -> b) -> a -> b
$ PackageDescription
pd)
  AGFileOptions
configOptions <- [(String, String)] -> IO AGFileOptions
getAGFileOptions ([BuildInfo]
bis [BuildInfo]
-> (BuildInfo -> [(String, String)]) -> [(String, String)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BuildInfo -> [(String, String)]
customFieldsBI)
  -- Construct new options map
  [(String, (Options, Maybe (String, [String])))]
newOptionsL <- AGFileOptions
-> (AGFileOption
    -> IO (String, (Options, Maybe (String, [String]))))
-> IO [(String, (Options, Maybe (String, [String])))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM AGFileOptions
configOptions (\ AGFileOption
opt ->
      let ([String]
notFound, Options
opts) = [(String, Options)] -> AGFileOption -> ([String], Options)
getOptionsFromClass [(String, Options)]
classes (AGFileOption -> ([String], Options))
-> AGFileOption -> ([String], Options)
forall a b. (a -> b) -> a -> b
$ AGFileOption
opt
          file :: String
file = String -> String
normalise (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ AGFileOption -> String
filename AGFileOption
opt
          gen :: Maybe (String, [String])
gen = Maybe (String, [String])
-> ((Options, Maybe (String, [String]))
    -> Maybe (String, [String]))
-> Maybe (Options, Maybe (String, [String]))
-> Maybe (String, [String])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (String, [String])
forall a. Maybe a
Nothing (Options, Maybe (String, [String])) -> Maybe (String, [String])
forall a b. (a, b) -> b
snd (Maybe (Options, Maybe (String, [String]))
 -> Maybe (String, [String]))
-> Maybe (Options, Maybe (String, [String]))
-> Maybe (String, [String])
forall a b. (a -> b) -> a -> b
$ String
-> Map String (Options, Maybe (String, [String]))
-> Maybe (Options, Maybe (String, [String]))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
file Map String (Options, Maybe (String, [String]))
oldOptions
      in do Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"options for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (Options -> [String]
optionsToString Options
opts)
            [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
notFound (Handle -> String -> IO ()
hPutStrLn Handle
stderr)
            (String, (Options, Maybe (String, [String])))
-> IO (String, (Options, Maybe (String, [String])))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
file, (Options
opts, Maybe (String, [String])
gen)))
  let newOptions :: Map String (Options, Maybe (String, [String]))
newOptions = [(String, (Options, Maybe (String, [String])))]
-> Map String (Options, Maybe (String, [String]))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, (Options, Maybe (String, [String])))]
newOptionsL
  String -> Map String (Options, Maybe (String, [String])) -> IO ()
writeFileOptions String
classesPath Map String (Options, Maybe (String, [String]))
newOptions
  -- Check if files should be regenerated
  ((String, (Options, Maybe (String, [String]))) -> IO ())
-> [(String, (Options, Maybe (String, [String])))] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (([String] -> String -> IO (ExitCode, [String]))
-> Map String (Options, Maybe (String, [String]))
-> (String, (Options, Maybe (String, [String])))
-> IO ()
updateAGFile [String] -> String -> IO (ExitCode, [String])
uuagc Map String (Options, Maybe (String, [String]))
newOptions) ([(String, (Options, Maybe (String, [String])))] -> IO ())
-> [(String, (Options, Maybe (String, [String])))] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map String (Options, Maybe (String, [String]))
-> [(String, (Options, Maybe (String, [String])))]
forall k a. Map k a -> [(k, a)]
Map.toList Map String (Options, Maybe (String, [String]))
oldOptions

getAGFileList :: AGFileOptions -> [FilePath]
getAGFileList :: AGFileOptions -> [String]
getAGFileList = (AGFileOption -> String) -> AGFileOptions -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
normalise (String -> String)
-> (AGFileOption -> String) -> AGFileOption -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AGFileOption -> String
filename)

uuagc :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
uuagc :: BuildInfo
-> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
uuagc = ([String] -> String -> IO (ExitCode, [String]))
-> BuildInfo
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> PreProcessor
uuagc' (String -> [String] -> String -> IO (ExitCode, [String])
uuagcFromString String
uuagcn)

uuagc' :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))
        -> BuildInfo
        -> LocalBuildInfo
        -> ComponentLocalBuildInfo
        -> PreProcessor
uuagc' :: ([String] -> String -> IO (ExitCode, [String]))
-> BuildInfo
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> PreProcessor
uuagc' [String] -> String -> IO (ExitCode, [String])
uuagc BuildInfo
build LocalBuildInfo
lbi ComponentLocalBuildInfo
_ =
   PreProcessor {
#if MIN_VERSION_Cabal(3,8,1)
     --  The ppOrdering field was added in Cabal 3.8.1 (GHC 9.4)
     ppOrdering :: Verbosity -> [String] -> [ModuleName] -> IO [ModuleName]
ppOrdering = \Verbosity
_verbosity [String]
_files [ModuleName]
modules -> [ModuleName] -> IO [ModuleName]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ModuleName]
modules,
#endif
     platformIndependent :: Bool
platformIndependent = Bool
True,
     runPreProcessor :: (String, String) -> (String, String) -> Verbosity -> IO ()
runPreProcessor = (String -> String -> Verbosity -> IO ())
-> (String, String) -> (String, String) -> Verbosity -> IO ()
mkSimplePreProcessor ((String -> String -> Verbosity -> IO ())
 -> (String, String) -> (String, String) -> Verbosity -> IO ())
-> (String -> String -> Verbosity -> IO ())
-> (String, String)
-> (String, String)
-> Verbosity
-> IO ()
forall a b. (a -> b) -> a -> b
$ \ String
inFile String
outFile Verbosity
verbosity ->
                       do Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"[UUAGC] processing: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" generating: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
outFile
                          let classesPath :: String
classesPath = LocalBuildInfo -> String
buildDir LocalBuildInfo
lbi String -> String -> String
</> String
agClassesFile
                          Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"uuagc-preprocessor: Assuming AG classesPath: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
classesPath
                          Map String (Options, Maybe (String, [String]))
fileOpts <- String -> IO (Map String (Options, Maybe (String, [String])))
readFileOptions String
classesPath
                          Options
opts <- case String
-> Map String (Options, Maybe (String, [String]))
-> Maybe (Options, Maybe (String, [String]))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
inFile Map String (Options, Maybe (String, [String]))
fileOpts of
                                       Maybe (Options, Maybe (String, [String]))
Nothing        -> do Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"No options found for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inFile
                                                            Options -> IO Options
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Options
noOptions
                                       Just (Options
opt,Maybe (String, [String])
gen) -> Options -> IO Options
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Options
opt
                          let search :: String
search  = String -> String
dropFileName String
inFile
                              options :: Options
options = Options
opts { searchPath = search : hsSourceDirsFilePaths (hsSourceDirs build) ++ searchPath opts
                                             , outputFiles = outFile : (outputFiles opts) }
                          (ExitCode
eCode,[String]
_) <- [String] -> String -> IO (ExitCode, [String])
uuagc (Options -> [String]
optionsToString Options
options) String
inFile
                          case ExitCode
eCode of
                            ExitCode
ExitSuccess   -> String -> Map String (Options, Maybe (String, [String])) -> IO ()
writeFileOptions String
classesPath (String
-> (Options, Maybe (String, [String]))
-> Map String (Options, Maybe (String, [String]))
-> Map String (Options, Maybe (String, [String]))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
inFile (Options
opts, (String, [String]) -> Maybe (String, [String])
forall a. a -> Maybe a
Just (String
outFile, Options -> [String]
searchPath Options
options)) Map String (Options, Maybe (String, [String]))
fileOpts)
                            ex :: ExitCode
ex@(ExitFailure Int
_) -> ExitCode -> IO ()
forall e a. Exception e => e -> IO a
throwIO ExitCode
ex
                }

-- | In Cabal 3.6.0.0 (GHC 9.2) and up, 'BuildInfo' member 'hsSourceDirs' has type
-- '[SymbolicPath PackageDir SourceDir]', but in versions before that, it is [FilePath].
#if MIN_VERSION_Cabal(3,6,0)
hsSourceDirsFilePaths :: [SymbolicPath PackageDir SourceDir] -> [FilePath]
hsSourceDirsFilePaths :: [SymbolicPath PackageDir SourceDir] -> [String]
hsSourceDirsFilePaths = (SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath PackageDir SourceDir -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath
#else
hsSourceDirsFilePaths :: [FilePath] -> [FilePath]
hsSourceDirsFilePaths = id
#endif

nouuagc :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
nouuagc :: BuildInfo
-> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
nouuagc BuildInfo
build LocalBuildInfo
lbi ComponentLocalBuildInfo
_ =
  PreProcessor {
#if MIN_VERSION_Cabal(3,8,1)
     --  The ppOrdering field was added in Cabal 3.8.1 (GHC 9.4)
     ppOrdering :: Verbosity -> [String] -> [ModuleName] -> IO [ModuleName]
ppOrdering = \Verbosity
_verbosity [String]
_files [ModuleName]
modules -> [ModuleName] -> IO [ModuleName]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ModuleName]
modules,
#endif
    platformIndependent :: Bool
platformIndependent = Bool
True,
    runPreProcessor :: (String, String) -> (String, String) -> Verbosity -> IO ()
runPreProcessor = (String -> String -> Verbosity -> IO ())
-> (String, String) -> (String, String) -> Verbosity -> IO ()
mkSimplePreProcessor ((String -> String -> Verbosity -> IO ())
 -> (String, String) -> (String, String) -> Verbosity -> IO ())
-> (String -> String -> Verbosity -> IO ())
-> (String, String)
-> (String, String)
-> Verbosity
-> IO ()
forall a b. (a -> b) -> a -> b
$ \String
inFile String
outFile Verbosity
verbosity -> do
      Verbosity -> String -> IO ()
info Verbosity
verbosity (String
"skipping: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
outFile)
  }