git.iko.soy/obelisk
on develop help sign in
obelisk/lib/command/src/Obelisk/Command/Preprocessor.hs
101 lines 5.0 kB history raw
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
4module Obelisk.Command.Preprocessor where
6import qualified Data.ByteString.Lazy as BL
7import qualified Data.ByteString.Lazy.Builder as BU
8import Data.Foldable (for_)
9import Data.List (intersperse, isPrefixOf, sortOn)
10import Data.Maybe (fromMaybe)
11import qualified Data.Text.Lazy.Builder as TL
12import qualified Data.Text.Lazy.Encoding as TL
13import Distribution.Compiler (CompilerFlavor (..))
14import Language.Haskell.Extension (Extension (..), Language(..))
15import System.Directory (canonicalizePath)
16import System.IO (IOMode (..), hPutStrLn, stderr, withFile)
17import System.FilePath (hasTrailingPathSeparator, joinPath, splitPath)
19import Obelisk.Command.Run (CabalPackageInfo (..), parseCabalPackage')
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.
29applyPackages :: FilePath -> FilePath -> FilePath -> [FilePath] -> IO ()
30applyPackages origPath inPath outPath packagePaths' = do
31 origPathCanonical <- canonicalizePath origPath
32 packagePaths <- traverse canonicalizePath packagePaths'
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 ]
40 -- The first element of matches is going to be the deepest path to a package spec that contains
41 -- our file as a subdirectory.
42 packageInfo' <- case matches of
43 [] -> do
44 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
53 writeOutput packageInfo' inPath outPath
55writeOutput :: Maybe CabalPackageInfo -> FilePath -> FilePath -> IO ()
56writeOutput packageInfo' origPath outPath = withFile outPath WriteMode $ \hOut -> do
57 for_ packageInfo' $ \packageInfo -> hPutTextBuilder hOut (generateHeader origPath packageInfo)
58 BL.readFile origPath >>= BL.hPut hOut
59 where
60 hPutTextBuilder h = BU.hPutBuilder h . TL.encodeUtf8Builder . TL.toLazyText
62--NOTE: We cannot restrict the package set by adding '-package' flags to OPTIONS_GHC, because GHC rejects them there. It seems that we won't be able to properly handle that situation until GHC itself supports loading multiple packages officially in GHCi
63generateHeader :: FilePath -> CabalPackageInfo -> TL.Builder
64generateHeader origPath packageInfo =
65 hsExtensions <> ghcOptions <> lineNumberPragma origPath
66 where
67 hsExtensions =
68 if null extList
69 then mempty
70 else pragma $ TL.fromText "LANGUAGE " <> mconcat (intersperse (TL.fromText ", ") extList)
71 extList = addDefaultLanguage $ concatMap showExt $ _cabalPackageInfo_defaultExtensions packageInfo
72 addDefaultLanguage =
73 case _cabalPackageInfo_defaultLanguage packageInfo of
74 Nothing -> id
75 Just x -> case x of
76 UnknownLanguage ext -> (TL.fromString ext :)
77 ext -> (TL.fromString (show ext) :)
78 showExt = \case
79 EnableExtension ext -> [TL.fromString (show ext)]
80 DisableExtension ext -> ["No" <> TL.fromString (show ext)]
81 UnknownExtension ext -> [TL.fromString ext]
83 ghcOptions =
84 if null optList
85 then mempty
86 else pragma $
87 TL.fromText "OPTIONS_GHC " <> mconcat (intersperse (TL.fromText " ") (map TL.fromString optList))
88 ghcOptList
89 = filter (not . isPrefixOf "-O")
90 $ fromMaybe []
91 $ lookup GHC (_cabalPackageInfo_compilerOptions packageInfo)
92 optList = _cabalPackageInfo_cppOptions packageInfo <> ghcOptList
94lineNumberPragma :: FilePath -> TL.Builder
95lineNumberPragma origPath = pragma $ TL.fromText "LINE 1 " <> quoted '"' (TL.fromString origPath)
97pragma :: TL.Builder -> TL.Builder
98pragma x = TL.fromText "{-# " <> x <> TL.fromText " #-}\n"
100quoted :: Char -> TL.Builder -> TL.Builder
101quoted char x = TL.singleton char <> x <> TL.singleton char