Cases.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | What the benchmarks of formatting measure: formatting a fixed sample of
-- the Hackage corpus and checking what that printed, and formatting modules
-- made to stress one part of the formatter each.
module Tilia.Bench.Cases
  ( Stage (..),
    stageName,
    Benchmark (..),
    Subject (..),
    corpusSubjects,
    syntheticSubjects,
  )
where

import Data.ByteString qualified as BS
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding (decodeUtf8')
import Data.Traversable (for)
import GHC.LanguageExtensions.Type (Extension)
import Tilia.Corpus (Example (..))
import Tilia.Cpp (usesCpp)
import Tilia.Format (rewritten)
import Tilia.Parser (parseModule)
import Tilia.TestConfig (formatCppExample, printExample)
import Tilia.TestUtils (effectiveExtensionsFor, parserConfigFor)

-- | What part of a run a benchmark measures.
data Stage
  = -- | Formatting a module.
    Format
  | -- | Checking that what formatting printed is the program it was given,
    -- as @--check-ast@ does.
    Check
  | -- | Reading what the modules of a package establish out of its tarball.
    Resolve
  | -- | The same, out of a cache that an earlier reading filled.
    Recall
  | -- | Decoding the interfaces of a package.
    Decode

-- | A stage, as the record and the report spell it.
stageName :: Stage -> Text
stageName = \case
  Format -> "format"
  Check -> "check"
  Resolve -> "resolve"
  Recall -> "recall"
  Decode -> "decode"

-- | A benchmark of something other than formatting a module.
data Benchmark = Benchmark
  { -- | What it measures.
    benchmarkStage :: Stage,
    -- | What it measures that on.
    benchmarkName :: Text,
    -- | Set one run up, giving the work, which says how much it computed.
    benchmarkRun :: IO (IO Int)
  }

-- | A module the benchmarks format, and check where they check it.
data Subject = Subject
  { -- | Its name in the corpus, or the stress it makes.
    subjectName :: Text,
    -- | The module.
    subjectSource :: Text,
    -- | Format it, or 'Nothing' where it is declined.
    subjectFormat :: Text -> Maybe Text,
    -- | Check what formatting it printed, giving what changed, where it is
    -- checked.
    subjectCheck :: Maybe (Text -> Maybe Text)
  }

-- | The corpus modules formatted and checked, by the name the corpus gives
-- them: middling ones from many packages, a few with conditionals among
-- them.
checked :: [FilePath]
checked =
  [ "haxl-2.5.1.1/Haxl/Core/Monad.hs",
    "vector-0.13.2.0/src/Data/Vector/Generic.hs",
    "aeson-2.3.1.0/src/Data/Aeson/KeyMap.hs",
    "pandoc-3.10.2/src/Text/Pandoc/Class/PandocPure.hs",
    "lifted-base-0.2.3.12/Control/Exception/Lifted.hs",
    "text-2.1.4/tests/Tests/Properties/Folds.hs",
    "ShellCheck-0.11.0/src/ShellCheck/Analytics.hs",
    "Agda-2.8.0/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs",
    "idris-1.3.4/src/Idris/Elab/Term.hs",
    "pandoc-3.10.2/src/Text/Pandoc/Writers/Powerpoint/Output.hs",
    "purescript-0.15.15/src/Language/PureScript/Errors.hs",
    "pandoc-3.10.2/src/Text/Pandoc/Readers/Markdown.hs",
    "esqueleto-3.6.0.3/test/PostgreSQL/Test.hs",
    "unpacked-containers-0/src/Map/Internal.hs",
    "purescript-0.15.15/src/Language/PureScript/TypeChecker/Types.hs",
    "distributed-process-0.7.8/src/Control/Distributed/Process/Node.hs",
    "servant-server-0.20.3.0/src/Servant/Server/Internal.hs",
    "brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal\
    \/Transformations/Alt.hs",
    "xmonad-0.18.1/src/XMonad/Operations.hs",
    "swagger2-2.9.1/src/Data/Swagger/Internal.hs",
    "time-1.16.0.1/test/main/Test/Format/ParseTime.hs",
    "optparse-applicative-0.19.0.0/tests/test.hs",
    "blaze-html-0.9.2.0/src/Text/Blaze/Html5/Attributes.hs",
    "tls-2.4.3/Network/TLS/Extension.hs",
    "recursion-schemes-5.2.3/src/Data/Functor/Foldable.hs",
    "megaparsec-9.8.1/Text/Megaparsec/Internal.hs"
  ]

-- | The corpus modules only formatted: the largest ones, whose checks would
-- take most of the time.
formattedOnly :: [FilePath]
formattedOnly =
  [ "QuickCheck-2.18.0.0/src/Test/QuickCheck/Arbitrary.hs",
    "unordered-containers-0.2.21/Data/HashMap/Internal.hs",
    "lens-5.3.6/src/Control/Lens/Wrapped.hs",
    "text-2.1.4/src/Data/Text/Internal/Fusion/CaseMapping.hs"
  ]

-- | The modules of the corpus measured, or which one the corpus does not
-- have.
corpusSubjects :: [Example] -> IO (Either Text [Subject])
corpusSubjects examples =
  sequence
    <$> for
      (fmap (,True) checked <> fmap (,False) formattedOnly)
      (uncurry load)
  where
    byName = Map.fromList [(exampleName e, e) | e <- examples]
    load name isChecked = case Map.lookup name byName of
      Nothing -> pure (Left ("the corpus has no " <> T.pack name))
      Just example -> do
        bytes <- BS.readFile (exampleInput example)
        pure $ case decodeUtf8' bytes of
          Left _ -> Left (T.pack name <> " is not valid UTF-8")
          Right source ->
            Right $
              subjectOf
                (exampleExtensions example)
                isChecked
                (T.pack name)
                source

-- | Modules made to stress one part of the formatter each.
syntheticSubjects :: [Subject]
syntheticSubjects =
  [ subjectOf Nothing False "synthetic/comments" commented,
    subjectOf Nothing False "synthetic/imports" imported,
    subjectOf Nothing False "synthetic/conditionals" conditional,
    subjectOf Nothing False "synthetic/nesting" nested
  ]
  where
    commented =
      T.unlines $
        ["module Commented where", ""]
          <> concat
            [ [ "-- | The function number " <> n <> ", which is documented.",
                "f" <> n <> " :: Int -> Int -- the type",
                "f" <> n <> " x =",
                "  {- a block comment -} x + " <> n <> " -- an end-of-line one",
                ""
              ]
            | n <- numbers 1500
            ]
    imported =
      T.unlines $
        ["module Imported where", ""]
          <> [ "import M" <> m <> " (f" <> n <> ", T" <> n <> " (..))"
             | n <- numbers 4,
               m <- numbers 250
             ]
          <> ["", "x :: Int", "x = 1"]
    conditional =
      T.unlines $
        ["{-# LANGUAGE CPP #-}", "module Conditional where", ""]
          <> concat
            [ [ "#ifdef FLAG" <> n,
                "g" <> n <> " :: Int",
                "g" <> n <> " = " <> n,
                "#else",
                "g" <> n <> " :: Integer",
                "g" <> n <> " = " <> n <> " + 1",
                "#endif",
                ""
              ]
            | n <- numbers 24
            ]
    nested =
      T.unlines
        [ "module Nested where",
          "",
          "deep :: Int -> Int",
          "deep x =",
          "  " <> foldr deeper "x" (numbers 40),
          "",
          "wide :: [Int]",
          "wide = [" <> T.intercalate ", " (numbers 5000) <> "]"
        ]
    deeper n e =
      "case x of { " <> n <> " -> (" <> e <> "); _ -> x + " <> n <> " }"
    numbers k = fmap (T.pack . show) [1 :: Int .. k]

-- | A module to format, and to check what that printed where it is
-- checked.
subjectOf :: Maybe [Extension] -> Bool -> Text -> Text -> Subject
subjectOf package isChecked name source =
  Subject
    { subjectName = name,
      subjectSource = source,
      subjectFormat = formatted package path,
      subjectCheck =
        if isChecked
          then Just (fst . rewritten parser cpp path (source, tree))
          else Nothing
    }
  where
    path = T.unpack name
    parser = parserConfigFor package
    cpp = usesCpp (effectiveExtensionsFor package source) source
    tree
      | cpp = Nothing
      | otherwise = either (const Nothing) Just (parseModule parser path source)

-- | What formatting a module prints, as the corpus does it, or 'Nothing'
-- where it is declined.
formatted :: Maybe [Extension] -> FilePath -> Text -> Maybe Text
formatted package path source
  | usesCpp (effectiveExtensionsFor package source) source =
      either (const Nothing) Just (formatCppExample package path source)
  | otherwise =
      either
        (const Nothing)
        (Just . printExample package source)
        (parseModule (parserConfigFor package) path source)