brittany.cabal

@@ -97,7 +97,7 @@ library {
     , pretty >=1.1.3.3 && <1.2
     , bytestring >=0.10.8.1 && <0.11
     , directory >=1.2.6.2 && <1.4
-    , butcher >=1.3 && <1.4
+    , butcher >=1.3.1 && <1.4
     , yaml >=0.8.18 && <0.9
     , aeson >=1.0.1.0 && <1.3
     , extra >=1.4.10 && <1.7

src-brittany/Main.hs

@@ -133,7 +133,7 @@ mainCmdParser helpDesc = do
   printVersion   <- addSimpleBoolFlag "" ["version"] mempty
   printLicense   <- addSimpleBoolFlag "" ["license"] mempty
   configPaths    <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
-  cmdlineConfig  <- configParser
+  cmdlineConfig  <- cmdlineConfigParser
   suppressOutput <- addSimpleBoolFlag
     ""
     ["suppress-output"]
@@ -179,7 +179,7 @@ mainCmdParser helpDesc = do
     config <- runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad) >>= \case
       Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)
       Just x  -> return x
-    when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $
+    when (config & _conf_debug & _dconf_dump_config & confUnpack) $
       trace (showConfigYaml config) $ return ()
 
     results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths
@@ -211,11 +211,14 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
   -- CPP (but requires the input to be a file..).
   let cppMode            = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack
   -- the flag will do the following: insert a marker string
-  -- ("-- BRITTANY_INCLUDE_HACK ") right before any lines starting with
+  -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with
   -- "#include" before processing (parsing) input; and remove that marker
   -- string from the transformation output.
+  -- The flag is intentionally misspelled to prevent clashing with
+  -- inline-config stuff.
   let hackAroundIncludes = config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
-  let exactprintOnly     = config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
+  let exactprintOnly     = (config & _conf_roundtrip_exactprint_only & confUnpack)
+                        || (config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack)
   let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
         then case cppMode of
           CPPModeAbort -> do
@@ -232,7 +235,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
   parseResult <- case inputPathM of
     Nothing -> do
       -- TODO: refactor this hack to not be mixed into parsing logic
-      let hackF s = if "#include" `isPrefixOf` s then "-- BRITTANY_INCLUDE_HACK " ++ s else s
+      let hackF s = if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s
       let hackTransform =
             if hackAroundIncludes && not exactprintOnly then List.intercalate "\n" . fmap hackF . lines' else id
       inputString <- liftIO $ System.IO.hGetContents System.IO.stdin
@@ -244,6 +247,15 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
       putErrorLn $ show left
       ExceptT.throwE 60
     Right (anns, parsedSource, hasCPP) -> do
+      inlineConf <- case extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) of
+        Left (err, input) -> do
+          putErrorLn
+            $  "Error: parse error in inline configuration:"
+          putErrorLn err
+          putErrorLn $ "  in the string \"" ++ input ++ "\"."
+          ExceptT.throwE 61
+        Right c -> -- trace (showTree c) $
+          pure c
       when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do
         let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
         trace ("---- ast ----\n" ++ show val) $ return ()
@@ -254,9 +266,9 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
           else do
             let omitCheck = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack
             (ews, outRaw) <- if hasCPP || omitCheck
-              then return $ pPrintModule config anns parsedSource
+              then return $ pPrintModule config inlineConf anns parsedSource
-              else liftIO $ pPrintModuleAndCheck config anns parsedSource
+              else liftIO $ pPrintModuleAndCheck config inlineConf anns parsedSource
-            let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s
+            let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
             let out = TextL.toStrict $ if hackAroundIncludes
                   then TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn (TextL.pack "\n") outRaw
                   else outRaw
@@ -266,6 +278,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
           customErrOrder ErrorOutputCheck{}   = 1
           customErrOrder ErrorUnusedComment{} = 2
           customErrOrder ErrorUnknownNode{}   = 3
+          customErrOrder ErrorMacroConfig{}   = 5
       when (not $ null errsWarns) $ do
         let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder $ errsWarns
         groupedErrsWarns `forM_` \case
@@ -296,6 +309,11 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
             unused `forM_` \case
               ErrorUnusedComment str -> putErrorLn str
               _                      -> error "cannot happen (TM)"
+          (ErrorMacroConfig err input:_) -> do
+            putErrorLn
+              $  "Error: parse error in inline configuration:"
+            putErrorLn err
+            putErrorLn $ "  in the string \"" ++ input ++ "\"."
           [] -> error "cannot happen"
       -- TODO: don't output anything when there are errors unless user
       -- adds some override?

src-literatetests/Main.hs

@@ -182,9 +182,8 @@ defaultTestConfig = Config
     { _econf_omit_output_valid_check = coerce True
     }
   , _conf_preprocessor              = _conf_preprocessor staticDefaultConfig
-  , _conf_forward      = ForwardOptions
+  , _conf_forward = ForwardOptions {_options_ghc = Identity []}
-    { _options_ghc = Identity []
+  , _conf_roundtrip_exactprint_only = coerce True
-    }
   }
 
 contextFreeTestConfig :: Config

src-unittests/TestUtils.hs

@@ -64,7 +64,6 @@ defaultTestConfig = Config
     { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever
     }
   , _conf_preprocessor              = (_conf_preprocessor staticDefaultConfig)
-  , _conf_forward      = ForwardOptions
+  , _conf_forward = ForwardOptions {_options_ghc = Identity []}
-    { _options_ghc = Identity []
+  , _conf_roundtrip_exactprint_only = coerce False
-    }
   }

src/Language/Haskell/Brittany/Internal.hs

@@ -8,6 +8,8 @@ module Language.Haskell.Brittany.Internal
    -- re-export from utils:
   , parseModule
   , parseModuleFromString
+  , extractCommentConfigs
+  , getTopLevelDeclNameMap
   )
 where
 
@@ -22,7 +24,10 @@ import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
 import           Data.Data
 import           Control.Monad.Trans.Except
 import           Data.HList.HList
+import qualified Data.Yaml
+import qualified Data.ByteString.Char8
 import           Data.CZipWith
+import qualified UI.Butcher.Monadic as Butcher
 
 import qualified Data.Text.Lazy.Builder as Text.Builder
 
@@ -53,6 +58,162 @@ import           HsSyn
 import qualified DynFlags as GHC
 import qualified GHC.LanguageExtensions.Type as GHC
 
+import           Data.Char (isSpace)
+
+
+
+data InlineConfigTarget
+    = InlineConfigTargetModule
+    | InlineConfigTargetNextDecl    -- really only next in module
+    | InlineConfigTargetNextBinding -- by name
+    | InlineConfigTargetBinding String
+
+extractCommentConfigs
+  :: ExactPrint.Anns
+  -> TopLevelDeclNameMap
+  -> Either (String, String) InlineConfig
+extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
+  let
+    commentLiness =
+      [ ( k
+        , [ x
+          | (ExactPrint.Comment x _ _, _) <-
+            (  ExactPrint.annPriorComments ann
+            ++ ExactPrint.annFollowingComments ann
+            )
+          ]
+          ++ [ x
+             | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <-
+               ExactPrint.annsDP ann
+             ]
+        )
+      | (k, ann) <- Map.toList anns
+      ]
+  let configLiness = commentLiness <&> second
+        (Data.Maybe.mapMaybe $ \line -> do
+          l1 <-
+            List.stripPrefix "-- BRITTANY" line
+            <|> List.stripPrefix "--BRITTANY" line
+            <|> List.stripPrefix "-- brittany" line
+            <|> List.stripPrefix "--brittany" line
+            <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}")
+          let l2 = dropWhile isSpace l1
+          guard
+            (  ("@" `isPrefixOf` l2)
+            || ("-disable" `isPrefixOf` l2)
+            || ("-next" `isPrefixOf` l2)
+            || ("{" `isPrefixOf` l2)
+            || ("--" `isPrefixOf` l2)
+            )
+          pure l2
+        )
+  let
+    configParser = Butcher.addAlternatives
+      [ ( "commandline-config"
+        , \s -> "-" `isPrefixOf` dropWhile (== ' ') s
+        , cmdlineConfigParser
+        )
+      , ( "yaml-config-document"
+        , \s -> "{" `isPrefixOf` dropWhile (== ' ') s
+        , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document")
+        $ fmap (\lconf -> (mempty { _conf_layout = lconf }, ""))
+        . Data.Yaml.decode
+        . Data.ByteString.Char8.pack
+          -- TODO: use some proper utf8 encoder instead?
+        )
+      ]
+    parser = do -- we will (mis?)use butcher here to parse the inline config
+                -- line.
+      let nextDecl = do
+            conf <- configParser
+            Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf)
+      Butcher.addCmd "-next-declaration" nextDecl
+      Butcher.addCmd "-Next-Declaration" nextDecl
+      Butcher.addCmd "-NEXT-DECLARATION" nextDecl
+      let nextBinding = do
+            conf <- configParser
+            Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf)
+      Butcher.addCmd "-next-binding" nextBinding
+      Butcher.addCmd "-Next-Binding" nextBinding
+      Butcher.addCmd "-NEXT-BINDING" nextBinding
+      let disableNextBinding = do
+            Butcher.addCmdImpl
+              ( InlineConfigTargetNextBinding
+              , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
+              )
+      Butcher.addCmd "-disable-next-binding" disableNextBinding
+      Butcher.addCmd "-Disable-Next-Binding" disableNextBinding
+      Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding
+      let disableNextDecl = do
+            Butcher.addCmdImpl
+              ( InlineConfigTargetNextDecl
+              , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
+              )
+      Butcher.addCmd "-disable-next-declaration" disableNextDecl
+      Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl
+      Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl
+      Butcher.addCmd "@" $ do
+        -- Butcher.addCmd "module" $ do
+        --   conf <- configParser
+        --   Butcher.addCmdImpl (InlineConfigTargetModule, conf)
+        Butcher.addNullCmd $ do
+          bindingName <- Butcher.addParamString "BINDING" mempty
+          conf        <- configParser
+          Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf)
+      conf <- configParser
+      Butcher.addCmdImpl (InlineConfigTargetModule, conf)
+  lineConfigss <- configLiness `forM` \(k, ss) -> do
+    r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of
+      Left  err -> Left $ (err, s)
+      Right c   -> Right $ c
+    pure (k, r)
+
+  let perModule = foldl'
+        (<>)
+        mempty
+        [ conf
+        | (_                       , lineConfigs) <- lineConfigss
+        , (InlineConfigTargetModule, conf       ) <- lineConfigs
+        ]
+  let
+    perBinding = Map.fromListWith
+      (<>)
+      [ (n, conf)
+      | (k     , lineConfigs) <- lineConfigss
+      , (target, conf       ) <- lineConfigs
+      , n                     <- case target of
+        InlineConfigTargetBinding s -> [s]
+        InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap ->
+          [name]
+        _ -> []
+      ]
+  let
+    perKey = Map.fromListWith
+      (<>)
+      [ (k, conf)
+      | (k     , lineConfigs) <- lineConfigss
+      , (target, conf       ) <- lineConfigs
+      , case target of
+        InlineConfigTargetNextDecl -> True
+        InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap ->
+          True
+        _ -> False
+      ]
+
+  pure $ InlineConfig
+    { _icd_perModule  = perModule
+    , _icd_perBinding = perBinding
+    , _icd_perKey     = perKey
+    }
+
+
+getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap
+getTopLevelDeclNameMap (L _ (HsModule _name _exports _ decls _ _)) =
+  TopLevelDeclNameMap $ Map.fromList
+    [ (ExactPrint.mkAnnKey decl, name)
+    | decl       <- decls
+    , (name : _) <- [getDeclBindingNames decl]
+    ]
 
 
 -- | Exposes the transformation in an pseudo-pure fashion. The signature
@@ -67,15 +228,16 @@ import qualified GHC.LanguageExtensions.Type as GHC
 -- may wish to put some proper upper bound on the input's size as a timeout
 -- won't do.
 parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)
-parsePrintModule configRaw inputText = runExceptT $ do
+parsePrintModule configWithDebugs inputText = runExceptT $ do
-  let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig }
+  let config =
+        configWithDebugs { _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
+          then "-- BRITANY_INCLUDE_HACK " ++ s
           else s
     let hackTransform = if hackAroundIncludes
           then List.intercalate "\n" . fmap hackF . lines'
@@ -94,6 +256,8 @@ parsePrintModule configRaw inputText = runExceptT $ do
     case parseResult of
       Left  err -> throwE [ErrorInput err]
       Right x   -> pure x
+  inlineConf <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure
+    $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
   (errsWarns, outputTextL) <- do
     let omitCheck =
           config
@@ -101,10 +265,10 @@ parsePrintModule configRaw inputText = runExceptT $ do
             & _econf_omit_output_valid_check
             & confUnpack
     (ews, outRaw) <- if hasCPP || omitCheck
-      then return $ pPrintModule config anns parsedSource
+      then return $ pPrintModule config inlineConf anns parsedSource
-      else lift $ pPrintModuleAndCheck config anns parsedSource
+      else lift $ pPrintModuleAndCheck config inlineConf anns parsedSource
     let hackF s = fromMaybe s
-          $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s
+          $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
     pure $ if hackAroundIncludes
       then
         ( ews
@@ -118,6 +282,7 @@ parsePrintModule configRaw inputText = runExceptT $ do
       customErrOrder ErrorOutputCheck{}   = 1
       customErrOrder ErrorUnusedComment{} = 2
       customErrOrder ErrorUnknownNode{}   = 3
+      customErrOrder ErrorMacroConfig{}   = 5
   let hasErrors =
         case config & _conf_errorHandling & _econf_Werror & confUnpack of
           False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)
@@ -132,10 +297,11 @@ parsePrintModule configRaw inputText = runExceptT $ do
 -- can occur.
 pPrintModule
   :: Config
+  -> InlineConfig
   -> ExactPrint.Anns
   -> GHC.ParsedSource
   -> ([BrittanyError], TextL.Text)
-pPrintModule conf anns parsedModule =
+pPrintModule conf inlineConf anns parsedModule =
   let
     ((out, errs), debugStrings) =
       runIdentity
@@ -145,6 +311,7 @@ pPrintModule conf anns parsedModule =
         $ MultiRWSS.withMultiWriterW
         $ MultiRWSS.withMultiReader anns
         $ MultiRWSS.withMultiReader conf
+        $ MultiRWSS.withMultiReader inlineConf
         $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
         $ do
             traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
@@ -168,12 +335,13 @@ pPrintModule conf anns parsedModule =
 -- if it does not.
 pPrintModuleAndCheck
   :: Config
+  -> InlineConfig
   -> ExactPrint.Anns
   -> GHC.ParsedSource
   -> IO ([BrittanyError], TextL.Text)
-pPrintModuleAndCheck conf anns parsedModule = do
+pPrintModuleAndCheck conf inlineConf anns parsedModule = do
   let ghcOptions     = conf & _conf_forward & _options_ghc & runIdentity
-  let (errs, output) = pPrintModule conf anns parsedModule
+  let (errs, output) = pPrintModule conf inlineConf anns parsedModule
   parseResult <- parseModuleFromString ghcOptions
                                        "output"
                                        (\_ -> return $ Right ())
@@ -192,28 +360,34 @@ parsePrintModuleTests conf filename input = do
   parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
   case parseResult of
     Left  (_   , s           ) -> return $ Left $ "parsing error: " ++ s
-    Right (anns, parsedModule) -> do
+    Right (anns, parsedModule) -> runExceptT $ do
+      inlineConf <-
+        case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of
+          Left  err -> throwE $ "error in inline config: " ++ show err
+          Right x   -> pure x
       let omitCheck =
             conf
               &  _conf_errorHandling
               .> _econf_omit_output_valid_check
               .> confUnpack
       (errs, ltext) <- if omitCheck
-        then return $ pPrintModule conf anns parsedModule
+        then return $ pPrintModule conf inlineConf anns parsedModule
-        else pPrintModuleAndCheck conf anns parsedModule
+        else lift $ pPrintModuleAndCheck conf inlineConf anns parsedModule
-      return $ if null errs
+      if null errs
-        then Right $ TextL.toStrict $ ltext
+        then pure $ TextL.toStrict $ ltext
         else
-          let errStrs = errs <&> \case
+          let
+            errStrs = errs <&> \case
               ErrorInput         str -> str
               ErrorUnusedComment str -> str
               LayoutWarning      str -> str
               ErrorUnknownNode str _ -> str
+              ErrorMacroConfig str _ -> "when parsing inline config: " ++ str
               ErrorOutputCheck       -> "Output is not syntactically valid."
-          in  Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
+          in  throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs
 
 
--- this approach would for with there was a pure GHC.parseDynamicFilePragma.
+-- this approach would for if there was a pure GHC.parseDynamicFilePragma.
 -- Unfortunately that does not exist yet, so we cannot provide a nominally
 -- pure interface.
 
@@ -247,12 +421,25 @@ parsePrintModuleTests conf filename input = do
 --           Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
 --         else return $ TextL.toStrict $ Text.Builder.toLazyText out
 
+toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a
+toLocal conf anns m = do
+  (x, write) <- lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m
+  MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write)
+  pure x
+
 ppModule :: GenLocated SrcSpan (HsModule GhcPs) -> PPM ()
 ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
   post <- ppPreamble lmod
   decls `forM_` \decl -> do
-    filteredAnns <- mAsk <&> \annMap ->
+    let declAnnKey       = ExactPrint.mkAnnKey decl
-      Map.findWithDefault Map.empty (ExactPrint.mkAnnKey decl) annMap
+    let declBindingNames = getDeclBindingNames decl
+    inlineConf <- mAsk
+    let inlineModConf = _icd_perModule inlineConf
+    let mDeclConf     = Map.lookup declAnnKey $ _icd_perKey inlineConf
+    let mBindingConfs =
+          declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
+    filteredAnns <- mAsk
+      <&> \annMap -> Map.findWithDefault Map.empty declAnnKey annMap
 
     traceIfDumpConf "bridoc annotations filtered/transformed"
                     _dconf_dump_annotations
@@ -260,11 +447,16 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
 
     config <- mAsk
 
-    MultiRWSS.withoutMultiReader $ do
+    let config' = cZipWith fromOptionIdentity config $ mconcat
-      MultiRWSS.mPutRawR $ config :+: filteredAnns :+: HNil
+          (inlineModConf : (catMaybes (mBindingConfs ++ [mDeclConf])))
-      ppDecl decl
+
+    toLocal config' filteredAnns
+      $ if (config' & _conf_roundtrip_exactprint_only & confUnpack)
+          then briDocMToPPM (briDocByExactNoComment decl) >>= layoutBriDoc
+          else ppDecl decl
+
   let finalComments = filter
-        ( fst .> \case
+        (fst .> \case
           ExactPrint.AnnComment{} -> True
           _                       -> False
         )
@@ -274,8 +466,7 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
       ppmMoveToExactLoc l
       mTell $ Text.Builder.fromString cmStr
     (ExactPrint.G AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->
-      let
+      let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
-        folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
             ExactPrint.AnnComment cm
               | GHC.RealSrcSpan span <- ExactPrint.commentIdentifier cm
               -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
@@ -283,8 +474,7 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
                  )
             _ -> (acc + y, x)
           (cmY, cmX) = foldl' folder (0, 0) finalComments
-      in
+      in  ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)
-        ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)
     _ -> return ()
 
 withTransformedAnns :: Data ast => ast -> PPMLocal () -> PPMLocal ()
@@ -301,6 +491,13 @@ withTransformedAnns ast m = do
     in  annsBalanced
 
 
+getDeclBindingNames :: LHsDecl GhcPs -> [String]
+getDeclBindingNames (L _ decl) = case decl of
+  SigD (TypeSig ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
+  ValD (FunBind (L _ n) _ _ _ _) -> [Text.unpack $ rdrNameToText n]
+  _ -> []
+
+
 ppDecl :: LHsDecl GhcPs -> PPMLocal ()
 ppDecl d@(L loc decl) = case decl of
   SigD sig -> -- trace (_sigHead sig) $
@@ -379,9 +576,7 @@ ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do
     $ annsDoc filteredAnns'
 
   if shouldReformatPreamble
-    then MultiRWSS.withoutMultiReader $ do
+    then toLocal config filteredAnns' $ withTransformedAnns lmod $ do
-      MultiRWSS.mPutRawR $ config :+: filteredAnns' :+: HNil
-      withTransformedAnns lmod $ do
         briDoc <- briDocMToPPM $ layoutModule lmod
         layoutBriDoc briDoc
     else

src/Language/Haskell/Brittany/Internal/Config.hs

@@ -5,7 +5,7 @@ module Language.Haskell.Brittany.Internal.Config
   , DebugConfig
   , LayoutConfig
   , Config
-  , configParser
+  , cmdlineConfigParser
   , staticDefaultConfig
   , forwardOptionsSyntaxExtsEnabled
   , readConfig
@@ -89,6 +89,7 @@ staticDefaultConfig = Config
   , _conf_forward = ForwardOptions
     { _options_ghc = Identity []
     }
+  , _conf_roundtrip_exactprint_only  = coerce False
   }
 
 forwardOptionsSyntaxExtsEnabled :: ForwardOptions
@@ -109,8 +110,9 @@ forwardOptionsSyntaxExtsEnabled = ForwardOptions
     ]
   }
 
-configParser :: CmdParser Identity out (CConfig Option)
+-- brittany-next-binding --columns=200
-configParser = do
+cmdlineConfigParser :: CmdParser Identity out (CConfig Option)
+cmdlineConfigParser = do
   -- TODO: why does the default not trigger; ind never should be []!!
   ind                <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level")
   cols               <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)")
@@ -156,7 +158,7 @@ configParser = do
       , _dconf_dump_bridoc_simpl_columns  = wrapLast $ falseToNothing dumpBriDocColumns
       , _dconf_dump_bridoc_simpl_indent   = wrapLast $ falseToNothing dumpBriDocIndent
       , _dconf_dump_bridoc_final          = wrapLast $ falseToNothing dumpBriDocFinal
-      , _dconf_roundtrip_exactprint_only  = wrapLast $ falseToNothing roundtripOnly
+      , _dconf_roundtrip_exactprint_only  = mempty
       }
     , _conf_layout = LayoutConfig
       { _lconfig_cols                      = optionConcat cols
@@ -187,6 +189,7 @@ configParser = do
     , _conf_forward = ForwardOptions
       { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ]
       }
+    , _conf_roundtrip_exactprint_only  = wrapLast $ falseToNothing roundtripOnly
     }
  where
   falseToNothing = Option . Bool.bool Nothing (Just True)

src/Language/Haskell/Brittany/Internal/Config/Types.hs

@@ -145,6 +145,11 @@ data CConfig f = Config
   , _conf_errorHandling :: CErrorHandlingConfig f
   , _conf_forward       :: CForwardOptions f
   , _conf_preprocessor  :: CPreProcessorConfig f
+  , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)
+    -- ^ this field is somewhat of a duplicate of the one in DebugConfig.
+    -- It is used for per-declaration disabling by the inline config
+    -- implementation. Could have re-used the existing field, but felt risky
+    -- to use a "debug" labeled field for non-debug functionality.
   }
   deriving (Generic)
 
@@ -176,6 +181,16 @@ deriving instance Data (CForwardOptions Identity)
 deriving instance Data (CPreProcessorConfig Identity)
 deriving instance Data (CConfig Identity)
 
+#if MIN_VERSION_ghc(8,2,0)
+-- these instances break on earlier ghcs
+deriving instance Data (CDebugConfig Option)
+deriving instance Data (CLayoutConfig Option)
+deriving instance Data (CErrorHandlingConfig Option)
+deriving instance Data (CForwardOptions Option)
+deriving instance Data (CPreProcessorConfig Option)
+deriving instance Data (CConfig Option)
+#endif
+
 instance Semigroup.Semigroup (CDebugConfig Option) where
   (<>) = gmappend
 instance Semigroup.Semigroup (CLayoutConfig Option) where

src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs

@@ -119,6 +119,7 @@ instance FromJSON (CConfig Maybe) where
     <*> v .:?= Text.pack "conf_errorHandling"
     <*> v .:?= Text.pack "conf_forward"
     <*> v .:?= Text.pack "conf_preprocessor"
+    <*> v .:?  Text.pack "conf_roundtrip_exactprint_only"
   parseJSON invalid    = Aeson.typeMismatch "Config" invalid
 
 -- Pretends that the value is {} when the key is not present.

src/Language/Haskell/Brittany/Internal/PreludeUtils.hs

@@ -32,13 +32,12 @@ instance Alternative Strict.Maybe where
   x <|> Strict.Nothing = x
   _ <|> x = x
 
-traceFunctionWith
+traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)
-  :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)
+traceFunctionWith name s1 s2 f x = trace traceStr y
-traceFunctionWith name s1 s2 f x =
-  trace traceStr y
  where
   y = f x
-    traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
+  traceStr =
+    name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
 
 (<&!>) :: Monad m => m a -> (a -> b) -> m b
 (<&!>) = flip (<$!>)

src/Language/Haskell/Brittany/Internal/Types.hs

@@ -13,6 +13,7 @@ where
 #include "prelude.inc"
 
 import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
 
 import qualified Data.Text.Lazy.Builder as Text.Builder
 
@@ -27,8 +28,17 @@ import           Data.Generics.Uniplate.Direct as Uniplate
 
 
 
+data InlineConfig = InlineConfig
+  { _icd_perModule :: CConfig Option
+  , _icd_perBinding :: Map String (CConfig Option)
+  , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Option)
+  }
+#if MIN_VERSION_ghc(8,2,0)
+  deriving Data.Data.Data
+#endif
+
 type PPM = MultiRWSS.MultiRWS
-  '[Map ExactPrint.AnnKey ExactPrint.Anns, Config, ExactPrint.Anns]
+  '[Map ExactPrint.AnnKey ExactPrint.Anns, InlineConfig, Config, ExactPrint.Anns]
   '[Text.Builder.Builder, [BrittanyError], Seq String]
   '[]
 
@@ -37,6 +47,8 @@ type PPMLocal = MultiRWSS.MultiRWS
   '[Text.Builder.Builder, [BrittanyError], Seq String]
   '[]
 
+newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String)
+
 data LayoutState = LayoutState
   { _lstate_baseYs         :: [Int]
      -- ^ stack of number of current indentation columns
@@ -118,6 +130,9 @@ data BrittanyError
     -- ^ parsing failed
   | ErrorUnusedComment String
     -- ^ internal error: some comment went missing
+  | ErrorMacroConfig String String
+    -- ^ in-source config string parsing error; first argument is the parser
+    --   output and second the corresponding, ill-formed input.
   | LayoutWarning String
     -- ^ some warning
   | forall ast . Data.Data.Data ast => ErrorUnknownNode String ast

stack-8.0.2.yaml

@@ -3,7 +3,7 @@ resolver: lts-9.0
 extra-deps:
   - monad-memo-0.4.1
   - czipwith-1.0.1.0
-  - butcher-1.3.0.0
+  - butcher-1.3.1.1
   - data-tree-print-0.1.0.0
   - deque-0.2
   - ghc-exactprint-0.5.6.0

stack-8.2.2.yaml

@@ -2,6 +2,7 @@ resolver: lts-11.1
 
 extra-deps:
   - czipwith-1.0.1.0
+  - butcher-1.3.1.1
 
 packages:
   - .

stack.yaml

@@ -2,6 +2,7 @@ resolver: lts-11.1
 
 extra-deps:
   - czipwith-1.0.1.0
+  - butcher-1.3.1.1
 
 packages:
   - .