@@ -0,0 +1,92 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+module Obelisk.Command.Preprocessor where
5+
6+import qualified Data.ByteString as BS
7+import qualified Data.ByteString.Lazy as BL
8+import qualified Data.ByteString.Lazy.Builder as BU
9+import Data.List
10+import Data.Maybe
11+import qualified Data.Text.Lazy as TL
12+import qualified Data.Text.Lazy.Builder as TL
13+import qualified Data.Text.Lazy.Encoding as TL
14+import Distribution.Compiler
15+import Language.Haskell.Extension
16+import System.Environment
17+import System.IO
18+import System.FilePath
19+
20+import Obelisk.App
21+import Obelisk.Command (mkObeliskConfig)
22+import Obelisk.Command.Run
23+
24+main :: IO ()
25+main = do
26+ -- The command line argumens are passed in via ghci.
27+ -- ghci dictates the first three options and meanings
28+ -- TODO: perform some validation and print a nice error/help message, if we don't see something plausible.
29+ -- We do have control over the remaining arguments, but they must be the same for all files.
30+ -- We assume all the remaining arguments passed in are paths to cabal or hpack package specifications.
31+
32+ args@(origPath:inPath:outPath:packagePaths) <- getArgs
33+
34+ outFile <- openFile outPath WriteMode
35+ let hPutTextBuilder h = BU.hPutBuilder h . TL.encodeUtf8Builder . TL.toLazyText
36+
37+ putStr "--------------------------------------------------------------------------------\n"
38+ print args
39+ putStr "--------------------------------------------------------------------------------\n"
40+
41+ -- Thus we must select among the packagePaths for the file we are going to parse.
42+
43+ let takeDirs = takeWhile hasTrailingPathSeparator
44+ packageDirs = sortOn (negate . length . takeDirs) $ map (splitPath . normalise) packagePaths
45+ origDir = splitPath $ normalise $ origPath
46+ matches = [ joinPath d | d <- packageDirs, takeDirs d `isPrefixOf` origDir ]
47+
48+ -- So the first element of matches is going to be the deepest path to a package spec that contains
49+ -- our file as a subdirectory.
50+
51+ config <- mkObeliskConfig
52+
53+ case matches of
54+ [] -> hPutTextBuilder outFile (lineNumberPragma origPath) -- TODO: probably should produce a warning
55+ (packagePath:_) -> do
56+ runObelisk config (parseCabalPackage packagePath) >>= \case
57+ Just packageInfo -> do
58+ hPutTextBuilder outFile (generateHeader origPath packageInfo)
59+
60+ BL.readFile inPath >>= BL.hPut outFile
61+ hClose outFile
62+
63+
64+ -- I'm pretty sure there's a certain amount of oversimplification in CabalPackageInfo, so I doubt this is fully robust.
65+
66+generateHeader :: FilePath -> CabalPackageInfo -> TL.Builder
67+generateHeader origPath packageInfo =
68+ hsExtensions <> ghcOptions <> lineNumberPragma origPath
69+ where
70+ hsExtensions =
71+ if not (null extList)
72+ then TL.fromText "{-# LANGUAGE "
73+ <> mconcat (intersperse (TL.fromText ", ") extList)
74+ <> TL.fromText " #-}\n"
75+ else mempty
76+ extList = concatMap showExt (_cabalPackageInfo_defaultExtensions packageInfo)
77+ showExt = \case
78+ EnableExtension ext -> [TL.fromString (show ext)]
79+ DisableExtension _ -> []
80+ UnknownExtension ext -> [TL.fromString ext]
81+
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 $ fromMaybe [] $ lookup GHC (_cabalPackageInfo_compilerOptions packageInfo)
89+
90+lineNumberPragma :: FilePath -> TL.Builder
91+lineNumberPragma origPath =
92+ TL.fromText "{-# LINE 1 \"" <> TL.fromString origPath <> TL.fromText "\" #-}\n"