@@ -5,7 +5,6 @@ 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_)
98import Data.List (intersperse, isPrefixOf, sortOn)
109import Data.Maybe (fromMaybe)
1110import qualified Data.Text.Lazy.Builder as TL
@@ -18,83 +17,79 @@ import System.FilePath (hasTrailingPathSeparator, joinPath, splitPath)
1817
1918import Obelisk.Command.Run (CabalPackageInfo (..), parseCabalPackage')
2019
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.
2920applyPackages :: FilePath -> FilePath -> FilePath -> [FilePath] -> IO ()
30−applyPackages origPath inPath outPath packagePaths' = do
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+
3131 origPathCanonical <- canonicalizePath origPath
3232 packagePaths <- traverse canonicalizePath packagePaths'
3333
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 ]
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 ]
3938
40− -- The first element of matches is going to be the deepest path to a package spec that contains
39+ -- So the first element of matches is going to be the deepest path to a package spec that contains
4140 -- our file as a subdirectory.
42− packageInfo' <- case matches of
43− [] -> do
41+
42+ case matches of
43+ [] ->
4444 hPutStrLn stderr $ "Error: Unable to find cabal information for " <> origPath <> "; Skipping preprocessor."
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
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)
5251
53− writeOutput packageInfo' inPath outPath
52+ BL.readFile inPath >>= BL.hPut outFile
5453
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
5954 where
6055 hPutTextBuilder h = BU.hPutBuilder h . TL.encodeUtf8Builder . TL.toLazyText
6156
57+
58+ -- I'm pretty sure there's a certain amount of oversimplification in CabalPackageInfo, so I doubt this is fully robust.
59+
6260generateHeader :: FilePath -> CabalPackageInfo -> TL.Builder
6361generateHeader origPath packageInfo =
6462 hsExtensions <> ghcOptions <> lineNumberPragma origPath
6563 where
6664 hsExtensions =
67− if null extList
68− then mempty
69− else pragma $ TL.fromText "LANGUAGE " <> mconcat (intersperse (TL.fromText ", ") extList)
65+ if not (null extList)
66+ then TL.fromText "{-# LANGUAGE "
67+ <> mconcat (intersperse (TL.fromText ", ") extList)
68+ <> TL.fromText " #-}\n"
69+ else mempty
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 ext -> ["No" <> TL.fromString (show ext)]
79+ DisableExtension _ -> []
8080 UnknownExtension ext -> [TL.fromString ext]
8181
8282 ghcOptions =
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
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)
9292
9393lineNumberPragma :: FilePath -> TL.Builder
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
94+lineNumberPragma origPath =
95+ TL.fromText "{-# LINE 1 \"" <> TL.fromString origPath <> TL.fromText "\" #-}\n"