{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Importify.Preprocessor
( parseModuleWithPreprocessor
) where
import Universum
import Language.Haskell.Exts (Extension, Module, ModulePragma (OptionsPragma),
ParseMode (extensions), SrcSpanInfo, Tool (GHC), defaultParseMode,
noLoc)
import Language.Haskell.Exts.CPP (CpphsOptions (includes), defaultCpphsOptions,
parseFileWithCommentsAndCPP)
import Path (Abs, File, Path, fromAbsFile, (-<.>))
import Path.IO (removeFile)
import Importify.ParseException (ModuleParseException (MPE), eitherParseResult)
import Importify.Syntax (modulePragmas)
import qualified Autoexporter (mainWithArgs)
parseModuleWithPreprocessor
:: [Extension]
-> [FilePath]
-> Path Abs File
-> IO $ Either ModuleParseException $ Module SrcSpanInfo
parseModuleWithPreprocessor extensions includeFiles pathToModule =
join (errorForcer <$> parseModuleAfterCPP extensions includeFiles pathToModule)
`catch`
(fmap Left . cppHandler) >>= \case
err@(Left _exception) -> return err
mdl@(Right parsedModule) -> case autoexportedArgs parsedModule of
Nothing -> return mdl
Just autoArgs -> do
let modulePath = fromAbsFile pathToModule
outputFilePath <- pathToModule -<.> ".auto"
let preprocessorArgs = [modulePath, modulePath, fromAbsFile outputFilePath]
Autoexporter.mainWithArgs (preprocessorArgs ++ autoArgs)
parseModuleAfterCPP extensions includeFiles outputFilePath
<* removeFile outputFilePath
where
errorForcer res = evaluateWHNF (show res :: String) >> return res
cppHandler :: SomeException -> IO ModuleParseException
cppHandler = return . MPE noLoc . show
parseModuleAfterCPP :: [Extension]
-> [FilePath]
-> Path Abs File
-> IO $ Either ModuleParseException $ Module SrcSpanInfo
parseModuleAfterCPP cabalExtensions includeFiles pathToModule =
second fst . eitherParseResult
<$> parseFileWithCommentsAndCPP (defaultCpphsOptions {includes = includeFiles})
(defaultParseMode {extensions = cabalExtensions})
(fromAbsFile pathToModule)
autoexportedArgs :: forall l. Module l -> Maybe [String]
autoexportedArgs = safeHead . mapMaybe autoexporterPragma . modulePragmas
where
autoexporterPragma :: ModulePragma l -> Maybe [String]
autoexporterPragma pragma = do
OptionsPragma _ tool args <- Just pragma
GHC <- tool
"-F":"-pgmF":"autoexporter":autoArgs <- Just $ words $ toText args
pure $ map toString autoArgs