From 1c78b092925cfb7eb988b2378de998d584e7e44c Mon Sep 17 00:00:00 2001
From: Andrew Gibiansky <andrew.gibiansky@gmail.com>
Date: Thu, 10 Sep 2015 23:06:50 -0700
Subject: [PATCH] Starting support for -F -pgmF

---
 src/IHaskell/Eval/Evaluate.hs | 36 +++++++++++++++++++++++++++++++++++
 src/IHaskell/Eval/Parser.hs   |  6 ++++--
 2 files changed, 40 insertions(+), 2 deletions(-)

diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs
index e18804c5..393fbeab 100644
--- a/src/IHaskell/Eval/Evaluate.hs
+++ b/src/IHaskell/Eval/Evaluate.hs
@@ -960,6 +960,42 @@ evalCommand output (Pragma PragmaLanguage pragmas) state = do
   write state $ "Got LANGUAGE pragma " ++ show pragmas
   evalCommand output (Directive SetExtension $ unwords pragmas) state
 
+evalCommand output (Pragma PragmaOptionsGhc pragmas) state = do
+  write state $ "Got OPTIONS_GHC pragma " ++ show pragmas
+  let hasPreprocessor = "-F" `elem` pragmas
+  when hasPreprocessor $ do
+    let -- Divide a list into pairs, if its evenly divisible.
+        pairs :: [a] -> Maybe [(a, a)]
+        pairs [] = Just []
+        pairs [_] = Nothing
+        pairs (x1:x2:xs) = (:) <$> Just (x1, x2) <*> pairs xs
+
+        wrong = return . displayError . ("Error in GHC options: " ++ )
+
+        -- Process a list of arguments, returning the pgmF command and any options to it.
+        process :: [(String, String)] -> Either String (String, [String])
+        process (("-pgmF", cmd):rest) = do
+          (_, opts) <- process rest
+          Right (cmd, opts)
+        process (("-optF", opt):rest) = do
+          (cmd, opts) <- process rest
+          Right (cmd, opt:opts)
+        process [] = Right ("", [])
+        process ((arg, _):_) = Left  $ "Unknown argument " ++ arg
+
+        otherOpts = pairs $ tail pragmas
+    case otherOpts of
+      Nothing -> wrong "Not an even number of arguments after -F. Only -F -pgmF supported."
+      Just ps -> 
+        case process ps of
+          Left err -> wrong err
+          Right ("", args) -> wrong "No -pgmF specified"
+          Right (cmd, args) ->
+            setCellPreprocessor cmd args
+
+  
+  evalCommand output (Directive SetExtension $ unwords pragmas) state
+
 hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut
 hoogleResults state results =
   EvalOut
diff --git a/src/IHaskell/Eval/Parser.hs b/src/IHaskell/Eval/Parser.hs
index dd593d4d..aecc20aa 100644
--- a/src/IHaskell/Eval/Parser.hs
+++ b/src/IHaskell/Eval/Parser.hs
@@ -65,9 +65,10 @@ data DirectiveType = GetType      -- ^ Get the type of an expression via ':type'
                    | LoadModule   -- ^ Load and unload modules via ':module'.
   deriving (Show, Eq)
 
--- | Pragma types. Only LANGUAGE pragmas are currently supported. Other pragma types are kept around
--- as a string for error reporting.
+-- | Pragma types. Only LANGUAGE and OPTIONS_GHC pragmas are currently supported. Other pragma types
+-- are kept around as a string for error reporting.
 data PragmaType = PragmaLanguage
+                | PragmaOptionsGhc
                 | PragmaUnsupported String
   deriving (Show, Eq)
 
@@ -243,6 +244,7 @@ parsePragma ('{':'-':'#':pragma) line =
     --empty string pragmas are unsupported
     [] -> Pragma (PragmaUnsupported "") []
     "LANGUAGE":xs -> Pragma PragmaLanguage xs
+    "OPTIONS_GHC":xs -> Pragma PragmaOptionsGhc xs
     x:xs -> Pragma (PragmaUnsupported x) xs
 
 -- | Parse a directive of the form :directiveName.