hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Add check of syntactic validity of output

pull/3/head
Lennart Spitzner 2016-08-12 13:57:12 +02:00
parent bc09b21473
commit d444c6e386
7 changed files with 91 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
brittany.cabal
View File

@ -139,6 +139,7 @@ executable brittany
, safe
, filepath >=1.4.1.0 && <1.5
, either
, ghc-boot-th
}
hs-source-dirs: src-brittany
default-language: Haskell2010

39
src-brittany/Main.hs
View File

@ -31,6 +31,9 @@ import qualified System.Exit
import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath
import qualified DynFlags as GHC
import qualified GHC.LanguageExtensions.Type as GHC
import Paths_brittany
@ -105,16 +108,35 @@ mainCmdParser = do
& _options_ghc
& runIdentity
liftIO $ do
let cppMode = config
& _conf_errorHandling
& _econf_CPPMode
& runIdentity
& Semigroup.getLast
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of
CPPModeAbort -> do
return $ Left "Encountered -XCPP. Aborting."
CPPModeWarn -> do
putStrErrLn
$ "Warning: Encountered -XCPP."
++ " Be warned that -XCPP is not supported and that"
++ " brittany cannot check that its output is syntactically"
++ " valid in its presence."
return $ Right True
CPPModeNowarn ->
return $ Right True
else return $ Right False
parseResult <- case inputPathM of
Nothing -> parseModuleFromString ghcOptions "stdin"
Nothing -> parseModuleFromString ghcOptions "stdin" cppCheckFunc
=<< System.IO.hGetContents System.IO.stdin
Just p -> parseModule ghcOptions p
Just p -> parseModule ghcOptions p cppCheckFunc
case parseResult of
Left left -> do
putStrErrLn "parse error:"
printErr left
System.Exit.exitWith (System.Exit.ExitFailure 60)
Right (anns, parsedSource) -> do
Right (anns, parsedSource, hasCPP) -> do
when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do
let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
trace ("---- ast ----\n" ++ show val) $ return ()
@ -125,15 +147,20 @@ mainCmdParser = do
-- let out = do
-- decl <- someDecls
-- ExactPrint.exactPrint decl anns
let (errsWarns, outLText) = pPrintModule config anns parsedSource
(errsWarns, outLText) <- if hasCPP
then return $ pPrintModule config anns parsedSource
else pPrintModuleAndCheck config anns parsedSource
let customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder LayoutErrorUnusedComment{} = 1
customErrOrder LayoutErrorUnknownNode{} = 2
customErrOrder LayoutErrorOutputCheck{} = 1
customErrOrder LayoutErrorUnusedComment{} = 2
customErrOrder LayoutErrorUnknownNode{} = 3
when (not $ null errsWarns) $ do
let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder
$ List.sortOn customErrOrder
$ errsWarns
groupedErrsWarns `forM_` \case
(LayoutErrorOutputCheck{}:_) -> do
putStrErrLn $ "ERROR: brittany pretty printer returned syntactically invalid result."
uns@(LayoutErrorUnknownNode{}:_) -> do
putStrErrLn $ "ERROR: encountered unknown syntactical constructs:"
uns `forM_` \case

28
src/Language/Haskell/Brittany.hs
View File

@ -3,6 +3,7 @@
module Language.Haskell.Brittany
( parsePrintModule
, pPrintModule
, pPrintModuleAndCheck
-- re-export from utils:
, parseModule
, parseModuleFromString
@ -79,6 +80,22 @@ pPrintModule conf anns parsedModule =
-- debugStrings `forM_` \s ->
-- trace s $ return ()
-- | Additionally checks that the output compiles again, appending an error
-- if it does not.
pPrintModuleAndCheck
:: Config
-> ExactPrint.Types.Anns
-> GHC.ParsedSource
-> IO ([LayoutError], TextL.Text)
pPrintModuleAndCheck conf anns parsedModule = do
let (errs, output) = pPrintModule conf anns parsedModule
parseResult <- ExactPrint.Parsers.parseModuleFromString "output" (TextL.unpack output)
let errs' = errs ++ case parseResult of
Left{} -> [LayoutErrorOutputCheck]
Right{} -> []
return (errs', output)
-- used for testing mostly, currently.
parsePrintModule
:: Config
@ -88,17 +105,18 @@ parsePrintModule
parsePrintModule conf filename input = do
let inputStr = Text.unpack input
parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
return $ case parseResult of
Left (_, s) -> Left $ "parsing error: " ++ s
Right (anns, parsedModule) ->
let (errs, ltext) = pPrintModule conf anns parsedModule
in if null errs
case parseResult of
Left (_, s) -> return $ Left $ "parsing error: " ++ s
Right (anns, parsedModule) -> do
(errs, ltext) <- pPrintModuleAndCheck conf anns parsedModule
return $ if null errs
then Right $ TextL.toStrict $ ltext
else
let errStrs = errs <&> \case
LayoutErrorUnusedComment str -> str
LayoutWarning str -> str
LayoutErrorUnknownNode str _ -> str
LayoutErrorOutputCheck -> "Output is not syntactically valid."
in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
-- this approach would for with there was a pure GHC.parseDynamicFilePragma.

1
src/Language/Haskell/Brittany/Config.hs
View File

@ -123,6 +123,7 @@ configParser = do
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors
, _econf_Werror = wrapLast $ falseToNothing wError
, _econf_CPPMode = Nothing
}
, _conf_forward = ForwardOptions
{ _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs

16
src/Language/Haskell/Brittany/Config/Types.hs
View File

@ -64,6 +64,7 @@ data ForwardOptionsF f = ForwardOptions
data ErrorHandlingConfigF f = ErrorHandlingConfig
{ _econf_produceOutputOnErrors :: f (Semigroup.Last Bool)
, _econf_Werror :: f (Semigroup.Last Bool)
, _econf_CPPMode :: f (Semigroup.Last CPPMode)
}
deriving (Generic)
@ -123,6 +124,8 @@ instance FromJSON IndentPolicy
instance ToJSON IndentPolicy
instance FromJSON AltChooser
instance ToJSON AltChooser
instance FromJSON CPPMode
instance ToJSON CPPMode
instance FromJSON (LayoutConfigF Maybe)
instance ToJSON (LayoutConfigF Maybe)
@ -181,6 +184,13 @@ data AltChooser = AltChooserSimpleQuick -- always choose last alternative.
-- options having sufficient space.
deriving (Show, Generic, Data)
data CPPMode = CPPModeAbort -- abort program on seeing -XCPP
| CPPModeWarn -- warn about CPP and non-roundtripping in its
-- presence.
| CPPModeNowarn -- silently allow CPP, if possible (i.e. input is
-- file.)
deriving (Show, Generic, Data)
staticDefaultConfig :: Config
staticDefaultConfig = Config
{ _conf_debug = DebugConfig
@ -208,6 +218,7 @@ staticDefaultConfig = Config
, _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = coerce False
, _econf_Werror = coerce False
, _econf_CPPMode = coerce CPPModeAbort
}
, _conf_forward = ForwardOptions
{ _options_ghc = Identity []
@ -247,10 +258,11 @@ instance CZip LayoutConfigF where
(f x7 y7)
instance CZip ErrorHandlingConfigF where
cZip f (ErrorHandlingConfig x1 x2)
(ErrorHandlingConfig y1 y2) = ErrorHandlingConfig
cZip f (ErrorHandlingConfig x1 x2 x3)
(ErrorHandlingConfig y1 y2 y3) = ErrorHandlingConfig
(f x1 y1)
(f x2 y2)
(f x3 y3)
instance CZip ForwardOptionsF where
cZip f (ForwardOptions x1)

21
src/Language/Haskell/Brittany/ExactPrintUtils.hs
View File

@ -64,7 +64,8 @@ import DataTreePrint
parseModule
:: [String]
-> System.IO.FilePath
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource))
-> (GHC.DynFlags -> IO (Either String a))
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
parseModule =
parseModuleWithCpp ExactPrint.defaultCppOptions ExactPrint.normalLayout
@ -74,8 +75,9 @@ parseModuleWithCpp
-> ExactPrint.DeltaOptions
-> [String]
-> System.IO.FilePath
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource))
parseModuleWithCpp cpp opts args fp =
-> (GHC.DynFlags -> IO (Either String a))
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
parseModuleWithCpp cpp opts args fp dynCheck =
ExactPrint.ghcWrapper $ EitherT.runEitherT $ do
dflags0 <- lift $ ExactPrint.initDynFlags fp
(dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine
@ -89,17 +91,20 @@ parseModuleWithCpp cpp opts args fp =
$ EitherT.left
$ "when parsing ghc flags: encountered warnings: "
++ show (warnings <&> \(L _ s) -> s)
x <- EitherT.EitherT $ liftIO $ dynCheck dflags1
res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags1 fp
EitherT.hoistEither
$ either (\(span, err) -> Left $ show span ++ ": " ++ err) Right
$ either (\(span, err) -> Left $ show span ++ ": " ++ err)
(\(a, m) -> Right (a, m, x))
$ ExactPrint.postParseTransform res opts
parseModuleFromString
:: [String]
-> System.IO.FilePath
-> (GHC.DynFlags -> IO (Either String a))
-> String
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource))
parseModuleFromString args fp str =
-> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
parseModuleFromString args fp dynCheck str =
ExactPrint.ghcWrapper $ EitherT.runEitherT $ do
dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str
(dflags1, leftover, warnings) <-
@ -112,8 +117,10 @@ parseModuleFromString args fp str =
$ EitherT.left
$ "when parsing ghc flags: encountered warnings: "
++ show (warnings <&> \(L _ s) -> s)
x <- EitherT.EitherT $ liftIO $ dynCheck dflags1
EitherT.hoistEither
$ either (\(span, err) -> Left $ show span ++ ": " ++ err) Right
$ either (\(span, err) -> Left $ show span ++ ": " ++ err)
(\(a, m) -> Right (a, m, x))
$ ExactPrint.parseWith dflags1 fp GHC.parseModule str
-----------

8
src/Language/Haskell/Brittany/Types.hs
View File

@ -115,9 +115,11 @@ instance Show LayoutState where
-- , _lsettings_initialAnns :: ExactPrint.Anns
-- }
data LayoutError = LayoutErrorUnusedComment String
| LayoutWarning String
| forall ast . Data.Data.Data ast => LayoutErrorUnknownNode String ast
data LayoutError
= LayoutErrorUnusedComment String
| LayoutWarning String
| forall ast . Data.Data.Data ast => LayoutErrorUnknownNode String ast
| LayoutErrorOutputCheck
data BriSpacing = BriSpacing
{ _bs_spacePastLineIndent :: Int -- space in the current,