Abstraction over GHC parsing - WIP1

lib/Language/Haskell/Stylish.hs

@@ -27,6 +27,7 @@ module Language.Haskell.Stylish
 
 --------------------------------------------------------------------------------
 import           Control.Monad                                    (foldM)
+import           Control.Monad.Except                             (ExceptT(..), liftEither, runExceptT)
 import           System.Directory                                 (doesDirectoryExist,
                                                                    doesFileExist,
                                                                    listDirectory)
@@ -35,7 +36,8 @@ import           System.FilePath                                  (takeExtension
 
 --------------------------------------------------------------------------------
 import           Language.Haskell.Stylish.Config
-import           Language.Haskell.Stylish.Parse
+import           Language.Haskell.Stylish.Parse                   as Parse
+import           Language.Haskell.Stylish.ParseGHC                as ParseGHC
 import           Language.Haskell.Stylish.Step
 import qualified Language.Haskell.Stylish.Step.Imports            as Imports
 import qualified Language.Haskell.Stylish.Step.LanguagePragmas    as LanguagePragmas
@@ -90,15 +92,20 @@ unicodeSyntax = UnicodeSyntax.step
 
 
 --------------------------------------------------------------------------------
-runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> Either String Lines
-runStep exts mfp ls step =
-    stepFilter step ls <$> parseModule exts mfp (unlines ls)
-
-
+runStep :: Extensions -> Maybe FilePath -> Lines -> Step -> ExceptT String IO Lines
+runStep exts mfp ls step = case step of
+  (Step _ (Left f)) -> do
+    let parsedModule = Parse.parseModule exts mfp (unlines ls)
+    liftEither $ f ls <$> parsedModule
+  (Step _ (Right f)) -> do
+    parsedModule <- ExceptT $ ParseGHC.parseModule exts mfp (unlines ls)
+    return $ f ls parsedModule
+
 --------------------------------------------------------------------------------
 runSteps :: Extensions -> Maybe FilePath -> [Step] -> Lines
-         -> Either String Lines
-runSteps exts mfp steps ls = foldM (runStep exts mfp) ls steps
+         -> IO (Either String Lines)
+runSteps exts mfp steps ls = do
+    runExceptT $ foldM (runStep exts mfp) ls steps
 
 newtype ConfigPath = ConfigPath { unConfigPath :: FilePath }
 
@@ -108,8 +115,7 @@ newtype ConfigPath = ConfigPath { unConfigPath :: FilePath }
 format :: Maybe ConfigPath -> Maybe FilePath -> String -> IO (Either String Lines)
 format maybeConfigPath maybeFilePath contents = do
   conf <- loadConfig (makeVerbose True) (fmap unConfigPath maybeConfigPath)
-  pure $ runSteps (configLanguageExtensions conf) maybeFilePath (configSteps conf) $ lines contents
-
+  runSteps (configLanguageExtensions conf) maybeFilePath (configSteps conf) $ lines contents
 
 --------------------------------------------------------------------------------
 -- | Searches Haskell source files in any given folder recursively.

lib/Language/Haskell/Stylish/ParseGHC.hs

@@ -0,0 +1,97 @@
+--------------------------------------------------------------------------------
+module Language.Haskell.Stylish.ParseGHC
+    ( parseModule
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Data.List                       (isPrefixOf)
+import           Data.Maybe                      (fromMaybe, listToMaybe, mapMaybe)
+import           Data.Foldable                   (foldMap)
+
+import qualified SrcLoc                          as S
+import qualified Lexer                           as L
+import qualified GHC.Hs                          as G
+import qualified GHC.Hs.Extension                as GE
+import qualified DynFlags                        as D
+
+import qualified Language.Haskell.TH.LanguageExtensions as Ext
+
+import qualified Language.Haskell.GhclibParserEx.GHC.Parser as Parser
+
+import Language.Haskell.GhclibParserEx.GHC.Settings.Config
+import Language.Haskell.GhclibParserEx.GHC.Driver.Session (readExtension, parsePragmasIntoDynFlags)
+
+--------------------------------------------------------------------------------
+import           Language.Haskell.Stylish.Config
+import           Language.Haskell.Stylish.Step
+
+
+--------------------------------------------------------------------------------
+-- | Syntax-related language extensions are always enabled for parsing. Since we
+-- can't authoritatively know which extensions are enabled at compile-time, we
+-- should try not to throw errors when parsing any GHC-accepted code.
+defaultExtensions :: [Ext.Extension] -- uncompleted list of extensions
+defaultExtensions  = [Ext.GADTs,
+                      Ext.KindSignatures,
+                      Ext.UnicodeSyntax,
+                      Ext.PatternGuards,
+                      Ext.StandaloneDeriving]
+
+
+--------------------------------------------------------------------------------
+-- | Filter out lines which use CPP macros
+unCpp :: String -> String
+unCpp = unlines . go False . lines
+  where
+    go _           []       = []
+    go isMultiline (x : xs) =
+        let isCpp         = isMultiline || listToMaybe x == Just '#'
+            nextMultiline = isCpp && not (null x) && last x == '\\'
+        in (if isCpp then "" else x) : go nextMultiline xs
+
+
+--------------------------------------------------------------------------------
+-- | Remove shebang lines
+unShebang :: String -> String
+unShebang str =
+    let (shebangs, other) = break (not . ("#!" `isPrefixOf`)) (lines str) in
+    unlines $ map (const "") shebangs ++ other
+
+
+--------------------------------------------------------------------------------
+-- | If the given string is prefixed with an UTF-8 Byte Order Mark, drop it
+-- because haskell-src-exts can't handle it.
+dropBom :: String -> String
+dropBom ('\xfeff' : str) = str
+dropBom str              = str
+
+--------------------------------------------------------------------------------
+-- | List of DynFlags to obtain before parsing
+baseDynFlags :: D.DynFlags
+baseDynFlags = D.defaultDynFlags fakeSettings fakeLlvmConfig
+
+--------------------------------------------------------------------------------
+-- | Abstraction over GHC's parsing
+parseModule :: Extensions -> Maybe FilePath -> String -> IO (Either String GHCModule)
+parseModule extraExts mfp string = do
+  -- Determine the extensions: those specified in the file and the extra ones
+    let noPrefixes        = unShebang . dropBom $ string
+        extraExts'        = mapMaybe readExtension extraExts
+        enableDisableExts = (extraExts' ++ defaultExtensions ,[])   
+
+        fp       = fromMaybe "<unknown>" mfp
+
+        processed = if Ext.Cpp `elem` fst enableDisableExts
+                    then unCpp noPrefixes
+                    else noPrefixes
+
+    dynFlags <- parsePragmasIntoDynFlags baseDynFlags enableDisableExts fp processed
+    return $ case dynFlags of
+      Right ghcFlags -> case Parser.parseModule processed ghcFlags of
+        L.POk _st md -> Right md
+        L.PFailed st -> let err = L.getErrorMessages st ghcFlags in
+           Left $ "Language.Haskell.Stylish.Parse.parseModule: could not parse " ++
+            fp ++ ": " ++ foldMap (\x -> show x ++ "\n") err
+      Left msg -> Left $ "Language.Haskell.Stylish.Parse.parseModule: could not parse pragmas into dynamic flags: " ++ show msg
+

lib/Language/Haskell/Stylish/Step.hs

@@ -2,6 +2,7 @@
 module Language.Haskell.Stylish.Step
     ( Lines
     , Module
+    , GHCModule
     , Step (..)
     , makeStep
     ) where
@@ -10,23 +11,32 @@ module Language.Haskell.Stylish.Step
 --------------------------------------------------------------------------------
 import qualified Language.Haskell.Exts as H
 
+import qualified Lexer                 as L
+import qualified SrcLoc                as S
+import qualified GHC.Hs                as G
+import qualified GHC.Hs.Extension      as GE
+
 
 --------------------------------------------------------------------------------
 type Lines = [String]
 
 
 --------------------------------------------------------------------------------
--- | Concrete module type
-type Module = (H.Module H.SrcSpanInfo, [H.Comment])
+-- | Concrete HSE module type
+type Module = (H.Module H.SrcSpanInfo, [H.Comment]) 
+
+-- | Concrete GHC module type
+type GHCModule = (S.Located (G.HsModule GE.GhcPs))
 
 
 --------------------------------------------------------------------------------
 data Step = Step
     { stepName   :: String
-    , stepFilter :: Lines -> Module -> Lines
+    , stepFilter :: Either (Lines -> Module -> Lines) (Lines -> GHCModule -> Lines)
     }
 
-
 --------------------------------------------------------------------------------
-makeStep :: String -> (Lines -> Module -> Lines) -> Step
+makeStep :: String -> Either (Lines -> Module -> Lines) (Lines -> GHCModule -> Lines) -> Step
 makeStep = Step
+
+

lib/Language/Haskell/Stylish/Step/Data.hs

@@ -35,7 +35,7 @@ datas _                        = []
 type ChangeLine = Change String
 
 step :: Config -> Step
-step cfg = makeStep "Data" (step' cfg)
+step cfg = makeStep "Data" . Left $ (step' cfg)
 
 step' :: Config -> Lines -> Module -> Lines
 step' cfg ls (module', allComments) = applyChanges changes ls

lib/Language/Haskell/Stylish/Step/Imports.hs

@@ -421,7 +421,7 @@ prettyImportGroup columns align fileAlign longest imps =
 
 --------------------------------------------------------------------------------
 step :: Maybe Int -> Options -> Step
-step columns = makeStep "Imports" . step' columns
+step columns = makeStep "Imports" . Left . step' columns
 
 
 --------------------------------------------------------------------------------

lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs

@@ -106,8 +106,8 @@ filterRedundant isRedundant' = snd . foldr filterRedundant' (S.empty, [])
 
 --------------------------------------------------------------------------------
 step :: Maybe Int -> Style -> Bool -> Bool -> String -> Step
-step = ((((makeStep "LanguagePragmas" .) .) .) .) . step'
-
+step columns style align removeRedundant lngPrefix = 
+  makeStep "LanguagePragmas" . Left $ step' columns style align removeRedundant lngPrefix
 
 --------------------------------------------------------------------------------
 step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines
@@ -126,7 +126,6 @@ step' columns style align removeRedundant lngPrefix ls (module', _)
         | (b, pg) <- filterRedundant isRedundant' groups
         ]
 
-
 --------------------------------------------------------------------------------
 -- | Add a LANGUAGE pragma to a module if it is not present already.
 addLanguagePragma :: String -> String -> H.Module H.SrcSpanInfo -> [Change String]

lib/Language/Haskell/Stylish/Step/SimpleAlign.hs

@@ -109,7 +109,7 @@ fieldDeclToAlignable (H.FieldDecl ann names ty) = Just $ Alignable
 
 --------------------------------------------------------------------------------
 step :: Maybe Int -> Config -> Step
-step maxColumns config = makeStep "Cases" $ \ls (module', _) ->
+step maxColumns config = makeStep "Cases" . Left $ \ls (module', _) ->
     let module''               = fmap H.srcInfoSpan module'
         changes search toAlign =
             [ change_

lib/Language/Haskell/Stylish/Step/Squash.hs

@@ -52,7 +52,7 @@ squashAlt (H.Alt _ pat rhs _) = squash pat rhs
 
 --------------------------------------------------------------------------------
 step :: Step
-step = makeStep "Squash" $ \ls (module', _) ->
+step = makeStep "Squash" $ Left $ \ls (module', _) ->
     let module'' = fmap H.srcInfoSpan module'
         changes  = concat
             [ mapMaybe squashAlt       (everything module'')

lib/Language/Haskell/Stylish/Step/Tabs.hs

@@ -18,4 +18,4 @@ removeTabs spaces = concatMap removeTabs'
 
 --------------------------------------------------------------------------------
 step :: Int -> Step
-step spaces = makeStep "Tabs" $ \ls _ -> map (removeTabs spaces) ls
+step spaces = makeStep "Tabs" $ Left $ \ls _ -> map (removeTabs spaces) ls

lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs

@@ -19,7 +19,7 @@ dropTrailingWhitespace = reverse . dropWhile isSpace . reverse
 
 --------------------------------------------------------------------------------
 step :: Step
-step = makeStep "TrailingWhitespace" $ \ls _ -> map dropTrailingWhitespace' ls
+step = makeStep "TrailingWhitespace" $ Left $ \ls _ -> map dropTrailingWhitespace' ls
   where
     dropTrailingWhitespace' l = case l of
       -- Preserve page breaks

lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs

@@ -105,7 +105,7 @@ between (startRow, startCol) (endRow, endCol) needle =
 
 --------------------------------------------------------------------------------
 step :: Bool -> String -> Step
-step = (makeStep "UnicodeSyntax" .) . step'
+step alp lg = makeStep "UnicodeSyntax" . Left $ step' alp lg
 
 
 --------------------------------------------------------------------------------

src/Main.hs

@@ -126,7 +126,7 @@ stylishHaskell sa = do
 file :: StylishArgs -> Config -> Maybe FilePath -> IO ()
 file sa conf mfp = do
     contents <- maybe getContents readUTF8File mfp
-    let result = runSteps (configLanguageExtensions conf)
+    result <- runSteps (configLanguageExtensions conf)
             mfp (configSteps conf) $ lines contents
     case result of
         Right ok  -> write contents $ unlines ok

stack.yaml

@@ -5,5 +5,8 @@ packages:
 extra-deps:
 - 'Cabal-3.0.0.0'
 - 'haskell-src-exts-1.23.0'
+- 'ghc-lib-parser-8.10.1.20200523'
+- 'ghc-lib-parser-ex-8.10.0.14'
 - 'HsYAML-0.2.1.0'
 - 'HsYAML-aeson-0.2.0.0'
+

stack.yaml.lock

@@ -18,6 +18,20 @@ packages:
       sha256: 8e5bc885533431db9bf75e9609f6b80b56ab0c289a903d701f8628e78322afd0
   original:
     hackage: haskell-src-exts-1.23.0
+- completed:
+    hackage: ghc-lib-parser-8.10.1.20200523@sha256:857dbd2d456d4b74e6c3dbd3dacff3888a3c64bdb9fe306bd51b94fdcfb9094e,8770
+    pantry-tree:
+      size: 19503
+      sha256: dc8f7fc30eb951adac7852c1c1cd0e8e3243f1c6dbcc1ce2eccf345421af3346
+  original:
+    hackage: ghc-lib-parser-8.10.1.20200523
+- completed:
+    hackage: ghc-lib-parser-ex-8.10.0.14@sha256:0ee983c978e55fe799814a469777bddd394fb7eff97bdfba960935cb91f15e1c,3627
+    pantry-tree:
+      size: 2118
+      sha256: 643c6d2dab9dd9dd9f9de86b5086ea43c2ca3fa1e82b1fd35a57154f168cd6b0
+  original:
+    hackage: ghc-lib-parser-ex-8.10.0.14
 - completed:
     hackage: HsYAML-0.2.1.0@sha256:e4677daeba57f7a1e9a709a1f3022fe937336c91513e893166bd1f023f530d68,5311
     pantry-tree:

stylish-haskell.cabal

@@ -46,27 +46,30 @@ Library
     Language.Haskell.Stylish.Config.Internal
     Language.Haskell.Stylish.Editor
     Language.Haskell.Stylish.Parse
+    Language.Haskell.Stylish.ParseGHC
     Language.Haskell.Stylish.Step
     Language.Haskell.Stylish.Util
     Language.Haskell.Stylish.Verbose
     Paths_stylish_haskell
 
   Build-depends:
-    aeson            >= 0.6    && < 1.5,
-    base             >= 4.8    && < 5,
-    bytestring       >= 0.9    && < 0.11,
-    Cabal            >= 2.4    && < 3.1,
-    containers       >= 0.3    && < 0.7,
-    directory        >= 1.2.3  && < 1.4,
-    filepath         >= 1.1    && < 1.5,
-    file-embed       >= 0.0.10 && < 0.1,
-    haskell-src-exts >= 1.18   && < 1.24,
-    mtl              >= 2.0    && < 2.3,
-    semigroups       >= 0.18   && < 0.20,
-    syb              >= 0.3    && < 0.8,
-    text             >= 1.2    && < 1.3,
-    HsYAML-aeson     >=0.2.0   && < 0.3,
-    HsYAML           >=0.2.0   && < 0.3
+    aeson             >= 0.6    && < 1.5,
+    base              >= 4.8    && < 5,
+    bytestring        >= 0.9    && < 0.11,
+    Cabal             >= 2.4    && < 3.1,
+    containers        >= 0.3    && < 0.7,
+    directory         >= 1.2.3  && < 1.4,
+    filepath          >= 1.1    && < 1.5,
+    file-embed        >= 0.0.10 && < 0.1,
+    haskell-src-exts  >= 1.18   && < 1.24,
+    ghc-lib-parser    >= 8.10   && < 8.11,
+    ghc-lib-parser-ex >= 8.10   && < 8.11,
+    mtl               >= 2.0    && < 2.3,
+    semigroups        >= 0.18   && < 0.20,
+    syb               >= 0.3    && < 0.8,
+    text              >= 1.2    && < 1.3,
+    HsYAML-aeson      >=0.2.0   && < 0.3,
+    HsYAML            >=0.2.0   && < 0.3
 
 Executable stylish-haskell
   Ghc-options:    -Wall
@@ -87,6 +90,8 @@ Executable stylish-haskell
     filepath         >= 1.1    && < 1.5,
     file-embed       >= 0.0.10 && < 0.1,
     haskell-src-exts >= 1.18   && < 1.24,
+    ghc-lib-parser   >= 8.10   && < 8.11,
+    ghc-lib-parser-ex   >= 8.10   && < 8.11,
     mtl              >= 2.0    && < 2.3,
     syb              >= 0.3    && < 0.8,
     HsYAML-aeson     >=0.2.0   && < 0.3,
@@ -108,6 +113,7 @@ Test-suite stylish-haskell-tests
     Language.Haskell.Stylish.Config.Tests
     Language.Haskell.Stylish.Editor
     Language.Haskell.Stylish.Parse
+    Language.Haskell.Stylish.ParseGHC
     Language.Haskell.Stylish.Parse.Tests
     Language.Haskell.Stylish.Step
     Language.Haskell.Stylish.Step.Imports
@@ -147,6 +153,7 @@ Test-suite stylish-haskell-tests
     filepath         >= 1.1    && < 1.5,
     file-embed       >= 0.0.10 && < 0.1,
     haskell-src-exts >= 1.18   && < 1.24,
+    ghc-lib-parser   >= 8.10   && < 8.11,
     mtl              >= 2.0    && < 2.3,
     syb              >= 0.3    && < 0.8,
     text             >= 1.2    && < 1.3,