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