From 0f3ee76944d041c5c36bff828f5e1553d4e198cd Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Wed, 27 Dec 2017 23:26:18 +0100
Subject: [PATCH] Fix shebang handling with stdin input

Fixes #92
probably should update upstream (ghc-exactprint)
---
 brittany.cabal                                |  2 +-
 .../Brittany/Internal/ExactPrintUtils.hs      | 51 +++++++++++++++++--
 .../Haskell/Brittany/Internal/PreludeUtils.hs |  3 ++
 3 files changed, 51 insertions(+), 5 deletions(-)

diff --git a/brittany.cabal b/brittany.cabal
index bfba1dc..42277ad 100644
--- a/brittany.cabal
+++ b/brittany.cabal
@@ -82,7 +82,7 @@ library {
     { base >=4.9 && <4.11
     , ghc >=8.0.1 && <8.3
     , ghc-paths >=0.1.0.9 && <0.2
-    , ghc-exactprint >=0.5.3.0 && <0.6
+    , ghc-exactprint >=0.5.3.0 && <0.5.6
     , transformers >=0.5.2.0 && <0.6
     , containers >=0.5.7.1 && <0.6
     , mtl >=2.2.1 && <2.3
diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
index d0f481c..7494d9e 100644
--- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
+++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
@@ -24,11 +24,17 @@ import qualified DynFlags      as GHC
 import qualified GHC           as GHC hiding (parseModule)
 import qualified Parser        as GHC
 import qualified SrcLoc        as GHC
+import qualified FastString    as GHC
+import qualified GHC           as GHC hiding (parseModule)
+import qualified Lexer         as GHC
+import qualified StringBuffer  as GHC
+import qualified Outputable    as GHC
 import           RdrName ( RdrName(..) )
 import           HsSyn
 import           SrcLoc ( SrcSpan, Located )
 import           RdrName ( RdrName(..) )
 
+
 import qualified Language.Haskell.GHC.ExactPrint            as ExactPrint
 import qualified Language.Haskell.GHC.ExactPrint.Annotate   as ExactPrint
 import qualified Language.Haskell.GHC.ExactPrint.Types      as ExactPrint
@@ -106,10 +112,47 @@ parseModuleFromString args fp dynCheck str =
       $  ExceptT.throwE
       $  "when parsing ghc flags: encountered warnings: "
       ++ show (warnings <&> \(L _ s) -> s)
-    x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
-    either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err)
-           (\(a, m) -> pure (a, m, x))
-      $ ExactPrint.parseWith dflags1 fp GHC.parseModule str
+    dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
+    let res = parseModulePure dflags1 fp str
+    case res of
+      Left  (span, err) -> ExceptT.throwE $ show span ++ ": " ++ err
+      Right (a   , m  ) -> pure (a, m, dynCheckRes)
+
+-----------
+
+-- this function should move to ghc-exactprint. btw, we can deprecate/remove
+-- the `parseModuleFromString` function that I added initially to
+-- ghc-exactprint.
+parseModulePure
+  :: GHC.DynFlags
+  -> System.IO.FilePath
+  -> String
+  -> Either (SrcSpan, String) (ExactPrint.Anns, GHC.ParsedSource)
+parseModulePure dflags fileName str =
+  let (str1, lp) = ExactPrint.stripLinePragmas str
+      res        = case runParser GHC.parseModule dflags fileName str1 of
+        GHC.PFailed ss m    -> Left (ss, GHC.showSDoc dflags m)
+        GHC.POk     x  pmod -> Right $ (mkApiAnns x, lp, dflags, pmod)
+  in  ExactPrint.postParseTransform res ExactPrint.normalLayout
+
+-- copied from exactprint until exactprint exposes a proper interface.
+runParser
+  :: GHC.P a
+  -> GHC.DynFlags
+  -> System.IO.FilePath
+  -> String
+  -> GHC.ParseResult a
+runParser parser flags filename str = GHC.unP parser parseState
+ where
+  location   = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1
+  buffer     = GHC.stringToStringBuffer str
+  parseState = GHC.mkPState flags buffer location
+mkApiAnns :: GHC.PState -> GHC.ApiAnns
+mkApiAnns pstate =
+  ( Map.fromListWith (++) . GHC.annotations $ pstate
+  , Map.fromList
+    ((GHC.noSrcSpan, GHC.comment_q pstate) : GHC.annotations_comments pstate)
+  )
 
 -----------
 
diff --git a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs
index d34690c..88f2894 100644
--- a/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs
+++ b/src/Language/Haskell/Brittany/Internal/PreludeUtils.hs
@@ -46,6 +46,9 @@ traceFunctionWith name s1 s2 f x =
 putStrErrLn :: String -> IO ()
 putStrErrLn s = hPutStrLn stderr s
 
+putStrErr :: String -> IO ()
+putStrErr s = hPutStr stderr s
+
 printErr :: Show a => a -> IO ()
 printErr = putStrErrLn . show