@@ -5,6 +5,7 @@ module Obelisk.Command.Preprocessor where
55
66import qualified Data.ByteString.Lazy as BL
77import qualified Data.ByteString.Lazy.Builder as BU
8+import Data.Foldable (for_)
89import Data.List (intersperse, isPrefixOf, sortOn)
910import Data.Maybe (fromMaybe)
1011import qualified Data.Text.Lazy.Builder as TL
@@ -17,79 +18,82 @@ import System.FilePath (hasTrailingPathSeparator, joinPath, splitPath)
1718
1819import Obelisk.Command.Run (CabalPackageInfo (..), parseCabalPackage')
1920
21+-- | This code is intended to be executed via ghci's -pgmF preprocessor option.
22+-- The command line arguments are passed in via ghc, which dictates the first three options and meanings
23+-- In order for this code to execute, origPath must contain either a '.' character or a '/' character.
24+-- (This is to avoid the possibility of the command line syntax conflicting with another ob command)
25+-- We do have control over the remaining arguments, but they must be the same for all files.
26+-- Thus, the fourth command line argument must be "apply-packages", which has already been handled.
27+-- We assume all the remaining arguments passed in are paths to cabal or hpack package specifications.
28+-- Thus we must select among the packagePaths for the file we are going to parse.
2029applyPackages :: 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−
30+applyPackages origPath inPath outPath packagePaths' = do
3131 origPathCanonical <- canonicalizePath origPath
3232 packagePaths <- traverse canonicalizePath packagePaths'
3333
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 ]
34+ let
35+ takeDirs = takeWhile hasTrailingPathSeparator
36+ packageDirs = sortOn (negate . length . takeDirs) $ map splitPath packagePaths
37+ origDir = splitPath origPathCanonical
38+ matches = [ joinPath d | d <- packageDirs, takeDirs d `isPrefixOf` origDir ]
3839
39− -- So the first element of matches is going to be the deepest path to a package spec that contains
40+ -- The first element of matches is going to be the deepest path to a package spec that contains
4041 -- our file as a subdirectory.
41−
42− case matches of
43− [] ->
42+ packageInfo' <- case matches of
43+ [] -> do
4444 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)
45+ pure Nothing
46+ packagePath:_ -> parseCabalPackage' packagePath >>= \case
47+ Left err -> do
48+ hPutStrLn stderr $ "Error: Unable to parse cabal package " <> packagePath <> "; Skipping preprocessor on " <> origPath <> ". Error: " <> show err
49+ pure Nothing
50+ Right (_, packageInfo) -> pure $ Just packageInfo
5151
52− BL.readFile inPath >>= BL.hPut outFile
52+ writeOutput packageInfo' inPath outPath
5353
54+writeOutput :: Maybe CabalPackageInfo -> FilePath -> FilePath -> IO ()
55+writeOutput packageInfo' origPath outPath = withFile outPath WriteMode $ \hOut -> do
56+ for_ packageInfo' $ \packageInfo -> hPutTextBuilder hOut (generateHeader origPath packageInfo)
57+ BL.readFile origPath >>= BL.hPut hOut
5458 where
5559 hPutTextBuilder h = BU.hPutBuilder h . TL.encodeUtf8Builder . TL.toLazyText
5660
57−
58− -- I'm pretty sure there's a certain amount of oversimplification in CabalPackageInfo, so I doubt this is fully robust.
59−
6061generateHeader :: FilePath -> CabalPackageInfo -> TL.Builder
6162generateHeader origPath packageInfo =
6263 hsExtensions <> ghcOptions <> lineNumberPragma origPath
6364 where
6465 hsExtensions =
65− if not (null extList)
66− then TL.fromText "{-# LANGUAGE "
67− <> mconcat (intersperse (TL.fromText ", ") extList)
68− <> TL.fromText " #-}\n"
69− else mempty
66+ if null extList
67+ then mempty
68+ else pragma $ TL.fromText "LANGUAGE " <> mconcat (intersperse (TL.fromText ", ") extList)
7069 extList = addDefaultLanguage $ concatMap showExt $ _cabalPackageInfo_defaultExtensions packageInfo
7170 addDefaultLanguage =
7271 case _cabalPackageInfo_defaultLanguage packageInfo of
7372 Nothing -> id
7473 Just x -> case x of
75− UnknownLanguage ext -> ( TL.fromString ext :)
76− ext -> ( TL.fromString (show ext) :)
74+ UnknownLanguage ext -> (TL.fromString ext :)
75+ ext -> (TL.fromString (show ext) :)
7776 showExt = \case
7877 EnableExtension ext -> [TL.fromString (show ext)]
7978 DisableExtension _ -> []
8079 UnknownExtension ext -> [TL.fromString ext]
8180
8281 ghcOptions =
83− if not (null optList)
84− then TL.fromText "{-# OPTIONS_GHC "
85− <> mconcat (intersperse (TL.fromText " ") optList)
86− <> TL.fromText " #-}\n"
87− else mempty
88− optList = map TL.fromString
89− $ filter (not . isPrefixOf "-O")
90− $ fromMaybe []
91− $ lookup GHC (_cabalPackageInfo_compilerOptions packageInfo)
82+ if null optList
83+ then mempty
84+ else pragma $
85+ TL.fromText "OPTIONS_GHC " <> mconcat (intersperse (TL.fromText " ") (map TL.fromString optList))
86+ ghcOptList
87+ = filter (not . isPrefixOf "-O")
88+ $ fromMaybe []
89+ $ lookup GHC (_cabalPackageInfo_compilerOptions packageInfo)
90+ optList = _cabalPackageInfo_cppOptions packageInfo <> ghcOptList
9291
9392lineNumberPragma :: FilePath -> TL.Builder
94−lineNumberPragma origPath =
95− TL.fromText "{-# LINE 1 \"" <> TL.fromString origPath <> TL.fromText "\" #-}\n"
93+lineNumberPragma origPath = pragma $ TL.fromText "LINE 1 " <> quoted '"' (TL.fromString origPath)
94+
95+pragma :: TL.Builder -> TL.Builder
96+pragma x = TL.fromText "{-# " <> x <> TL.fromText " #-}\n"
97+
98+quoted :: Char -> TL.Builder -> TL.Builder
99+quoted char x = TL.singleton char <> x <> TL.singleton char