Refactor Main/Brittany.hs, code structure

2016-08-08 17:34:17 +02:00 · 2016-08-08 17:34:17 +02:00 · d625c90461
parent 23f19e653f
commit d625c90461
6 changed files with 189 additions and 108 deletions
--- a/brittany.cabal
+++ b/brittany.cabal
@ -26,14 +26,17 @@ library {
  hs-source-dirs:
    src
  exposed-modules: {
-    Language.Haskell.Brittany.Prelude
    Language.Haskell.Brittany
+    Language.Haskell.Brittany.Prelude
    Language.Haskell.Brittany.Types
    Language.Haskell.Brittany.Utils
    Language.Haskell.Brittany.Config
    Language.Haskell.Brittany.Config.Types
+  }
+  other-modules: {
    Language.Haskell.Brittany.LayoutBasics
    Language.Haskell.Brittany.BriLayouter
+    Language.Haskell.Brittany.ExactPrintUtils
    Language.Haskell.Brittany.Layouters.Type
    Language.Haskell.Brittany.Layouters.Decl
    Language.Haskell.Brittany.Layouters.Expr
--- a/src-brittany/Main.hs
+++ b/src-brittany/Main.hs
@ -6,17 +6,6 @@ module Main where

 #include "prelude.inc"

-import DynFlags ( getDynFlags )
-import GHC ( runGhc, GenLocated(L), moduleNameString )
-import qualified Parser as GHC.Parser
-import RdrName ( RdrName(..) )
-import Control.Monad.IO.Class
-import GHC.Paths (libdir)
-import HsSyn
-import SrcLoc ( SrcSpan, Located )
-- import Outputable ( ppr, runSDoc )
-- import DynFlags ( unsafeGlobalDynFlags )
-
 import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
 import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
 import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
@ -28,7 +17,6 @@ import qualified Data.Text.Lazy.Builder as Text.Builder
 import qualified Debug.Trace as Trace

 import Language.Haskell.Brittany.Types
-import Language.Haskell.Brittany.LayoutBasics
 import Language.Haskell.Brittany
 import Language.Haskell.Brittany.Config
 import Language.Haskell.Brittany.Config.Types
@ -93,20 +81,6 @@ mainCmdParser = do
    when printHelp $ do
      liftIO $ print $ ppHelpShallow desc
      System.Exit.exitSuccess
-    -- runGhc (Just libdir) $ do
-    --   dynflags <- getDynFlags
-    --   input <- liftIO $ readFile "local/Sample.hs"
-    --   let parseOutput = runParser dynflags parserModule input
-    --   liftIO $ case parseOutput of
-    --     Failure msg strloc -> do
-    --       putStrLn "some failed parse"
-    --       putStrLn msg
-    --       print strloc
-    --     Parsed a -> putStrLn "some successful parse."
-    --     Partial a (x,y) -> do
-    --       putStrLn "some partial parse"
-    --       print x
-    --       print y
    inputPathM <- case inputPaths of
      [] -> do
        return Nothing
--- a/src/Language/Haskell/Brittany.hs
+++ b/src/Language/Haskell/Brittany.hs
@ -3,6 +3,9 @@
 module Language.Haskell.Brittany
  ( parsePrintModule
  , pPrintModule
+   -- re-export from utils:
+  , parseModule
+  , parseModuleFromString
  )
 where

@ -10,29 +13,6 @@ where

 #include "prelude.inc"

-import DynFlags ( getDynFlags )
-import GHC ( runGhc, GenLocated(L), moduleNameString )
-import qualified Parser        as GHC
-import qualified ApiAnnotation as GHC
-import qualified DynFlags      as GHC
-import qualified FastString    as GHC
-import qualified GHC           as GHC hiding (parseModule)
-import qualified HeaderInfo    as GHC
-import qualified Lexer         as GHC
-import qualified MonadUtils    as GHC
-import qualified Outputable    as GHC
-import qualified Parser        as GHC
-import qualified SrcLoc        as GHC
-import qualified StringBuffer  as GHC
-import RdrName ( RdrName(..) )
-import Control.Monad.IO.Class
-import GHC.Paths (libdir)
-import HsSyn
-import SrcLoc ( SrcSpan, Located )
-- import Outputable ( ppr, runSDoc )
-- import DynFlags ( unsafeGlobalDynFlags )
-
-import           ApiAnnotation ( AnnKeywordId(..) )
 import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
 import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
 import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
@ -54,14 +34,14 @@ import           Language.Haskell.Brittany.Layouters.Type
 import           Language.Haskell.Brittany.Layouters.Decl
 import           Language.Haskell.Brittany.Utils
 import           Language.Haskell.Brittany.BriLayouter
+import           Language.Haskell.Brittany.ExactPrintUtils

+import qualified GHC as GHC hiding (parseModule)
+import           ApiAnnotation ( AnnKeywordId(..) )
 import           RdrName ( RdrName(..) )
 import           GHC ( runGhc, GenLocated(L), moduleNameString )
 import           SrcLoc ( SrcSpan )
 import           HsSyn
-import           Name
-import qualified FastString
-import           BasicTypes



@ -120,55 +100,6 @@ parsePrintModule conf filename input = do
                LayoutErrorUnknownNode str _ -> str
          in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs

-- TODO: move to separate module
-commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()
-commentAnnFixTransform modul = SYB.everything (>>) genF modul
- where
-  genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
-  genF = (\_ -> return ()) `SYB.extQ` exprF
-  exprF :: Located (HsExpr RdrName) -> ExactPrint.Transform ()
-  exprF lexpr@(L _ expr) = case expr of
-    RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) ->
-      moveTrailingComments lexpr (List.last fs)
-    RecordUpd _lname fs@(_:_) _ _ _ _ ->
-      moveTrailingComments lexpr (List.last fs)
-    _ -> return ()
-
-moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b)
-                     => GHC.Located a -> GHC.Located b -> ExactPrint.Transform ()
-moveTrailingComments astFrom astTo = do
-  let
-    breakHet :: (a -> Either b c) -> [a] -> ([b],[c])
-    breakHet _ [] = ([],[])
-    breakHet fn (a1:aR) = case fn a1 of
-      Left  b -> (b:bs,cs)
-      Right c -> (bs,c:cs)
-     where
-      (bs,cs) = breakHet fn aR
-          
-    k1 = ExactPrint.Types.mkAnnKey astFrom
-    k2 = ExactPrint.Types.mkAnnKey astTo
-    moveComments ans = ans'
-      where
-        an1 = Data.Maybe.fromJust $ Map.lookup k1 ans
-        an2 = Data.Maybe.fromJust $ Map.lookup k2 ans
-        cs1f = ExactPrint.Types.annFollowingComments an1
-        cs2f = ExactPrint.Types.annFollowingComments an2
-        (comments, nonComments) = flip breakHet (ExactPrint.Types.annsDP an1)
-             $ \case
-               (ExactPrint.Types.AnnComment com, dp) -> Left (com, dp)
-               x -> Right x
-        an1' = an1
-          { ExactPrint.annsDP               = nonComments
-          , ExactPrint.annFollowingComments = []
-          }
-        an2' = an2
-          { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments
-          }
-        ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans
-
-  ExactPrint.modifyAnnsT moveComments
-
 -- this approach would for with there was a pure GHC.parseDynamicFilePragma.
 -- Unfortunately that does not exist yet, so we cannot provide a nominally
 -- pure interface.
--- a/src/Language/Haskell/Brittany/ExactPrintUtils.hs
+++ b/src/Language/Haskell/Brittany/ExactPrintUtils.hs
@ -0,0 +1,174 @@
+{-# LANGUAGE DataKinds #-}
+
+module Language.Haskell.Brittany.ExactPrintUtils
+  ( parseModule
+  , parseModuleFromString
+  , commentAnnFixTransform
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import DynFlags ( getDynFlags )
+import GHC ( runGhc, GenLocated(L), moduleNameString )
+import qualified Parser        as GHC
+import qualified ApiAnnotation as GHC
+import qualified DynFlags      as GHC
+import qualified FastString    as GHC
+import qualified GHC           as GHC hiding (parseModule)
+import qualified HeaderInfo    as GHC
+import qualified Lexer         as GHC
+import qualified MonadUtils    as GHC
+import qualified Outputable    as GHC
+import qualified Parser        as GHC
+import qualified SrcLoc        as GHC
+import qualified StringBuffer  as GHC
+import RdrName ( RdrName(..) )
+import Control.Monad.IO.Class
+import HsSyn
+import SrcLoc ( SrcSpan, Located )
+import           RdrName ( RdrName(..) )
+import           GHC ( runGhc, GenLocated(L), moduleNameString )
+import           Name
+import qualified FastString
+import           BasicTypes
+
+import           ApiAnnotation ( AnnKeywordId(..) )
+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
+import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
+import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint
+import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint
+
+import qualified Data.Generics as SYB
+
+import qualified Data.Map as Map
+
+import qualified Data.Text.Lazy.Builder as Text.Builder
+
+import qualified Debug.Trace as Trace
+
+import Language.Haskell.Brittany.Types
+import Language.Haskell.Brittany.Config.Types
+import Language.Haskell.Brittany.LayoutBasics
+
+
+
+parseModule
+  :: [String]
+  -> System.IO.FilePath
+  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource))
+parseModule =
+  parseModuleWithCpp ExactPrint.defaultCppOptions ExactPrint.normalLayout
+
+-- | Parse a module with specific instructions for the C pre-processor.
+parseModuleWithCpp
+  :: ExactPrint.CppOptions
+  -> ExactPrint.DeltaOptions
+  -> [String]
+  -> System.IO.FilePath
+  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource))
+parseModuleWithCpp cpp opts args fp =
+  ExactPrint.ghcWrapper $ EitherT.runEitherT $ do
+    dflags0                       <- lift $ ExactPrint.initDynFlags fp
+    (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine
+      dflags0
+      (GHC.noLoc <$> args)
+    when (not $ null leftover)
+      $  EitherT.left
+      $  "when parsing ghc flags: leftover flags: "
+      ++ show (leftover <&> \(L _ s) -> s)
+    when (not $ null warnings)
+      $  EitherT.left
+      $  "when parsing ghc flags: encountered warnings: "
+      ++ show (warnings <&> \(L _ s) -> s)
+    res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags1 fp
+    EitherT.hoistEither
+      $ either (\(span, err) -> Left $ show span ++ ": " ++ err) Right
+      $ ExactPrint.postParseTransform res opts
+
+parseModuleFromString
+  :: [String]
+  -> System.IO.FilePath
+  -> String
+  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource))
+parseModuleFromString args fp str =
+  ExactPrint.ghcWrapper $ EitherT.runEitherT $ do
+    dflags0                       <- lift $ ExactPrint.initDynFlagsPure fp str
+    (dflags1, leftover, warnings) <-
+      lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args)
+    when (not $ null leftover)
+      $  EitherT.left
+      $  "when parsing ghc flags: leftover flags: "
+      ++ show (leftover <&> \(L _ s) -> s)
+    when (not $ null warnings)
+      $  EitherT.left
+      $  "when parsing ghc flags: encountered warnings: "
+      ++ show (warnings <&> \(L _ s) -> s)
+    EitherT.hoistEither
+      $ either (\(span, err) -> Left $ show span ++ ": " ++ err) Right
+      $ ExactPrint.parseWith dflags1 fp GHC.parseModule str
+
+-----------
+
+-- data LNode = forall a . LNode (Located a)
+-- 
+-- commentAnnFixTransformGlob :: GHC.ParsedSource -> ExactPrint.Transform ()
+-- commentAnnFixTransformGlob modul = do
+--   let extract :: forall a . SYB.Data a => a -> Seq LNode
+--       extract = const Seq.empty `SYB.ext1Q` (Seq.singleton . LNode)
+--   let nodes  = SYB.everything (<>) extract modul
+--   let comp = _
+--   let sorted = Seq.sortBy (comparing _) nodes
+--   _
+
+commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()
+commentAnnFixTransform modul = SYB.everything (>>) genF modul
+ where
+  genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
+  genF = (\_ -> return ()) `SYB.extQ` exprF
+  exprF :: Located (HsExpr RdrName) -> ExactPrint.Transform ()
+  exprF lexpr@(L _ expr) = case expr of
+    RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) ->
+      moveTrailingComments lexpr (List.last fs)
+    RecordUpd _lname fs@(_:_) _ _ _ _ ->
+      moveTrailingComments lexpr (List.last fs)
+    _ -> return ()
+
+moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b)
+                     => GHC.Located a -> GHC.Located b -> ExactPrint.Transform ()
+moveTrailingComments astFrom astTo = do
+  let
+    breakHet :: (a -> Either b c) -> [a] -> ([b],[c])
+    breakHet _ [] = ([],[])
+    breakHet fn (a1:aR) = case fn a1 of
+      Left  b -> (b:bs,cs)
+      Right c -> (bs,c:cs)
+     where
+      (bs,cs) = breakHet fn aR
+          
+    k1 = ExactPrint.mkAnnKey astFrom
+    k2 = ExactPrint.mkAnnKey astTo
+    moveComments ans = ans'
+      where
+        an1 = Data.Maybe.fromJust $ Map.lookup k1 ans
+        an2 = Data.Maybe.fromJust $ Map.lookup k2 ans
+        cs1f = ExactPrint.annFollowingComments an1
+        cs2f = ExactPrint.annFollowingComments an2
+        (comments, nonComments) = flip breakHet (ExactPrint.annsDP an1)
+             $ \case
+               (ExactPrint.AnnComment com, dp) -> Left (com, dp)
+               x -> Right x
+        an1' = an1
+          { ExactPrint.annsDP               = nonComments
+          , ExactPrint.annFollowingComments = []
+          }
+        an2' = an2
+          { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments
+          }
+        ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans
+
+  ExactPrint.modifyAnnsT moveComments
--- a/src/Language/Haskell/Brittany/LayoutBasics.hs
+++ b/src/Language/Haskell/Brittany/LayoutBasics.hs
@ -67,7 +67,6 @@ module Language.Haskell.Brittany.LayoutBasics
  , docDebug
  , briDocByExact
  , briDocByExactNoComment
-  , fromMaybeIdentity
  , foldedAnnKeys
  , unknownNodeError
  , appSep
@ -1086,11 +1085,6 @@ docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm
 docEnsureIndent :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
 docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd

-
-fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
-fromMaybeIdentity x y = Data.Coerce.coerce
-                      $ fromMaybe (Data.Coerce.coerce x) y
-
 unknownNodeError
  :: Data.Data.Data ast => String -> ast -> ToBriDocM BriDocNumbered
 unknownNodeError infoStr ast = do
--- a/src/Language/Haskell/Brittany/Utils.hs
+++ b/src/Language/Haskell/Brittany/Utils.hs
@ -5,6 +5,7 @@ module Language.Haskell.Brittany.Utils
  ( (.=+)
  , (%=+)
  , parDoc
+  , fromMaybeIdentity
  , traceIfDumpConf
  , mModify
  , customLayouterF
@ -71,6 +72,10 @@ showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags
 showGhc :: (GHC.Outputable a) => a -> String
 showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags

+fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
+fromMaybeIdentity x y = Data.Coerce.coerce
+                      $ fromMaybe (Data.Coerce.coerce x) y
+
 -- maximum monoid over N+0
 -- or more than N, because Num is allowed.
 newtype Max a = Max { getMax :: a }