brittany/source/library/Language/Haskell/Brittany/Internal/Config/InlineParsing.hs

{-# LANGUAGE NoImplicitPrelude #-}

module Language.Haskell.Brittany.Internal.Config.InlineParsing
  ( extractCommentConfigs
  )
where

import           Language.Haskell.Brittany.Internal.Prelude

import qualified Data.ByteString.Char8
import           Data.Char                      ( isSpace )
import qualified Data.Map                      as Map
import qualified Data.Yaml
import qualified GHC
import           GHC                            ( EpaComment(EpaComment)
                                                , GenLocated(L)
                                                )
import qualified GHC.OldList                   as List
import           GHC.Parser.Annotation          ( EpaCommentTok
                                                  ( EpaBlockComment
                                                  , EpaLineComment
                                                  )
                                                )
import qualified UI.Butcher.Monadic            as Butcher
import           Control.Monad.Trans.Except

import           Language.Haskell.Brittany.Internal.Config.Config
import           Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Util.AST
import Language.Haskell.Brittany.Internal.Config.Types.Instances1 ()
import Language.Haskell.Brittany.Internal.Config.Types.Instances2 ()
-- import Language.Haskell.Brittany.Internal.Utils
-- import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
-- import Data.Data(toConstr)



data InlineConfigTarget
    = InlineConfigTargetModule
    | InlineConfigTargetNextDecl    -- really only next in module
    | InlineConfigTargetNextBinding -- by name
    | InlineConfigTargetBinding String
  deriving Show

extractCommentConfigs
  :: (String -> IO ())
  -> GHC.ParsedSource
  -> ExceptT (String, String) IO (CConfig Maybe, PerItemConfig)
extractCommentConfigs _putErrorLn modul = do
  let (L _ (GHC.HsModule modAnn _ _ _ _ decls _ _)) = modul
  let declMap :: Map GHC.RealSrcSpan [String]
      declMap = Map.fromList
        [ ( case span of
            GHC.RealSrcSpan s _ -> s
            GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan"
          , getDeclBindingNames decl
          )
        | decl <- decls
        , let (L (GHC.SrcSpanAnn _ span) _) = decl
        ]
  let epAnnComms = \case
        GHC.EpAnn _ _ (GHC.EpaComments prior) -> prior
        GHC.EpAnn _ _ (GHC.EpaCommentsBalanced prior following) ->
          prior ++ following
        GHC.EpAnnNotUsed -> []
  let gatheredComments =
        join
          $ epAnnComms modAnn
          : [ epAnnComms epAnn | L (GHC.SrcSpanAnn epAnn _) _x <- decls ]
  -- gatheredComments `forM_` \comm@(L anchor _) -> do
  --   liftIO $ putErrorLn $ showOutputable comm
  --   case Map.lookupLE (GHC.anchor anchor) declMap of
  --     Nothing -> pure ()
  --     Just (pos, le) -> do
  --       liftIO $ putErrorLn $ "  le = " ++ show (toConstr le) ++ " at " ++ show
  --         (ExactPrint.Utils.ss2deltaEnd pos (GHC.anchor anchor))
  --   case Map.lookupGE (GHC.anchor anchor) declMap of
  --     Nothing -> pure ()
  --     Just (pos, ge) -> do
  --       liftIO $ putErrorLn $ "  ge = " ++ show (toConstr ge) ++ " at " ++ show
  --         (ExactPrint.Utils.ss2deltaStart (GHC.anchor anchor) pos)
  lineConfigs <- sequence
    [ case Butcher.runCmdParserSimpleString line2 parser of
        Left  err            -> throwE (err, line2)
        Right (target, conf) -> pure $ (GHC.anchor anchr, target, conf)
    | L anchr (EpaComment comm _) <- gatheredComments
    , Just line1                  <- case comm of
      EpaLineComment l ->
        [ List.stripPrefix "-- BRITTANY" l
            <|> List.stripPrefix "--BRITTANY" l
            <|> List.stripPrefix "-- brittany" l
            <|> List.stripPrefix "--brittany" l
        ]
      EpaBlockComment l ->
        [List.stripPrefix "{- BRITTANY" l >>= stripSuffix "-}"]
      _ -> []
    , let line2 = dropWhile isSpace line1
    , (  ("@" `isPrefixOf` line2)
      || ("-disable" `isPrefixOf` line2)
      || ("-next" `isPrefixOf` line2)
      || ("{" `isPrefixOf` line2)
      || ("--" `isPrefixOf` line2)
      )
    ]
  let perModule = foldl'
        (<>)
        mempty
        [ conf | (_, InlineConfigTargetModule, conf) <- lineConfigs ]
  let perBinding = Map.fromListWith
        (<>)
        [ (n, conf)
        | (srcSpan, target, conf) <- lineConfigs
        , let perBindRes = Map.lookupGT srcSpan declMap
        , n <- case target of
          InlineConfigTargetBinding s -> [s]
          InlineConfigTargetNextBinding | Just (_, names) <- perBindRes -> names
          _                           -> []
        ]
  let perSpan = Map.fromListWith
        (<>)
        [ (declSpan, conf)
        | (srcSpan, target, conf) <- lineConfigs
        , Just (declSpan, names) <- [Map.lookupGT srcSpan declMap]
        , case target of
          InlineConfigTargetNextDecl    -> True
          InlineConfigTargetNextBinding -> null names
          _ -> False
        ]

  pure
    $ ( perModule
      , PerItemConfig { _icd_perBinding = perBinding, _icd_perAnchor = perSpan }
      )
 where
  configParser = Butcher.addAlternatives
    [ ( "commandline-config"
      , \s -> "-" `isPrefixOf` dropWhile (== ' ') s
      , cmdlineConfigParser
      )
    , ( "yaml-config-document"
      , \s -> "{" `isPrefixOf` dropWhile (== ' ') s
      , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document")
      $ either
          (\_ -> Butcher.Failure Nothing)
          (\lconf -> Butcher.Success (mempty { _conf_layout = lconf }) "")
      . Data.Yaml.decodeEither'
      . 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
    let disableFormatting = do
          Butcher.addCmdImpl
            ( InlineConfigTargetModule
            , mempty { _conf_disable_formatting = pure $ pure True }
            )
    Butcher.addCmd "-disable" disableFormatting
    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)