@@ -17,40 +17,39 @@ import System.FilePath (hasTrailingPathSeparator, joinPath, splitPath)
1717
1818import Obelisk.Command.Run (CabalPackageInfo (..), parseCabalPackage')
1919
20+-- | This code is intended to be executed via ghci's -pgmF preprocessor option.
21+-- The command line arguments are passed in via ghc, which dictates the first three options and meanings
22+-- In order for this code to execute, origPath must contain either a '.' character or a '/' character.
23+-- (This is to avoid the possibility of the command line syntax conflicting with another ob command)
24+-- We do have control over the remaining arguments, but they must be the same for all files.
25+-- Thus, the fourth command line argument must be "apply-packages", which has already been handled.
26+-- We assume all the remaining arguments passed in are paths to cabal or hpack package specifications.
27+-- Thus we must select among the packagePaths for the file we are going to parse.
2028applyPackages :: FilePath -> FilePath -> FilePath -> [FilePath] -> IO ()
21−applyPackages origPath inPath outPath packagePaths' = withFile outPath WriteMode $ \outFile -> do
22− -- This code is intended to be executed via ghci's -pgmF preprocessor option
23− -- The command line arguments are passed in via ghc, which dictates the first three options and meanings
24− -- In order for this code to execute, origPath must contain either a '.' character or a '/' character.
25− -- (This is to avoid the possibility of the command line syntax conflicting with another ob command)
26− -- We do have control over the remaining arguments, but they must be the same for all files.
27− -- Thus, the fourth command line argument must be "apply-packages", which has already been handled.
28− -- We assume all the remaining arguments passed in are paths to cabal or hpack package specifications.
29− -- Thus we must select among the packagePaths for the file we are going to parse.
30−
29+applyPackages origPath inPath outPath packagePaths' = do
3130 origPathCanonical <- canonicalizePath origPath
3231 packagePaths <- traverse canonicalizePath packagePaths'
3332
34− let takeDirs = takeWhile hasTrailingPathSeparator
35− packageDirs = sortOn (negate . length . takeDirs) $ map splitPath packagePaths
36− origDir = splitPath origPathCanonical
37− matches = [ joinPath d | d <- packageDirs, takeDirs d `isPrefixOf` origDir ]
33+ let
34+ takeDirs = takeWhile hasTrailingPathSeparator
35+ packageDirs = sortOn (negate . length . takeDirs) $ map splitPath packagePaths
36+ origDir = splitPath origPathCanonical
37+ matches = [ joinPath d | d <- packageDirs, takeDirs d `isPrefixOf` origDir ]
3838
39− -- So the first element of matches is going to be the deepest path to a package spec that contains
39+ -- The first element of matches is going to be the deepest path to a package spec that contains
4040 -- our file as a subdirectory.
41−
4241 case matches of
43− [] ->
44− hPutStrLn stderr $ "Error: Unable to find cabal information for " <> origPath <> "; Skipping preprocessor."
45− packagePath:_ -> do
46− parseCabalPackage' packagePath >>= \case
47− Left err ->
48− hPutStrLn stderr $ "Error: Unable to parse cabal package " <> packagePath <> "; Skipping preprocessor on " <> origPath <> ". Error: " <> show err
49− Right (_warnings, packageInfo) ->
50− hPutTextBuilder outFile (generateHeader origPath packageInfo)
51−
52− BL.readFile inPath >>= BL.hPut outFile
42+ [] -> hPutStrLn stderr $ "Error: Unable to find cabal information for " <> origPath <> "; Skipping preprocessor."
43+ packagePath:_ -> parseCabalPackage' packagePath >>= \case
44+ Left err ->
45+ hPutStrLn stderr $ "Error: Unable to parse cabal package " <> packagePath <> "; Skipping preprocessor on " <> origPath <> ". Error: " <> show err
46+ Right (_warnings, packageInfo) -> do
47+ writeOutput packageInfo inPath outPath
5348
49+writeOutput :: CabalPackageInfo -> FilePath -> FilePath -> IO ()
50+writeOutput packageInfo origPath outPath = withFile outPath WriteMode $ \hOut -> do
51+ hPutTextBuilder hOut (generateHeader origPath packageInfo)
52+ BL.readFile origPath >>= BL.hPut hOut
5453 where
5554 hPutTextBuilder h = BU.hPutBuilder h . TL.encodeUtf8Builder . TL.toLazyText
5655
@@ -86,8 +85,7 @@ generateHeader origPath packageInfo =
8685 optList = _cabalPackageInfo_cppOptions packageInfo <> ghcOptList
8786
8887lineNumberPragma :: FilePath -> TL.Builder
89−lineNumberPragma origPath =
90− pragma $ TL.fromText "LINE 1 " <> quoted '"' (TL.fromString origPath)
88+lineNumberPragma origPath = pragma $ TL.fromText "LINE 1 " <> quoted '"' (TL.fromString origPath)
9189
9290pragma :: TL.Builder -> TL.Builder
9391pragma x = TL.fromText "{-# " <> x <> TL.fromText " #-}\n"