@@ -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,83 @@ 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 (Just (_, packageInfo)) -> pure $ Just packageInfo
51+ Right Nothing -> pure Nothing
5152
52− BL.readFile inPath >>= BL.hPut outFile
53+ writeOutput packageInfo' inPath outPath
5354
55+writeOutput :: Maybe CabalPackageInfo -> FilePath -> FilePath -> IO ()
56+writeOutput packageInfo' origPath outPath = withFile outPath WriteMode $ \hOut -> do
57+ for_ packageInfo' $ \packageInfo -> hPutTextBuilder hOut (generateHeader origPath packageInfo)
58+ BL.readFile origPath >>= BL.hPut hOut
5459 where
5560 hPutTextBuilder h = BU.hPutBuilder h . TL.encodeUtf8Builder . TL.toLazyText
5661
57−
58− -- I'm pretty sure there's a certain amount of oversimplification in CabalPackageInfo, so I doubt this is fully robust.
59−
6062generateHeader :: FilePath -> CabalPackageInfo -> TL.Builder
6163generateHeader origPath packageInfo =
6264 hsExtensions <> ghcOptions <> lineNumberPragma origPath
6365 where
6466 hsExtensions =
65− if not (null extList)
66− then TL.fromText "{-# LANGUAGE "
67− <> mconcat (intersperse (TL.fromText ", ") extList)
68− <> TL.fromText " #-}\n"
69− else mempty
67+ if null extList
68+ then mempty
69+ else pragma $ TL.fromText "LANGUAGE " <> mconcat (intersperse (TL.fromText ", ") extList)
7070 extList = addDefaultLanguage $ concatMap showExt $ _cabalPackageInfo_defaultExtensions packageInfo
7171 addDefaultLanguage =
7272 case _cabalPackageInfo_defaultLanguage packageInfo of
7373 Nothing -> id
7474 Just x -> case x of
75− UnknownLanguage ext -> ( TL.fromString ext :)
76− ext -> ( TL.fromString (show ext) :)
75+ UnknownLanguage ext -> (TL.fromString ext :)
76+ ext -> (TL.fromString (show ext) :)
7777 showExt = \case
7878 EnableExtension ext -> [TL.fromString (show ext)]
79− DisableExtension _ -> []
79+ DisableExtension ext -> ["No" <> TL.fromString (show ext)]
8080 UnknownExtension ext -> [TL.fromString ext]
8181
8282 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)
83+ if null optList
84+ then mempty
85+ else pragma $
86+ TL.fromText "OPTIONS_GHC " <> mconcat (intersperse (TL.fromText " ") (map TL.fromString optList))
87+ ghcOptList
88+ = filter (not . isPrefixOf "-O")
89+ $ fromMaybe []
90+ $ lookup GHC (_cabalPackageInfo_compilerOptions packageInfo)
91+ optList = _cabalPackageInfo_cppOptions packageInfo <> ghcOptList
9292
9393lineNumberPragma :: FilePath -> TL.Builder
94−lineNumberPragma origPath =
95− TL.fromText "{-# LINE 1 \"" <> TL.fromString origPath <> TL.fromText "\" #-}\n"
94+lineNumberPragma origPath = pragma $ TL.fromText "LINE 1 " <> quoted '"' (TL.fromString origPath)
95+
96+pragma :: TL.Builder -> TL.Builder
97+pragma x = TL.fromText "{-# " <> x <> TL.fromText " #-}\n"
98+
99+quoted :: Char -> TL.Builder -> TL.Builder
100+quoted char x = TL.singleton char <> x <> TL.singleton char