diff --git a/lib/Language/Haskell/Stylish.hs b/lib/Language/Haskell/Stylish.hs index c50db4d0..566e413e 100644 --- a/lib/Language/Haskell/Stylish.hs +++ b/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. diff --git a/lib/Language/Haskell/Stylish/ParseGHC.hs b/lib/Language/Haskell/Stylish/ParseGHC.hs new file mode 100644 index 00000000..e7b13409 --- /dev/null +++ b/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 "" 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 + diff --git a/lib/Language/Haskell/Stylish/Step.hs b/lib/Language/Haskell/Stylish/Step.hs index e5f3424d..db9eecd6 100644 --- a/lib/Language/Haskell/Stylish/Step.hs +++ b/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 + + diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs index 1f7732be..2b338d04 100644 --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/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 diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs index 7cb78d4c..26591f9b 100644 --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/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 -------------------------------------------------------------------------------- diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs index c9d461f6..a3adf5b5 100644 --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/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] diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs index 5e611232..f3f43193 100644 --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/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_ diff --git a/lib/Language/Haskell/Stylish/Step/Squash.hs b/lib/Language/Haskell/Stylish/Step/Squash.hs index 0eb4895a..56f3f1f7 100644 --- a/lib/Language/Haskell/Stylish/Step/Squash.hs +++ b/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'') diff --git a/lib/Language/Haskell/Stylish/Step/Tabs.hs b/lib/Language/Haskell/Stylish/Step/Tabs.hs index 0694cd9a..8f15d4e0 100644 --- a/lib/Language/Haskell/Stylish/Step/Tabs.hs +++ b/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 diff --git a/lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs b/lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs index e41bace1..cb0aef8d 100644 --- a/lib/Language/Haskell/Stylish/Step/TrailingWhitespace.hs +++ b/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 diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs index 266e8e59..3cb6dff9 100644 --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/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 -------------------------------------------------------------------------------- diff --git a/src/Main.hs b/src/Main.hs index b1ca2d5c..898b6e5a 100644 --- a/src/Main.hs +++ b/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 diff --git a/stack.yaml b/stack.yaml index b7c37af5..07898f6b 100644 --- a/stack.yaml +++ b/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' + diff --git a/stack.yaml.lock b/stack.yaml.lock index bc43b4e9..6eecd6a2 100644 --- a/stack.yaml.lock +++ b/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: diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal index 8e9dffda..b405da46 100644 --- a/stylish-haskell.cabal +++ b/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,