git.iko.soy/obelisk
on ae@ssh-options help sign in
obelisk/lib/command/src/Obelisk/Command/Preprocessor.hs
95 lines 4.4 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.List (intersperse, isPrefixOf, sortOn)
9import Data.Maybe (fromMaybe)
10import qualified Data.Text.Lazy.Builder as TL
11import qualified Data.Text.Lazy.Encoding as TL
12import Distribution.Compiler (CompilerFlavor (..))
13import Language.Haskell.Extension (Extension (..), Language(..))
14import System.Directory (canonicalizePath)
15import System.IO (IOMode (..), hPutStrLn, stderr, withFile)
16import System.FilePath (hasTrailingPathSeparator, joinPath, splitPath)
18import Obelisk.Command.Run (CabalPackageInfo (..), parseCabalPackage')
20applyPackages :: FilePath -> FilePath -> FilePath -> [FilePath] -> IO ()
21applyPackages 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.
31 origPathCanonical <- canonicalizePath origPath
32 packagePaths <- traverse canonicalizePath packagePaths'
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 ]
39 -- So the first element of matches is going to be the deepest path to a package spec that contains
40 -- our file as a subdirectory.
42 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)
52 BL.readFile inPath >>= BL.hPut outFile
54 where
55 hPutTextBuilder h = BU.hPutBuilder h . TL.encodeUtf8Builder . TL.toLazyText
58 -- I'm pretty sure there's a certain amount of oversimplification in CabalPackageInfo, so I doubt this is fully robust.
60generateHeader :: FilePath -> CabalPackageInfo -> TL.Builder
61generateHeader origPath packageInfo =
62 hsExtensions <> ghcOptions <> lineNumberPragma origPath
63 where
64 hsExtensions =
65 if not (null extList)
66 then TL.fromText "{-# LANGUAGE "
67 <> mconcat (intersperse (TL.fromText ", ") extList)
68 <> TL.fromText " #-}\n"
69 else mempty
70 extList = addDefaultLanguage $ concatMap showExt $ _cabalPackageInfo_defaultExtensions packageInfo
71 addDefaultLanguage =
72 case _cabalPackageInfo_defaultLanguage packageInfo of
73 Nothing -> id
74 Just x -> case x of
75 UnknownLanguage ext -> ( TL.fromString ext :)
76 ext -> ( TL.fromString (show ext) :)
77 showExt = \case
78 EnableExtension ext -> [TL.fromString (show ext)]
79 DisableExtension _ -> []
80 UnknownExtension ext -> [TL.fromString ext]
82 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)
93lineNumberPragma :: FilePath -> TL.Builder
94lineNumberPragma origPath =
95 TL.fromText "{-# LINE 1 \"" <> TL.fromString origPath <> TL.fromText "\" #-}\n"