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

Add function pureModuleTransform

pull/35/head
Lennart Spitzner 2017-05-22 21:04:19 +02:00
parent 2dfa691f9e
commit 5dbe0f2c9c
4 changed files with 100 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
brittany.cabal
View File

@ -108,6 +108,7 @@ library {
, cmdargs >=0.10.14 && <0.11
, czipwith >=1.0.0.0 && <1.1
, unordered-containers >=0.2.7 && <0.3
, ghc-boot-th >=8.0.1 && <8.1
}
default-extensions: {
CPP
@ -169,9 +170,9 @@ executable brittany
, cmdargs
, czipwith
, unordered-containers
, ghc-boot-th
, hspec >=2.4.1 && <2.5
, filepath >=1.4.1.0 && <1.5
, ghc-boot-th >=8.0.1 && <8.1
}
hs-source-dirs: src-brittany
default-language: Haskell2010
@ -248,6 +249,7 @@ test-suite unittests
, cmdargs
, czipwith
, unordered-containers
, ghc-boot-th
, hspec >=2.4.1 && <2.5
}
ghc-options: -Wall
@ -322,6 +324,7 @@ test-suite littests
, cmdargs
, czipwith
, unordered-containers
, ghc-boot-th
, hspec >=2.4.1 && <2.5
, parsec >=3.1.11 && <3.2
}

19
src-brittany/Main.hs
View File

@ -111,6 +111,11 @@ mainCmdParser helpDesc = do
trace (showConfigYaml config) $ return ()
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
liftIO $ do
-- there is a good of code duplication between the following code and the
-- `pureModuleTransform` function. Unfortunately, there are also a good
-- amount of slight differences: This module is a bit more verbose, and
-- it tries to use the full-blown `parseModule` function which supports
-- CPP (but requires the input to be a file..).
let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & runIdentity & Semigroup.getLast
-- the flag will do the following: insert a marker string
-- ("-- BRITTANY_INCLUDE_HACK ") right before any lines starting with
@ -147,21 +152,15 @@ mainCmdParser helpDesc = do
when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do
let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
trace ("---- ast ----\n" ++ show val) $ return ()
-- mapM_ printErr (Map.toList anns)
-- let L _ (HsModule name exports imports decls _ _) = parsedSource
-- let someDecls = take 3 decls
-- -- let out = ExactPrint.exactPrint parsedSource anns
-- let out = do
-- decl <- someDecls
-- ExactPrint.exactPrint decl anns
let omitCheck = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack
(errsWarns, outLText) <- do
let omitCheck = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack
(ews, outRaw) <- if hasCPP || omitCheck
then return $ pPrintModule config anns parsedSource
else pPrintModuleAndCheck config anns parsedSource
let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw) else (ews, outRaw)
let customErrOrder LayoutWarning{} = 0 :: Int
let customErrOrder LayoutErrorInput{} = 4
customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder LayoutErrorOutputCheck{} = 1
customErrOrder LayoutErrorUnusedComment{} = 2
customErrOrder LayoutErrorUnknownNode{} = 3
@ -170,6 +169,8 @@ mainCmdParser helpDesc = do
groupedErrsWarns `forM_` \case
(LayoutErrorOutputCheck{}:_) -> do
putStrErrLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result."
(LayoutErrorInput str:_) -> do
putStrErrLn $ "ERROR: parse error: " ++ str
uns@(LayoutErrorUnknownNode{}:_) -> do
putStrErrLn $ "ERROR: encountered unknown syntactical constructs:"
uns `forM_` \case

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

@ -1,7 +1,8 @@
{-# LANGUAGE DataKinds #-}
module Language.Haskell.Brittany
( parsePrintModule
( pureModuleTransform
, parsePrintModule
, pPrintModule
, pPrintModuleAndCheck
-- re-export from utils:
@ -18,7 +19,10 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import qualified Data.Generics as SYB
import Data.Data
import Control.Monad.Trans.Either
import Data.HList.HList
import Data.CZipWith
import qualified Data.Text.Lazy.Builder as Text.Builder
@ -45,10 +49,73 @@ import RdrName ( RdrName(..) )
import GHC ( runGhc, GenLocated(L), moduleNameString )
import SrcLoc ( SrcSpan )
import HsSyn
import qualified DynFlags as GHC
import qualified GHC.LanguageExtensions.Type as GHC
import Data.HList.HList
-- | Exposes the transformation in an pseudo-pure fashion. The signature
-- contains `IO` due to the GHC API not exposing a pure parsing function, but
-- there should be no observable effects.
--
-- Note that this function ignores/resets all config values regarding
-- debugging, i.e. it will never use `trace`/write to stderr.
pureModuleTransform :: CConfig Option -> Text -> IO (Either [LayoutError] Text)
pureModuleTransform oConfigRaw inputText = runEitherT $ do
let configRaw = cZipWith fromOptionIdentity staticDefaultConfig oConfigRaw
let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig }
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
let config_pp = config & _conf_preprocessor
let cppMode = config_pp & _ppconf_CPPMode & confUnpack
let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack
(anns, parsedSource, hasCPP) <- do
let hackF s = if "#include" `isPrefixOf` s
then "-- BRITTANY_INCLUDE_HACK " ++ s
else s
let hackTransform = if hackAroundIncludes
then List.unlines . fmap hackF . List.lines
else id
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of
CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting."
CPPModeWarn -> return $ Right True
CPPModeNowarn -> return $ Right True
else return $ Right False
parseResult <- lift $ parseModuleFromString
ghcOptions
"stdin"
cppCheckFunc
(hackTransform $ Text.unpack inputText)
case parseResult of
Left err -> left $ [LayoutErrorInput err]
Right x -> pure $ x
(errsWarns, outputTextL) <- do
let omitCheck =
config
& _conf_errorHandling
& _econf_omit_output_valid_check
& confUnpack
(ews, outRaw) <- if hasCPP || omitCheck
then return $ pPrintModule config anns parsedSource
else lift $ pPrintModuleAndCheck config anns parsedSource
let hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes
then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw)
else (ews, outRaw)
let customErrOrder LayoutErrorInput{} = 4
customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder LayoutErrorOutputCheck{} = 1
customErrOrder LayoutErrorUnusedComment{} = 2
customErrOrder LayoutErrorUnknownNode{} = 3
let hasErrors =
case config & _conf_errorHandling & _econf_Werror & confUnpack of
False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)
True -> not $ null errsWarns
if hasErrors
then left $ errsWarns
else pure $ TextL.toStrict outputTextL
-- LayoutErrors can be non-fatal warnings, thus both are returned instead
-- of an Either.
@ -115,7 +182,11 @@ parsePrintModule conf filename input = do
case parseResult of
Left (_ , s ) -> return $ Left $ "parsing error: " ++ s
Right (anns, parsedModule) -> do
let omitCheck = conf & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack
let omitCheck =
conf
& _conf_errorHandling
.> _econf_omit_output_valid_check
.> confUnpack
(errs, ltext) <- if omitCheck
then return $ pPrintModule conf anns parsedModule
else pPrintModuleAndCheck conf anns parsedModule
@ -124,6 +195,7 @@ parsePrintModule conf filename input = do
else
let
errStrs = errs <&> \case
LayoutErrorInput str -> str
LayoutErrorUnusedComment str -> str
LayoutWarning str -> str
LayoutErrorUnknownNode str _ -> str
@ -131,6 +203,7 @@ parsePrintModule conf filename input = do
in
Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
-- 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.
@ -215,7 +288,7 @@ ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do
ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY - cmY)
_ -> return ()
withTransformedAnns :: SYB.Data ast => ast -> PPM () -> PPM ()
withTransformedAnns :: Data ast => ast -> PPM () -> PPM ()
withTransformedAnns ast m = do
-- TODO: implement `local` for MultiReader/MultiRWS
readers@(conf :+: anns :+: HNil) <- MultiRWSS.mGetRawR

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

@ -115,10 +115,17 @@ instance Show LayoutState where
-- }
data LayoutError
= LayoutErrorUnusedComment String
= LayoutErrorInput String
-- ^ parsing failed
| LayoutErrorUnusedComment String
-- ^ internal error: some comment went missing
| LayoutWarning String
-- ^ some warning
| forall ast . Data.Data.Data ast => LayoutErrorUnknownNode String ast
-- ^ internal error: pretty-printing is not implemented for type of node
-- in the syntax-tree
| LayoutErrorOutputCheck
-- ^ checking the output for syntactic validity failed
data BriSpacing = BriSpacing
{ _bs_spacePastLineIndent :: Int -- space in the current,