packages feed

aihc-parser (empty) → 1.0.0.2

raw patch · 1674 files changed

+43031/−0 lines, 1674 filesdep +Cabal-syntaxdep +Diffdep +QuickCheck

Dependencies added: Cabal-syntax, Diff, QuickCheck, aeson, aihc-cpp, aihc-hackage, base, bytestring, containers, deepseq, directory, filepath, ghc-lib-parser, haskell-src-exts, megaparsec, optparse-applicative, prettyprinter, process, tasty, tasty-hunit, tasty-quickcheck, template-haskell, text, yaml

Files

+ CHANGELOG.md view
@@ -0,0 +1,36 @@+# Changelog++All notable changes to `aihc-parser` will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/).++## [Unreleased]++## [1.0.0.2] - 2026-05-28++### Fixed++- Removed the internal `parser-tooling-common` and `parser-test-support`+  sublibraries from the published Cabal package so Hackage exposes only the+  core `aihc-parser` library.++## [1.0.0.1] - 2026-05-28++### Fixed++- Removed internal progress executables from the published Cabal package so+  Hackage lists `aihc-parser` as library-only.+- Included parser fixture files in the source distribution so Hackage can run+  the package test suite and report coverage.++## [1.0.0.0] - 2026-05-27++### Added++- Initial stable release of the from-scratch Haskell parser package.+- Public parser, lexer, syntax, pretty-printer, shorthand, token, and+  parenthesis-insertion modules.+- Oracle-backed parser validation against GHC with parse/pretty round-trip+  fingerprint checks.+- Haskell2010 and extension coverage tracking, including the current fully+  implemented Haskell2010 baseline and supported tracked extensions.
+ LICENSE view
@@ -0,0 +1,24 @@+This is free and unencumbered software released into the public domain.++Anyone is free to copy, modify, publish, use, compile, sell, or+distribute this software, either in source code form or as a compiled+binary, for any purpose, commercial or non-commercial, and by any+means.++In jurisdictions that recognize copyright laws, the author or authors+of this software dedicate any and all copyright interest in the+software to the public domain. We make this dedication for the benefit+of the public at large and to the detriment of our heirs and+successors. We intend this dedication to be an overt act of+relinquishment in perpetuity of all present and future rights to this+software under copyright law.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.++For more information, please refer to <https://unlicense.org>
+ aihc-parser.cabal view
@@ -0,0 +1,180 @@+cabal-version: 3.8+name: aihc-parser+version: 1.0.0.2+build-type: Simple+license: Unlicense+license-file: LICENSE+extra-doc-files: CHANGELOG.md+extra-source-files:+  test/Test/Fixtures/**/*.hs+  test/Test/Fixtures/**/*.yaml++author: David Himmelstrup+maintainer: lemmih@gmail.com+category: Development+synopsis: Haskell parser+description:+  A from-scratch Haskell parser with lexer, syntax tree, and pretty-printer.+  The package is validated with golden tests and oracle-backed differential+  tests against GHC.++homepage: https://github.com/ai-haskell-compiler/aihc/tree/main/components/aihc-parser+bug-reports: https://github.com/ai-haskell-compiler/aihc/issues++source-repository head+  type: git+  location: https://github.com/ai-haskell-compiler/aihc.git+  subdir: components/aihc-parser++library+  exposed-modules:+    Aihc.Parser+    Aihc.Parser.Parens+    Aihc.Parser.Pretty+    Aihc.Parser.Shorthand+    Aihc.Parser.Syntax+    Aihc.Parser.Token++  other-modules:+    Aihc.Parser.Internal.CheckPattern+    Aihc.Parser.Internal.Cmd+    Aihc.Parser.Internal.Common+    Aihc.Parser.Internal.Decl+    Aihc.Parser.Internal.Errors+    Aihc.Parser.Internal.Expr+    Aihc.Parser.Internal.FromTokens+    Aihc.Parser.Internal.Import+    Aihc.Parser.Internal.Module+    Aihc.Parser.Internal.Pattern+    Aihc.Parser.Internal.Type+    Aihc.Parser.Lex+    Aihc.Parser.Lex.Header+    Aihc.Parser.Lex.Layout+    Aihc.Parser.Lex.Numbers+    Aihc.Parser.Lex.Pragmas+    Aihc.Parser.Lex.Quoted+    Aihc.Parser.Lex.Trivia+    Aihc.Parser.Lex.Types+    Aihc.Parser.Types++  hs-source-dirs: src+  build-depends:+    base >=4.16 && <5,+    bytestring >=0.10.8 && <0.13,+    containers >=0.5 && <0.8,+    deepseq >=1.4 && <1.6,+    megaparsec >=9.0 && <10,+    prettyprinter >=1.7 && <1.8,+    text >=1.2 && <2.2,++  ghc-options: -Wall+  default-language: GHC2021++test-suite spec+  type: exitcode-stdio-1.0+  hs-source-dirs:+    test+    common+    src++  main-is: Spec.hs+  other-modules:+    Aihc.Parser+    Aihc.Parser.Internal.CheckPattern+    Aihc.Parser.Internal.Cmd+    Aihc.Parser.Internal.Common+    Aihc.Parser.Internal.Decl+    Aihc.Parser.Internal.Errors+    Aihc.Parser.Internal.Expr+    Aihc.Parser.Internal.FromTokens+    Aihc.Parser.Internal.Import+    Aihc.Parser.Internal.Module+    Aihc.Parser.Internal.Pattern+    Aihc.Parser.Internal.Type+    Aihc.Parser.Lex+    Aihc.Parser.Lex.Header+    Aihc.Parser.Lex.Layout+    Aihc.Parser.Lex.Numbers+    Aihc.Parser.Lex.Pragmas+    Aihc.Parser.Lex.Quoted+    Aihc.Parser.Lex.Trivia+    Aihc.Parser.Lex.Types+    Aihc.Parser.Parens+    Aihc.Parser.Pretty+    Aihc.Parser.Shorthand+    Aihc.Parser.Syntax+    Aihc.Parser.Token+    Aihc.Parser.Types+    CppSupport+    ExtensionSupport+    GhcOracle+    HackageSupport+    HackageTester.CLI+    HackageTester.Model+    HseExtensions+    LexerGolden+    ParserEquivalent+    ParserErrorGolden+    ParserGolden+    ParserValidation+    ShrinkUtils+    StackageProgress.Summary+    Test.ErrorMessages.Suite+    Test.ExtensionMapping.Suite+    Test.HackageTester.Suite+    Test.Lexer.Suite+    Test.Oracle.Suite+    Test.Parser.Suite+    Test.Performance.Suite+    Test.Properties.Arb.Decl+    Test.Properties.Arb.Expr+    Test.Properties.Arb.Identifiers+    Test.Properties.Arb.Module+    Test.Properties.Arb.Pattern+    Test.Properties.Arb.Type+    Test.Properties.Arb.Utils+    Test.Properties.Coverage+    Test.Properties.DeclRoundTrip+    Test.Properties.ExprRoundTrip+    Test.Properties.MinimalParentheses+    Test.Properties.ModuleRoundTrip+    Test.Properties.NoExceptions+    Test.Properties.ParensIdempotency+    Test.Properties.PatternRoundTrip+    Test.Properties.ShorthandSubset+    Test.Properties.TypeRoundTrip+    Test.StackageProgress.Summary++  build-depends:+    Cabal-syntax >=3.14 && <3.17,+    Diff >=1.0 && <1.1,+    QuickCheck >=2.14 && <2.19,+    aeson >=2.0 && <2.3,+    aihc-cpp >=1.0 && <1.1,+    aihc-hackage >=0.1 && <0.2,+    base >=4.16 && <5,+    bytestring >=0.10.8 && <0.13,+    containers >=0.5 && <0.8,+    deepseq >=1.4 && <1.6,+    directory >=1.2.3 && <1.5,+    filepath >=1.3.0.1 && <1.6,+    ghc-lib-parser >=9.14.1 && <9.15,+    haskell-src-exts >=1.23 && <1.24,+    megaparsec >=9.0 && <10,+    optparse-applicative >=0.16 && <0.19,+    prettyprinter >=1.7 && <1.8,+    process >=1.6 && <1.7,+    tasty >=1.5 && <1.6,+    tasty-hunit >=0.10 && <0.11,+    tasty-quickcheck >=0.11.1 && <0.12,+    template-haskell >=2.18 && <2.24,+    text >=1.2 && <2.2,+    yaml >=0.11 && <0.12,++  ghc-options:+    -Wall+    -threaded+    -rtsopts+    -with-rtsopts=-N++  default-language: GHC2021
+ common/CppSupport.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE OverloadedStrings #-}++module CppSupport+  ( preprocessForParser,+    preprocessForParserIfEnabled,+    preprocessForParserWithoutIncludes,+    preprocessForParserWithoutIncludesIfEnabled,+    moduleHeaderExtensionSettings,+    moduleHeaderPragmas,+    cppEnabledInSource,+  )+where++import Aihc.Cpp+  ( Config (..),+    IncludeRequest (..),+    Result (..),+    Step (..),+    defaultConfig,+    preprocess,+  )+import Aihc.Hackage.Cpp qualified as HackageCpp+import Aihc.Parser.Syntax (Extension (CPP), ExtensionSetting (..), ModuleHeaderPragmas (..))+import Aihc.Parser.Token (readModuleHeaderExtensions, readModuleHeaderPragmas)+import Data.ByteString (ByteString)+import Data.Char (toLower)+import Data.Functor.Identity (Identity (..), runIdentity)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import System.FilePath (takeExtension)++preprocessForParser :: (Monad m) => FilePath -> [Text] -> (IncludeRequest -> m (Maybe ByteString)) -> Text -> m Result+preprocessForParser inputFile deps resolveInclude source =+  preprocessForParserWithCppOptions [] inputFile deps resolveInclude (normalizeSourceForParser inputFile source)++preprocessForParserWithCppOptions :: (Monad m) => [String] -> FilePath -> [Text] -> (IncludeRequest -> m (Maybe ByteString)) -> Text -> m Result+preprocessForParserWithCppOptions cppOptions inputFile deps resolveInclude source = do+  let minVersionMacros = HackageCpp.minVersionMacroNamesFromDeps deps+  let injected = HackageCpp.injectSyntheticCppMacros cppOptions minVersionMacros source+  let cfg =+        defaultConfig+          { configInputFile = inputFile,+            configMacros = HackageCpp.cppMacrosFromOptions cppOptions+          }+  drive (preprocess cfg (TE.encodeUtf8 injected))+  where+    drive (Done result) = pure result+    drive (NeedInclude req k) = resolveInclude req >>= drive . k++preprocessForParserWithoutIncludes :: FilePath -> [Text] -> Text -> Result+preprocessForParserWithoutIncludes inputFile deps source =+  runIdentity (preprocessForParser inputFile deps (\_ -> Identity Nothing) source)++preprocessForParserIfEnabled :: (Monad m) => [ExtensionSetting] -> [String] -> FilePath -> [Text] -> (IncludeRequest -> m (Maybe ByteString)) -> Text -> m Result+preprocessForParserIfEnabled globalExtensionNames cppOptions inputFile deps resolveInclude source =+  let normalizedSource = normalizeSourceForParser inputFile source+      shouldPreprocess = cppEnabledInSourceWithGlobals globalExtensionNames normalizedSource+   in if shouldPreprocess+        then preprocessForParserWithCppOptions cppOptions inputFile deps resolveInclude normalizedSource+        else pure Result {resultOutput = normalizedSource, resultDiagnostics = []}++preprocessForParserWithoutIncludesIfEnabled :: [ExtensionSetting] -> [String] -> FilePath -> [Text] -> Text -> Result+preprocessForParserWithoutIncludesIfEnabled globalExtensionNames cppOptions inputFile deps source =+  runIdentity (preprocessForParserIfEnabled globalExtensionNames cppOptions inputFile deps (\_ -> Identity Nothing) source)++moduleHeaderExtensionSettings :: Text -> [ExtensionSetting]+moduleHeaderExtensionSettings = readModuleHeaderExtensions++moduleHeaderPragmas :: Text -> ModuleHeaderPragmas+moduleHeaderPragmas = readModuleHeaderPragmas++cppEnabledInSource :: Text -> Bool+cppEnabledInSource = cppEnabledInSettings . moduleHeaderExtensionSettings++cppEnabledInSourceWithGlobals :: [ExtensionSetting] -> Text -> Bool+cppEnabledInSourceWithGlobals globalExtensionNames source =+  cppEnabledInSettings globalExtensionNames+    || cppEnabledInSettings (moduleHeaderExtensionSettings source)++cppEnabledInSettings :: [ExtensionSetting] -> Bool+cppEnabledInSettings = foldl apply False+  where+    apply enabled setting =+      case setting of+        EnableExtension CPP -> True+        DisableExtension CPP -> False+        _ -> enabled++normalizeSourceForParser :: FilePath -> Text -> Text+normalizeSourceForParser inputFile =+  unliterateIfNeeded inputFile . stripLeadingBom++stripLeadingBom :: Text -> Text+stripLeadingBom txt =+  fromMaybe txt (T.stripPrefix "\xfeff" txt)++unliterateIfNeeded :: FilePath -> Text -> Text+unliterateIfNeeded inputFile source+  | map toLower (takeExtension inputFile) /= ".lhs" = source+  | otherwise =+      let ls = T.lines source+       in if any (\line -> T.strip line == "\\begin{code}") ls+            then T.unlines (unlitLatex False ls)+            else T.unlines (map unlitBirdLine ls)+  where+    -- Replace the leading '>' with a space instead of stripping it.+    -- This preserves original column positions, which is critical for+    -- layout-sensitive parsing when tabs are present.  Stripping "> "+    -- shifts columns by 2, but tab stops depend on absolute column+    -- position, so tab-aligned code and space-aligned code would end+    -- up at different columns after the shift.+    unlitBirdLine line =+      case T.stripPrefix ">" line of+        Just _rest -> " " <> _rest+        Nothing -> ""++    unlitLatex _ [] = []+    unlitLatex inCode (line : rest)+      | T.strip line == "\\begin{code}" = "" : unlitLatex True rest+      | T.strip line == "\\end{code}" = "" : unlitLatex False rest+      | inCode = line : unlitLatex inCode rest+      | otherwise = "" : unlitLatex inCode rest
+ common/ExtensionSupport.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedStrings #-}++module ExtensionSupport+  ( Expected (..),+    Outcome (..),+    CaseMeta (..),+    oracleFixtureRoot,+    caseSourcePath,+    caseEnabledExtensionNames,+    loadOracleCases,+    classifyOutcome,+    finalizeOutcome,+    evaluateCaseFromFile,+    evaluateCaseText,+  )+where++import Aihc.Cpp (resultOutput)+import Aihc.Parser.Syntax qualified as Syntax+import CppSupport (moduleHeaderExtensionSettings, preprocessForParserWithoutIncludesIfEnabled)+import Data.Char (isSpace)+import Data.List (dropWhileEnd, sort, sortOn)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO.Utf8 qualified as Utf8+import GhcOracle (oracleModuleAstFingerprint)+import ParserValidation (validateParser)+import System.Directory (doesDirectoryExist, listDirectory)+import System.FilePath (dropExtension, makeRelative, takeDirectory, takeExtension, (</>))++data Expected = ExpectPass | ExpectXFail deriving (Eq, Show)++data Outcome = OutcomePass | OutcomeXFail | OutcomeXPass | OutcomeFail deriving (Eq, Show)++data CaseMeta = CaseMeta+  { caseId :: !String,+    caseCategory :: !String,+    casePath :: !FilePath,+    caseExpected :: !Expected,+    caseReason :: !String,+    caseExtensions :: ![Syntax.ExtensionSetting]+  }+  deriving (Eq, Show)++oracleFixtureRoot :: FilePath+oracleFixtureRoot = "test/Test/Fixtures/oracle"++caseSourcePath :: CaseMeta -> FilePath+caseSourcePath meta = oracleFixtureRoot </> casePath meta++caseEnabledExtensionNames :: CaseMeta -> [Text]+caseEnabledExtensionNames meta =+  [Syntax.extensionName ext | Syntax.EnableExtension ext <- caseExtensions meta]++loadOracleCases :: IO [CaseMeta]+loadOracleCases = do+  files <- listFixtureFiles oracleFixtureRoot+  cases <- mapM (loadCaseMeta dir) files+  pure (sortOn casePath cases)+  where+    dir = oracleFixtureRoot++classifyOutcome :: Expected -> Maybe Text -> Maybe String -> (Outcome, String)+classifyOutcome _expected (Just oracleErr) _roundtripOk = (OutcomeFail, T.unpack oracleErr)+classifyOutcome ExpectPass Nothing (Just err) = (OutcomeFail, err)+classifyOutcome ExpectPass Nothing Nothing = (OutcomePass, "")+classifyOutcome ExpectXFail Nothing (Just err) = (OutcomeXFail, err)+classifyOutcome ExpectXFail Nothing Nothing = (OutcomeXPass, "test case passed unexpectedly. Maybe update testcase from xfail to pass.")++finalizeOutcome :: CaseMeta -> Maybe Text -> Maybe String -> (CaseMeta, Outcome, String)+finalizeOutcome meta oracleOk roundtripOk =+  let (outcome, details) = classifyOutcome (caseExpected meta) oracleOk roundtripOk+   in (meta, outcome, details)++evaluateCaseFromFile :: CaseMeta -> IO (CaseMeta, Outcome, String)+evaluateCaseFromFile meta = do+  source <- Utf8.readFile (caseSourcePath meta)+  pure (evaluateCaseText meta source)++evaluateCaseText :: CaseMeta -> Text -> (CaseMeta, Outcome, String)+evaluateCaseText meta source =+  let exts = caseExtensions meta+      source' =+        resultOutput+          ( preprocessForParserWithoutIncludesIfEnabled+              (caseExtensions meta)+              []+              (casePath meta)+              []+              source+          )+      oracleOk = either Just (const Nothing) (oracleModuleAstFingerprint (casePath meta) Syntax.Haskell2010Edition exts source')+      validationOk = fmap show (validateParser (casePath meta) Syntax.Haskell2010Edition exts source')+   in finalizeOutcome meta oracleOk validationOk++trim :: String -> String+trim = dropWhile isSpace . dropWhileEnd isSpace++listFixtureFiles :: FilePath -> IO [FilePath]+listFixtureFiles = go+  where+    go dir = do+      entries <- sort <$> listDirectory dir+      concat+        <$> mapM+          ( \entry -> do+              let path = dir </> entry+              isDir <- doesDirectoryExist path+              if isDir+                then go path+                else+                  if takeExtension path == ".hs"+                    then pure [path]+                    else pure []+          )+          entries++loadCaseMeta :: FilePath -> FilePath -> IO CaseMeta+loadCaseMeta root path = do+  source <- Utf8.readFile path+  let (expected, reason) = parseOracleTestBlock path source+      relPath = makeRelative root path+      cid = dropExtension relPath+      categoryRaw = takeDirectory relPath+      category = if categoryRaw == "." then "fixture" else categoryRaw+  pure+    CaseMeta+      { caseId = cid,+        caseCategory = category,+        casePath = relPath,+        caseExpected = expected,+        caseReason = reason,+        caseExtensions = moduleHeaderExtensionSettings source+      }++parseOracleTestBlock :: FilePath -> Text -> (Expected, String)+parseOracleTestBlock path source =+  case extractOracleBlock source of+    Nothing ->+      error ("Fixture is missing an ORACLE_TEST block: " <> path)+    Just block ->+      case T.words block of+        ["pass"] -> (ExpectPass, "")+        ("xfail" : rest) ->+          let reason = trim (T.unpack (T.unwords rest))+           in if null reason+                then error ("ORACLE_TEST xfail case requires a reason in " <> path)+                else (ExpectXFail, reason)+        _ ->+          error+            ( "Invalid ORACLE_TEST block in "+                <> path+                <> " (expected `pass` or `xfail <reason>`): "+                <> T.unpack block+            )++extractOracleBlock :: Text -> Maybe Text+extractOracleBlock source = do+  remainder <- T.stripPrefix "{- ORACLE_TEST" (T.stripStart source)+  let (block, suffix) = T.breakOn "-}" remainder+  if T.null suffix+    then Nothing+    else Just (T.strip block)
+ common/GhcOracle.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module GhcOracle+  ( oracleModuleAstFingerprint,+    oracleModuleAstFingerprintNoCPP,+    parseWithGhcWithExtensions,+    toGhcExtension,+    fromGhcExtension,+  )+where++import Aihc.Cpp (resultOutput)+import Aihc.Parser.Syntax qualified as Syntax+import Aihc.Parser.Token qualified as Token+import Control.Exception (catch, displayException, evaluate)+import CppSupport (preprocessForParserWithoutIncludes)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Data.EnumSet qualified as EnumSet+import GHC.Data.FastString (mkFastString)+import GHC.Data.StringBuffer (stringToStringBuffer)+import GHC.Hs (GhcPs, HsModule)+import GHC.LanguageExtensions.Type qualified as GHC+import GHC.Parser (parseModule)+import GHC.Parser.Lexer+  ( PState,+    ParseResult (..),+    Token (..),+    getPsErrorMessages,+    initParserState,+    lexer,+    mkParserOpts,+    unP,+  )+import GHC.Types.Error (NoDiagnosticOpts (NoDiagnosticOpts), errorsFound)+import GHC.Types.SourceError (SourceError)+import GHC.Types.SrcLoc (Located, mkRealSrcLoc, unLoc)+import GHC.Utils.Error (emptyDiagOpts, pprMessages)+import GHC.Utils.Outputable (ppr, showSDocUnsafe)+import System.IO.Unsafe (unsafePerformIO)+import Prelude hiding (foldl')++-- | Compute an AST fingerprint using extension names and a language edition,+-- reading in-file pragmas to determine the full effective extension set.+oracleModuleAstFingerprint :: String -> Syntax.LanguageEdition -> [Syntax.ExtensionSetting] -> Text -> Either Text Text+oracleModuleAstFingerprint sourceTag edition extNames input =+  let initialPragmas = Token.readModuleHeaderPragmas input+      initialExts = computeEffectiveExtensions edition extNames initialPragmas+      preprocessedInput =+        if Syntax.CPP `elem` initialExts+          then resultOutput (preprocessForParserWithoutIncludes sourceTag [] input)+          else input+   in oracleModuleAstFingerprintNoCPP sourceTag edition extNames preprocessedInput++-- | Compute an AST fingerprint using extension names and a language edition,+-- reading in-file pragmas to determine the full effective extension set.+-- This version does not preprocess the input for CPP.+oracleModuleAstFingerprintNoCPP :: String -> Syntax.LanguageEdition -> [Syntax.ExtensionSetting] -> Text -> Either Text Text+oracleModuleAstFingerprintNoCPP sourceTag edition extNames input =+  let pragmas = Token.readModuleHeaderPragmas input+      exts = computeEffectiveExtensions edition extNames pragmas+      ghcExts = mapMaybe toGhcExtension exts+   in do+        parsed <- parseWithGhcWithExtensions sourceTag ghcExts input+        pure (T.pack (showSDocUnsafe (ppr parsed)))++-- | Parse a module with GHC using the given extensions.+-- The extensions should be the complete set - no base extensions are added.+-- Extension handling (language editions, pragmas, implied extensions) should be done+-- by the caller using aihc-parser infrastructure.+parseWithGhcWithExtensions :: String -> [GHC.Extension] -> Text -> Either Text (HsModule GhcPs)+parseWithGhcWithExtensions sourceTag exts input =+  let opts = mkParserOpts (EnumSet.fromList exts) emptyDiagOpts False False False True+      buffer = stringToStringBuffer (T.unpack input)+      start = mkRealSrcLoc (mkFastString sourceTag) 1 1+   in case catchPureExceptionText $ case unP parseModule (initParserState opts buffer start) of+        POk st modu ->+          if not (parserStateHasErrors st)+            then case firstSignificantTokenAfterModule st of+              Right tok ->+                case unLoc tok of+                  ITeof -> Right (unLoc modu)+                  _ ->+                    Left+                      ( "GHC parser accepted module prefix but left trailing token: "+                          <> T.pack (show tok)+                      )+              Left lexErr ->+                Left+                  ( "GHC lexer failed while checking for trailing tokens: "+                      <> lexErr+                  )+            else Left (renderParserErrors st)+        PFailed st ->+          let rendered = showSDocUnsafe (pprMessages NoDiagnosticOpts (getPsErrorMessages st))+           in Left (T.pack rendered) of+        Left err -> Left ("GHC parser exception: " <> err)+        Right result -> result++firstSignificantTokenAfterModule :: PState -> Either Text (Located Token)+firstSignificantTokenAfterModule st =+  case unP (lexer False pure) st of+    POk st' tok+      | isIgnorableToken (unLoc tok) -> firstSignificantTokenAfterModule st'+      | otherwise -> Right tok+    PFailed st' ->+      Left (T.pack (showSDocUnsafe (pprMessages NoDiagnosticOpts (getPsErrorMessages st'))))++renderParserErrors :: PState -> Text+renderParserErrors st =+  T.pack (showSDocUnsafe (pprMessages NoDiagnosticOpts (getPsErrorMessages st)))++parserStateHasErrors :: PState -> Bool+parserStateHasErrors st = errorsFound (getPsErrorMessages st)++isIgnorableToken :: Token -> Bool+isIgnorableToken tok =+  case tok of+    ITdocComment {} -> True+    ITdocOptions {} -> True+    ITlineComment {} -> True+    ITblockComment {} -> True+    _ -> False++catchPureExceptionText :: a -> Either Text a+catchPureExceptionText value =+  unsafePerformIO $ do+    (Right <$> evaluate value)+      `catch` \(err :: SourceError) ->+        pure (Left (T.pack (displayException err)))+{-# NOINLINE catchPureExceptionText #-}++toGhcExtension :: Syntax.Extension -> Maybe GHC.Extension+toGhcExtension ext =+  case ext of+    Syntax.NondecreasingIndentation ->+      lookupAny ["NondecreasingIndentation", "AlternativeLayoutRule", "AlternativeLayoutRuleTransitional", "RelaxedLayout"]+    _ ->+      lookupAny [toGhcExtensionName ext]+  where+    ghcExtensions = [(show ghcExt, ghcExt) | ghcExt <- [minBound .. maxBound]]+    lookupAny [] = Nothing+    lookupAny (name : names) =+      case lookup name ghcExtensions of+        Just ghcExt -> Just ghcExt+        Nothing -> lookupAny names++    toGhcExtensionName Syntax.CPP = "Cpp"+    toGhcExtensionName Syntax.GeneralizedNewtypeDeriving = "GeneralisedNewtypeDeriving"+    toGhcExtensionName Syntax.SafeHaskell = "Safe"+    toGhcExtensionName Syntax.Trustworthy = "Trustworthy"+    toGhcExtensionName Syntax.UnsafeHaskell = "Unsafe"+    toGhcExtensionName Syntax.Rank2Types = "RankNTypes"+    toGhcExtensionName Syntax.PolymorphicComponents = "RankNTypes"+    toGhcExtensionName other = T.unpack (Syntax.extensionName other)++fromGhcExtension :: GHC.Extension -> Maybe Syntax.Extension+fromGhcExtension ghcExt = Syntax.parseExtensionName (T.pack (show ghcExt))++-- | Compute the effective set of parser extensions from:+-- 1. A default language edition (from cabal file)+-- 2. Extension names from cabal file+-- 3. Module header pragmas (which may override the language edition)+--+-- This is the unified extension computation that should be used by all parsers.+computeEffectiveExtensions ::+  -- | Default language edition (from cabal file)+  Syntax.LanguageEdition ->+  -- | Extension names from cabal file (e.g., ["UnicodeSyntax", "NoFieldSelectors"])+  [Syntax.ExtensionSetting] ->+  -- | Module header pragmas (from readModuleHeaderPragmas)+  Syntax.ModuleHeaderPragmas ->+  -- | Effective set of extensions+  [Syntax.Extension]+computeEffectiveExtensions edition extensionSettings headerPragmas =+  let effectiveEdition = fromMaybe edition (Syntax.headerLanguageEdition headerPragmas)+   in Syntax.effectiveExtensions effectiveEdition (extensionSettings ++ Syntax.headerExtensionSettings headerPragmas)
+ common/HackageSupport.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Thin adapter over "Aihc.Hackage" that converts string-typed results+-- to the rich types used by @aihc-parser@ executables and tests.+module HackageSupport+  ( downloadPackage,+    downloadPackageQuiet,+    downloadPackageQuietWithNetwork,+    findPackageBuildToolDependencyNames,+    findPackageDefaultsToHaskell98,+    findPackageUsesCustomPreprocessor,+    findTargetFilesFromCabal,+    FileInfo (..),+    readTextFileLenient,+    resolveIncludeBestEffort,+    diagToText,+    prefixCppErrors,+  )+where++import Aihc.Cpp (Diagnostic (..), IncludeKind (..), IncludeRequest (..), Severity (..))+import Aihc.Hackage.Cabal qualified as HC+import Aihc.Hackage.Download qualified as HD+import Aihc.Hackage.Types qualified as HT+import Aihc.Hackage.Util qualified as HU+import Aihc.Parser.Syntax qualified as Syntax+import Data.ByteString qualified as BS+import Data.List (nub)+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult)+import Distribution.Types.GenericPackageDescription (GenericPackageDescription)+import System.Directory (doesFileExist)+import System.FilePath (isAbsolute, makeRelative, normalise, splitDirectories, takeDirectory, (</>))++-- | Download a Hackage package with verbose logging.+downloadPackage :: String -> String -> IO FilePath+downloadPackage name version =+  HD.downloadPackage (HT.PackageSpec name version)++-- | Download a Hackage package silently.+downloadPackageQuiet :: String -> String -> IO FilePath+downloadPackageQuiet name version =+  HD.downloadPackageQuiet (HT.PackageSpec name version)++-- | Download a Hackage package, controlling network access.+downloadPackageQuietWithNetwork :: Bool -> String -> String -> IO FilePath+downloadPackageQuietWithNetwork allowNetwork name version =+  HD.downloadPackageWithOptions+    HD.defaultDownloadOptions+      { HD.downloadVerbose = False,+        HD.downloadAllowNetwork = allowNetwork+      }+    (HT.PackageSpec name version)++-- | Rich file info with parser-typed extensions and language.+data FileInfo = FileInfo+  { fileInfoPath :: FilePath,+    fileInfoExtensions :: [Syntax.ExtensionSetting],+    fileInfoCppOptions :: [String],+    fileInfoIncludeDirs :: [FilePath],+    fileInfoLanguage :: Maybe Syntax.LanguageEdition,+    fileInfoDependencies :: [Text]+  }+  deriving (Show)++-- | Find target Haskell source files from a @.cabal@ file.+--+-- Delegates to 'Aihc.Hackage.Cabal.collectComponentFiles' and then converts+-- the string-typed results to the rich types used by @aihc-parser@.+findTargetFilesFromCabal :: FilePath -> IO [FileInfo]+findTargetFilesFromCabal extractedRoot = do+  (gpd, cabalFile) <- parsePackageDescriptionFromRoot extractedRoot+  rawFiles <- HC.collectComponentFiles gpd (takeDirectory cabalFile)+  pure (map convertFileInfo rawFiles)++-- | Find active build-tool dependency names from a package's @.cabal@ file.+findPackageBuildToolDependencyNames :: FilePath -> IO [Text]+findPackageBuildToolDependencyNames extractedRoot = do+  (gpd, _) <- parsePackageDescriptionFromRoot extractedRoot+  pure (HC.buildToolDependencyNames gpd)++-- | Return whether any active library or executable defaults to Haskell98.+findPackageDefaultsToHaskell98 :: FilePath -> IO Bool+findPackageDefaultsToHaskell98 extractedRoot = do+  (gpd, _) <- parsePackageDescriptionFromRoot extractedRoot+  pure (HC.packageDefaultsToHaskell98 gpd)++-- | Find whether active package metadata requests a custom GHC preprocessor.+findPackageUsesCustomPreprocessor :: FilePath -> IO Bool+findPackageUsesCustomPreprocessor extractedRoot = do+  (gpd, _) <- parsePackageDescriptionFromRoot extractedRoot+  pure (HC.packageUsesCustomPreprocessor gpd)++parsePackageDescriptionFromRoot :: FilePath -> IO (GenericPackageDescription, FilePath)+parsePackageDescriptionFromRoot extractedRoot = do+  cabalFiles <- HU.findCabalFiles extractedRoot+  cabalFile <-+    case cabalFiles of+      [file] -> pure file+      [] ->+        ioError+          ( userError+              ("No .cabal file found under extracted package root: " ++ extractedRoot)+          )+      files -> pure (HU.chooseBestCabalFile extractedRoot files)+  cabalBytes <- BS.readFile cabalFile+  let (_, parseResult) = runParseResult (parseGenericPackageDescription cabalBytes)+  gpd <-+    case parseResult of+      Right parsed -> pure parsed+      Left (_, errs) ->+        ioError+          ( userError+              ("Failed to parse cabal file " ++ cabalFile ++ ": " ++ show errs)+          )+  pure (gpd, cabalFile)++-- | Convert a string-typed 'HC.FileInfo' to the rich-typed local 'FileInfo'.+convertFileInfo :: HC.FileInfo -> FileInfo+convertFileInfo raw =+  FileInfo+    { fileInfoPath = HC.fileInfoPath raw,+      fileInfoExtensions = mapMaybe (Syntax.parseExtensionSettingName . T.pack) (HC.fileInfoExtensions raw),+      fileInfoCppOptions = HC.fileInfoCppOptions raw,+      fileInfoIncludeDirs = HC.fileInfoIncludeDirs raw,+      fileInfoLanguage = HC.fileInfoLanguage raw >>= Syntax.parseLanguageEdition . T.pack,+      fileInfoDependencies = HC.fileInfoDependencies raw+    }++readTextFileLenient :: FilePath -> IO Text+readTextFileLenient = HU.readTextFileLenient++resolveIncludeBestEffort :: FilePath -> [FilePath] -> FilePath -> IncludeRequest -> IO (Maybe BS.ByteString)+resolveIncludeBestEffort packageRoot includeDirs currentFile req = do+  firstExisting <- firstExistingPath (includeCandidates packageRoot includeDirs currentFile req)+  case firstExisting of+    Nothing -> pure Nothing+    Just includeFile -> Just <$> BS.readFile includeFile++includeCandidates :: FilePath -> [FilePath] -> FilePath -> IncludeRequest -> [FilePath]+includeCandidates packageRoot includeDirs currentFile req =+  map normalise $ nub [dir </> includePath req | dir <- searchDirs]+  where+    includeDir = takeDirectory (includeFrom req)+    sourceRelDir = takeDirectory (makeRelative packageRoot currentFile)+    packageAncestors = ancestorDirs sourceRelDir+    localRoots =+      [ takeDirectory currentFile,+        packageRoot </> sourceRelDir,+        packageRoot </> includeDir+      ]+    systemRoots =+      includeDirs+        <> [ packageRoot </> "include",+             packageRoot </> "includes",+             packageRoot </> "cbits",+             packageRoot+           ]+    searchDirs =+      case includeKind req of+        IncludeLocal -> localRoots <> map (packageRoot </>) packageAncestors <> systemRoots+        IncludeSystem -> systemRoots <> localRoots <> map (packageRoot </>) packageAncestors++ancestorDirs :: FilePath -> [FilePath]+ancestorDirs path =+  case filter (not . null) (splitDirectories path) of+    [] -> []+    parts ->+      [ foldl (</>) "." (take n parts)+      | n <- [length parts, length parts - 1 .. 1]+      ]++firstExistingPath :: [FilePath] -> IO (Maybe FilePath)+firstExistingPath [] = pure Nothing+firstExistingPath (candidate : rest) = do+  let path = if isAbsolute candidate then candidate else normalise candidate+  exists <- doesFileExist path+  if exists+    then pure (Just path)+    else firstExistingPath rest++diagToText :: Diagnostic -> Text+diagToText diag =+  T.pack (diagFile diag)+    <> ":"+    <> T.pack (show (diagLine diag))+    <> ": "+    <> sev+    <> ": "+    <> diagMessage diag+  where+    sev =+      case diagSeverity diag of+        Warning -> "warning"+        Error -> "error"++prefixCppErrors :: Maybe Text -> Text -> Text+prefixCppErrors cppMsg msg =+  case cppMsg of+    Nothing -> msg+    Just cppText -> "cpp diagnostics:\n" <> cppText <> "\n" <> msg
+ common/HackageTester/CLI.hs view
@@ -0,0 +1,77 @@+module HackageTester.CLI+  ( Options (..),+    optionsParser,+    parseOptionsIO,+    parseOptionsPure,+  )+where++import Options.Applicative qualified as OA++data Options = Options+  { optPackage :: String,+    optVersion :: Maybe String,+    optJobs :: Maybe Int,+    optJson :: Bool,+    optOnlyGhcErrors :: Bool+  }+  deriving (Eq, Show)++parseOptionsIO :: IO Options+parseOptionsIO = OA.execParser parserInfo++parseOptionsPure :: [String] -> Either String Options+parseOptionsPure args =+  case OA.execParserPure OA.defaultPrefs parserInfo args of+    OA.Success opts -> Right opts+    OA.Failure failure ->+      let (msg, _) = OA.renderFailure failure "hackage-tester"+       in Left msg+    OA.CompletionInvoked _ ->+      Left "shell completion requested"++parserInfo :: OA.ParserInfo Options+parserInfo =+  OA.info+    (optionsParser OA.<**> OA.helper)+    ( OA.fullDesc+        <> OA.progDesc "Test parser behavior on a Hackage package"+        <> OA.header "hackage-tester"+    )++optionsParser :: OA.Parser Options+optionsParser =+  Options+    <$> OA.strArgument+      ( OA.metavar "PACKAGE"+          <> OA.help "Hackage package name"+      )+    <*> OA.optional+      ( OA.strOption+          ( OA.long "version"+              <> OA.metavar "VERSION"+              <> OA.help "Exact package version (defaults to latest from Hackage)"+          )+      )+    <*> OA.optional+      ( OA.option+          positiveIntReader+          ( OA.long "jobs"+              <> OA.metavar "N"+              <> OA.help "Number of files to process concurrently (default: CPU cores)"+          )+      )+    <*> OA.switch+      ( OA.long "json"+          <> OA.help "Print final summary as JSON"+      )+    <*> OA.switch+      ( OA.long "only-ghc-errors"+          <> OA.help "Ignore parser/roundtrip errors and report only GHC parse failures"+      )++positiveIntReader :: OA.ReadM Int+positiveIntReader = OA.eitherReader $ \raw ->+  case reads raw of+    [(n, "")] | n > 0 -> Right n+    _ -> Left "must be a positive integer"
+ common/HackageTester/Model.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DeriveGeneric #-}++module HackageTester.Model+  ( Outcome (..),+    FileResult (..),+    Summary (..),+    summarizeResults,+    shouldFailSummary,+    failureLabel,+  )+where++import Data.Aeson (ToJSON)+import Data.Text (Text)+import GHC.Generics (Generic)++data Outcome+  = OutcomeSuccess+  | OutcomeGhcError+  | OutcomeParseError+  | OutcomeRoundtripFail+  deriving (Eq, Show, Generic)++instance ToJSON Outcome++data FileResult = FileResult+  { filePath :: FilePath,+    outcome :: Outcome,+    cppDiagnostics :: [Text],+    outcomeDetail :: Maybe Text+  }+  deriving (Eq, Show, Generic)++instance ToJSON FileResult++data Summary = Summary+  { totalFiles :: Int,+    ghcErrors :: Int,+    parseErrors :: Int,+    roundtripFails :: Int,+    successCount :: Int,+    failureCount :: Int,+    successRate :: Double+  }+  deriving (Eq, Show, Generic)++instance ToJSON Summary++summarizeResults :: [FileResult] -> Summary+summarizeResults results =+  let total = length results+      ghcErrs = length [() | r <- results, outcome r == OutcomeGhcError]+      parseErrs = length [() | r <- results, outcome r == OutcomeParseError]+      roundtripErrs = length [() | r <- results, outcome r == OutcomeRoundtripFail]+      successes = length [() | r <- results, outcome r == OutcomeSuccess]+      failures = total - successes+      rate =+        if total > 0+          then fromIntegral successes * 100.0 / fromIntegral total+          else 0.0+   in Summary+        { totalFiles = total,+          ghcErrors = ghcErrs,+          parseErrors = parseErrs,+          roundtripFails = roundtripErrs,+          successCount = successes,+          failureCount = failures,+          successRate = rate+        }++shouldFailSummary :: Summary -> Bool+shouldFailSummary summary =+  totalFiles summary == 0 || failureCount summary > 0++failureLabel :: Outcome -> Maybe String+failureLabel out =+  case out of+    OutcomeSuccess -> Nothing+    OutcomeGhcError -> Just "GHC_ERROR"+    OutcomeParseError -> Just "PARSE_ERROR"+    OutcomeRoundtripFail -> Just "ROUNDTRIP_FAIL"
+ common/HseExtensions.hs view
@@ -0,0 +1,59 @@+module HseExtensions+  ( toHseExtension,+    fromHseExtension,+    toHseExtensions,+    toHseExtensionSetting,+    toHseExtensionSettings,+    fromExtensionNames,+    fromParserExtensions,+  )+where++import Aihc.Parser.Syntax qualified as Syntax+import Data.Maybe (listToMaybe, mapMaybe)+import Data.Text qualified as T+import Language.Haskell.Exts qualified as HSE+import Text.Read (readMaybe)++toHseExtension :: Syntax.Extension -> Maybe HSE.Extension+toHseExtension ext =+  HSE.EnableExtension <$> toHseKnownExtension ext++fromHseExtension :: HSE.Extension -> Maybe Syntax.Extension+fromHseExtension hseExt =+  case hseExt of+    HSE.EnableExtension known -> Syntax.parseExtensionName (T.pack (show known))+    HSE.DisableExtension known -> Syntax.parseExtensionName (T.pack (show known))+    HSE.UnknownExtension name -> Syntax.parseExtensionName (T.pack name)++toHseExtensions :: [Syntax.Extension] -> [HSE.Extension]+toHseExtensions = mapMaybe toHseExtension++toHseExtensionSetting :: Syntax.ExtensionSetting -> Maybe HSE.Extension+toHseExtensionSetting setting =+  case setting of+    Syntax.EnableExtension ext -> toHseExtension ext+    Syntax.DisableExtension ext -> HSE.DisableExtension <$> toHseKnownExtension ext++toHseExtensionSettings :: [Syntax.ExtensionSetting] -> [HSE.Extension]+toHseExtensionSettings = mapMaybe toHseExtensionSetting++fromExtensionNames :: [String] -> [HSE.Extension]+fromExtensionNames names =+  toHseExtensionSettings (mapMaybe (Syntax.parseExtensionSettingName . T.pack) names)++-- | Convert a list of parser extensions to HSE extensions.+-- This is the preferred way to convert extensions when using unified extension handling.+fromParserExtensions :: [Syntax.Extension] -> [HSE.Extension]+fromParserExtensions = toHseExtensions++toHseKnownExtension :: Syntax.Extension -> Maybe HSE.KnownExtension+toHseKnownExtension ext =+  listToMaybe [known | name <- hseKnownNameCandidates ext, Just known <- [readMaybe name]]++hseKnownNameCandidates :: Syntax.Extension -> [String]+hseKnownNameCandidates ext =+  case ext of+    Syntax.CPP -> ["CPP", "Cpp"]+    Syntax.GeneralizedNewtypeDeriving -> ["GeneralizedNewtypeDeriving", "GeneralisedNewtypeDeriving"]+    _ -> [T.unpack (Syntax.extensionName ext)]
+ common/LexerGolden.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE OverloadedStrings #-}++module LexerGolden+  ( ExpectedStatus (..),+    Outcome (..),+    LexerCase (..),+    fixtureRoot,+    loadLexerCases,+    parseLexerCaseText,+    evaluateLexerCase,+    progressSummary,+  )+where++import Aihc.Parser.Syntax (Extension, FloatType, Pragma (..), PragmaType, parseExtensionName)+import Aihc.Parser.Token+  ( LexToken (..),+    LexTokenKind (..),+    lexModuleTokensWithExtensions,+    lexTokensWithExtensions,+  )+import Data.Aeson ((.!=), (.:), (.:?))+import Data.Aeson.Types (parseEither, withObject)+import Data.Char (isDigit, isSpace, toLower)+import Data.List (dropWhileEnd, isPrefixOf, sort)+import Data.Ratio ((%))+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (encodeUtf8)+import Data.Text.IO.Utf8 qualified as Utf8+import Data.Yaml qualified as Y+import System.Directory (doesDirectoryExist, listDirectory)+import System.FilePath (takeDirectory, takeExtension, (</>))+import Text.Read (readMaybe)++data ExpectedStatus+  = StatusPass+  | StatusXPass+  | StatusXFail+  deriving (Eq, Show)++data Outcome+  = OutcomePass+  | OutcomeXFail+  | OutcomeXPass+  | OutcomeFail+  deriving (Eq, Show)++data LexerCase = LexerCase+  { caseId :: !String,+    caseCategory :: !String,+    casePath :: !FilePath,+    caseIsModule :: !Bool,+    caseExtensions :: ![Extension],+    caseInput :: !Text,+    caseTokens :: ![LexTokenKind],+    caseStatus :: !ExpectedStatus,+    caseReason :: !String+  }+  deriving (Eq, Show)++fixtureRoot :: FilePath+fixtureRoot = "test/Test/Fixtures/lexer"++loadLexerCases :: IO [LexerCase]+loadLexerCases = do+  exists <- doesDirectoryExist fixtureRoot+  if not exists+    then pure []+    else do+      paths <- listFixtureFiles fixtureRoot+      mapM loadLexerCase paths++loadLexerCase :: FilePath -> IO LexerCase+loadLexerCase path = do+  source <- Utf8.readFile path+  case parseLexerCaseText path source of+    Left err -> fail err+    Right parsed -> pure parsed++parseLexerCaseText :: FilePath -> Text -> Either String LexerCase+parseLexerCaseText path source = do+  value <-+    case Y.decodeEither' (encodeUtf8 source) of+      Left err -> Left ("Invalid YAML fixture " <> path <> ": " <> Y.prettyPrintParseException err)+      Right parsed -> Right parsed+  (extNames, inputText, tokenTexts, statusText, reasonText) <- parseYamlFixture path value+  exts <- mapM (parseFixtureExtensionName path) extNames+  toks <- mapM (parseTokenKind path) tokenTexts+  status <- parseStatus path statusText+  reason <- validateReason path status (T.unpack reasonText)+  let relPath = dropRootPrefix path+      category = categoryFromPath relPath+      isModuleFixture = isModulePath relPath+  pure+    LexerCase+      { caseId = relPath,+        caseCategory = category,+        casePath = relPath,+        caseIsModule = isModuleFixture,+        caseExtensions = exts,+        caseInput = inputText,+        caseTokens = toks,+        caseStatus = status,+        caseReason = reason+      }++parseYamlFixture :: FilePath -> Y.Value -> Either String ([Text], Text, [Text], Text, Text)+parseYamlFixture path value =+  case parseEither+    ( withObject "lexer fixture" $ \obj -> do+        exts <- obj .: "extensions"+        inputText <- obj .: "input"+        tokenTexts <- obj .: "tokens"+        statusText <- obj .: "status"+        reasonText <- obj .:? "reason" .!= ""+        pure (exts, inputText, tokenTexts, statusText, reasonText)+    )+    value of+    Left err -> Left ("Invalid lexer fixture schema in " <> path <> ": " <> err)+    Right parsed -> Right parsed++evaluateLexerCase :: LexerCase -> (Outcome, String)+evaluateLexerCase meta =+  let expectedKinds = caseTokens meta+      actualTokens =+        if caseIsModule meta+          then lexModuleTokensWithExtensions (caseExtensions meta) (caseInput meta)+          else lexTokensWithExtensions (caseExtensions meta) (caseInput meta)+      actualKinds = map (normalizeTokKind . lexTokenKind) actualTokens+      tokenMatch = actualKinds == map normalizeTokKind expectedKinds+   in case caseStatus meta of+        StatusPass+          | tokenMatch -> (OutcomePass, "")+          | otherwise ->+              ( OutcomeFail,+                "expected successful lex with matching token kinds"+                  <> detailsSuffix actualKinds expectedKinds+              )+        StatusXFail+          | tokenMatch -> (OutcomeFail, "expected xfail (known failing bug), but tokens now match")+          | otherwise ->+              ( OutcomeXFail,+                "known bug still present"+                  <> detailsSuffix actualKinds expectedKinds+              )+        StatusXPass+          | tokenMatch -> (OutcomeXPass, "known bug still passes unexpectedly")+          | otherwise -> (OutcomeFail, "expected xpass (known passing bug), but tokens no longer match")++progressSummary :: [(LexerCase, Outcome, String)] -> (Int, Int, Int, Int)+progressSummary outcomes =+  ( count OutcomePass,+    count OutcomeXFail,+    count OutcomeXPass,+    count OutcomeFail+  )+  where+    count wanted = length [() | (_, out, _) <- outcomes, out == wanted]++detailsSuffix :: [LexTokenKind] -> [LexTokenKind] -> String+detailsSuffix actual expected =+  if actual == expected+    then ""+    else " (expected=" <> show expected <> ", actual=" <> show actual <> ")"++listFixtureFiles :: FilePath -> IO [FilePath]+listFixtureFiles dir = do+  entries <- sort <$> listDirectory dir+  concat+    <$> mapM+      ( \entry -> do+          let path = dir </> entry+          isDir <- doesDirectoryExist path+          if isDir+            then listFixtureFiles path+            else+              if takeExtension path `elem` [".yaml", ".yml"]+                then pure [path]+                else pure []+      )+      entries++parseFixtureExtensionName :: FilePath -> Text -> Either String Extension+parseFixtureExtensionName path name =+  case parseExtensionName name of+    Just ext -> Right ext+    Nothing -> Left ("Unknown lexer extension in " <> path <> ": " <> T.unpack name)++-- | Parse a TkPragma token from the old fixture format "TkPragma (PragmaXxx ...)".+-- Fixtures don't store pragmaRawText, so it is set to empty string.+parseTkPragmaKind :: Text -> Maybe LexTokenKind+parseTkPragmaKind raw = do+  inner <- T.stripPrefix "TkPragma " (T.strip raw)+  pt <- readMaybe (T.unpack inner) :: Maybe PragmaType+  pure (TkPragma (Pragma {pragmaType = pt, pragmaRawText = ""}))++-- | Normalize a token kind for fixture comparison by clearing pragmaRawText.+normalizeTokKind :: LexTokenKind -> LexTokenKind+normalizeTokKind (TkPragma p) = TkPragma (p {pragmaRawText = ""})+normalizeTokKind tok = tok++parseTokenKind :: FilePath -> Text -> Either String LexTokenKind+parseTokenKind path raw =+  case parseTkPragmaKind (T.strip raw) of+    Just parsed -> Right parsed+    Nothing -> case parseFloatTokenKind (T.strip raw) of+      Just parsed -> Right parsed+      Nothing -> case readMaybe (T.unpack (T.strip raw)) of+        Just parsed -> Right parsed+        Nothing -> Left ("Invalid token constructor in " <> path <> ": " <> T.unpack raw)++parseFloatTokenKind :: Text -> Maybe LexTokenKind+parseFloatTokenKind raw = do+  body <- T.stripPrefix "TkFloat " raw+  let (valueTxt, typeTxt0) = T.break isSpace body+      typeTxt = T.strip typeTxt0+  value <- parseDecimalRational valueTxt+  floatType <- readMaybe (T.unpack typeTxt) :: Maybe FloatType+  pure (TkFloat value floatType)++parseDecimalRational :: Text -> Maybe Rational+parseDecimalRational txt = do+  let (sign, unsigned) =+        case T.uncons txt of+          Just ('-', rest) -> (-1, rest)+          Just ('+', rest) -> (1, rest)+          _ -> (1, txt)+      (mantissaTxt, exponentTxt0) = T.break (`elem` ['e', 'E']) unsigned+      exponentTxt = T.drop 1 exponentTxt0+  mantissa <- parseMantissa mantissaTxt+  exponentValue <-+    if T.null exponentTxt0+      then Just 0+      else readMaybe (T.unpack exponentTxt)+  pure (applyExponent (fromInteger sign * mantissa) exponentValue)++parseMantissa :: Text -> Maybe Rational+parseMantissa txt = do+  let (whole, frac0) = T.break (== '.') txt+      frac = T.drop 1 frac0+  if T.null whole && T.null frac+    then Nothing+    else do+      wholeDigits <- parseDigitsAllowEmpty whole+      fracDigits <- parseDigitsAllowEmpty frac+      let fracScale = 10 ^ T.length frac+      pure ((wholeDigits * fracScale + fracDigits) % fracScale)++parseDigitsAllowEmpty :: Text -> Maybe Integer+parseDigitsAllowEmpty digits+  | T.null digits = Just 0+  | T.all isDigit digits = readMaybe (T.unpack digits)+  | otherwise = Nothing++applyExponent :: Rational -> Integer -> Rational+applyExponent value exponentValue+  | exponentValue >= 0 = value * fromInteger (10 ^ exponentValue)+  | otherwise = value / fromInteger (10 ^ negate exponentValue)++parseStatus :: FilePath -> Text -> Either String ExpectedStatus+parseStatus path raw =+  case map toLower (trim (T.unpack raw)) of+    "pass" -> Right StatusPass+    "xpass" -> Right StatusXPass+    "xfail" -> Right StatusXFail+    _ -> Left ("Invalid [status] in " <> path <> ": " <> T.unpack raw)++validateReason :: FilePath -> ExpectedStatus -> String -> Either String String+validateReason path status reason =+  let trimmed = trim reason+   in case status of+        StatusXFail | null trimmed -> Left ("[reason] is required for xfail status in " <> path)+        StatusXPass | null trimmed -> Left ("[reason] is required for xpass status in " <> path)+        _ -> Right trimmed++dropRootPrefix :: FilePath -> FilePath+dropRootPrefix path =+  maybe path T.unpack (T.stripPrefix (T.pack (fixtureRoot <> "/")) (T.pack path))++categoryFromPath :: FilePath -> String+categoryFromPath path =+  case takeDirectory path of+    "." -> "lexer"+    dir -> dir++isModulePath :: FilePath -> Bool+isModulePath path =+  "module/" `isPrefixOf` path++trim :: String -> String+trim = dropWhile isSpace . dropWhileEnd isSpace
+ common/ParserEquivalent.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE OverloadedStrings #-}++module ParserEquivalent+  ( CaseKind (..),+    ExpectedStatus (..),+    Outcome (..),+    EquivalentCase (..),+    fixtureRoot,+    exprFixtureRoot,+    moduleFixtureRoot,+    declFixtureRoot,+    patternFixtureRoot,+    loadExprCases,+    loadModuleCases,+    loadDeclCases,+    loadPatternCases,+    parseEquivalentCaseText,+    evaluateExprCase,+    evaluateModuleCase,+    evaluateDeclCase,+    evaluatePatternCase,+    progressSummary,+  )+where++import Aihc.Parser+  ( ParseResult (..),+    ParserConfig (..),+    defaultConfig,+    formatParseErrors,+    parseDecl,+    parseExpr,+    parseModule,+    parsePattern,+  )+import Aihc.Parser.Shorthand (Shorthand (..))+import Aihc.Parser.Syntax+  ( Decl,+    Expr (..),+    ExtensionSetting,+    LanguageEdition (Haskell2010Edition),+    Module,+    Pattern (..),+    editionFromExtensionSettings,+    effectiveExtensions,+    parseExtensionSettingName,+    stripAnnotations,+  )+import Data.Aeson ((.!=), (.:), (.:?))+import Data.Aeson.Types (parseEither, withObject)+import Data.Char (isSpace, toLower)+import Data.Data (Data (..))+import Data.List (dropWhileEnd, sort, stripPrefix)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (encodeUtf8)+import Data.Text.IO qualified as TIO+import Data.Yaml qualified as Y+import ParserValidation (stripParens)+import System.Directory (doesDirectoryExist, listDirectory)+import System.FilePath (addTrailingPathSeparator, normalise, takeDirectory, takeExtension, (</>))++data CaseKind = CaseExpr | CaseModule | CaseDecl | CasePattern deriving (Eq, Show)++data ExpectedStatus+  = StatusPass+  | StatusFail+  | StatusXFail+  deriving (Eq, Show)++data Outcome+  = OutcomePass+  | OutcomeXFail+  | OutcomeXPass+  | OutcomeFail+  deriving (Eq, Show)++data EquivalentCase = EquivalentCase+  { caseKind :: !CaseKind,+    caseId :: !String,+    caseCategory :: !String,+    casePath :: !FilePath,+    caseExtensions :: ![ExtensionSetting],+    caseInputs :: ![Text],+    caseStatus :: !ExpectedStatus,+    caseReason :: !String+  }+  deriving (Eq, Show)++fixtureRoot :: FilePath+fixtureRoot = "test/Test/Fixtures/equivalent"++exprFixtureRoot :: FilePath+exprFixtureRoot = fixtureRoot </> "expr"++moduleFixtureRoot :: FilePath+moduleFixtureRoot = fixtureRoot </> "module"++declFixtureRoot :: FilePath+declFixtureRoot = fixtureRoot </> "decl"++patternFixtureRoot :: FilePath+patternFixtureRoot = fixtureRoot </> "pattern"++loadExprCases :: IO [EquivalentCase]+loadExprCases = loadCases CaseExpr exprFixtureRoot++loadModuleCases :: IO [EquivalentCase]+loadModuleCases = loadCases CaseModule moduleFixtureRoot++loadDeclCases :: IO [EquivalentCase]+loadDeclCases = loadCases CaseDecl declFixtureRoot++loadPatternCases :: IO [EquivalentCase]+loadPatternCases = loadCases CasePattern patternFixtureRoot++loadCases :: CaseKind -> FilePath -> IO [EquivalentCase]+loadCases kind root = do+  exists <- doesDirectoryExist root+  if not exists+    then pure []+    else do+      paths <- listFixtureFiles root+      mapM (loadEquivalentCase kind) paths++loadEquivalentCase :: CaseKind -> FilePath -> IO EquivalentCase+loadEquivalentCase kind path = do+  source <- TIO.readFile path+  case parseEquivalentCaseText kind path source of+    Left err -> fail err+    Right parsed -> pure parsed++parseEquivalentCaseText :: CaseKind -> FilePath -> Text -> Either String EquivalentCase+parseEquivalentCaseText kind path source = do+  value <-+    case Y.decodeEither' (encodeUtf8 source) of+      Left err -> Left ("Invalid YAML equivalence fixture " <> path <> ": " <> Y.prettyPrintParseException err)+      Right parsed -> Right parsed+  (extNames, inputTexts, statusText, reasonText) <- parseYamlFixture path value+  exts <- validateExtensions path extNames+  inputs <- validateInputs path inputTexts+  status <- parseStatus path statusText+  reason <- validateReason path status (T.unpack reasonText)+  let relPath = dropRootPrefix path+      category = categoryFromPath relPath+  pure+    EquivalentCase+      { caseKind = kind,+        caseId = relPath,+        caseCategory = category,+        casePath = relPath,+        caseExtensions = exts,+        caseInputs = inputs,+        caseStatus = status,+        caseReason = reason+      }++parseYamlFixture :: FilePath -> Y.Value -> Either String ([Text], [Text], Text, Text)+parseYamlFixture path value =+  case parseEither+    ( withObject "parser equivalence fixture" $ \obj -> do+        exts <- obj .: "extensions"+        inputs <- obj .: "equivalent"+        statusText <- obj .: "status"+        reasonText <- obj .:? "reason" .!= ""+        pure (exts, inputs, statusText, reasonText)+    )+    value of+    Left err -> Left ("Invalid parser equivalence fixture schema in " <> path <> ": " <> err)+    Right parsed -> Right parsed++evaluateExprCase :: EquivalentCase -> (Outcome, String)+evaluateExprCase meta = evaluateEquivalentCase meta parseExprValue++evaluateModuleCase :: EquivalentCase -> (Outcome, String)+evaluateModuleCase meta = evaluateEquivalentCase meta parseModuleValue++evaluateDeclCase :: EquivalentCase -> (Outcome, String)+evaluateDeclCase meta = evaluateEquivalentCase meta parseDeclValue++evaluatePatternCase :: EquivalentCase -> (Outcome, String)+evaluatePatternCase meta = evaluateEquivalentCase meta parsePatternValue++evaluateEquivalentCase ::+  (Eq a, Data a, Shorthand a) =>+  EquivalentCase ->+  (ParserConfig -> Text -> Either String a) ->+  (Outcome, String)+evaluateEquivalentCase meta parseValue =+  case traverse parseOne (zip [(1 :: Int) ..] (caseInputs meta)) of+    Left err -> classifyFailure meta err+    Right parsed -> classifyEquivalence meta parsed+  where+    config = parserConfig meta+    parseOne (ix, inputText) =+      case parseValue config inputText of+        Left err -> Left ("input #" <> show ix <> " failed to parse: " <> err)+        Right ast -> Right (ix, normalize ast)++parseExprValue :: ParserConfig -> Text -> Either String Expr+parseExprValue config source =+  case parseExpr config source of+    ParseOk ast -> Right ast+    ParseErr err -> Left (formatParseErrors (parserSourceName config) (Just source) err)++parseModuleValue :: ParserConfig -> Text -> Either String Module+parseModuleValue config source =+  case parseModule config source of+    ([], ast) -> Right ast+    (errs, _) -> Left (formatParseErrors (parserSourceName config) (Just source) errs)++parseDeclValue :: ParserConfig -> Text -> Either String Decl+parseDeclValue config source =+  case parseDecl config source of+    ParseOk ast -> Right ast+    ParseErr err -> Left (formatParseErrors (parserSourceName config) (Just source) err)++parsePatternValue :: ParserConfig -> Text -> Either String Pattern+parsePatternValue config source =+  case parsePattern config source of+    ParseOk ast -> Right ast+    ParseErr err -> Left (formatParseErrors (parserSourceName config) (Just source) err)++classifyEquivalence :: (Eq a, Shorthand a) => EquivalentCase -> [(Int, a)] -> (Outcome, String)+classifyEquivalence meta parsed =+  case findMismatch parsed of+    Nothing -> classifyEquivalent meta+    Just (expected, actual) -> classifyDifferent meta expected actual++findMismatch :: (Eq a) => [(Int, a)] -> Maybe ((Int, a), (Int, a))+findMismatch [] = Nothing+findMismatch [_] = Nothing+findMismatch (expected : rest) =+  case filter ((/= snd expected) . snd) rest of+    [] -> Nothing+    actual : _ -> Just (expected, actual)++classifyEquivalent :: EquivalentCase -> (Outcome, String)+classifyEquivalent meta =+  case caseStatus meta of+    StatusPass -> (OutcomePass, "")+    StatusFail ->+      ( OutcomeFail,+        "expected non-equivalent inputs but normalized ASTs matched"+      )+    StatusXFail ->+      ( OutcomeXPass,+        "expected xfail (known failing bug), but inputs now normalize to equivalent ASTs"+      )++classifyDifferent :: (Shorthand a) => EquivalentCase -> (Int, a) -> (Int, a) -> (Outcome, String)+classifyDifferent meta expected actual =+  case caseStatus meta of+    StatusPass ->+      ( OutcomeFail,+        equivalenceMismatchDetails expected actual+      )+    StatusFail -> (OutcomePass, "")+    StatusXFail ->+      ( OutcomeXFail,+        "known bug still present: " <> equivalenceMismatchDetails expected actual+      )++classifyFailure :: EquivalentCase -> String -> (Outcome, String)+classifyFailure meta errDetails =+  case caseStatus meta of+    StatusPass ->+      ( OutcomeFail,+        "expected parse success, got parse error: " <> errDetails+      )+    -- StatusFail means the inputs should parse successfully but normalize to+    -- different ASTs; parse errors indicate a malformed equivalence fixture.+    StatusFail ->+      ( OutcomeFail,+        "expected parse success for non-equivalent inputs, got parse error: " <> errDetails+      )+    StatusXFail ->+      ( OutcomeXFail,+        "known bug still present: " <> errDetails+      )++equivalenceMismatchDetails :: (Shorthand a) => (Int, a) -> (Int, a) -> String+equivalenceMismatchDetails (expectedIx, expected) (actualIx, actual) =+  "normalized AST mismatch between input #"+    <> show expectedIx+    <> " and input #"+    <> show actualIx+    <> " (expected shorthand="+    <> show (shorthand expected)+    <> ", actual shorthand="+    <> show (shorthand actual)+    <> ")"++normalize :: (Data a) => a -> a+normalize = stripParens . stripAnnotations++parserConfig :: EquivalentCase -> ParserConfig+parserConfig meta =+  defaultConfig+    { parserSourceName = casePath meta,+      parserExtensions = effectiveExtensions edition (caseExtensions meta)+    }+  where+    edition = fromMaybe Haskell2010Edition (editionFromExtensionSettings (caseExtensions meta))++progressSummary :: [(EquivalentCase, Outcome, String)] -> (Int, Int, Int, Int)+progressSummary outcomes =+  ( count OutcomePass,+    count OutcomeXFail,+    count OutcomeXPass,+    count OutcomeFail+  )+  where+    count wanted = length [() | (_, out, _) <- outcomes, out == wanted]++listFixtureFiles :: FilePath -> IO [FilePath]+listFixtureFiles dir = do+  entries <- sort <$> listDirectory dir+  concat+    <$> mapM+      ( \entry -> do+          let path = dir </> entry+          isDir <- doesDirectoryExist path+          if isDir+            then listFixtureFiles path+            else+              if takeExtension path `elem` [".yaml", ".yml"]+                then pure [path]+                else pure []+      )+      entries++validateExtensions :: FilePath -> [Text] -> Either String [ExtensionSetting]+validateExtensions path = traverse parseOne+  where+    parseOne raw =+      case parseExtensionSettingName raw of+        Just setting -> Right setting+        Nothing -> Left ("Unknown parser extension " <> show raw <> " in " <> path)++validateInputs :: FilePath -> [Text] -> Either String [Text]+validateInputs path inputs =+  case inputs of+    [] -> Left ("[equivalent] must contain at least two inputs in " <> path)+    [_] -> Left ("[equivalent] must contain at least two inputs in " <> path)+    _ -> Right inputs++parseStatus :: FilePath -> Text -> Either String ExpectedStatus+parseStatus path raw =+  case map toLower (trim (T.unpack raw)) of+    "pass" -> Right StatusPass+    "fail" -> Right StatusFail+    "xfail" -> Right StatusXFail+    "xpass" -> Left ("xpass is not allowed in " <> path <> ": use xfail instead")+    _ -> Left ("Invalid [status] in " <> path <> ": " <> T.unpack raw)++validateReason :: FilePath -> ExpectedStatus -> String -> Either String String+validateReason path status reason =+  let trimmed = trim reason+   in case status of+        StatusXFail | null trimmed -> Left ("[reason] is required for xfail status in " <> path)+        _ -> Right trimmed++dropRootPrefix :: FilePath -> FilePath+dropRootPrefix path =+  fromMaybe path (stripPrefix prefix normalizedPath)+  where+    prefix = addTrailingPathSeparator (normalise fixtureRoot)+    normalizedPath = normalise path++categoryFromPath :: FilePath -> String+categoryFromPath path =+  case takeDirectory path of+    "." -> "equivalent"+    dir -> dir++trim :: String -> String+trim = dropWhile isSpace . dropWhileEnd isSpace
+ common/ParserErrorGolden.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE OverloadedStrings #-}++module ParserErrorGolden+  ( Outcome (..),+    ErrorMessageCase (..),+    fixtureRoot,+    loadErrorMessageCases,+    parseErrorMessageCaseText,+    evaluateErrorMessageCase,+    progressSummary,+  )+where++import Aihc.Cpp (Result (..))+import Aihc.Parser (ParserConfig (..), defaultConfig, formatParseErrors, parseModule)+import Aihc.Parser.Syntax qualified as Syntax+import CppSupport (cppEnabledInSource, preprocessForParserWithoutIncludes)+import Data.Aeson ((.:))+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (parseEither, withObject)+import Data.Char (toLower)+import Data.List (sort)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (encodeUtf8)+import Data.Text.IO qualified as TIO+import Data.Yaml qualified as Y+import GhcOracle (oracleModuleAstFingerprint)+import System.Directory (doesDirectoryExist, listDirectory)+import System.FilePath (makeRelative, takeDirectory, takeExtension, (</>))++data Outcome+  = OutcomePass+  | OutcomeFail+  deriving (Eq, Show)++data ErrorMessageCase = ErrorMessageCase+  { caseId :: !String,+    caseCategory :: !String,+    casePath :: !FilePath,+    caseSource :: !Text,+    caseExpectedGhc :: !Text,+    caseExpectedAihc :: !Text+  }+  deriving (Eq, Show)++fixtureRoot :: FilePath+fixtureRoot = "test/Test/Fixtures/error-messages"++loadErrorMessageCases :: IO [ErrorMessageCase]+loadErrorMessageCases = do+  exists <- doesDirectoryExist fixtureRoot+  if not exists+    then pure []+    else do+      paths <- listFixtureFiles fixtureRoot+      mapM loadErrorMessageCase paths++loadErrorMessageCase :: FilePath -> IO ErrorMessageCase+loadErrorMessageCase path = do+  source <- TIO.readFile path+  case parseErrorMessageCaseText path source of+    Left err -> fail err+    Right parsed -> pure parsed++parseErrorMessageCaseText :: FilePath -> Text -> Either String ErrorMessageCase+parseErrorMessageCaseText path source = do+  value <-+    case Y.decodeEither' (encodeUtf8 source) of+      Left err -> Left ("Invalid YAML fixture " <> path <> ": " <> Y.prettyPrintParseException err)+      Right parsed -> Right parsed+  (inputText, ghcText, aihcText) <- parseYamlFixture path value+  let relPath = dropRootPrefix path+      category = categoryFromPath relPath+  pure+    ErrorMessageCase+      { caseId = relPath,+        caseCategory = category,+        casePath = relPath,+        caseSource = inputText,+        caseExpectedGhc = normalizeText ghcText,+        caseExpectedAihc = normalizeText aihcText+      }++parseYamlFixture :: FilePath -> Y.Value -> Either String (Text, Text, Text)+parseYamlFixture path value =+  case parseEither+    ( withObject "parser error fixture" $ \obj -> do+        case validateAllowedKeys path obj ["src", "ghc", "aihc"] of+          Left err -> fail err+          Right () -> pure ()+        inputText <- obj .: "src"+        ghcText <- obj .: "ghc"+        aihcText <- obj .: "aihc"+        pure (inputText, ghcText, aihcText)+    )+    value of+    Left err -> Left ("Invalid parser error fixture schema in " <> path <> ": " <> err)+    Right parsed -> Right parsed++evaluateErrorMessageCase :: ErrorMessageCase -> (Outcome, String)+evaluateErrorMessageCase meta =+  case ghcMismatch meta of+    Just details -> (OutcomeFail, details)+    Nothing ->+      case renderAihcMessage meta of+        Left details -> (OutcomeFail, details)+        Right actual+          | actual == caseExpectedAihc meta -> (OutcomePass, "")+          | otherwise ->+              ( OutcomeFail,+                "aihc error mismatch.\nEXPECTED:\n"+                  <> T.unpack (caseExpectedAihc meta)+                  <> "\nACTUAL:\n"+                  <> T.unpack actual+              )++ghcMismatch :: ErrorMessageCase -> Maybe String+ghcMismatch meta =+  case oracleModuleAstFingerprint sourceName Syntax.Haskell2010Edition [] (caseSource meta) of+    Right {} ->+      Just "expected GHC parse failure, but parser accepted the input."+    Left actual+      | normalizeText actual == caseExpectedGhc meta -> Nothing+      | otherwise ->+          Just+            ( "GHC error mismatch. expected="+                <> show (T.unpack (caseExpectedGhc meta))+                <> " actual="+                <> show (T.unpack (normalizeText actual))+            )++renderAihcMessage :: ErrorMessageCase -> Either String Text+renderAihcMessage meta =+  let source = caseSource meta+      preprocessed =+        if cppEnabledInSource source+          then resultOutput (preprocessForParserWithoutIncludes sourceName [] source)+          else source+      (errs, _) = parseModule defaultConfig {parserSourceName = sourceName} preprocessed+   in case errs of+        _ : _ -> Right (normalizeText (T.pack (formatParseErrors sourceName (Just preprocessed) errs)))+        [] -> Left "aihc parser accepted the input"++progressSummary :: [(ErrorMessageCase, Outcome, String)] -> (Int, Int)+progressSummary outcomes =+  ( count OutcomePass,+    count OutcomeFail+  )+  where+    count wanted = length [() | (_, out, _) <- outcomes, out == wanted]++sourceName :: FilePath+sourceName = "test.hs"++normalizeText :: Text -> Text+normalizeText = normalizeLines . dropTrailingNewlines . normalizeLineEndings++normalizeLineEndings :: Text -> Text+normalizeLineEndings = T.replace "\r\n" "\n"++dropTrailingNewlines :: Text -> Text+dropTrailingNewlines = T.dropWhileEnd (`elem` ['\n', '\r'])++normalizeLines :: Text -> Text+normalizeLines = T.intercalate "\n" . map T.stripEnd . T.lines++listFixtureFiles :: FilePath -> IO [FilePath]+listFixtureFiles root = do+  entries <- listDirectory root+  paths <- mapM visit (sort entries)+  pure (concat paths)+  where+    visit name+      | isHidden name = pure []+      | otherwise = do+          let path = root </> name+          isDir <- doesDirectoryExist path+          if isDir+            then listFixtureFiles path+            else pure [path | isYamlFile path]++dropRootPrefix :: FilePath -> FilePath+dropRootPrefix = makeRelative fixtureRoot++categoryFromPath :: FilePath -> String+categoryFromPath relPath =+  case takeDirectory relPath of+    "." -> "error-messages"+    dir -> dir++isYamlFile :: FilePath -> Bool+isYamlFile path =+  let ext = map toLower (takeExtension path)+   in ext == ".yaml" || ext == ".yml"++isHidden :: FilePath -> Bool+isHidden [] = False+isHidden (c : _) = c == '.'++validateAllowedKeys :: FilePath -> KeyMap.KeyMap v -> [Text] -> Either String ()+validateAllowedKeys path obj allowed =+  let allowedSet = sort allowed+      extras =+        sort+          [ Key.toText key+          | key <- KeyMap.keys obj,+            Key.toText key `notElem` allowedSet+          ]+   in case extras of+        [] -> Right ()+        _ -> Left ("Unexpected keys " <> show extras <> " in " <> path)
+ common/ParserGolden.hs view
@@ -0,0 +1,322 @@+{-# LANGUAGE OverloadedStrings #-}++module ParserGolden+  ( CaseKind (..),+    ExpectedStatus (..),+    Outcome (..),+    ParserCase (..),+    fixtureRoot,+    exprFixtureRoot,+    moduleFixtureRoot,+    patternFixtureRoot,+    loadExprCases,+    loadImportCases,+    loadModuleCases,+    loadPatternCases,+    loadPragmaCases,+    parseParserCaseText,+    evaluateExprCase,+    evaluateModuleCase,+    evaluatePatternCase,+    progressSummary,+  )+where++import Aihc.Parser+  ( ParseResult (..),+    ParserConfig (..),+    defaultConfig,+    formatParseErrors,+    parseExpr,+    parseModule,+    parsePattern,+  )+import Aihc.Parser.Shorthand (Shorthand (..))+import Aihc.Parser.Syntax+  ( ExtensionSetting,+    LanguageEdition (Haskell2010Edition),+    editionFromExtensionSettings,+    effectiveExtensions,+    parseExtensionSettingName,+  )+import Data.Aeson ((.!=), (.:), (.:?))+import Data.Aeson.Types (parseEither, withObject)+import Data.Char (isSpace, toLower)+import Data.List (dropWhileEnd, sort)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (encodeUtf8)+import Data.Text.IO qualified as TIO+import Data.Yaml qualified as Y+import System.Directory (doesDirectoryExist, listDirectory)+import System.FilePath (takeDirectory, takeExtension, (</>))++data CaseKind = CaseExpr | CaseModule | CasePattern deriving (Eq, Show)++data ExpectedStatus+  = StatusPass+  | StatusFail+  | StatusXFail+  deriving (Eq, Show)++data Outcome+  = OutcomePass+  | OutcomeXFail+  | OutcomeXPass+  | OutcomeFail+  deriving (Eq, Show)++data ParserCase = ParserCase+  { caseKind :: !CaseKind,+    caseId :: !String,+    caseCategory :: !String,+    casePath :: !FilePath,+    caseExtensions :: ![ExtensionSetting],+    caseInput :: !Text,+    caseAst :: !String,+    caseStatus :: !ExpectedStatus,+    caseReason :: !String+  }+  deriving (Eq, Show)++fixtureRoot :: FilePath+fixtureRoot = "test/Test/Fixtures/golden"++exprFixtureRoot :: FilePath+exprFixtureRoot = fixtureRoot </> "expr"++moduleFixtureRoot :: FilePath+moduleFixtureRoot = fixtureRoot </> "module"++importFixtureRoot :: FilePath+importFixtureRoot = fixtureRoot </> "import"++patternFixtureRoot :: FilePath+patternFixtureRoot = fixtureRoot </> "pattern"++pragmaFixtureRoot :: FilePath+pragmaFixtureRoot = fixtureRoot </> "pragma"++loadExprCases :: IO [ParserCase]+loadExprCases = loadCases CaseExpr exprFixtureRoot++loadImportCases :: IO [ParserCase]+loadImportCases = loadCases CaseModule importFixtureRoot++loadModuleCases :: IO [ParserCase]+loadModuleCases = loadCases CaseModule moduleFixtureRoot++loadPatternCases :: IO [ParserCase]+loadPatternCases = loadCases CasePattern patternFixtureRoot++loadPragmaCases :: IO [ParserCase]+loadPragmaCases = loadCases CaseModule pragmaFixtureRoot++loadCases :: CaseKind -> FilePath -> IO [ParserCase]+loadCases kind root = do+  exists <- doesDirectoryExist root+  if not exists+    then pure []+    else do+      paths <- listFixtureFiles root+      mapM (loadParserCase kind) paths++loadParserCase :: CaseKind -> FilePath -> IO ParserCase+loadParserCase kind path = do+  source <- TIO.readFile path+  case parseParserCaseText kind path source of+    Left err -> fail err+    Right parsed -> pure parsed++parseParserCaseText :: CaseKind -> FilePath -> Text -> Either String ParserCase+parseParserCaseText kind path source = do+  value <-+    case Y.decodeEither' (encodeUtf8 source) of+      Left err -> Left ("Invalid YAML fixture " <> path <> ": " <> Y.prettyPrintParseException err)+      Right parsed -> Right parsed+  (extNames, inputText, astText, statusText, reasonText) <- parseYamlFixture path value+  exts <- validateExtensions path extNames+  status <- parseStatus path statusText+  reason <- validateReason path status (T.unpack reasonText)+  ast <- validateAst path status (T.unpack astText)+  let relPath = dropRootPrefix path+      category = categoryFromPath relPath+  pure+    ParserCase+      { caseKind = kind,+        caseId = relPath,+        caseCategory = category,+        casePath = relPath,+        caseExtensions = exts,+        caseInput = inputText,+        caseAst = ast,+        caseStatus = status,+        caseReason = reason+      }++parseYamlFixture :: FilePath -> Y.Value -> Either String ([Text], Text, Text, Text, Text)+parseYamlFixture path value =+  case parseEither+    ( withObject "parser fixture" $ \obj -> do+        exts <- obj .: "extensions"+        inputText <- obj .: "input"+        astText <- obj .:? "ast" .!= ""+        statusText <- obj .: "status"+        reasonText <- obj .:? "reason" .!= ""+        pure (exts, inputText, astText, statusText, reasonText)+    )+    value of+    Left err -> Left ("Invalid parser fixture schema in " <> path <> ": " <> err)+    Right parsed -> Right parsed++evaluateExprCase :: ParserCase -> (Outcome, String)+evaluateExprCase meta =+  case parseExpr parserConfig (caseInput meta) of+    ParseOk ast -> classifySuccess meta (show (shorthand ast))+    ParseErr err -> classifyFailure meta (formatParseErrors (casePath meta) (Just (caseInput meta)) err)+  where+    edition = fromMaybe Haskell2010Edition (editionFromExtensionSettings (caseExtensions meta))+    parserConfig =+      ( defaultConfig+          { parserSourceName = casePath meta,+            parserExtensions = effectiveExtensions edition (caseExtensions meta)+          }+      )++evaluateModuleCase :: ParserCase -> (Outcome, String)+evaluateModuleCase meta =+  let (errs, ast) = parseModule parserConfig (caseInput meta)+   in if null errs+        then classifySuccess meta (show (shorthand ast))+        else classifyFailure meta (formatParseErrors (casePath meta) (Just (caseInput meta)) errs)+  where+    edition = fromMaybe Haskell2010Edition (editionFromExtensionSettings (caseExtensions meta))+    parserConfig =+      ( defaultConfig+          { parserSourceName = casePath meta,+            parserExtensions = effectiveExtensions edition (caseExtensions meta)+          }+      )++evaluatePatternCase :: ParserCase -> (Outcome, String)+evaluatePatternCase meta =+  case parsePattern parserConfig (caseInput meta) of+    ParseOk ast -> classifySuccess meta (show (shorthand ast))+    ParseErr err -> classifyFailure meta (formatParseErrors (casePath meta) (Just (caseInput meta)) err)+  where+    edition = fromMaybe Haskell2010Edition (editionFromExtensionSettings (caseExtensions meta))+    parserConfig =+      ( defaultConfig+          { parserSourceName = casePath meta,+            parserExtensions = effectiveExtensions edition (caseExtensions meta)+          }+      )++classifySuccess :: ParserCase -> String -> (Outcome, String)+classifySuccess meta actualAst =+  case caseStatus meta of+    StatusPass+      | actualAst == caseAst meta -> (OutcomePass, "")+      | otherwise ->+          ( OutcomeFail,+            "AST mismatch.\nExpected:\n" <> show (caseAst meta) <> "\nActual:\n" <> show actualAst+          )+    StatusFail ->+      ( OutcomeFail,+        "expected parse failure but parser succeeded with AST=" <> actualAst+      )+    StatusXFail+      | null (caseAst meta) ->+          ( OutcomeXPass,+            "expected xfail (known failing bug), but parser succeeded"+          )+      | actualAst == caseAst meta -> (OutcomeXPass, "expected xfail (known failing bug), but parser now produces correct AST")+      | otherwise ->+          ( OutcomeXFail,+            "known bug still present: AST mismatch (expected=" <> show (caseAst meta) <> ", actual=" <> show actualAst <> ")"+          )++classifyFailure :: ParserCase -> String -> (Outcome, String)+classifyFailure meta errDetails =+  case caseStatus meta of+    StatusPass ->+      ( OutcomeFail,+        "expected parse success, got parse error: " <> errDetails+      )+    StatusFail -> (OutcomePass, "")+    StatusXFail ->+      ( OutcomeXFail,+        "known bug still present: " <> errDetails+      )++progressSummary :: [(ParserCase, Outcome, String)] -> (Int, Int, Int, Int)+progressSummary outcomes =+  ( count OutcomePass,+    count OutcomeXFail,+    count OutcomeXPass,+    count OutcomeFail+  )+  where+    count wanted = length [() | (_, out, _) <- outcomes, out == wanted]++listFixtureFiles :: FilePath -> IO [FilePath]+listFixtureFiles dir = do+  entries <- sort <$> listDirectory dir+  concat+    <$> mapM+      ( \entry -> do+          let path = dir </> entry+          isDir <- doesDirectoryExist path+          if isDir+            then listFixtureFiles path+            else+              if takeExtension path `elem` [".yaml", ".yml"]+                then pure [path]+                else pure []+      )+      entries++validateExtensions :: FilePath -> [Text] -> Either String [ExtensionSetting]+validateExtensions path = traverse parseOne+  where+    parseOne raw =+      case parseExtensionSettingName raw of+        Just setting -> Right setting+        Nothing -> Left ("Unknown parser extension " <> show raw <> " in " <> path)++parseStatus :: FilePath -> Text -> Either String ExpectedStatus+parseStatus path raw =+  case map toLower (trim (T.unpack raw)) of+    "pass" -> Right StatusPass+    "fail" -> Right StatusFail+    "xfail" -> Right StatusXFail+    "xpass" -> Left ("xpass is not allowed in " <> path <> ": use xfail instead")+    _ -> Left ("Invalid [status] in " <> path <> ": " <> T.unpack raw)++validateReason :: FilePath -> ExpectedStatus -> String -> Either String String+validateReason path status reason =+  let trimmed = trim reason+   in case status of+        StatusXFail | null trimmed -> Left ("[reason] is required for xfail status in " <> path)+        _ -> Right trimmed++validateAst :: FilePath -> ExpectedStatus -> String -> Either String String+validateAst path status ast =+  let trimmed = trim ast+   in case status of+        StatusPass | null trimmed -> Left ("[ast] is required for pass status in " <> path)+        _ -> Right trimmed++dropRootPrefix :: FilePath -> FilePath+dropRootPrefix path =+  maybe path T.unpack (T.stripPrefix (T.pack (fixtureRoot <> "/")) (T.pack path))++categoryFromPath :: FilePath -> String+categoryFromPath path =+  case takeDirectory path of+    "." -> "golden"+    dir -> dir++trim :: String -> String+trim = dropWhile isSpace . dropWhileEnd isSpace
+ common/ParserValidation.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}++module ParserValidation+  ( ValidationErrorKind (..),+    ValidationError (..),+    formatDiff,+    stripParens,+    validateParser,+  )+where++import Aihc.Parser (ParserConfig (..), defaultConfig, formatParseErrors, parseModule)+import Aihc.Parser.Syntax qualified as Syntax+import Control.DeepSeq (NFData)+import Data.Algorithm.Diff (PolyDiff (..), getDiff)+import Data.Data (Data (..))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Typeable (Typeable, cast)+import GHC.Generics (Generic)+import GhcOracle qualified+import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.Text (renderStrict)++data ValidationErrorKind+  = ValidationParseError+  | ValidationRoundtripError+  deriving (Eq, Show, NFData, Generic)++data ValidationError = ValidationError+  { validationErrorKind :: ValidationErrorKind,+    validationErrorMessage :: String+  }+  deriving (Eq, NFData, Generic)++instance Show ValidationError where+  show ValidationError {validationErrorKind = kind, validationErrorMessage = message} =+    show kind <> ":\n" <> message++-- | Core validation with a caller-supplied fingerprint function.+-- This allows the caller to choose how GHC extensions are determined (e.g. from+-- pre-computed extension lists or by reading in-file pragmas).+validateParser :: String -> Syntax.LanguageEdition -> [Syntax.ExtensionSetting] -> Text -> Maybe ValidationError+validateParser sourceTag edition extensionSettings source =+  let (errs, parsed) = parseModule parserConfig source+   in case errs of+        _ : _ ->+          Just+            ValidationError+              { validationErrorKind = ValidationParseError,+                validationErrorMessage = formatParseErrors sourceTag (Just source) errs+              }+        [] ->+          let rendered = renderStrict (layoutPretty defaultLayoutOptions (pretty parsed))+              sourceAst = fingerprint source+              renderedAst = fingerprint rendered+           in case (sourceAst, renderedAst) of+                (Right sourceFp, Right renderedFp)+                  | sourceFp == renderedFp -> Nothing+                  | otherwise ->+                      Just+                        ValidationError+                          { validationErrorKind = ValidationRoundtripError,+                            validationErrorMessage = formatFingerprintMismatch sourceFp renderedFp+                          }+                (Left sourceErr, Left renderedErr) ->+                  Just+                    ValidationError+                      { validationErrorKind = ValidationRoundtripError,+                        validationErrorMessage =+                          unlines+                            [ "Roundtrip check failed: GHC rejected both module versions.",+                              "Original error:",+                              T.unpack sourceErr,+                              "Roundtripped error:",+                              T.unpack renderedErr+                            ]+                      }+                (Left sourceErr, Right _) ->+                  Just+                    ValidationError+                      { validationErrorKind = ValidationRoundtripError,+                        validationErrorMessage =+                          unlines+                            [ "Roundtrip check failed: GHC rejected the original module.",+                              T.unpack sourceErr+                            ]+                      }+                (Right _, Left renderedErr) ->+                  Just+                    ValidationError+                      { validationErrorKind = ValidationRoundtripError,+                        validationErrorMessage =+                          unlines+                            [ "Roundtrip check failed: GHC rejected the roundtripped module.",+                              T.unpack renderedErr+                            ]+                      }+  where+    finalExts = Syntax.effectiveExtensions edition extensionSettings+    fingerprint = GhcOracle.oracleModuleAstFingerprint sourceTag edition extensionSettings+    parserConfig =+      defaultConfig+        { parserSourceName = sourceTag,+          parserExtensions = finalExts+        }++stripParens :: (Data a) => a -> a+stripParens x = applyStrip (gmapT stripParens x)+  where+    applyStrip :: (Data c) => c -> c+    applyStrip =+      id+        `extT` stripExprParens+        `extT` stripTypeParens+        `extT` stripPatternParens++    stripExprParens :: Syntax.Expr -> Syntax.Expr+    stripExprParens (Syntax.EParen expr) = expr+    stripExprParens expr = expr++    stripTypeParens :: Syntax.Type -> Syntax.Type+    stripTypeParens (Syntax.TParen typ) = typ+    stripTypeParens typ = typ++    stripPatternParens :: Syntax.Pattern -> Syntax.Pattern+    stripPatternParens (Syntax.PParen pat) = pat+    stripPatternParens pat = pat++    extT :: (Typeable c, Typeable d) => (c -> c) -> (d -> d) -> c -> c+    extT f g y = fromMaybe (f y) (cast . g =<< cast y)++formatFingerprintMismatch :: Text -> Text -> String+formatFingerprintMismatch sourceFp renderedFp =+  let header = "Roundtrip mismatch: GHC fingerprint changed after pretty-print(parse(module))."+      diffText = formatDiff sourceFp renderedFp+   in case diffText of+        Nothing -> header+        Just diffChunk ->+          unlines+            [ header,+              "Changed section in GHC pretty-printed output:",+              T.unpack diffChunk+            ]++formatDiff :: Text -> Text -> Maybe Text+formatDiff before after =+  let beforeLines = T.lines before+      afterLines = T.lines after+      prefixLen = commonPrefixLen beforeLines afterLines+      beforeRest = drop prefixLen beforeLines+      afterRest = drop prefixLen afterLines+      suffixLen = commonSuffixLen beforeRest afterRest+      changedBefore = take (length beforeRest - suffixLen) beforeRest+      changedAfter = take (length afterRest - suffixLen) afterRest+      diffLines = concatMap renderDiffLine (getDiff changedBefore changedAfter)+   in if null diffLines+        then Nothing+        else+          Just+            ( T.unlines+                ( ["@@ line " <> T.pack (show (prefixLen + 1)) <> " @@"]+                    <> diffLines+                )+            )++renderDiffLine :: PolyDiff Text Text -> [Text]+renderDiffLine diffLine =+  case diffLine of+    First lineText -> ["- " <> lineText]+    Second lineText -> ["+ " <> lineText]+    Both _ _ -> []++commonPrefixLen :: (Eq a) => [a] -> [a] -> Int+commonPrefixLen = go 0+  where+    go n (a : as) (b : bs)+      | a == b = go (n + 1) as bs+      | otherwise = n+    go n _ _ = n++commonSuffixLen :: (Eq a) => [a] -> [a] -> Int+commonSuffixLen xs ys =+  let lenXs = length xs+      lenYs = length ys+      minLen = min lenXs lenYs+      alignedXs = drop (lenXs - minLen) xs+      alignedYs = drop (lenYs - minLen) ys+      suffixEqs = zipWith (==) (reverse alignedXs) (reverse alignedYs)+   in length (takeWhile id suffixEqs)
+ common/ShrinkUtils.hs view
@@ -0,0 +1,275 @@+module ShrinkUtils+  ( candidateTransformsWith,+    removeModuleHead,+    shrinkModuleHeadNameWith,+    removeModuleHeadExports,+    shrinkModuleHeadExports,+    removeModuleImports,+    shrinkModuleImports,+    removeModuleDecls,+    shrinkModuleDecls,+    shrinkModuleNameWith,+    shrinkModuleNamePartsWith,+    dropSegmentShrinks,+    shrinkSegmentShrinksWith,+    replaceAt,+    unique,+    splitModuleName,+    joinModuleName,+    isValidModuleName,+    isValidModuleSegment,+    isSegmentRestChar,+  )+where++import Data.Char (isAlphaNum, isUpper)+import Data.List (intercalate)+import Language.Haskell.Exts qualified as HSE++candidateTransformsWith :: (String -> [String]) -> HSE.Module HSE.SrcSpanInfo -> [HSE.Module HSE.SrcSpanInfo]+candidateTransformsWith shrinkSegment modu =+  removeModuleHead modu+    <> shrinkModuleHeadNameWith shrinkSegment modu+    <> removeModuleHeadExports modu+    <> shrinkModuleHeadExports modu+    <> removeModuleImports modu+    <> shrinkModuleImports modu+    <> removeModuleDecls modu+    <> shrinkModuleDecls modu++removeModuleHead :: HSE.Module HSE.SrcSpanInfo -> [HSE.Module HSE.SrcSpanInfo]+removeModuleHead modu =+  case modu of+    HSE.Module loc (Just _) pragmas imports decls ->+      [HSE.Module loc Nothing pragmas imports decls]+    _ -> []++shrinkModuleHeadNameWith :: (String -> [String]) -> HSE.Module HSE.SrcSpanInfo -> [HSE.Module HSE.SrcSpanInfo]+shrinkModuleHeadNameWith shrinkSegment modu =+  case modu of+    HSE.Module loc (Just (HSE.ModuleHead hLoc (HSE.ModuleName nLoc name) warning exports)) pragmas imports decls ->+      [ HSE.Module+          loc+          (Just (HSE.ModuleHead hLoc (HSE.ModuleName nLoc name') warning exports))+          pragmas+          imports+          decls+      | name' <- shrinkModuleNameWith shrinkSegment name+      ]+    _ -> []++removeModuleHeadExports :: HSE.Module HSE.SrcSpanInfo -> [HSE.Module HSE.SrcSpanInfo]+removeModuleHeadExports modu =+  case modu of+    HSE.Module loc (Just (HSE.ModuleHead hLoc modName warning (Just _))) pragmas imports decls ->+      [HSE.Module loc (Just (HSE.ModuleHead hLoc modName warning Nothing)) pragmas imports decls]+    _ -> []++shrinkModuleHeadExports :: HSE.Module HSE.SrcSpanInfo -> [HSE.Module HSE.SrcSpanInfo]+shrinkModuleHeadExports modu =+  case modu of+    HSE.Module loc (Just (HSE.ModuleHead hLoc modName warning (Just (HSE.ExportSpecList eLoc specs)))) pragmas imports decls ->+      let removeAt idx = take idx specs <> drop (idx + 1) specs+          shrunkLists = [removeAt idx | idx <- [0 .. length specs - 1]] <> [[], specs]+       in [ HSE.Module+              loc+              (Just (HSE.ModuleHead hLoc modName warning (Just (HSE.ExportSpecList eLoc specs'))))+              pragmas+              imports+              decls+          | specs' <- unique shrunkLists,+            specs' /= specs+          ]+    _ -> []++removeModuleImports :: HSE.Module HSE.SrcSpanInfo -> [HSE.Module HSE.SrcSpanInfo]+removeModuleImports modu =+  case modu of+    HSE.Module loc header pragmas (_ : _) decls ->+      [HSE.Module loc header pragmas [] decls]+    _ -> []++shrinkModuleImports :: HSE.Module HSE.SrcSpanInfo -> [HSE.Module HSE.SrcSpanInfo]+shrinkModuleImports modu =+  case modu of+    HSE.Module loc header pragmas imports decls ->+      let removeAt idx = take idx imports <> drop (idx + 1) imports+          shrunkLists =+            [removeAt idx | idx <- [0 .. length imports - 1]]+              <> [replaceAt idx decl' imports | idx <- [0 .. length imports - 1], decl' <- shrinkImportDecl (imports !! idx)]+              <> [replaceAt idx (simplifyImportDecl (imports !! idx)) imports | idx <- [0 .. length imports - 1]]+              <> [[], imports]+       in [HSE.Module loc header pragmas imports' decls | imports' <- unique shrunkLists, imports' /= imports]+    _ -> []++removeModuleDecls :: HSE.Module HSE.SrcSpanInfo -> [HSE.Module HSE.SrcSpanInfo]+removeModuleDecls modu =+  case modu of+    HSE.Module loc header pragmas imports (_ : _) ->+      [HSE.Module loc header pragmas imports []]+    _ -> []++shrinkModuleDecls :: HSE.Module HSE.SrcSpanInfo -> [HSE.Module HSE.SrcSpanInfo]+shrinkModuleDecls modu =+  case modu of+    HSE.Module loc header pragmas imports decls ->+      let removeAt idx = take idx decls <> drop (idx + 1) decls+          shrunkLists =+            [removeAt idx | idx <- [0 .. length decls - 1]]+              <> [replaceAt idx decl' decls | idx <- [0 .. length decls - 1], decl' <- simplifyDecl (decls !! idx)]+              <> [[], decls]+       in [HSE.Module loc header pragmas imports decls' | decls' <- unique shrunkLists, decls' /= decls]+    _ -> []++simplifyImportDecl :: HSE.ImportDecl HSE.SrcSpanInfo -> HSE.ImportDecl HSE.SrcSpanInfo+simplifyImportDecl decl =+  decl+    { HSE.importQualified = False,+      HSE.importSrc = False,+      HSE.importSafe = False,+      HSE.importPkg = Nothing,+      HSE.importAs = Nothing,+      HSE.importSpecs = Nothing+    }++shrinkImportDecl :: HSE.ImportDecl HSE.SrcSpanInfo -> [HSE.ImportDecl HSE.SrcSpanInfo]+shrinkImportDecl decl =+  case HSE.importSpecs decl of+    Nothing -> []+    Just (HSE.ImportSpecList specLoc hidingFlag specs) ->+      let removeAt specIdx = take specIdx specs <> drop (specIdx + 1) specs+          shrinkSpecs =+            [ decl {HSE.importSpecs = Just (HSE.ImportSpecList specLoc hidingFlag specs')}+            | specs' <- unique ([removeAt idx | idx <- [0 .. length specs - 1]] <> [take 1 specs]),+              not (null specs'),+              specs' /= specs+            ]+       in shrinkSpecs <> [decl {HSE.importSpecs = Just (HSE.ImportSpecList specLoc hidingFlag [spec'])} | spec <- specs, spec' <- shrinkImportSpec spec]++shrinkImportSpec :: HSE.ImportSpec HSE.SrcSpanInfo -> [HSE.ImportSpec HSE.SrcSpanInfo]+shrinkImportSpec spec =+  case spec of+    HSE.IVar loc name -> [HSE.IVar loc name]+    HSE.IAbs loc ns name -> [HSE.IVar loc name, HSE.IAbs loc ns name]+    HSE.IThingAll loc name -> [HSE.IVar loc name, HSE.IThingAll loc name]+    HSE.IThingWith loc name cnames ->+      [HSE.IThingAll loc name, HSE.IThingWith loc name (take 1 cnames)]++simplifyDecl :: HSE.Decl HSE.SrcSpanInfo -> [HSE.Decl HSE.SrcSpanInfo]+simplifyDecl decl =+  case decl of+    HSE.TypeSig loc names _ty ->+      case names of+        [] -> []+        name : _ -> [HSE.TypeSig loc [name] (simpleType loc)]+    HSE.FunBind loc matches ->+      case matches of+        [] -> []+        match : _ ->+          case match of+            HSE.Match mLoc name _pats _rhs _binds ->+              [HSE.FunBind loc [simplifyMatch mLoc name]]+            HSE.InfixMatch mLoc lhs name _pats _rhs _binds ->+              [HSE.FunBind loc [simplifyMatch mLoc name, HSE.Match mLoc name [lhs] (simpleRhs mLoc name) Nothing]]+    HSE.PatBind loc pat _rhs _binds ->+      [HSE.PatBind loc (simplifyPat pat) (simpleRhs loc (nameFromPat pat)) Nothing]+    _ -> []++simplifyMatch :: HSE.SrcSpanInfo -> HSE.Name HSE.SrcSpanInfo -> HSE.Match HSE.SrcSpanInfo+simplifyMatch loc name =+  HSE.Match loc name [] (simpleRhs loc name) Nothing++simpleRhs :: HSE.SrcSpanInfo -> HSE.Name HSE.SrcSpanInfo -> HSE.Rhs HSE.SrcSpanInfo+simpleRhs loc name =+  HSE.UnGuardedRhs loc (HSE.Var loc (HSE.UnQual loc name))++simpleType :: HSE.SrcSpanInfo -> HSE.Type HSE.SrcSpanInfo+simpleType loc =+  HSE.TyVar loc (HSE.Ident loc "a")++simplifyPat :: HSE.Pat HSE.SrcSpanInfo -> HSE.Pat HSE.SrcSpanInfo+simplifyPat pat =+  case pat of+    HSE.PVar loc name -> HSE.PVar loc name+    HSE.PWildCard loc -> HSE.PWildCard loc+    _ -> HSE.PWildCard (HSE.ann pat)++nameFromPat :: HSE.Pat HSE.SrcSpanInfo -> HSE.Name HSE.SrcSpanInfo+nameFromPat pat =+  case pat of+    HSE.PVar _ name -> name+    _ -> HSE.Ident (HSE.ann pat) "x"++shrinkModuleNameWith :: (String -> [String]) -> String -> [String]+shrinkModuleNameWith shrinkSegment name =+  let parts = splitModuleName name+      joinedShrinks =+        [ joinModuleName parts'+        | parts' <- shrinkModuleNamePartsWith shrinkSegment parts,+          isValidModuleName parts'+        ]+   in unique joinedShrinks++shrinkModuleNamePartsWith :: (String -> [String]) -> [String] -> [[String]]+shrinkModuleNamePartsWith shrinkSegment parts =+  dropSegmentShrinks parts <> shrinkSegmentShrinksWith shrinkSegment parts++-- Remove one segment at a time (if at least one segment remains).+dropSegmentShrinks :: [String] -> [[String]]+dropSegmentShrinks parts =+  [ before <> after+  | idx <- [0 .. length parts - 1],+    let (before, rest) = splitAt idx parts,+    (_ : after) <- [rest],+    not (null (before <> after))+  ]++-- Shrink each segment independently.+shrinkSegmentShrinksWith :: (String -> [String]) -> [String] -> [[String]]+shrinkSegmentShrinksWith shrinkSegment parts =+  [ replaceAt idx segment' parts+  | (idx, segment) <- zip [0 ..] parts,+    segment' <- shrinkSegment segment,+    isValidModuleSegment segment'+  ]++replaceAt :: Int -> a -> [a] -> [a]+replaceAt idx value xs =+  let (before, rest) = splitAt idx xs+   in case rest of+        [] -> xs+        (_ : after) -> before <> (value : after)++unique :: (Eq a) => [a] -> [a]+unique = foldr keep []+  where+    keep x acc+      | x `elem` acc = acc+      | otherwise = x : acc++splitModuleName :: String -> [String]+splitModuleName raw =+  case raw of+    "" -> []+    _ -> splitOnDot raw++splitOnDot :: String -> [String]+splitOnDot s =+  case break (== '.') s of+    (prefix, []) -> [prefix]+    (prefix, _ : rest) -> prefix : splitOnDot rest++joinModuleName :: [String] -> String+joinModuleName = intercalate "."++isValidModuleName :: [String] -> Bool+isValidModuleName segments = not (null segments) && all isValidModuleSegment segments++isValidModuleSegment :: String -> Bool+isValidModuleSegment segment =+  case segment of+    first : rest -> isUpper first && all isSegmentRestChar rest+    [] -> False++isSegmentRestChar :: Char -> Bool+isSegmentRestChar ch = isAlphaNum ch || ch == '\'' || ch == '_'
+ common/StackageProgress/Summary.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE BangPatterns #-}++module StackageProgress.Summary+  ( FailedPackage (..),+    PackageResult (..),+    PackageSpec (..),+    PromptCandidate (..),+    RunSummary,+    SummaryOptions (..),+    addPackageResults,+    emptySummary,+    finalizeSummary,+    forceString,+    formatPackage,+    packageParserFailed,+    promptCandidateFromResult,+    renderPrompt,+    selectPromptCandidate,+    summaryFailedPackages,+    summaryGhcErrors,+    summarySuccessGhcN,+    summarySuccessHseN,+    summarySuccessOursN,+    summarySucceededPackages,+  )+where++import Aihc.Hackage.Types (PackageSpec (..), formatPackage)+import Data.Char (isSpace)+import Data.List qualified as List++data PackageResult = PackageResult+  { package :: !PackageSpec,+    packageOursOk :: !Bool,+    packageHseOk :: !Bool,+    packageGhcOk :: !Bool,+    packageReason :: !String,+    packageGhcError :: !(Maybe String),+    packageSourceSize :: !Integer,+    packageFileErrors :: ![(String, String)] -- [(filePath, errorMessage)]+  }++data FailedPackage = FailedPackage+  { failedPackageName :: !String,+    failedPackageSourceSize :: !Integer,+    failedPackageErrors :: ![(String, String)] -- [(filePath, errorMessage)]+  }+  deriving (Eq, Show)++data PromptCandidate = PromptCandidate+  { promptPackageName :: !String,+    promptErrorMessage :: !String+  }+  deriving (Eq, Show)++data SummaryOptions = SummaryOptions+  { summaryKeepSucceeded :: !Bool,+    summaryKeepFailedPackages :: !Bool,+    summaryGhcErrorLimit :: !Int+  }++data RunSummary = RunSummary+  { summarySuccessOursN :: !Int,+    summarySuccessHseN :: !Int,+    summarySuccessGhcN :: !Int,+    summarySucceededPackagesAcc :: ![String],+    summaryFailedPackagesAcc :: ![FailedPackage],+    summaryGhcErrorsAcc :: ![(String, String)],+    summaryGhcErrorsStored :: !Int+  }++emptySummary :: RunSummary+emptySummary =+  RunSummary+    { summarySuccessOursN = 0,+      summarySuccessHseN = 0,+      summarySuccessGhcN = 0,+      summarySucceededPackagesAcc = [],+      summaryFailedPackagesAcc = [],+      summaryGhcErrorsAcc = [],+      summaryGhcErrorsStored = 0+    }++addPackageResults :: SummaryOptions -> [PackageResult] -> RunSummary -> RunSummary+addPackageResults opts results summary0 = List.foldl' (addPackageResult opts) summary0 results+  where+    addPackageResult :: SummaryOptions -> RunSummary -> PackageResult -> RunSummary+    addPackageResult summaryOpts summary result =+      let !oursN = summarySuccessOursN summary + boolToInt (packageOursOk result)+          !hseN = summarySuccessHseN summary + boolToInt (packageHseOk result)+          !ghcN = summarySuccessGhcN summary + boolToInt (packageGhcOk result)+          !pkgLabel = forceString (formatPackage (package result))+          succeededRev =+            if summaryKeepSucceeded summaryOpts && packageOursOk result+              then pkgLabel : summarySucceededPackagesAcc summary+              else summarySucceededPackagesAcc summary+          failedRev =+            if summaryKeepFailedPackages summaryOpts && packageParserFailed result+              then FailedPackage pkgLabel (packageSourceSize result) (packageFileErrors result) : summaryFailedPackagesAcc summary+              else summaryFailedPackagesAcc summary+          (!ghcStored, ghcErrorsRev) = addGhcErrorIfNeeded summaryOpts summary result pkgLabel+       in RunSummary+            { summarySuccessOursN = oursN,+              summarySuccessHseN = hseN,+              summarySuccessGhcN = ghcN,+              summarySucceededPackagesAcc = succeededRev,+              summaryFailedPackagesAcc = failedRev,+              summaryGhcErrorsAcc = ghcErrorsRev,+              summaryGhcErrorsStored = ghcStored+            }++    addGhcErrorIfNeeded :: SummaryOptions -> RunSummary -> PackageResult -> String -> (Int, [(String, String)])+    addGhcErrorIfNeeded summaryOpts summary result pkgLabel+      | packageGhcOk result = (summaryGhcErrorsStored summary, summaryGhcErrorsAcc summary)+      | summaryGhcErrorsStored summary >= summaryGhcErrorLimit summaryOpts = (summaryGhcErrorsStored summary, summaryGhcErrorsAcc summary)+      | otherwise =+          let !message = forceString (ghcFailureMessage result)+           in (summaryGhcErrorsStored summary + 1, (pkgLabel, message) : summaryGhcErrorsAcc summary)++finalizeSummary :: RunSummary -> RunSummary+finalizeSummary summary =+  summary+    { summarySucceededPackagesAcc = reverse (summarySucceededPackagesAcc summary),+      summaryFailedPackagesAcc = reverse (summaryFailedPackagesAcc summary),+      summaryGhcErrorsAcc = reverse (summaryGhcErrorsAcc summary)+    }++summarySucceededPackages :: RunSummary -> [String]+summarySucceededPackages = summarySucceededPackagesAcc++summaryFailedPackages :: RunSummary -> [FailedPackage]+summaryFailedPackages = summaryFailedPackagesAcc++summaryGhcErrors :: RunSummary -> [(String, String)]+summaryGhcErrors = summaryGhcErrorsAcc++packageParserFailed :: PackageResult -> Bool+packageParserFailed result = not (packageOursOk result) && packageSourceSize result > 0++promptCandidateFromResult :: PackageResult -> Maybe PromptCandidate+promptCandidateFromResult result+  | packageOursOk result = Nothing+  | otherwise =+      Just+        PromptCandidate+          { promptPackageName = pkgName (package result),+            promptErrorMessage = packageReason result+          }++renderPrompt :: String -> PromptCandidate -> String+renderPrompt template candidate =+  replaceAll "{{ERROR_MESSAGES}}" (promptErrorMessage candidate) $ replaceAll "{{PACKAGE_NAME}}" (promptPackageName candidate) template++selectPromptCandidate :: Integer -> [PromptCandidate] -> Maybe PromptCandidate+selectPromptCandidate _ [] = Nothing+selectPromptCandidate seed candidates =+  let n = length candidates+      idx = fromInteger (seed `mod` toInteger n)+   in Just (candidates !! idx)++ghcFailureMessage :: PackageResult -> String+ghcFailureMessage result =+  case packageGhcError result of+    Just err -> forceString err+    Nothing ->+      let reason = trim (packageReason result)+       in if null reason+            then "GHC check failed without diagnostic details"+            else "No direct GHC diagnostic; package failed before/around GHC check: " ++ forceString reason++trim :: String -> String+trim = List.dropWhileEnd isSpace . dropWhile isSpace++boolToInt :: Bool -> Int+boolToInt True = 1+boolToInt False = 0++forceString :: String -> String+forceString value = length value `seq` value++replaceAll :: String -> String -> String -> String+replaceAll needle replacement = go+  where+    go haystack+      | null needle = haystack+      | otherwise =+          case List.stripPrefix needle haystack of+            Just rest -> replacement ++ go rest+            Nothing ->+              case haystack of+                [] -> []+                x : xs -> x : go xs
+ src/Aihc/Parser.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Aihc.Parser+-- Description : Haskell parser for the AIHC compiler+-- License     : Unlicense+--+-- This module provides parsing functions for Haskell source code.+-- The main entry point is 'parseModule' for parsing complete Haskell modules.+-- Additional functions are provided for parsing individual expressions,+-- patterns, and types.+module Aihc.Parser+  ( -- * Parsing modules+    parseModule,++    -- * Configuration+    ParserConfig (..),+    defaultConfig,++    -- * Parse results+    ParseResult (..),+    formatParseErrors,++    -- * Parsing expressions, patterns, types, and declarations+    parseExpr,+    parseSignatureType,+    parseType,+    parsePattern,+    parseDecl,+  )+where++import Aihc.Parser.Internal.Common (drainParseErrors, eofTok)+import Aihc.Parser.Internal.Decl (declParser)+import Aihc.Parser.Internal.Errors (parseErrorBundleToSpannedText, parseErrorsToSpannedText)+import Aihc.Parser.Internal.Expr (exprParser)+import Aihc.Parser.Internal.Module (moduleParser)+import Aihc.Parser.Internal.Pattern (patternParser)+import Aihc.Parser.Internal.Type (typeParser, typeSignatureParser)+import Aihc.Parser.Pretty ()+import Aihc.Parser.Syntax (Decl, Expr, Module (..), Pattern, SourceSpan (..), Type, applyImpliedExtensions)+import Aihc.Parser.Types+import Data.ByteString qualified as BS+import Data.List qualified as List+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Word (Word8)+import Prettyprinter (Doc, colon, defaultLayoutOptions, layoutPretty, pretty, vcat)+import Prettyprinter.Render.String (renderString)+import Text.Megaparsec (runParser)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Aihc.Parser+-- >>> import Aihc.Parser.Syntax (moduleName)+-- >>> import Aihc.Parser.Shorthand (Shorthand(..))++-- | Default parser configuration.+--+-- * 'parserSourceName' is set to @\"\<input\>\"@+-- * 'parserExtensions' is empty (no extensions enabled by default)+--+-- >>> parserSourceName defaultConfig+-- "<input>"+--+-- >>> parserExtensions defaultConfig+-- []+defaultConfig :: ParserConfig+defaultConfig =+  ParserConfig+    { parserSourceName = "<input>",+      parserExtensions = []+    }++-- | Parse a Haskell expression.+--+-- >>> shorthand $ parseExpr defaultConfig "1 + 2"+-- ParseOk (EInfix (EInt 1 TInteger) "+" (EInt 2 TInteger))+--+-- >>> shorthand $ parseExpr defaultConfig "\\x -> x + 1"+-- ParseOk (ELambdaPats [PVar "x"] (EInfix (EVar "x") "+" (EInt 1 TInteger)))+--+-- Parse errors are returned as 'ParseErr':+--+-- >>> case parseExpr defaultConfig "1 +" of { ParseErr _ -> "error"; ParseOk _ -> "ok" }+-- "error"+parseExpr :: ParserConfig -> Text -> ParseResult Expr+parseExpr cfg input =+  let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input+   in case runParser (exprParser <* eofTok) (parserSourceName cfg) ts of+        Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)+        Right expr -> ParseOk expr++-- | Parse a Haskell pattern.+--+-- >>> shorthand $ parsePattern defaultConfig "(x, y)"+-- ParseOk (PTuple [PVar "x", PVar "y"])+--+-- >>> shorthand $ parsePattern defaultConfig "Just x"+-- ParseOk (PCon "Just" [PVar "x"])+parsePattern :: ParserConfig -> Text -> ParseResult Pattern+parsePattern cfg input =+  let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input+   in case runParser (patternParser <* eofTok) (parserSourceName cfg) ts of+        Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)+        Right pat -> ParseOk pat++-- | Parse a Haskell signature type.+--+-- This is the context used by top-level type signatures. Unlike 'parseType',+-- it rejects an unparenthesized outer kind signature:+--+-- >>> case parseSignatureType defaultConfig "_ :: _" of { ParseErr _ -> "error"; ParseOk _ -> "ok" }+-- "error"+parseSignatureType :: ParserConfig -> Text -> ParseResult Type+parseSignatureType cfg input =+  let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input+   in case runParser (typeSignatureParser <* eofTok) (parserSourceName cfg) ts of+        Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)+        Right ty -> ParseOk ty++-- | Parse a Haskell type in the general declaration RHS context.+--+-- >>> shorthand $ parseType defaultConfig "Int -> Bool"+-- ParseOk (TFun (TCon "Int") (TCon "Bool"))+--+-- >>> shorthand $ parseType defaultConfig "Maybe a"+-- ParseOk (TApp (TCon "Maybe") (TVar "a"))+--+-- >>> shorthand $ parseType defaultConfig "_ :: _"+-- ParseOk (TKindSig (TWildcard) (TWildcard))+parseType :: ParserConfig -> Text -> ParseResult Type+parseType cfg input =+  let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input+   in case runParser (typeParser <* eofTok) (parserSourceName cfg) ts of+        Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)+        Right ty -> ParseOk ty++-- | Parse a single Haskell declaration.+--+-- >>> shorthand $ parseDecl defaultConfig "f x = x + 1"+-- ParseOk (DeclValue (FunctionBind "f" [Match {MatchHeadPrefix, [PVar "x"], EInfix (EVar "x") "+" (EInt 1 TInteger)}]))+parseDecl :: ParserConfig -> Text -> ParseResult Decl+parseDecl cfg input =+  let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input+   in case runParser (declParser <* eofTok) (parserSourceName cfg) ts of+        Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)+        Right decl -> ParseOk decl++-- | Parse a complete Haskell module.+--+-- Returns any recovered parse errors alongside a (possibly partial) 'Module'.+-- When individual declarations fail to parse, the parser recovers and continues,+-- returning the error and the successfully parsed declarations.+--+-- >>> shorthand $ snd $ parseModule defaultConfig "module Main where\nmain = putStrLn \"Hello\""+-- Module {ModuleHead {"Main"}, [DeclValue (PatternBind (PVar "main") (EApp (EVar "putStrLn") (EString "Hello")))]}+--+-- Modules without a header are also supported:+--+-- >>> case parseModule defaultConfig "x = 1" of { (_, m) -> moduleName m }+-- Nothing+parseModule :: ParserConfig -> Text -> ([(SourceSpan, Text)], Module)+parseModule cfg input =+  let ts = mkTokStreamModule (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input+      parser = do+        modu <- moduleParser+        _ <- eofTok+        errs <- drainParseErrors+        pure (errs, modu)+   in case runParser parser (parserSourceName cfg) ts of+        Left bundle ->+          ( parseErrorBundleToSpannedText bundle,+            Module+              { moduleAnns = [],+                moduleHead = Nothing,+                moduleLanguagePragmas = [],+                moduleImports = [],+                moduleDecls = []+              }+          )+        Right (errs, modu) ->+          (parseErrorsToSpannedText errs, modu)++-- | Pretty-print a list of spanned parse errors with source context.+formatParseErrors :: FilePath -> Maybe Text -> [(SourceSpan, Text)] -> String+formatParseErrors sourceName mSource errs =+  let opts = defaultLayoutOptions+      blocks =+        map+          ( \(srcSpan, msg) ->+              renderString+                ( layoutPretty opts $+                    case (srcSpan, mSource) of+                      (ss@SourceSpan {}, Just source) ->+                        vcat [renderSourceReference sourceName source ss, pretty msg]+                      _ ->+                        vcat [pretty sourceName, pretty msg]+                )+          )+          errs+   in List.intercalate "\n\n" blocks++-- renderSourceReference "<input>" "x = 1" (SourceSpan 1 5 1 6) = """+-- <input>:1:5:+-- 1 | x = 1+--   |     ^+-- """+-- renderSourceReference "<input>" "module where" (SourceSpan 1 8 1 13) = """+-- <input>:1:5:+-- 1 | module where+--   |        ^^^^^+-- """+renderSourceReference :: String -> Text -> SourceSpan -> Doc ann+renderSourceReference origin source srcSpan =+  let (renderedOrigin, lineNo, colNo, endCol, srcLine) = case srcSpan of+        SourceSpan {sourceSpanSourceName, sourceSpanStartLine, sourceSpanStartCol, sourceSpanEndCol, sourceSpanStartOffset} ->+          ( sourceSpanSourceName,+            sourceSpanStartLine,+            sourceSpanStartCol,+            sourceSpanEndCol,+            extractSourceLineByOffset source sourceSpanStartOffset+          )+        NoSourceSpan -> (origin, 1, 1, 1, "")+      lineNoText = show lineNo+      markerPrefix = replicate (length lineNoText) ' ' ++ " | "+      markerStart = max 0 (colNo - 1)+      markerLen = max 1 (endCol - colNo)+      marker = replicate markerStart ' ' ++ replicate markerLen '^'+      header =+        pretty renderedOrigin <> colon <> pretty lineNo <> colon <> pretty colNo <> colon+   in vcat+        [ header,+          pretty (lineNoText ++ " | " ++ srcLine),+          pretty (markerPrefix ++ marker)+        ]++extractSourceLineByOffset :: Text -> Int -> String+extractSourceLineByOffset source offset =+  let bytes = TE.encodeUtf8 source+      len = BS.length bytes+      anchor = max 0 (min len offset)+      lineStart = scanBackward bytes anchor+      lineEnd = scanForward bytes anchor+   in T.unpack (TE.decodeUtf8 (BS.take (lineEnd - lineStart) (BS.drop lineStart bytes)))++scanBackward :: BS.ByteString -> Int -> Int+scanBackward bytes = go+  where+    go idx+      | idx <= 0 = 0+      | isLineBreak (BS.index bytes (idx - 1)) = idx+      | otherwise = go (idx - 1)++scanForward :: BS.ByteString -> Int -> Int+scanForward bytes = go+  where+    len = BS.length bytes+    go idx+      | idx >= len = len+      | isLineBreak (BS.index bytes idx) = idx+      | otherwise = go (idx + 1)++isLineBreak :: Word8 -> Bool+isLineBreak w = w == 10 || w == 13
+ src/Aihc/Parser/Internal/CheckPattern.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+--+-- Module      : Aihc.Parser.Internal.CheckPattern+-- Description : Reclassify Expr trees as Pattern trees+-- License     : Unlicense+--+-- Convert an expression AST into a pattern AST. This implements the+-- \"parse as expression, then reclassify\" strategy described in+-- @docs\/unified-expr-pattern-parsing.md@.+--+-- The core function 'checkPattern' performs a structural recursion over+-- 'Expr', converting each expression node into its pattern counterpart.+-- Expression-only constructs (if, case, do, lambda, etc.) are rejected+-- with a descriptive error message.+module Aihc.Parser.Internal.CheckPattern+  ( checkPattern,+    checkPatterns,+  )+where++import Aihc.Parser.Internal.Common (isConLikeName)+import Aihc.Parser.Syntax+import Data.Maybe (isJust, isNothing)+import Data.Text (Text)++-- | Convert an expression tree into a pattern.+-- Returns @Left@ with a diagnostic message if the expression cannot be+-- interpreted as a valid pattern.+checkPattern :: Expr -> Either Text Pattern+checkPattern expr = case expr of+  EAnn ann sub -> fmap (PAnn ann) (checkPattern sub)+  EPragma pragma _ -> checkPragmaPattern pragma+  -- Variables and constructors+  EVar name+    | nameText name == "_" -> Right PWildcard+    | isConLikeName name -> Right (PCon name [] [])+    | isJust (nameQualifier name) -> Left "unexpected qualified name in pattern"+    | otherwise -> Right (PVar (mkUnqualifiedName (nameType name) (nameText name)))+  ETypeSyntax form ty -> Right (PTypeSyntax form ty)+  -- Parenthesized expression+  -- When the inner expression is a view-pattern arrow (@expr -> expr@),+  -- produce @PParen (PView f pat)@ to preserve the explicit parens in+  -- the AST, matching the shape produced by the dedicated pattern parser.+  EParen inner+    | Just vp <- asViewPat inner -> Right (PParen vp)+    | otherwise -> PParen <$> checkPattern inner+  -- Tuple+  ETuple fl elems+    | Just tupleCon <- tupleConstructorPattern fl elems -> Right tupleCon+    | otherwise -> do+        pats <- traverse checkTupleElement elems+        Right (PTuple fl pats)+  -- List+  EList elems -> PList <$> traverse checkPattern elems+  -- Unboxed sum+  EUnboxedSum i n e -> PUnboxedSum i n <$> checkPattern e+  -- Infix: only constructor operators (starting with ':') or the view-pattern+  -- arrow @->@ are valid in patterns.+  EInfix l op r+    | renderName op == "->" -> do+        rPat <- checkPattern r+        Right (PView l rPat)+    | isConLikeOp op -> do+        lPat <- checkPattern l+        rPat <- checkPattern r+        Right (PInfix lPat op rPat)+    | otherwise -> Left ("unexpected variable operator '" <> renderName op <> "' in pattern")+  -- Type signature+  ETypeSig e ty -> do+    pat <- checkPattern e+    Right (PTypeSig pat ty)+  -- Negation (must be a literal)+  ENegate inner -> checkNegLitPattern inner+  -- Application: accumulate arguments into PCon+  EApp f x -> do+    fPat <- checkPattern f+    xPat <- checkPattern x+    case peelPatternAnn fPat of+      PCon name typeArgs args -> Right (PCon name typeArgs (args ++ [xPat]))+      _ -> Left "invalid pattern: application of non-constructor"+  -- Record construction -> record pattern+  ERecordCon name fields wc -> do+    patFields <-+      traverse+        ( \field -> do+            pat <- checkPattern (recordFieldValue field)+            pure field {recordFieldValue = pat}+        )+        fields+    Right (PRecord name patFields wc)+  -- Literals+  EInt n nt repr -> Right (PLit (LitInt n nt repr))+  EFloat x ft repr -> Right (PLit (LitFloat x ft repr))+  EChar c repr -> Right (PLit (LitChar c repr))+  ECharHash c repr -> Right (PLit (LitCharHash c repr))+  EString s repr -> Right (PLit (LitString s repr))+  EStringHash s repr -> Right (PLit (LitStringHash s repr))+  EOverloadedLabel {} -> Left "unexpected overloaded label in pattern"+  -- TH splice+  ETHSplice body -> Right (PSplice body)+  -- Quasi-quote+  EQuasiQuote q b -> Right (PQuasiQuote q b)+  -- Expression-only constructs: clear errors+  EIf {} -> Left "unexpected if-then-else in pattern"+  EMultiWayIf {} -> Left "unexpected multi-way if in pattern"+  ECase {} -> Left "unexpected case expression in pattern"+  EDo {} -> Left "unexpected do expression in pattern"+  ELambdaPats {} -> Left "unexpected lambda in pattern"+  ELambdaCase {} -> Left "unexpected lambda-case in pattern"+  ELambdaCases {} -> Left "unexpected lambda-cases in pattern"+  ELetDecls {} -> Left "unexpected let expression in pattern"+  EArithSeq {} -> Left "unexpected arithmetic sequence in pattern"+  EListComp {} -> Left "unexpected list comprehension in pattern"+  EListCompParallel {} -> Left "unexpected parallel list comprehension in pattern"+  ESectionL {} -> Left "unexpected left section in pattern"+  ESectionR {} -> Left "unexpected right section in pattern"+  ERecordUpd {} -> Left "unexpected record update in pattern"+  EGetField {} -> Left "unexpected record field access in pattern"+  EGetFieldProjection {} -> Left "unexpected projection section in pattern"+  ETypeApp fun ty -> do+    funPat <- checkPattern fun+    case peelPatternAnn funPat of+      PCon name typeArgs args -> Right (PCon name (typeArgs ++ [ty]) args)+      _ -> Left "unexpected type application in pattern"+  ETHExpQuote {} -> Left "unexpected Template Haskell expression quote in pattern"+  ETHTypedQuote {} -> Left "unexpected Template Haskell typed quote in pattern"+  ETHDeclQuote {} -> Left "unexpected Template Haskell declaration quote in pattern"+  ETHTypeQuote {} -> Left "unexpected Template Haskell type quote in pattern"+  ETHPatQuote {} -> Left "unexpected Template Haskell pattern quote in pattern"+  ETHNameQuote {} -> Left "unexpected Template Haskell name quote in pattern"+  ETHTypeNameQuote {} -> Left "unexpected Template Haskell type name quote in pattern"+  ETHTypedSplice {} -> Left "unexpected typed Template Haskell splice in pattern"+  EProc {} -> Left "unexpected proc expression in pattern"++checkPragmaPattern :: Pragma -> Either Text Pattern+checkPragmaPattern pragma =+  case pragmaType pragma of+    PragmaSCC {} -> Left "unexpected SCC pragma in pattern"+    _ -> Left "unexpected pragma in pattern"++-- | Convert a list of expressions into patterns.+checkPatterns :: [Expr] -> Either Text [Pattern]+checkPatterns = traverse checkPattern++-- | Check that a tuple element is not a tuple section (Nothing).+checkTupleElement :: Maybe Expr -> Either Text Pattern+checkTupleElement Nothing = Left "unexpected tuple section in pattern"+checkTupleElement (Just e) = checkPattern e++tupleConstructorPattern :: TupleFlavor -> [Maybe Expr] -> Maybe Pattern+tupleConstructorPattern fl elems+  | null elems = Nothing+  | all isNothing elems = Just (PCon (tupleConstructorName fl (length elems)) [] [])+  | otherwise = Nothing++tupleConstructorName :: TupleFlavor -> Int -> Name+tupleConstructorName fl arity =+  qualifyName Nothing (mkUnqualifiedName NameConSym symbol)+  where+    symbol = case fl of+      Boxed -> tupleCommas+      Unboxed -> "#" <> tupleCommas <> "#"+    tupleCommas+      | arity == 1 = ""+      | otherwise = mconcat (replicate (arity - 1) ",")++-- | Check that a negated expression is a literal (for PNegLit patterns).+checkNegLitPattern :: Expr -> Either Text Pattern+checkNegLitPattern inner = case inner of+  EInt n nt repr -> Right (PNegLit (LitInt n nt repr))+  EFloat x ft repr -> Right (PNegLit (LitFloat x ft repr))+  EAnn ann sub -> fmap (PAnn ann) (checkNegLitPattern sub)+  _ -> Left "negation in pattern requires a numeric literal"++-- | Check whether an operator is a constructor operator (starts with ':').+-- Constructor operators and backtick-quoted constructors are valid in patterns;+-- variable operators like @+@ or @*@ are not.+isConLikeOp :: Name -> Bool+isConLikeOp = isConLikeName++-- | Try to interpret an expression as a view pattern @expr -> expr@.+-- Returns 'Just' the corresponding 'PView' when the expression is an+-- 'EInfix' with @->@; 'Nothing' otherwise.  Used by the 'EParen' case of+-- 'checkPattern' to strip the outer parentheses and produce @PView@+-- directly (matching the AST shape that the dedicated pattern parser+-- produces).+asViewPat :: Expr -> Maybe Pattern+asViewPat (EInfix l op r)+  | renderName op == "->" = case checkPattern r of+      Right rPat -> Just (PView l rPat)+      Left _ -> Nothing+asViewPat _ = Nothing
+ src/Aihc/Parser/Internal/Cmd.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE OverloadedStrings #-}++module Aihc.Parser.Internal.Cmd+  ( cmdParser,+  )+where++import Aihc.Parser.Internal.CheckPattern (checkPattern)+import Aihc.Parser.Internal.Common+import {-# SOURCE #-} Aihc.Parser.Internal.Expr (atomExprParser, caseRhsParserWithBodyParser, cmdArrAppLhsParser, exprParser, parseLetDeclsParser, parseLetDeclsStmtParser)+import Aihc.Parser.Internal.Pattern (apatParser, caseAltPatternParser, patternParser)+import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind)+import Aihc.Parser.Syntax+import Aihc.Parser.Types (ParserErrorComponent (..), mkFoundToken)+import Text.Megaparsec (anySingle, lookAhead, (<|>))+import Text.Megaparsec qualified as MP++-- | Parse a command (the body of a @proc@ abstraction).+--+-- Grammar (simplified):+--+-- @+-- cmd   = exp10 -\< exp | exp10 -\<\< exp | cmd0+-- cmd0  = cmd10 (op cmd10)*+-- cmd10 = do { cstmts } | if … | case … | let … | \\pats -> cmd | fcmd+-- fcmd  = fcmd aexp | (cmd)+-- @+cmdParser :: TokParser Cmd+cmdParser = do+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkKeywordDo -> cmd0Parser+    TkKeywordIf -> cmd0Parser+    TkKeywordCase -> cmd0Parser+    TkKeywordLet -> cmd0Parser+    TkReservedBackslash -> cmd0Parser+    TkSpecialLParen -> MP.try cmd0Parser <|> cmdArrAppParser+    _ -> MP.try cmdArrAppParser <|> cmd0Parser++cmd0Parser :: TokParser Cmd+cmd0Parser = do+  lhs <- cmd10Parser+  rest <-+    MP.many+      ( (,)+          <$> infixOperatorParser+          <*> cmd10Parser+      )+  pure (foldl buildCmdInfix lhs rest)+  where+    buildCmdInfix l (op, r) = CmdInfix l op r++cmd10Parser :: TokParser Cmd+cmd10Parser = do+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkKeywordDo -> cmdDoParser+    TkKeywordIf -> cmdIfParser+    TkKeywordCase -> cmdCaseParser+    TkKeywordLet ->+      -- 'let decls in cmd' is a command; 'let decls' (without 'in') inside+      -- a do-block is a statement, not handled here.+      cmdLetParser+    TkReservedBackslash -> cmdLamParser+    _ -> cmdFcmdParser++cmdArrAppParser :: TokParser Cmd+cmdArrAppParser = do+  expr <- cmdArrAppLhsParser+  (appType, rhs) <- cmdArrTailParser+  pure (CmdArrApp expr appType rhs)++cmdFcmdParser :: TokParser Cmd+cmdFcmdParser = do+  headCmd <- cmdParenParser+  args <- MP.many atomExprParser+  pure (foldl CmdApp headCmd args)++-- | Parse an arrow tail operator in command context, returning the+-- application type and the right-hand expression.+cmdArrTailParser :: TokParser (ArrAppType, Expr)+cmdArrTailParser = do+  appType <- tokenSatisfy "arrow operator" $ \tok ->+    case lexTokenKind tok of+      TkArrowTail -> Just HsFirstOrderApp+      TkDoubleArrowTail -> Just HsHigherOrderApp+      _ -> Nothing+  rhs <- exprParser+  pure (appType, rhs)++-- | Parse a command do-block: @do { cstmt ; ... }@+cmdDoParser :: TokParser Cmd+cmdDoParser = withSpanAnn (CmdAnn . mkAnnotation) $ do+  expectedTok TkKeywordDo+  CmdDo <$> bracedSemiSep1 cmdStmtParser++-- | Parse a command if-then-else: @if exp then cmd else cmd@+cmdIfParser :: TokParser Cmd+cmdIfParser = withSpanAnn (CmdAnn . mkAnnotation) $ do+  expectedTok TkKeywordIf+  cond <- exprParser+  skipSemicolons+  expectedTok TkKeywordThen+  yes <- cmdParser+  skipSemicolons+  expectedTok TkKeywordElse+  CmdIf cond yes <$> cmdParser++-- | Parse a command case: @case exp of { calts }@+cmdCaseParser :: TokParser Cmd+cmdCaseParser = withSpanAnn (CmdAnn . mkAnnotation) $ do+  expectedTok TkKeywordCase+  scrut <- region "while parsing case scrutinee" exprParser+  expectedTok TkKeywordOf+  alts <- bracedSemiSep1 cmdCaseAltParser+  pure (CmdCase scrut alts)++cmdCaseAltParser :: TokParser (CaseAlt Cmd)+cmdCaseAltParser = withSpan $ do+  pat <- caseAltPatternParser+  rhs <- caseRhsParserWithBodyParser cmdParser+  pure (\span' -> CaseAlt [mkAnnotation span'] pat rhs)++-- | Parse a command let: @let decls in cmd@+cmdLetParser :: TokParser Cmd+cmdLetParser = withSpanAnn (CmdAnn . mkAnnotation) $ do+  decls <- parseLetDeclsParser+  expectedTok TkKeywordIn+  CmdLet decls <$> cmdParser++-- | Parse a command lambda: @\\pats -> cmd@+cmdLamParser :: TokParser Cmd+cmdLamParser = withSpanAnn (CmdAnn . mkAnnotation) $ do+  expectedTok TkReservedBackslash+  pats <- MP.some apatParser+  expectedTok TkReservedRightArrow+  CmdLam pats <$> cmdParser++-- | Parse a parenthesised command: @( cmd )@+cmdParenParser :: TokParser Cmd+cmdParenParser =+  withSpanAnn (CmdAnn . mkAnnotation) $+    CmdPar <$> parens cmdParser++-- | Parse a do-statement in command context (arrow do).+cmdStmtParser :: TokParser (DoStmt Cmd)+cmdStmtParser = do+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkKeywordLet -> MP.try cmdLetStmtParser <|> cmdBodyStmtParser+    TkKeywordRec -> cmdRecStmtParser+    -- Keyword commands: parse as command body statements.+    TkKeywordDo -> cmdBodyStmtParser+    TkKeywordIf -> cmdBodyStmtParser+    TkKeywordCase -> cmdBodyStmtParser+    TkReservedBackslash -> cmdBodyStmtParser+    TkSpecialLParen -> MP.try cmdBindOrBodyStmtParser <|> MP.try cmdBindStmtParser <|> cmdBodyStmtParser+    _ -> do+      isPatternBind <- startsWithPatternBind+      if isPatternBind+        then cmdBindStmtParser+        else cmdBindOrBodyStmtParser++startsWithPatternBind :: TokParser Bool+startsWithPatternBind =+  fmap (either (const False) (const True)) . MP.observing . MP.try . MP.lookAhead $ do+    _ <- patternParser+    expectedTok TkReservedLeftArrow++-- | Parse a command do-statement: @cmd@ or @pat <- cmd@.+-- Uses the expression-first approach: parse as expression, check for @<-@.+cmdBindOrBodyStmtParser :: TokParser (DoStmt Cmd)+cmdBindOrBodyStmtParser = withSpanAnn (DoAnn . mkAnnotation) $ do+  -- Arrow tails (-<, -<<) belong to the command level, not the expression.+  expr <- exprParser+  mArrow <- MP.optional (expectedTok TkReservedLeftArrow)+  case mArrow of+    Just () -> DoBind <$> liftCheck (checkPattern expr) <*> cmdParser+    Nothing -> do+      -- No bind arrow: this is a body statement.  Check for arrow tail.+      mArrTail <- MP.optional cmdArrTailParser+      case mArrTail of+        Just (appType, rhs) ->+          pure (DoExpr (CmdArrApp expr appType rhs))+        Nothing -> do+          mTok <- MP.optional (lookAhead anySingle)+          MP.customFailure+            UnexpectedTokenExpecting+              { unexpectedFound = mkFoundToken <$> mTok,+                unexpectedExpecting = "arrow command (-< or -<<) in do statement",+                unexpectedContext = []+              }++-- | Parse a command bind statement where the pattern is unambiguously a+-- pattern (starts with !, ~, or x@).+cmdBindStmtParser :: TokParser (DoStmt Cmd)+cmdBindStmtParser = withSpanAnn (DoAnn . mkAnnotation) $ do+  pat <- patternParser+  expectedTok TkReservedLeftArrow+  cmd <- region "while parsing '<-' binding" cmdParser+  pure (DoBind pat cmd)++-- | Parse a body-only command statement (fallback from cmdStmtParser).+cmdBodyStmtParser :: TokParser (DoStmt Cmd)+cmdBodyStmtParser =+  withSpanAnn (DoAnn . mkAnnotation) $+    DoExpr <$> cmdParser++-- | Parse a command let-statement: @let decls@+cmdLetStmtParser :: TokParser (DoStmt Cmd)+cmdLetStmtParser =+  withSpanAnn (DoAnn . mkAnnotation) $+    DoLetDecls <$> parseLetDeclsStmtParser++-- | Parse a command rec-statement: @rec { cstmts }@+cmdRecStmtParser :: TokParser (DoStmt Cmd)+cmdRecStmtParser = withSpanAnn (DoAnn . mkAnnotation) $ do+  expectedTok TkKeywordRec+  DoRecStmt <$> bracedSemiSep1 cmdStmtParser
+ src/Aihc/Parser/Internal/Common.hs view
@@ -0,0 +1,1062 @@+{-# LANGUAGE OverloadedStrings #-}++module Aihc.Parser.Internal.Common+  ( TokParser,+    label,+    region,+    expectedTok,+    eofTok,+    varIdTok,+    tokenSatisfy,+    hiddenPragma,+    optionalHiddenPragma,+    moduleNameParser,+    identifierNameParser,+    identifierUnqualifiedNameParser,+    identifierTextParser,+    lowerIdentifierParser,+    tyVarNameParser,+    implicitParamNameParser,+    constructorNameParser,+    constructorUnqualifiedNameParser,+    constructorOperatorUnqualifiedNameParser,+    binderNameParser,+    recordFieldNameParser,+    operatorNameParser,+    operatorUnqualifiedNameParser,+    operatorTextParser,+    constructorInfixOperatorNameParser,+    stringTextParser,+    withSpan,+    withSpanAnn,+    optionalSuffix,+    parens,+    braces,+    thQuoteParser,+    skipSemicolons,+    bracedSemiSep,+    bracedSemiSep1,+    plainSemiSep,+    plainSemiSep1,+    contextItemParserWith,+    contextItemsParserWith,+    contextParserWith,+    typedSignaturePrefixParser,+    typedBindingOrSignatureParser,+    functionHeadParserWith,+    functionHeadParserWithBinder,+    functionBindValue,+    functionBindDecl,+    isExtensionEnabled,+    thAnyEnabled,+    asPatternParser,+    tupleDelimsParser,+    recordFieldsWithWildcardsParser,+    closeImplicitLayout,+    layoutSepEndBy,+    layoutSepBy1,+    drainParseErrors,+    startsWithContextType,+    startsWithTypeSig,+    startsWithAsPattern,+    startsWithTypeBinder,+    isConLikeName,+    isConLikeNameType,+    liftCheck,+    infixOperatorParser,+    foldInfixL,+    foldInfixR,+  )+where++import Aihc.Parser.Lex (LayoutState (..), LexToken (..), LexTokenKind (..), closeImplicitLayoutContext)+import Aihc.Parser.Syntax+import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken)+import Control.Monad (guard)+import Data.Char (isUpper)+import Data.Functor (($>))+import Data.List.NonEmpty qualified as NE+import Data.Maybe (catMaybes)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Text.Megaparsec (Parsec, anySingle, lookAhead, (<|>))+import Text.Megaparsec qualified as MP+import Text.Megaparsec.Error qualified as MPE++type TokParser = Parsec ParserErrorComponent TokStream++label :: Text -> TokParser a -> TokParser a+label expected parser = do+  outcome <- MP.observing parser+  case outcome of+    Right parsed -> pure parsed+    Left err ->+      case err of+        MPE.TrivialError off _ _ -> do+          mTok <- MP.optional (lookAhead anySingle)+          let mFound = mkFoundToken <$> mTok+          MP.parseError $+            MPE.FancyError+              off+              ( Set.singleton+                  ( MPE.ErrorCustom+                      UnexpectedTokenExpecting+                        { unexpectedFound = mFound,+                          unexpectedExpecting = expected,+                          unexpectedContext = []+                        }+                  )+              )+        _ -> MP.parseError err++region :: Text -> TokParser a -> TokParser a+region context =+  MP.region addContextToError+  where+    addContextToError err =+      case err of+        MPE.FancyError off fancySet ->+          MPE.FancyError off (Set.map appendContext fancySet)+        _ -> err+    appendContext fancyErr =+      case fancyErr of+        MPE.ErrorCustom custom ->+          case custom of+            UnexpectedTokenExpecting found expecting contexts ->+              MPE.ErrorCustom (UnexpectedTokenExpecting found expecting (contexts <> [context]))+        _ -> fancyErr++-- | Match a specific token kind exactly.+expectedTok :: LexTokenKind -> TokParser ()+expectedTok expected =+  tokenSatisfy (renderTokenKind expected) $ \tok ->+    if lexTokenKind tok == expected then Just () else Nothing++-- | Match the end-of-file token.+--+-- The lexer emits a 'TkEOF' token at the end of input. This parser consumes+-- that token, ensuring the entire input has been processed.+eofTok :: TokParser ()+eofTok =+  tokenSatisfy "end of input" $ \tok ->+    if lexTokenKind tok == TkEOF then Just () else Nothing++-- | Match a specific variable identifier (contextual keyword).+varIdTok :: Text -> TokParser ()+varIdTok expected =+  tokenSatisfy ("identifier '" <> T.unpack expected <> "'") $ \tok ->+    case lexTokenKind tok of+      TkVarId ident | ident == expected -> Just ()+      _ -> Nothing++renderTokenKind :: LexTokenKind -> String+renderTokenKind tk = case tk of+  TkSpecialLParen -> "symbol '('"+  TkSpecialRParen -> "symbol ')'"+  TkSpecialUnboxedLParen -> "symbol '(#'"+  TkSpecialUnboxedRParen -> "symbol '#)'"+  TkSpecialComma -> "symbol ','"+  TkSpecialSemicolon -> "symbol ';'"+  TkSpecialLBracket -> "symbol '['"+  TkSpecialRBracket -> "symbol ']'"+  TkSpecialBacktick -> "symbol '`'"+  TkSpecialLBrace -> "symbol '{'"+  TkSpecialRBrace -> "symbol '}'"+  TkReservedDotDot -> "operator '..'"+  TkReservedColon -> "operator ':'"+  TkReservedDoubleColon -> "operator '::'"+  TkReservedEquals -> "operator '='"+  TkReservedBackslash -> "operator '\\'"+  TkReservedPipe -> "operator '|'"+  TkReservedLeftArrow -> "operator '<-'"+  TkReservedRightArrow -> "operator '->'"+  TkReservedAt -> "operator '@'"+  TkReservedDoubleArrow -> "operator '=>'"+  TkArrowTail -> "operator '-<'"+  TkArrowTailReverse -> "operator '>-'"+  TkDoubleArrowTail -> "operator '-<<'"+  TkDoubleArrowTailReverse -> "operator '>>-'"+  TkBananaOpen -> "operator '(|'"+  TkBananaClose -> "operator '|)'"+  TkPrefixBang -> "bang pattern '!'"+  TkPrefixTilde -> "irrefutable pattern '~'"+  TkTypeApp -> "type application '@'"+  TkTHExpQuoteOpen -> "TH expression quote '[|'"+  TkTHExpQuoteClose -> "TH expression quote close '|]'"+  TkTHTypedQuoteOpen -> "TH typed quote '[||'"+  TkTHTypedQuoteClose -> "TH typed quote close '||]'"+  TkTHDeclQuoteOpen -> "TH declaration quote '[d|'"+  TkTHTypeQuoteOpen -> "TH type quote '[t|'"+  TkTHPatQuoteOpen -> "TH pattern quote '[p|'"+  TkTHQuoteTick -> "TH name quote '''"+  TkTHTypeQuoteTick -> "TH type name quote ''''"+  TkTHSplice -> "TH splice '$'"+  TkTHTypedSplice -> "TH typed splice '$$'"+  TkImplicitParam name -> "implicit parameter " <> show name+  TkVarSym op -> "operator '" <> show op <> "'"+  TkConSym op -> "operator '" <> show op <> "'"+  TkKeywordModule -> "keyword 'module'"+  TkKeywordWhere -> "keyword 'where'"+  TkKeywordDo -> "keyword 'do'"+  TkKeywordData -> "keyword 'data'"+  TkKeywordImport -> "keyword 'import'"+  TkKeywordCase -> "keyword 'case'"+  TkKeywordOf -> "keyword 'of'"+  TkKeywordLet -> "keyword 'let'"+  TkKeywordIn -> "keyword 'in'"+  TkKeywordIf -> "keyword 'if'"+  TkKeywordThen -> "keyword 'then'"+  TkKeywordElse -> "keyword 'else'"+  TkKeywordProc -> "keyword 'proc'"+  TkKeywordPattern -> "keyword 'pattern'"+  TkKeywordRec -> "keyword 'rec'"+  TkKeywordBy -> "keyword 'by'"+  TkKeywordUsing -> "keyword 'using'"+  _ -> show tk++tokenSatisfy :: String -> (LexToken -> Maybe a) -> TokParser a+tokenSatisfy expectedLabel f =+  MP.token f expectedItems+  where+    expectedItems =+      Set.singleton $+        if null expectedLabel+          then MPE.EndOfInput+          else MPE.Label (NE.fromList expectedLabel)++hiddenPragma :: String -> (Pragma -> Maybe a) -> TokParser a+hiddenPragma expectedLabel f = do+  mResult <- optionalHiddenPragma f+  case mResult of+    Just result -> pure result+    Nothing -> fail expectedLabel++optionalHiddenPragma :: (Pragma -> Maybe a) -> TokParser (Maybe a)+optionalHiddenPragma f = do+  pst <- MP.getParserState+  case spanNoMatch (tokStreamPendingPragmas (MP.stateInput pst)) of+    (ignored, pragmaTok : rest)+      | Just result <- f pragmaTok -> do+          MP.updateParserState $ \st ->+            st+              { MP.stateInput =+                  (MP.stateInput st)+                    { tokStreamPendingPragmas = ignored <> rest+                    }+              }+          pure (Just result)+      | otherwise -> pure Nothing+    _ -> pure Nothing+  where+    spanNoMatch pragmas =+      case pragmas of+        pragmaTok : rest+          | Just _ <- f pragmaTok -> ([], pragmaTok : rest)+          | otherwise ->+              let (ignored, remaining) = spanNoMatch rest+               in (pragmaTok : ignored, remaining)+        [] -> ([], [])++moduleNameParser :: TokParser Text+moduleNameParser =+  label "module name" $+    tokenSatisfy "module name" $ \tok ->+      case lexTokenKind tok of+        TkConId ident | isModuleName ident -> Just ident+        TkQConId modName name | isModuleName (modName <> "." <> name) -> Just (modName <> "." <> name)+        _ -> Nothing++identifierNameParser :: TokParser Name+identifierNameParser =+  tokenSatisfy "identifier" $ \tok ->+    case lexTokenKind tok of+      TkVarId ident -> Just (qualifyName Nothing (mkUnqualifiedName NameVarId ident))+      TkConId ident -> Just (qualifyName Nothing (mkUnqualifiedName NameConId ident))+      TkQVarId modName ident -> Just (mkName (Just modName) NameVarId ident)+      TkQConId modName ident -> Just (mkName (Just modName) NameConId ident)+      _ -> Nothing++identifierUnqualifiedNameParser :: TokParser UnqualifiedName+identifierUnqualifiedNameParser =+  tokenSatisfy "unqualified identifier" $ \tok ->+    case lexTokenKind tok of+      TkVarId ident -> Just (mkUnqualifiedName NameVarId ident)+      TkConId ident -> Just (mkUnqualifiedName NameConId ident)+      _ -> Nothing++identifierTextParser :: TokParser Text+identifierTextParser = renderName <$> identifierNameParser++lowerIdentifierParser :: TokParser Text+lowerIdentifierParser =+  tokenSatisfy "lowercase identifier" $ \tok ->+    case lexTokenKind tok of+      TkVarId ident -> Just ident+      TkQVarId modName ident -> Just (modName <> "." <> ident)+      _ -> Nothing++tyVarNameParser :: TokParser Text+tyVarNameParser =+  lowerIdentifierParser+    <|> (expectedTok TkKeywordUnderscore $> "_")++implicitParamNameParser :: TokParser Text+implicitParamNameParser =+  tokenSatisfy "implicit parameter" $ \tok ->+    case lexTokenKind tok of+      TkImplicitParam name -> Just name+      _ -> Nothing++constructorNameParser :: TokParser Name+constructorNameParser =+  tokenSatisfy "constructor identifier" $ \tok ->+    case lexTokenKind tok of+      TkConId ident -> Just (qualifyName Nothing (mkUnqualifiedName NameConId ident))+      TkQConId modName ident -> Just (mkName (Just modName) NameConId ident)+      _ -> Nothing++constructorUnqualifiedNameParser :: TokParser UnqualifiedName+constructorUnqualifiedNameParser =+  tokenSatisfy "unqualified constructor identifier" $ \tok ->+    case lexTokenKind tok of+      TkConId ident -> Just (mkUnqualifiedName NameConId ident)+      _ -> Nothing++constructorOperatorUnqualifiedNameParser :: TokParser UnqualifiedName+constructorOperatorUnqualifiedNameParser =+  tokenSatisfy "unqualified constructor operator" $ \tok ->+    case lexTokenKind tok of+      TkConSym op -> Just (mkUnqualifiedName NameConSym op)+      TkReservedColon -> Just (mkUnqualifiedName NameConSym ":")+      _ -> Nothing++binderNameParser :: TokParser UnqualifiedName+binderNameParser =+  identifierUnqualifiedNameParser+    <|> parens operatorUnqualifiedNameParser++recordFieldNameParser :: TokParser Name+recordFieldNameParser =+  identifierNameParser+    <|> parens operatorNameParser++operatorTextParser :: TokParser Text+operatorTextParser = renderName <$> operatorNameParser++operatorNameParser :: TokParser Name+operatorNameParser =+  tokenSatisfy "operator" $ \tok ->+    case lexTokenKind tok of+      TkVarSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym op))+      TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op))+      TkQVarSym modName op -> Just (mkName (Just modName) NameVarSym op)+      TkQConSym modName op -> Just (mkName (Just modName) NameConSym op)+      TkReservedAt -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "@"))+      _ -> Nothing++operatorUnqualifiedNameParser :: TokParser UnqualifiedName+operatorUnqualifiedNameParser =+  tokenSatisfy "unqualified operator" $ \tok ->+    case lexTokenKind tok of+      TkVarSym op -> Just (mkUnqualifiedName NameVarSym op)+      TkConSym op -> Just (mkUnqualifiedName NameConSym op)+      TkReservedRightArrow -> Just (mkUnqualifiedName NameVarSym "->")+      TkReservedLeftArrow -> Just (mkUnqualifiedName NameVarSym "<-")+      TkReservedDoubleArrow -> Just (mkUnqualifiedName NameVarSym "=>")+      TkReservedEquals -> Just (mkUnqualifiedName NameVarSym "=")+      TkReservedPipe -> Just (mkUnqualifiedName NameVarSym "|")+      TkReservedDotDot -> Just (mkUnqualifiedName NameVarSym "..")+      TkReservedDoubleColon -> Just (mkUnqualifiedName NameVarSym "::")+      TkReservedColon -> Just (mkUnqualifiedName NameConSym ":")+      TkReservedAt -> Just (mkUnqualifiedName NameVarSym "@")+      _ -> Nothing++-- | Parse an infix operator name (varop) for function definitions.+-- Per Haskell Report section 4.4.3, funlhs uses 'varop' which is:+--   varop → varsym | ` varid `+-- This excludes constructor operators (consym) and qualified operators.+-- Note: Whitespace-sensitive lexing (GHC proposal 0229) now distinguishes+-- TkVarSym "!" (infix operator) from TkPrefixBang (bang pattern), so we+-- can accept all VarSym operators here.+infixOperatorNameParser :: TokParser UnqualifiedName+infixOperatorNameParser =+  symbolicOperatorParser <|> backtickIdentifierParser+  where+    symbolicOperatorParser =+      tokenSatisfy "variable operator" $ \tok ->+        case lexTokenKind tok of+          TkVarSym op -> Just (mkUnqualifiedName NameVarSym op)+          _ -> Nothing+    backtickIdentifierParser = do+      expectedTok TkSpecialBacktick+      op <- varIdTextParser+      expectedTok TkSpecialBacktick+      pure (mkUnqualifiedName NameVarId op)+    varIdTextParser =+      tokenSatisfy "variable identifier" $ \tok ->+        case lexTokenKind tok of+          TkVarId name -> Just name+          _ -> Nothing++-- | Parse an infix constructor operator name (conop) for pattern synonym where clauses.+-- Per Haskell Report, pattern synonym where-clause equations use the constructor+-- name in infix position: @pat ConOp pat = expr@.+-- This is the constructor counterpart of 'infixOperatorNameParser'.+--   conop → consym | ` conid `+constructorInfixOperatorNameParser :: TokParser UnqualifiedName+constructorInfixOperatorNameParser =+  symbolicConstructorOperatorParser <|> backtickConstructorIdentifierParser+  where+    symbolicConstructorOperatorParser =+      tokenSatisfy "constructor operator" $ \tok ->+        case lexTokenKind tok of+          TkConSym op -> Just (mkUnqualifiedName NameConSym op)+          TkReservedColon -> Just (mkUnqualifiedName NameConSym ":")+          _ -> Nothing+    backtickConstructorIdentifierParser = do+      expectedTok TkSpecialBacktick+      op <- constructorIdentifierTextParser+      expectedTok TkSpecialBacktick+      pure (mkUnqualifiedName NameConId op)+    constructorIdentifierTextParser =+      tokenSatisfy "constructor identifier" $ \tok ->+        case lexTokenKind tok of+          TkConId name -> Just name+          _ -> Nothing++stringTextParser :: TokParser Text+stringTextParser =+  tokenSatisfy "string literal" $ \tok ->+    case lexTokenKind tok of+      TkString txt -> Just txt+      _ -> Nothing++withSpanAnn :: (SourceSpan -> a -> a) -> TokParser a -> TokParser a+withSpanAnn f parser = do+  ts <- fmap MP.stateInput MP.getParserState+  let startSpan+        | tokStreamEOFEmitted ts = noSourceSpan+        | tok : _ <- layoutBuffer (tokStreamLayoutState ts) = lexTokenSpan tok+        | rawTok : _ <- tokStreamRawTokens ts = lexTokenSpan rawTok+        | otherwise = noSourceSpan+  out <- parser+  lastToken <- fmap (tokStreamPrevToken . MP.stateInput) MP.getParserState+  let endSpan = maybe noSourceSpan lexTokenSpan lastToken+      parserSpan = mergeSourceSpans startSpan endSpan+  pure $ f parserSpan out++-- FIXME: Remove.+withSpan :: TokParser (SourceSpan -> a) -> TokParser a+withSpan parser = do+  ts <- fmap MP.stateInput MP.getParserState+  let startSpan+        | tokStreamEOFEmitted ts = noSourceSpan+        | tok : _ <- layoutBuffer (tokStreamLayoutState ts) = lexTokenSpan tok+        | rawTok : _ <- tokStreamRawTokens ts = lexTokenSpan rawTok+        | otherwise = noSourceSpan+  out <- parser+  lastToken <- fmap (tokStreamPrevToken . MP.stateInput) MP.getParserState+  let endSpan = maybe noSourceSpan lexTokenSpan lastToken+      parserSpan = mergeSourceSpans startSpan endSpan+  pure (out parserSpan)++optionalSuffix :: TokParser b -> (a -> b -> a) -> TokParser a -> TokParser a+optionalSuffix suffixParser attach parser = do+  base <- parser+  mSuffix <- MP.optional suffixParser+  pure $+    case mSuffix of+      Just suffix -> attach base suffix+      Nothing -> base++parens :: TokParser a -> TokParser a+parens parser = expectedTok TkSpecialLParen *> parser <* expectedTok TkSpecialRParen++braces :: TokParser a -> TokParser a+braces parser = expectedTok TkSpecialLBrace *> parser <* closeAndExpectRBrace++-- | Parse a delimited construct with an annotation wrapper.+-- Used for Template Haskell quotes: @open body close@.+thQuoteParser :: (SourceSpan -> c -> c) -> LexTokenKind -> LexTokenKind -> TokParser a -> (a -> c) -> TokParser c+thQuoteParser ann openTok closeTok bodyParser ctor =+  withSpanAnn ann $ do+    expectedTok openTok+    body <- bodyParser+    expectedTok closeTok+    pure (ctor body)++-- | Expect a @}@ token, closing implicit layout contexts if needed.+-- This implements the parse-error rule for closing braces: if @}@ is not found+-- but there is an implicit layout context, close it (which buffers a virtual @}@)+-- and consume that virtual @}@.+closeAndExpectRBrace :: TokParser ()+closeAndExpectRBrace =+  expectedTok TkSpecialRBrace <|> do+    closed <- closeImplicitLayout+    if closed then expectedTok TkSpecialRBrace else MP.empty++skipSemicolons :: TokParser ()+skipSemicolons = MP.skipMany (expectedTok TkSpecialSemicolon)++bracedSemiSep :: TokParser a -> TokParser [a]+bracedSemiSep = braces . layoutSemiSep++bracedSemiSep1 :: TokParser a -> TokParser [a]+bracedSemiSep1 = braces . layoutSemiSep1++-- | Zero-or-more variant of 'plainSemiSep1'.+-- Parses zero or more items separated by semicolons (no surrounding braces).+plainSemiSep :: TokParser a -> TokParser [a]+plainSemiSep = layoutSemiSep++plainSemiSep1 :: TokParser a -> TokParser [a]+plainSemiSep1 = layoutSemiSep1++layoutSemiSep :: TokParser a -> TokParser [a]+layoutSemiSep parser =+  catMaybes <$> MP.sepBy (MP.optional parser) (expectedTok TkSpecialSemicolon)++layoutSemiSep1 :: TokParser a -> TokParser [a]+layoutSemiSep1 parser = do+  items <- layoutSemiSep parser+  case items of+    [] -> MP.empty+    _ -> pure items++contextItemParserWith :: TokParser Type -> TokParser Type -> TokParser Type+contextItemParserWith typeParser typeAtomParser =+  withSpanAnn (TAnn . mkAnnotation) $+    MP.try parenthesizedContextItemParser <|> MP.try kindSigContextItemParser <|> bareContextItemParser+  where+    bareContextItemParser =+      do+        name <- implicitParamNameParser+        expectedTok TkReservedDoubleColon+        TImplicitParam name <$> typeParser+        <|> do+          expectedTok TkKeywordUnderscore+          pure TWildcard+        <|> constraintTypeParser+    parenthesizedContextItemParser = do+      expectedTok TkSpecialLParen+      item <- contextItemParserWith typeParser typeAtomParser+      expectedTok TkSpecialRParen+      guardNotFollowedByConstraintInfixOp+      pure (TParen item)+      where+        guardNotFollowedByConstraintInfixOp = do+          isFollowed <-+            fmap (either (const False) (const True))+              . MP.observing+              . MP.try+              . MP.lookAhead+              $ constraintTypeInfixOperatorParser+          guard (not isFollowed)+    -- \| Parse a type followed by `::` and another type (kind annotation).+    -- This handles cases like `(c :: Type -> Constraint)` in superclass contexts,+    -- both as standalone parenthesized constraints and as items in comma-separated lists.+    -- Uses lookahead to check for `::` at top bracket depth to avoid ambiguity.+    -- IMPORTANT: Uses `constraintTypeAppParser` (not `typeParser`) for the left side+    -- to avoid a parsing cycle: typeParser -> contextTypeParser -> constraintsParserWith+    -- -> constraintParserWith -> kindSigConstraintParser -> typeParser.+    kindSigContextItemParser :: TokParser Type+    kindSigContextItemParser = do+      guard =<< hasKindSignatureAtTopLevel+      ty <- constraintTypeAppParser+      expectedTok TkReservedDoubleColon+      TKindSig ty <$> kindTypeParser++    -- \| Lookahead: check if there's a `::` at the top bracket depth.+    -- This avoids ambiguity with the bare constraint parser.+    hasKindSignatureAtTopLevel :: TokParser Bool+    hasKindSignatureAtTopLevel = MP.lookAhead (go 0)+      where+        go :: Int -> TokParser Bool+        go depth = do+          tok <- anySingle+          case lexTokenKind tok of+            TkEOF -> pure False+            TkReservedDoubleColon | depth == 0 -> pure True+            TkReservedRightArrow | depth == 0 -> pure False+            TkSpecialComma | depth == 0 -> pure False+            TkSpecialLParen -> go (depth + 1)+            TkSpecialRParen+              | depth > 0 -> go (depth - 1)+              | otherwise -> pure False+            TkSpecialUnboxedLParen -> go (depth + 1)+            TkSpecialUnboxedRParen+              | depth > 0 -> go (depth - 1)+              | otherwise -> pure False+            TkSpecialLBracket -> go (depth + 1)+            TkSpecialRBracket+              | depth > 0 -> go (depth - 1)+              | otherwise -> pure False+            _ -> go depth+    constraintTypeParser = do+      first <- constraintTypeAppParser+      rest <- MP.many ((,) <$> constraintTypeInfixOperatorParser <*> constraintTypeAppParser)+      pure (foldInfixR buildInfixType first rest)+    constraintTypeAppParser = do+      first <- typeAtomParser+      rest <- MP.many constraintTypeAppArgParser+      pure (foldl applyConstraintAppArg first rest)+    constraintTypeAppArgParser =+      (Left <$> MP.try (expectedTok TkTypeApp *> (typeAtomParser >>= rejectBareConstraintImplicitParam)))+        <|> (Right <$> (typeAtomParser >>= rejectBareConstraintImplicitParam))+    applyConstraintAppArg fn (Left ty) = TTypeApp fn ty+    applyConstraintAppArg fn (Right ty) = TApp fn ty+    rejectBareConstraintImplicitParam ty =+      case peelTypeAnn ty of+        TImplicitParam {} -> fail "implicit parameter type must be parenthesized"+        _ -> pure ty+    -- \| Parse a type expression that can appear as a kind annotation.+    -- Handles function types (e.g., Type -> Constraint) and type application,+    -- but NOT context types (C a => ...) to avoid parsing cycles.+    kindTypeParser = do+      first <- constraintTypeAppParser+      rest <- MP.many ((,) <$> constraintTypeInfixOperatorParser <*> constraintTypeAppParser)+      let baseType = foldInfixR buildInfixType first rest+      mRhs <- MP.optional (expectedTok TkReservedRightArrow *> kindTypeParser)+      case mRhs of+        Just rhs ->+          pure (TFun ArrowUnrestricted baseType rhs)+        Nothing -> pure baseType+    buildInfixType lhs ((op, promoted), rhs) =+      TInfix lhs op promoted rhs+    constraintTypeInfixOperatorParser =+      MP.try promotedInfixOperatorParser <|> backtickConstraintOperatorParser <|> unpromotedInfixOperatorParser+    backtickConstraintOperatorParser = MP.try $ do+      expectedTok TkSpecialBacktick+      op <- constraintOperatorIdentifierParser+      expectedTok TkSpecialBacktick+      pure (op, Unpromoted)+    constraintOperatorIdentifierParser =+      tokenSatisfy "constraint operator identifier" $ \tok ->+        case lexTokenKind tok of+          TkVarId name -> Just (qualifyName Nothing (mkUnqualifiedName NameVarId name))+          TkConId name -> Just (qualifyName Nothing (mkUnqualifiedName NameConId name))+          _ -> Nothing+    unpromotedInfixOperatorParser =+      tokenSatisfy "type infix operator" $ \tok ->+        case lexTokenKind tok of+          TkVarSym op+            | op /= "."+                && op /= "!" ->+                Just (qualifyName Nothing (mkUnqualifiedName NameVarSym op), Unpromoted)+          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op), Unpromoted)+          TkQVarSym modName op ->+            Just (mkName (Just modName) NameVarSym op, Unpromoted)+          TkQConSym modName op -> Just (mkName (Just modName) NameConSym op, Unpromoted)+          _ -> Nothing+    promotedInfixOperatorParser = do+      expectedTok (TkVarSym "'")+      expectedTok TkReservedColon+      pure (qualifyName Nothing (mkUnqualifiedName NameConSym ":"), Promoted)++contextItemsParserWith :: TokParser Type -> TokParser Type -> TokParser [Type]+contextItemsParserWith typeParser typeAtomParser =+  MP.try parenthesizedContextItemsParser <|> fmap pure (contextItemParserWith typeParser typeAtomParser)+  where+    parenthesizedContextItemsParser = do+      items <- parens (contextItemParserWith typeParser typeAtomParser `MP.sepEndBy` expectedTok TkSpecialComma)+      guardNotFollowedByConstraintInfixOp+      case items of+        [] -> fail "empty constraint list in parens"+        [item] -> pure [typeAnnSpan NoSourceSpan (TParen item)]+        _ -> pure items+    guardNotFollowedByConstraintInfixOp = do+      isFollowed <-+        fmap (either (const False) (const True))+          . MP.observing+          . MP.try+          . MP.lookAhead+          $ constraintInfixOpStartParser+      guard (not isFollowed)+    constraintInfixOpStartParser =+      tokenSatisfy "constraint infix operator" $ \tok ->+        case lexTokenKind tok of+          TkVarSym op+            | op /= "."+                && op /= "!" ->+                Just ()+          TkConSym _ -> Just ()+          TkQVarSym _ _ -> Just ()+          TkQConSym _ _ -> Just ()+          TkSpecialBacktick -> Just ()+          _ -> Nothing++contextParserWith :: TokParser Type -> TokParser Type -> TokParser [Type]+contextParserWith = contextItemsParserWith++-- | Parse the shared @vars :: type@ prefix used by type signatures and typed+-- bindings.+typedSignaturePrefixParser :: TokParser ty -> TokParser ([UnqualifiedName], ty)+typedSignaturePrefixParser typeParser = do+  names <- binderNameParser `MP.sepBy1` expectedTok TkSpecialComma+  expectedTok TkReservedDoubleColon+  ty <- typeParser+  pure (names, ty)++-- | Parse either a plain type signature or a typed binding that must be+-- reinterpreted when followed by @=@ or guarded RHS syntax.+typedBindingOrSignatureParser ::+  TokParser ty ->+  ([UnqualifiedName] -> ty -> a) ->+  (UnqualifiedName -> ty -> TokParser a) ->+  String ->+  TokParser a+typedBindingOrSignatureParser typeParser signatureCtor bindingCtor singleBinderMsg = do+  (names, ty) <- typedSignaturePrefixParser typeParser+  nextKind <- lexTokenKind <$> lookAhead anySingle+  if nextKind == TkReservedEquals || nextKind == TkReservedPipe+    then case names of+      [name] -> bindingCtor name ty+      _ -> fail singleBinderMsg+    else pure (signatureCtor names ty)++functionHeadParserWith :: TokParser Pattern -> TokParser Pattern -> TokParser (MatchHeadForm, UnqualifiedName, [Pattern])+functionHeadParserWith = functionHeadParserWithBinder functionBinderNameParser infixOperatorNameParser++functionHeadParserWithBinder :: TokParser UnqualifiedName -> TokParser UnqualifiedName -> TokParser Pattern -> TokParser Pattern -> TokParser (MatchHeadForm, UnqualifiedName, [Pattern])+functionHeadParserWithBinder binderParser infixOpParser infixPatternParser prefixPatternParser =+  MP.try parenthesizedInfixHeadParser+    <|> MP.try infixHeadParser+    <|> prefixHeadParser+  where+    prefixHeadParser = do+      name <- binderParser+      pats <- MP.many prefixPatternParser+      pure (MatchHeadPrefix, name, pats)++    infixHeadParser = do+      lhsPat <- infixPatternParser+      op <- infixOpParser+      rhsPat <- infixPatternParser+      pure (MatchHeadInfix, op, [lhsPat, rhsPat])++    parenthesizedInfixHeadParser = do+      expectedTok TkSpecialLParen+      lhsPat <- infixPatternParser+      op <- infixOpParser+      rhsPat <- infixPatternParser+      expectedTok TkSpecialRParen+      tailPats <- MP.many prefixPatternParser+      pure (MatchHeadInfix, op, [lhsPat, rhsPat] <> tailPats)++functionBinderNameParser :: TokParser UnqualifiedName+functionBinderNameParser =+  variableIdentifierParser <|> parens variableOperatorParser+  where+    variableIdentifierParser =+      tokenSatisfy "function binder" $ \tok ->+        case lexTokenKind tok of+          TkVarId ident -> Just (mkUnqualifiedName NameVarId ident)+          _ -> Nothing+    variableOperatorParser =+      tokenSatisfy "variable operator" $ \tok ->+        case lexTokenKind tok of+          TkVarSym ident -> Just (mkUnqualifiedName NameVarSym ident)+          TkReservedAt -> Just (mkUnqualifiedName NameVarSym "@")+          _ -> Nothing++functionBindValue :: MatchHeadForm -> UnqualifiedName -> [Pattern] -> Rhs Expr -> ValueDecl+functionBindValue _headForm name [] rhs =+  -- Zero-argument bindings (e.g. @x = 5@, @x | g = 5@) are pattern bindings,+  -- not function bindings. 'FunctionBind' is reserved for declarations with+  -- at least one argument pattern.+  PatternBind NoMultiplicityTag (PVar name) rhs+functionBindValue headForm name pats rhs =+  FunctionBind+    name+    [ Match+        { matchAnns = [],+          matchHeadForm = headForm,+          matchPats = pats,+          matchRhs = rhs+        }+    ]++functionBindDecl :: MatchHeadForm -> UnqualifiedName -> [Pattern] -> Rhs Expr -> Decl+functionBindDecl headForm name pats rhs =+  DeclValue (functionBindValue headForm name pats rhs)++isModuleName :: Text -> Bool+isModuleName name =+  case T.splitOn "." name of+    [] -> False+    segments -> all isConstructorIdentifier segments++isConstructorIdentifier :: Text -> Bool+isConstructorIdentifier txt =+  case T.uncons txt of+    Just (c, _) -> isUpper c+    Nothing -> False++isExtensionEnabled :: Extension -> TokParser Bool+isExtensionEnabled ext = do+  pst <- MP.getParserState+  pure (ext `elem` tokStreamExtensions (MP.stateInput pst))++-- | Check whether any Template Haskell extension is enabled (quotes or full TH).+thAnyEnabled :: TokParser Bool+thAnyEnabled = do+  thEnabled <- isExtensionEnabled TemplateHaskellQuotes+  thFullEnabled <- isExtensionEnabled TemplateHaskell+  pure (thEnabled || thFullEnabled)++asPatternParser :: TokParser Pattern -> TokParser Pattern+asPatternParser bodyParser = withSpanAnn (PAnn . mkAnnotation) $ do+  name <- MP.try (binderNameParser <* expectedTok TkReservedAt)+  PAs name <$> bodyParser++tupleDelimsParser :: TokParser (TupleFlavor, LexTokenKind)+tupleDelimsParser =+  (expectedTok TkSpecialLParen $> (Boxed, TkSpecialRParen))+    <|> (expectedTok TkSpecialUnboxedLParen $> (Unboxed, TkSpecialUnboxedRParen))++recordFieldsWithWildcardsParser :: TokParser [a] -> TokParser ([a], Bool)+recordFieldsWithWildcardsParser fieldsParser = do+  rwcEnabled <- isExtensionEnabled RecordWildCards+  fields <- fieldsParser+  if rwcEnabled+    then do+      mDotDot <- MP.optional (expectedTok TkReservedDotDot)+      case mDotDot of+        Nothing -> pure (fields, False)+        Just _ -> do+          _ <- MP.optional (expectedTok TkSpecialComma)+          pure (fields, True)+    else pure (fields, False)++-- | Signal to the layout engine that a virtual close brace should be inserted.+-- This implements the parse-error rule: when the parser encounters a token that+-- is illegal in the current context but @}@ would be legal, it calls this to+-- close the innermost implicit layout context.+--+-- Returns @True@ if a layout was closed, @False@ if there was no implicit+-- layout context to close.+closeImplicitLayout :: TokParser Bool+closeImplicitLayout = do+  pst <- MP.getParserState+  let ts = MP.stateInput pst+  case closeImplicitLayoutContext (tokStreamLayoutState ts) of+    Nothing -> pure False+    Just laySt' -> do+      MP.updateParserState (\s -> s {MP.stateInput = (MP.stateInput s) {tokStreamLayoutState = laySt'}})+      pure True++-- | Like Megaparsec's 'MP.sepEndBy' but implements the parse-error rule for+-- the separator. When the separator fails, we try closing an implicit layout+-- context and retrying — this handles cases like:+--+-- @R { f = case y of A -> 1, g = 2 }@+--+-- where the comma is a record field separator but appears inside the implicit+-- @case@ layout.+layoutSepEndBy :: TokParser a -> TokParser sep -> TokParser [a]+layoutSepEndBy p sep = layoutSepEndBy1 p sep <|> pure []++layoutSepEndBy1 :: TokParser a -> TokParser sep -> TokParser [a]+layoutSepEndBy1 p sep = do+  x <- p+  rest <- MP.option [] $ do+    _ <- layoutSep sep+    layoutSepEndBy p sep+  pure (x : rest)++-- | Like Megaparsec's 'MP.sepBy1' but implements the parse-error rule for+-- the separator.+layoutSepBy1 :: TokParser a -> TokParser sep -> TokParser [a]+layoutSepBy1 p sep = do+  x <- p+  rest <- MP.many $ do+    _ <- layoutSep sep+    p+  pure (x : rest)++-- | Try to match a separator token. If that fails, try closing an implicit+-- layout context and then matching the separator. This implements the+-- parse-error rule: if a token is illegal in the current context but would+-- be legal after inserting a virtual @}@, insert the @}@ and retry.+layoutSep :: TokParser sep -> TokParser sep+layoutSep sep =+  MP.try sep <|> do+    closed <- closeImplicitLayout+    if closed then sep else MP.empty++-- | Drain all registered parse errors from the parser state, returning them+-- and resetting the error list to empty. This prevents 'runParser' from+-- converting a successful parse into a failure due to registered errors+-- (from 'MP.registerParseError' / 'MP.withRecovery').+drainParseErrors :: TokParser [MPE.ParseError TokStream ParserErrorComponent]+drainParseErrors = do+  st <- MP.getParserState+  let errs = MP.stateParseErrors st+  MP.updateParserState (\s -> s {MP.stateParseErrors = []})+  pure errs++-- | Non-consuming lookahead dispatch for optional context types.+-- Uses scanning to probe for @=>@ at top bracket depth.+-- Returns 'True' when the input looks like a context.+startsWithContextType :: TokParser Bool+startsWithContextType = MP.lookAhead (go [])+  where+    go :: [LexTokenKind] -> TokParser Bool+    go [] = do+      tok <- anySingle+      case lexTokenKind tok of+        TkEOF -> pure False+        TkReservedDoubleArrow -> pure True+        TkReservedDoubleColon -> pure False+        TkReservedRightArrow -> pure False+        TkReservedEquals -> pure False+        TkSpecialComma -> pure False+        TkSpecialSemicolon -> pure False+        TkReservedPipe -> pure False+        TkSpecialRParen -> pure False+        TkSpecialUnboxedRParen -> pure False+        TkSpecialRBracket -> pure False+        TkSpecialRBrace -> pure False+        TkTHExpQuoteClose -> pure False+        TkTHTypedQuoteClose -> pure False+        TkSpecialLParen -> go [TkSpecialRParen]+        TkSpecialUnboxedLParen -> go [TkSpecialUnboxedRParen]+        TkSpecialLBracket -> go [TkSpecialRBracket]+        TkTHExpQuoteOpen -> go [TkTHExpQuoteClose]+        TkTHTypedQuoteOpen -> go [TkTHTypedQuoteClose]+        TkTHDeclQuoteOpen -> go [TkTHExpQuoteClose]+        TkTHTypeQuoteOpen -> go [TkTHExpQuoteClose]+        TkTHPatQuoteOpen -> go [TkTHExpQuoteClose]+        TkSpecialLBrace -> go [TkSpecialRBrace]+        -- Keywords that cannot appear inside a type expression: stop scanning.+        -- This also prevents an enclosing expression form (such as if/then/else)+        -- from being mistaken for a later top-level context arrow.+        TkKeywordThen -> pure False+        TkKeywordElse -> pure False+        TkKeywordOf -> pure False+        TkKeywordIn -> pure False+        TkKeywordInstance -> pure False+        TkKeywordWhere -> pure False+        TkKeywordDeriving -> pure False+        TkKeywordClass -> pure False+        TkKeywordData -> pure False+        TkKeywordNewtype -> pure False+        _ -> go []+    go stack@(expectedClose : rest) = do+      tok <- anySingle+      case lexTokenKind tok of+        TkEOF -> pure False+        kind+          | kind == expectedClose ->+              case rest of+                [] -> go []+                _ -> go rest+        TkSpecialLParen -> go (TkSpecialRParen : stack)+        TkSpecialUnboxedLParen -> go (TkSpecialUnboxedRParen : stack)+        TkSpecialLBracket -> go (TkSpecialRBracket : stack)+        TkTHExpQuoteOpen -> go (TkTHExpQuoteClose : stack)+        TkTHTypedQuoteOpen -> go (TkTHTypedQuoteClose : stack)+        TkTHDeclQuoteOpen -> go (TkTHExpQuoteClose : stack)+        TkTHTypeQuoteOpen -> go (TkTHExpQuoteClose : stack)+        TkTHPatQuoteOpen -> go (TkTHExpQuoteClose : stack)+        TkSpecialLBrace -> go (TkSpecialRBrace : stack)+        _ -> go stack++-- | Non-consuming lookahead: does the input start with @name1, name2, ... ::@?+-- Used by declaration parsers to dispatch to the type-signature path without+-- 'MP.try', eliminating backtracking over the name list.+startsWithTypeSig :: TokParser Bool+startsWithTypeSig =+  fmap (either (const False) (const True)) . MP.observing . MP.try . MP.lookAhead $ do+    _ <- sigBinderNameParser+    let moreNames = (expectedTok TkSpecialComma *> sigBinderNameParser *> moreNames) <|> pure ()+    moreNames+    expectedTok TkReservedDoubleColon+  where+    sigBinderNameParser =+      binderNameParser+        <|> parens sigOperatorParser++    sigOperatorParser =+      tokenSatisfy "signature operator" $ \tok ->+        case lexTokenKind tok of+          TkVarSym op -> Just (mkUnqualifiedName NameVarSym op)+          TkConSym op -> Just (mkUnqualifiedName NameConSym op)+          TkReservedColon -> Just (mkUnqualifiedName NameConSym ":")+          _ -> Nothing++-- | Non-consuming lookahead: does the input start with @name \@@?+startsWithAsPattern :: TokParser Bool+startsWithAsPattern =+  fmap (either (const False) (const True)) . MP.observing . MP.try . MP.lookAhead $ do+    _ <- binderNameParser+    expectedTok TkReservedAt++-- | Non-consuming lookahead: does the input start with a type binder (@\@@var or @\@@_)?+-- 'TypeAbstractions' implies 'TypeApplications', so the lexer always emits 'TkTypeApp' (not+-- 'TkReservedAt') for @\@@ preceded by whitespace. All valid type binder positions have+-- whitespace before @\@@, so only 'TkTypeApp' is checked. Accepting 'TkReservedAt' here+-- would produce false positives for as-patterns such as @x\@p@.+startsWithTypeBinder :: TokParser Bool+startsWithTypeBinder =+  fmap (either (const False) (const True)) . MP.observing . MP.try . MP.lookAhead $ do+    expectedTok TkTypeApp+    _ <- lowerIdentifierParser <|> (expectedTok TkKeywordUnderscore $> "_")+    pure ()++-- | Check whether a name looks like a constructor (starts with uppercase or ':').+isConLikeName :: Name -> Bool+isConLikeName = isConLikeNameType . nameType++-- | Check whether a name type is constructor-like.+isConLikeNameType :: NameType -> Bool+isConLikeNameType NameConId = True+isConLikeNameType NameConSym = True+isConLikeNameType _ = False++-- | Lift an @Either Text a@ into the parser, converting @Left@ into a parse error.+liftCheck :: Either Text a -> TokParser a+liftCheck (Right a) = pure a+liftCheck (Left msg) = fail (T.unpack msg)++-- | Parse an infix operator.+infixOperatorParser :: TokParser Name+infixOperatorParser =+  symbolicOperatorParser <|> backtickIdentifierOperatorParser+  where+    symbolicOperatorParser =+      tokenSatisfy "infix operator" $ \tok ->+        case lexTokenKind tok of+          TkVarSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym op))+          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op))+          TkPrefixPercent -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "%"))+          TkQVarSym modName op -> Just (mkName (Just modName) NameVarSym op)+          TkQConSym modName op -> Just (mkName (Just modName) NameConSym op)+          -- TkMinusOperator is minus when LexicalNegation is enabled but used as infix+          TkMinusOperator -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "-"))+          -- Reserved operators that can be used as infix operators+          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"))+          _ -> Nothing++    backtickIdentifierOperatorParser =+      expectedTok TkSpecialBacktick *> identifierNameParser <* expectedTok TkSpecialBacktick++-- | Build a left-associated infix chain from a left operand and a list+-- of @(operator, operand)@ pairs.  Given @lhs@ and+-- @[(op1, a), (op2, b), (op3, c)]@ this produces+-- @((lhs \`op1\` a) \`op2\` b) \`op3\` c@.+--+-- This matches GHC's parsed expression AST before any later fixity+-- reassociation pass has run.+foldInfixL :: (a -> (op, a) -> a) -> a -> [(op, a)] -> a+foldInfixL = foldl++-- | Build a right-associated infix chain from a left operand and a list+-- of @(operator, operand)@ pairs.  Given @lhs@ and+-- @[(op1, a), (op2, b), (op3, c)]@ this produces+-- @lhs \`op1\` (a \`op2\` (b \`op3\` c))@.+foldInfixR :: (a -> (op, a) -> a) -> a -> [(op, a)] -> a+foldInfixR _ lhs [] = lhs+foldInfixR build lhs ((op, rhs) : rest) =+  build lhs (op, foldInfixR build rhs rest)
+ src/Aihc/Parser/Internal/Decl.hs view
@@ -0,0 +1,1696 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++module Aihc.Parser.Internal.Decl+  ( declParser,+    fixityDeclParser,+    pragmaDeclParser,+    typeSigDeclParser,+  )+where++import Aihc.Parser.Internal.Common+import {-# SOURCE #-} Aihc.Parser.Internal.Expr (equationRhsParser, exprParser)+import Aihc.Parser.Internal.Import (warningPragmaParser)+import Aihc.Parser.Internal.Pattern (apatParser, lpatParser, patParser, patternParser)+import Aihc.Parser.Internal.Type (arrowKindParser, forallTelescopeParser, typeAppParser, typeAtomParser, typeInfixOperatorParser, typeInfixParser, typeParser, typeSignatureParser)+import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind, pattern TkVarFamily, pattern TkVarRole)+import Aihc.Parser.Syntax+import Aihc.Parser.Types (ParserErrorComponent (..), mkFoundToken)+import Control.Monad (when)+import Data.Char (isLower)+import Data.Functor (($>))+import Data.Maybe (fromMaybe, isJust)+import Data.Text (Text)+import Data.Text qualified as T+import Text.Megaparsec (anySingle, lookAhead, (<|>))+import Text.Megaparsec qualified as MP++instanceOverlapPragmaParser :: TokParser Pragma+instanceOverlapPragmaParser =+  hiddenPragma "instance overlap pragma" $ \p -> case pragmaType p of+    PragmaInstanceOverlap _ -> Just p+    _ -> Nothing++anyPragmaParser :: String -> TokParser Pragma+anyPragmaParser expectedLabel = hiddenPragma expectedLabel Just++-- | Report core:+--+-- > decl -> gendecl+-- >      | (funlhs | pat) rhs+declParser :: TokParser Decl+declParser = pragmaDeclParser <|> ordinaryDeclParser++ordinaryDeclParser :: TokParser Decl+ordinaryDeclParser = do+  (tok, nextTok) <- lookAhead ((,) <$> anySingle <*> anySingle)+  exprFallback <- exprDeclEnabled+  typeSigPrefix <- startsWithTypeSig+  let tokKind = lexTokenKind tok+      nextTokKind = lexTokenKind nextTok+      valueDecl+        | exprFallback = MP.try valueDeclParser <|> exprDeclParser+        | otherwise = valueDeclParser+      sigOrValueDecl+        | typeSigPrefix = typeSigOrPatternTypeSigDeclParser+        | otherwise = valueDecl+  case tokKind of+    TkKeywordData ->+      case nextTokKind of+        TkVarFamily -> dataFamilyDeclParser+        TkKeywordInstance -> dataFamilyInstParser+        _ -> dataDeclParser+    TkKeywordClass -> classDeclParser+    TkKeywordDefault -> defaultDeclParser+    TkKeywordDeriving -> standaloneDerivingDeclParser+    TkKeywordForeign -> foreignDeclParser+    TkKeywordInfix -> fixityDeclParser+    TkKeywordInfixl -> fixityDeclParser+    TkKeywordInfixr -> fixityDeclParser+    TkKeywordInstance -> instanceDeclParser+    TkKeywordNewtype+      | nextTokKind == TkKeywordInstance -> newtypeFamilyInstParser+    TkKeywordNewtype -> newtypeDeclParser+    TkKeywordType ->+      case nextTokKind of+        TkVarRole -> roleAnnotationDeclParser+        TkVarFamily -> typeFamilyDeclParser+        TkKeywordData -> typeDataDeclParser+        TkKeywordInstance -> typeFamilyInstParser+        _ -> typeDeclarationParser+    TkKeywordPattern -> patternSynonymParser+    TkVarId {} ->+      case nextTokKind of+        TkReservedDoubleColon -> sigOrValueDecl+        TkSpecialComma -> sigOrValueDecl+        TkReservedEquals -> valueDecl+        _ -> nonBareVarPatternBindDeclParser <|> valueDecl+    _ ->+      (if typeSigPrefix then typeSigOrPatternTypeSigDeclParser else MP.empty)+        <|> MP.try valueDeclParser+        <|> patternBindDeclParser+        <|> (if exprFallback then exprDeclParser else MP.empty)++-- | Like 'patternBindDeclParser' but rejects bare variable patterns.+-- When the leading token is a variable identifier, a bare @x = 5@ must be+-- parsed as a zero-argument function bind, not a pattern bind.  This parser+-- detects that case early (after parsing the pattern) and fails, letting+-- 'valueDeclParser' handle it instead.+nonBareVarPatternBindDeclParser :: TokParser Decl+nonBareVarPatternBindDeclParser = MP.try $ withSpanAnn (DeclAnn . mkAnnotation) $ do+  pat <- region "while parsing pattern binding" patternParser+  case pat of+    PVar {} -> fail "bare variable bindings are parsed as function declarations"+    _ -> do+      DeclValue . PatternBind NoMultiplicityTag pat <$> equationRhsParser++-- | Parse a pragma declaration (e.g. {-# INLINE f #-}, {-# SPECIALIZE ... #-})+pragmaDeclParser :: TokParser Decl+pragmaDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ DeclPragma <$> anyPragmaParser "pragma declaration"++-- | Check whether the expression-as-declaration fallback is enabled.+-- GHC allows top-level expressions under TemplateHaskell (bare splices),+-- TemplateHaskellQuotes, and QuasiQuotes (e.g. @[qq|...|]@ at the top level).+exprDeclEnabled :: TokParser Bool+exprDeclEnabled = do+  th <- isExtensionEnabled TemplateHaskell+  thq <- isExtensionEnabled TemplateHaskellQuotes+  qq <- isExtensionEnabled QuasiQuotes+  pure (th || thq || qq)++-- | Parse a top-level expression as a declaration.+--+-- GHC allows arbitrary expressions at the top level under TemplateHaskell+-- (interpreted as declaration splices). This parser wraps the expression in+-- 'DeclSplice'. The expression parser itself handles extension-specific+-- constructs (e.g. @$expr@, @$(expr)@ via TH, @[qq|...|]@ via QuasiQuotes),+-- so no special dispatch is needed here.+exprDeclParser :: TokParser Decl+exprDeclParser = DeclSplice <$> exprParser++-- | Parse a @type@ declaration after the @type@ keyword has been consumed.+-- Uses 'typeDeclHeadParser' to handle both prefix and infix type heads,+-- then dispatches based on the next token:+-- - @::@ → standalone kind signature (must have zero type parameters)+-- - @=@ → type synonym+--+-- > topdecl -> 'type' simpletype '=' type+typeDeclarationParser :: TokParser Decl+typeDeclarationParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordType+  typeHead <- typeDeclHeadParser+  nextTok <- anySingle+  case lexTokenKind nextTok of+    TkReservedDoubleColon -> do+      -- Standalone kind signature: cannot have type parameters+      if null (binderHeadParams typeHead)+        then+          DeclStandaloneKindSig (binderHeadName typeHead) <$> typeParser+        else+          fail "Standalone kind signatures cannot have type parameters."+    TkReservedEquals -> do+      body <- typeParser+      pure $+        DeclTypeSyn+          TypeSynDecl+            { typeSynHead = typeHead,+              typeSynBody = body+            }+    _ ->+      MP.customFailure+        UnexpectedTokenExpecting+          { unexpectedFound = Just (mkFoundToken nextTok),+            unexpectedExpecting = "'::' or '=' after type declaration head",+            unexpectedContext = []+          }++roleAnnotationDeclParser :: TokParser Decl+roleAnnotationDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordType+  expectedTok TkVarRole+  typeName <- constructorUnqualifiedNameParser <|> parens constructorOperatorUnqualifiedNameParser+  roles <- MP.many roleParser+  pure $+    DeclRoleAnnotation+      RoleAnnotation+        { roleAnnotationName = typeName,+          roleAnnotationRoles = roles+        }++roleParser :: TokParser Role+roleParser =+  (varIdTok "nominal" >> pure RoleNominal)+    <|> (varIdTok "representational" >> pure RoleRepresentational)+    <|> (varIdTok "phantom" >> pure RolePhantom)+    <|> (expectedTok TkKeywordUnderscore >> pure RoleInfer)++-- ---------------------------------------------------------------------------+-- TypeFamilies: shared helpers++-- | Parse an optional declaration context, returning @[]@ on absence.+-- Uses 'MP.try' so inputs like @data T :: C => ()@ can backtrack from a+-- failed context parse and treat @::@ as an inline kind signature instead.+contextPrefixDispatchList :: TokParser [Type]+contextPrefixDispatchList = MP.option [] (MP.try (declContextParser <* expectedTok TkReservedDoubleArrow))++-- | Parse a declaration head with an optional leading context, but prefer an+-- inline @::@ result kind when the head is immediately followed by @::@.+--+-- Without this preference, inputs like @data T :: C => K@ are ambiguous:+-- @T :: C@ is also a valid context item. GHC resolves that form as a head with+-- an inline result kind, so we do the same.+declHeadPreferringInlineKind :: TokParser head -> TokParser (Maybe [Type], head, Maybe Type)+declHeadPreferringInlineKind headParser =+  MP.try+    ( do+        head' <- headParser+        inlineKind <- expectedTok TkReservedDoubleColon *> typeParser+        pure (Nothing, head', Just inlineKind)+    )+    <|> do+      (context, head') <- declHeadWithOptionalContext headParser+      inlineKind <- MP.optional (expectedTok TkReservedDoubleColon *> typeParser)+      pure (context, head', inlineKind)++-- | Parse a declaration head that may be preceded by a context.+--+-- The @MP.try@ must cover both the context and the following head parser so+-- inputs like @data T :: C => ()@ can backtrack and treat @::@ as an inline+-- kind signature rather than committing to a datatype context too early.+declHeadWithOptionalContext :: TokParser head -> TokParser (Maybe [Type], head)+declHeadWithOptionalContext headParser =+  MP.try ((,) . Just <$> (declContextParser <* expectedTok TkReservedDoubleArrow) <*> headParser)+    <|> ((Nothing,) <$> headParser)++-- | Parse an explicit forall telescope: @forall a (b :: Kind).@.+-- Used for type family instances, data family instances, and instance heads.+explicitForallParser :: TokParser [TyVarBinder]+explicitForallParser = do+  expectedTok TkKeywordForall+  binders <- MP.some explicitForallBinderParser+  expectedTok (TkVarSym ".")+  pure binders++-- | Parse an optional unnamed @:: Kind@ result signature for a family head.+familyResultKindParser :: TokParser (Maybe Type)+familyResultKindParser =+  MP.optional (expectedTok TkReservedDoubleColon *> typeParser)++-- | Parse an optional type family result signature. GHC admits either an unnamed+-- @:: Kind@ annotation or a named result variable with optional injectivity annotation,+-- such as @= r@, @= r | r -> a@, or @= (r :: Type) | r -> a where ...@.+--+-- The 'Bool' parameter indicates whether the @family@ keyword was explicitly+-- present.  When it was /not/ present (i.e. the shorthand @type T a …@ form+-- inside a class body), @= r@ is syntactically ambiguous with a default type+-- instance (@type T a = r@).  GHC resolves this by treating @= binder |@ as a+-- named result signature with injectivity, while @= expr@ without @|@ is+-- always a default type instance.  We mirror that behaviour: without an+-- explicit @family@ keyword, @namedSigParser@ requires the @|@ injectivity+-- annotation that follows the binder.+typeFamilyResultSigParser :: Bool -> TokParser (Maybe TypeFamilyResultSig)+typeFamilyResultSigParser explicitFamily =+  MP.optional (kindSigParser <|> namedSigParser)+  where+    kindSigParser =+      TypeFamilyKindSig <$> (expectedTok TkReservedDoubleColon *> typeParser)++    namedSigParser = do+      expectedTok TkReservedEquals+      result <- namedResultBinderParser+      mInjectivity <- MP.optional typeFamilyInjectivityParser+      case mInjectivity of+        Just injectivity -> pure $ TypeFamilyInjectiveSig result injectivity+        Nothing+          -- With an explicit @family@ keyword, @= r@ on its own is+          -- unambiguously a named result signature.+          | explicitFamily -> pure $ TypeFamilyTyVarSig result+          -- Without @family@, @= r@ (no injectivity @|@) is ambiguous with a+          -- default type instance.  Fail so the caller can backtrack and try+          -- the default-instance parser instead.+          | otherwise -> fail "named result sig without injectivity requires explicit 'family' keyword"++    namedResultBinderParser =+      withSpan $+        ( do+            ident <- lowerIdentifierParser+            pure (\span' -> TyVarBinder [mkAnnotation span'] ident Nothing TyVarBSpecified TyVarBVisible)+        )+          <|> ( do+                  expectedTok TkSpecialLParen+                  ident <- lowerIdentifierParser+                  expectedTok TkReservedDoubleColon+                  kind <- typeParser+                  expectedTok TkSpecialRParen+                  pure (\span' -> TyVarBinder [mkAnnotation span'] ident (Just kind) TyVarBSpecified TyVarBVisible)+              )++typeFamilyInjectivityParser :: TokParser TypeFamilyInjectivity+typeFamilyInjectivityParser = withSpan $ do+  expectedTok TkReservedPipe+  result <- lowerIdentifierParser+  expectedTok TkReservedRightArrow+  determined <- MP.some lowerIdentifierParser+  pure $ \span' ->+    TypeFamilyInjectivity+      { typeFamilyInjectivityAnns = [mkAnnotation span'],+        typeFamilyInjectivityResult = result,+        typeFamilyInjectivityDetermined = determined+      }++-- ---------------------------------------------------------------------------+-- TypeFamilies: top-level type family declaration++-- | Parse @type family Name params [:: Kind] [where { equations }]@+typeFamilyDeclParser :: TokParser Decl+typeFamilyDeclParser =+  withSpanAnn (DeclAnn . mkAnnotation) $+    DeclTypeFamilyDecl <$> typeFamilyDeclBodyParser FamilyKeywordRequired++-- | Parse the @where { eq; ... }@ block of a closed type family.+closedTypeFamilyWhereParser :: TokParser [TypeFamilyEq]+closedTypeFamilyWhereParser = whereClauseItemsParser typeFamilyEqParser++-- | Parse one closed type family equation: @[forall binders.] LhsType = RhsType@+typeFamilyEqParser :: TokParser TypeFamilyEq+typeFamilyEqParser = withSpan $ do+  forallBinders <- MP.option [] explicitForallParser+  (headForm, lhs) <- typeFamilyLhsParser+  expectedTok TkReservedEquals+  rhs <- typeParser+  pure $ \span' ->+    TypeFamilyEq+      { typeFamilyEqAnns = [mkAnnotation span'],+        typeFamilyEqForall = forallBinders,+        typeFamilyEqHeadForm = headForm,+        typeFamilyEqLhs = lhs,+        typeFamilyEqRhs = rhs+      }++-- ---------------------------------------------------------------------------+-- TypeFamilies: top-level data family declaration++-- | Parse @data family Name params [:: Kind]@+dataFamilyDeclParser :: TokParser Decl+dataFamilyDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordData+  varIdTok "family"+  head' <- typeDeclHeadParser+  kind <- familyResultKindParser+  pure $+    DeclDataFamilyDecl+      DataFamilyDecl+        { dataFamilyDeclHead = head',+          dataFamilyDeclKind = kind+        }++-- ---------------------------------------------------------------------------+-- TypeFamilies: top-level type/data/newtype family instances++-- | Parse @type instance [forall binders.] LhsType = RhsType@+typeFamilyInstParser :: TokParser Decl+typeFamilyInstParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordType+  expectedTok TkKeywordInstance+  forallBinders <- MP.option [] explicitForallParser+  (headForm, lhs) <- typeFamilyLhsParser+  expectedTok TkReservedEquals+  rhs <- typeParser+  pure $+    DeclTypeFamilyInst+      TypeFamilyInst+        { typeFamilyInstForall = forallBinders,+          typeFamilyInstHeadForm = headForm,+          typeFamilyInstLhs = lhs,+          typeFamilyInstRhs = rhs+        }++-- | Parse @data instance [forall binders.] HeadType = Cons | ...@ (also GADT style)+dataFamilyInstParser :: TokParser Decl+dataFamilyInstParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordData+  expectedTok TkKeywordInstance+  forallBinders <- MP.option [] explicitForallParser+  (_, head') <- typeFamilyLhsParser+  kind <- familyResultKindParser+  (constructors, derivingClauses) <- gadtDataDeclParser <|> traditionalDataDeclParser+  pure $+    DeclDataFamilyInst+      DataFamilyInst+        { dataFamilyInstIsNewtype = False,+          dataFamilyInstForall = forallBinders,+          dataFamilyInstHead = head',+          dataFamilyInstKind = kind,+          dataFamilyInstConstructors = constructors,+          dataFamilyInstDeriving = derivingClauses+        }++-- | Parse @newtype instance [forall binders.] HeadType = Constructor@+newtypeFamilyInstParser :: TokParser Decl+newtypeFamilyInstParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordNewtype+  expectedTok TkKeywordInstance+  forallBinders <- MP.option [] explicitForallParser+  (_, head') <- typeFamilyLhsParser+  kind <- familyResultKindParser+  expectedTok TkReservedEquals+  constructor <- dataConDeclParser+  derivingClauses <- MP.many derivingClauseParser+  pure $+    DeclDataFamilyInst+      DataFamilyInst+        { dataFamilyInstIsNewtype = True,+          dataFamilyInstForall = forallBinders,+          dataFamilyInstHead = head',+          dataFamilyInstKind = kind,+          dataFamilyInstConstructors = [constructor],+          dataFamilyInstDeriving = derivingClauses+        }++-- ---------------------------------------------------------------------------+-- TypeFamilies: class body items (associated type/data families + defaults)++-- | Parse @type [family] Name params [:: Kind]@ as an associated type family in a class.+-- Callers must ensure the next token after @type@ is not @instance@+-- (which is handled by 'classDefaultTypeInstParser' via token dispatch).+classTypeFamilyDeclParser :: TokParser ClassDeclItem+classTypeFamilyDeclParser =+  withSpanAnn (ClassItemAnn . mkAnnotation) $+    ClassItemTypeFamilyDecl <$> typeFamilyDeclBodyParser FamilyKeywordOptional++-- | Parse @data Name params [:: Kind]@ as an associated data family in a class.+classDataFamilyDeclParser :: TokParser ClassDeclItem+classDataFamilyDeclParser = withSpanAnn (ClassItemAnn . mkAnnotation) $ do+  expectedTok TkKeywordData+  head' <- typeDeclHeadParser+  kind <- familyResultKindParser+  pure+    ( ClassItemDataFamilyDecl+        DataFamilyDecl+          { dataFamilyDeclHead = head',+            dataFamilyDeclKind = kind+          }+    )++-- | Parse @type instance LhsType = RhsType@ as a default type family instance in a class.+classDefaultTypeInstParser :: TokParser ClassDeclItem+classDefaultTypeInstParser = classDefaultTypeInstParser' True++-- | Parse @type [forall binders.] LhsType = RhsType@ as a shorthand default+-- associated type instance in a class body.+classDefaultTypeInstShorthandParser :: TokParser ClassDeclItem+classDefaultTypeInstShorthandParser = classDefaultTypeInstParser' False++classDefaultTypeInstParser' :: Bool -> TokParser ClassDeclItem+classDefaultTypeInstParser' requireInstance = withSpanAnn (ClassItemAnn . mkAnnotation) $ do+  expectedTok TkKeywordType+  when requireInstance (expectedTok TkKeywordInstance)+  forallBinders <- MP.option [] explicitForallParser+  (headForm, lhs) <- typeFamilyLhsParser+  expectedTok TkReservedEquals+  rhs <- typeParser+  pure+    ( ClassItemDefaultTypeInst+        TypeFamilyInst+          { typeFamilyInstForall = forallBinders,+            typeFamilyInstHeadForm = headForm,+            typeFamilyInstLhs = lhs,+            typeFamilyInstRhs = rhs+          }+    )++-- ---------------------------------------------------------------------------+-- TypeFamilies: instance body items++-- | Parse @type [instance] LhsType = RhsType@ inside an instance body.+-- The @instance@ keyword is accepted but optional (GHC normalizes both forms+-- to the same AST, so we treat them identically).+instanceTypeFamilyInstParser :: TokParser InstanceDeclItem+instanceTypeFamilyInstParser = withSpanAnn (InstanceItemAnn . mkAnnotation) $ do+  expectedTok TkKeywordType+  _ <- MP.optional (expectedTok TkKeywordInstance)+  forallBinders <- MP.option [] explicitForallParser+  (headForm, lhs) <- typeFamilyLhsParser+  expectedTok TkReservedEquals+  rhs <- typeParser+  pure $+    InstanceItemTypeFamilyInst+      TypeFamilyInst+        { typeFamilyInstForall = forallBinders,+          typeFamilyInstHeadForm = headForm,+          typeFamilyInstLhs = lhs,+          typeFamilyInstRhs = rhs+        }++-- | Parse @data [instance] HeadType = Cons | ...@ (or GADT style) inside an instance body.+-- The @instance@ keyword is accepted but optional.+instanceDataFamilyInstParser :: TokParser InstanceDeclItem+instanceDataFamilyInstParser = withSpanAnn (InstanceItemAnn . mkAnnotation) $ do+  expectedTok TkKeywordData+  _ <- MP.optional (expectedTok TkKeywordInstance)+  (_, head') <- typeFamilyLhsParser+  kind <- familyResultKindParser+  (constructors, derivingClauses) <- gadtDataDeclParser <|> traditionalDataDeclParser+  pure $+    InstanceItemDataFamilyInst+      DataFamilyInst+        { dataFamilyInstIsNewtype = False,+          dataFamilyInstForall = [],+          dataFamilyInstHead = head',+          dataFamilyInstKind = kind,+          dataFamilyInstConstructors = constructors,+          dataFamilyInstDeriving = derivingClauses+        }++-- | Parse @newtype [instance] HeadType = Constructor@ inside an instance body.+-- The @instance@ keyword is accepted but optional.+instanceNewtypeFamilyInstParser :: TokParser InstanceDeclItem+instanceNewtypeFamilyInstParser = withSpanAnn (InstanceItemAnn . mkAnnotation) $ do+  expectedTok TkKeywordNewtype+  _ <- MP.optional (expectedTok TkKeywordInstance)+  (_, head') <- typeFamilyLhsParser+  kind <- familyResultKindParser+  expectedTok TkReservedEquals+  constructor <- dataConDeclParser+  derivingClauses <- MP.many derivingClauseParser+  pure $+    InstanceItemDataFamilyInst+      DataFamilyInst+        { dataFamilyInstIsNewtype = True,+          dataFamilyInstForall = [],+          dataFamilyInstHead = head',+          dataFamilyInstKind = kind,+          dataFamilyInstConstructors = [constructor],+          dataFamilyInstDeriving = derivingClauses+        }++-- ---------------------------------------------------------------------------++-- | Report core general declaration:+--+-- > gendecl -> vars '::' [context '=>'] type+typeSigDeclParser :: TokParser Decl+typeSigDeclParser =+  withSpanAnn (DeclAnn . mkAnnotation) $+    uncurry DeclTypeSig <$> typedSignaturePrefixParser typeSignatureParser++-- | Parse a type signature or a pattern-typed equation.+--+-- With @ScopedTypeVariables@, @f :: Int = 0@ is valid Haskell meaning the same+-- as @(f :: Int) = 0@: a pattern bind whose LHS carries a type annotation.+-- GHC parses @name :: Type@ and then, if @=@ (or a guard @|@) follows,+-- reinterprets the construct as a 'PatternBind' with a 'PTypeSig' pattern.+--+-- This parser mirrors that behaviour at the top level.  It first parses+-- @name(s) :: Type@ (the type-signature prefix), then peeks at the next+-- token.  If the next token begins an equation RHS (@=@ or @|@), the result is+-- reinterpreted as a pattern-typed equation; otherwise a plain type signature+-- is returned.+typeSigOrPatternTypeSigDeclParser :: TokParser Decl+typeSigOrPatternTypeSigDeclParser =+  withSpanAnn (DeclAnn . mkAnnotation) $+    typedBindingOrSignatureParser+      typeSignatureParser+      DeclTypeSig+      ( \name ty -> do+          rhs <- equationRhsParser+          let pat = PTypeSig (PVar name) ty+          pure (DeclValue (PatternBind NoMultiplicityTag pat rhs))+      )+      "typed pattern bindings with '=' require exactly one binder"++defaultDeclParser :: TokParser Decl+defaultDeclParser = do+  expectedTok TkKeywordDefault+  DeclDefault <$> parens (typeParser `MP.sepEndBy` expectedTok TkSpecialComma)++-- | Report core general declaration:+--+-- > gendecl -> fixity [integer] ops+fixityDeclParser :: TokParser Decl+fixityDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  (parsedAssoc, prec, mNamespace, ops) <- fixityDeclPartsParser+  pure (DeclFixity parsedAssoc mNamespace prec ops)++fixityDeclPartsParser :: TokParser (FixityAssoc, Maybe Int, Maybe IEEntityNamespace, [UnqualifiedName])+fixityDeclPartsParser = do+  assoc <- fixityAssocParser+  prec <- MP.optional fixityPrecedenceParser+  mNamespace <- MP.optional fixityNamespaceParser+  ops <- fixityOperatorParser `MP.sepBy1` expectedTok TkSpecialComma+  pure (assoc, prec, mNamespace, ops)++fixityNamespaceParser :: TokParser IEEntityNamespace+fixityNamespaceParser =+  (expectedTok TkKeywordType >> pure IEEntityNamespaceType)+    <|> (expectedTok TkKeywordData >> pure IEEntityNamespaceData)++fixityAssocParser :: TokParser FixityAssoc+fixityAssocParser =+  (expectedTok TkKeywordInfix >> pure Infix)+    <|> (expectedTok TkKeywordInfixl >> pure InfixL)+    <|> (expectedTok TkKeywordInfixr >> pure InfixR)++fixityPrecedenceParser :: TokParser Int+fixityPrecedenceParser =+  tokenSatisfy "fixity precedence" $ \tok ->+    case lexTokenKind tok of+      TkInteger n _+        | n <= 9 -> Just (fromInteger n)+      _ -> Nothing++fixityOperatorParser :: TokParser UnqualifiedName+fixityOperatorParser =+  symbolicOperatorParser <|> backtickIdentifierParser+  where+    symbolicOperatorParser =+      tokenSatisfy "fixity operator" $ \tok ->+        case lexTokenKind tok of+          TkVarSym op -> Just (mkUnqualifiedName NameVarSym op)+          TkConSym op -> Just (mkUnqualifiedName NameConSym op)+          TkReservedColon -> Just (mkUnqualifiedName NameConSym ":")+          TkReservedRightArrow -> Just (mkUnqualifiedName NameVarSym "->")+          _ -> Nothing+    backtickIdentifierParser = do+      expectedTok TkSpecialBacktick+      op <- identifierUnqualifiedNameParser+      expectedTok TkSpecialBacktick+      pure op++-- | Report core:+--+-- > topdecl -> 'class' [scontext '=>'] tycls tyvar ['where' cdecls]+classDeclParser :: TokParser Decl+classDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordClass+  (context, classHead) <- declHeadWithOptionalContext classHeadParser+  classFundeps <- MP.option [] (MP.try classFundepsParser)+  items <- MP.option [] classWhereClauseParser+  pure $+    DeclClass+      ClassDecl+        { classDeclContext = context,+          classDeclHead = classHead,+          classDeclFundeps = classFundeps,+          classDeclItems = items+        }++classFundepsParser :: TokParser [FunctionalDependency]+classFundepsParser = do+  expectedTok TkReservedPipe+  classFundepParser `MP.sepBy1` expectedTok TkSpecialComma++classFundepParser :: TokParser FunctionalDependency+classFundepParser = withSpan $ do+  determinedBy <- MP.many lowerIdentifierParser+  expectedTok TkReservedRightArrow+  determines <- MP.many lowerIdentifierParser+  pure $ \span' ->+    FunctionalDependency+      { functionalDependencyAnns = [mkAnnotation span'],+        functionalDependencyDeterminers = determinedBy,+        functionalDependencyDetermined = determines+      }++classWhereClauseParser :: TokParser [ClassDeclItem]+classWhereClauseParser = do+  expectedTok TkKeywordWhere+  bracedSemiSep classDeclItemParser+    <|> plainSemiSep1 classDeclItemParser+    <|> pure []++whereClauseItemsParser :: TokParser a -> TokParser [a]+whereClauseItemsParser itemParser = do+  expectedTok TkKeywordWhere+  bracedSemiSep itemParser <|> plainSemiSep1 itemParser <|> pure []++-- | Report core:+--+-- > cdecl -> gendecl+-- >       | (funlhs | var) rhs+classDeclItemParser :: TokParser ClassDeclItem+classDeclItemParser =+  classPragmaItemParser+    <|> do+      (tok, nextTok) <- lookAhead ((,) <$> anySingle <*> anySingle)+      typeSigPrefix <- startsWithTypeSig+      case lexTokenKind tok of+        TkKeywordInfix -> classFixityItemParser+        TkKeywordInfixl -> classFixityItemParser+        TkKeywordInfixr -> classFixityItemParser+        TkKeywordData -> classDataFamilyDeclParser+        TkKeywordDefault -> classDefaultSigItemParser+        TkKeywordType+          | lexTokenKind nextTok == TkKeywordInstance -> classDefaultTypeInstParser+        TkKeywordType -> MP.try classTypeFamilyDeclParser <|> classDefaultTypeInstShorthandParser+        _ -> (if typeSigPrefix then classTypeSigItemParser else classDefaultItemParser)++classPragmaItemParser :: TokParser ClassDeclItem+classPragmaItemParser =+  withSpanAnn (ClassItemAnn . mkAnnotation) $+    ClassItemPragma <$> anyPragmaParser "pragma declaration"++classTypeSigItemParser :: TokParser ClassDeclItem+classTypeSigItemParser = typeSigItemParser (ClassItemAnn . mkAnnotation) ClassItemTypeSig++classDefaultSigItemParser :: TokParser ClassDeclItem+classDefaultSigItemParser = withSpanAnn (ClassItemAnn . mkAnnotation) $ do+  expectedTok TkKeywordDefault+  name <- binderNameParser+  expectedTok TkReservedDoubleColon+  ClassItemDefaultSig name <$> typeSignatureParser++classFixityItemParser :: TokParser ClassDeclItem+classFixityItemParser = fixityItemParser (ClassItemAnn . mkAnnotation) ClassItemFixity++classDefaultItemParser :: TokParser ClassDeclItem+classDefaultItemParser = valueItemParser (ClassItemAnn . mkAnnotation) ClassItemDefault++-- | Report core:+--+-- > topdecl -> 'instance' [scontext '=>'] qtycls inst ['where' idecls]+instanceDeclParser :: TokParser Decl+instanceDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordInstance+  overlapPragmas <- MP.option [] (fmap (: []) instanceOverlapPragmaParser)+  warningText <- MP.optional warningPragmaParser+  forallBinders <- MP.optional explicitForallParser+  (context, instanceHead) <- declHeadWithOptionalContext typeInfixParser+  items <- MP.option [] instanceWhereClauseParser+  pure $+    DeclInstance+      InstanceDecl+        { instanceDeclPragmas = overlapPragmas,+          instanceDeclWarning = warningText,+          instanceDeclForall = fromMaybe [] forallBinders,+          instanceDeclContext = fromMaybe [] context,+          instanceDeclHead = instanceHead,+          instanceDeclItems = items+        }++standaloneDerivingDeclParser :: TokParser Decl+standaloneDerivingDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordDeriving+  strategy <- MP.optional derivingStrategyParser+  expectedTok TkKeywordInstance+  overlapPragmas <- MP.option [] (fmap (: []) instanceOverlapPragmaParser)+  warningText <- MP.optional warningPragmaParser+  forallBinders <- MP.optional explicitForallParser+  (context, derivingHead) <- declHeadWithOptionalContext typeInfixParser+  pure $+    DeclStandaloneDeriving+      StandaloneDerivingDecl+        { standaloneDerivingStrategy = strategy,+          standaloneDerivingPragmas = overlapPragmas,+          standaloneDerivingWarning = warningText,+          standaloneDerivingForall = fromMaybe [] forallBinders,+          standaloneDerivingContext = fromMaybe [] context,+          standaloneDerivingHead = derivingHead+        }++instanceWhereClauseParser :: TokParser [InstanceDeclItem]+instanceWhereClauseParser = do+  expectedTok TkKeywordWhere+  bracedSemiSep instanceDeclItemParser+    <|> plainSemiSep1 instanceDeclItemParser+    <|> pure []++-- | Report core:+--+-- > idecl -> (funlhs | var) rhs+-- >       | empty+instanceDeclItemParser :: TokParser InstanceDeclItem+instanceDeclItemParser =+  instancePragmaItemParser+    <|> do+      tok <- lookAhead anySingle+      typeSigPrefix <- startsWithTypeSig+      case lexTokenKind tok of+        TkKeywordInfix -> instanceFixityItemParser+        TkKeywordInfixl -> instanceFixityItemParser+        TkKeywordInfixr -> instanceFixityItemParser+        TkKeywordData -> instanceDataFamilyInstParser+        TkKeywordNewtype -> instanceNewtypeFamilyInstParser+        TkKeywordType -> instanceTypeFamilyInstParser+        _ -> (if typeSigPrefix then instanceTypeSigItemParser else instanceValueItemParser)++instancePragmaItemParser :: TokParser InstanceDeclItem+instancePragmaItemParser = withSpanAnn (InstanceItemAnn . mkAnnotation) $ do+  pragma <- anyPragmaParser "pragma declaration"+  pure (InstanceItemPragma pragma)++instanceTypeSigItemParser :: TokParser InstanceDeclItem+instanceTypeSigItemParser = typeSigItemParser (InstanceItemAnn . mkAnnotation) InstanceItemTypeSig++instanceFixityItemParser :: TokParser InstanceDeclItem+instanceFixityItemParser = fixityItemParser (InstanceItemAnn . mkAnnotation) InstanceItemFixity++instanceValueItemParser :: TokParser InstanceDeclItem+instanceValueItemParser = valueItemParser (InstanceItemAnn . mkAnnotation) InstanceItemBind++-- ---------------------------------------------------------------------------+-- Shared class/instance item helpers++typeSigItemParser :: (SourceSpan -> a -> a) -> ([UnqualifiedName] -> Type -> a) -> TokParser a+typeSigItemParser ann ctor = withSpanAnn ann $ uncurry ctor <$> typedSignaturePrefixParser typeSignatureParser++fixityItemParser :: (SourceSpan -> a -> a) -> (FixityAssoc -> Maybe IEEntityNamespace -> Maybe Int -> [UnqualifiedName] -> a) -> TokParser a+fixityItemParser ann ctor = withSpanAnn ann $ do+  (assoc, prec, mNamespace, ops) <- fixityDeclPartsParser+  pure (ctor assoc mNamespace prec ops)++valueItemParser :: (SourceSpan -> a -> a) -> (ValueDecl -> a) -> TokParser a+valueItemParser ann ctor = withSpanAnn ann $ do+  (headForm, name, pats) <- functionHeadParserWith patParser apatParser+  ctor . functionBindValue headForm name pats <$> equationRhsParser++foreignDeclParser :: TokParser Decl+foreignDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordForeign+  direction <- foreignDirectionParser+  callConv <- callConvParser+  safety <-+    case direction of+      ForeignImport -> MP.optional foreignSafetyParser+      ForeignExport -> pure Nothing+  entity <- MP.optional foreignEntityParser+  name <- binderNameParser+  expectedTok TkReservedDoubleColon+  ty <- typeSignatureParser+  pure $+    DeclForeign+      ForeignDecl+        { foreignDirection = direction,+          foreignCallConv = callConv,+          foreignSafety = safety,+          foreignEntity = fromMaybe ForeignEntityOmitted entity,+          foreignName = name,+          foreignType = ty+        }++foreignDirectionParser :: TokParser ForeignDirection+foreignDirectionParser =+  (expectedTok TkKeywordImport >> pure ForeignImport)+    <|> (varIdTok "export" >> pure ForeignExport)++callConvParser :: TokParser CallConv+callConvParser =+  (varIdTok "ccall" >> pure CCall)+    <|> (varIdTok "stdcall" >> pure StdCall)+    <|> (varIdTok "capi" >> pure CApi)+    <|> (varIdTok "prim" >> pure CPrim)+    <|> (varIdTok "javascript" >> pure JavaScript)++foreignSafetyParser :: TokParser ForeignSafety+foreignSafetyParser =+  (varIdTok "safe" >> pure Safe)+    <|> (varIdTok "unsafe" >> pure Unsafe)+    <|> (varIdTok "interruptible" >> pure Interruptible)++foreignEntityParser :: TokParser ForeignEntitySpec+foreignEntityParser = foreignEntityFromString <$> stringTextParser++foreignEntityFromString :: Text -> ForeignEntitySpec+foreignEntityFromString txt+  | txt == "dynamic" = ForeignEntityDynamic+  | txt == "wrapper" = ForeignEntityWrapper+  | txt == "static" = ForeignEntityStatic Nothing+  | Just rest <- T.stripPrefix "static " txt = ForeignEntityStatic (Just rest)+  | txt == "&" = ForeignEntityAddress Nothing+  | Just rest <- T.stripPrefix "&" txt = ForeignEntityAddress (Just rest)+  | otherwise = ForeignEntityNamed txt++traditionalDataDeclParser :: TokParser ([DataConDecl], [DerivingClause])+traditionalDataDeclParser = do+  constructors <- MP.optional (expectedTok TkReservedEquals *> dataConDeclParser `MP.sepBy1` expectedTok TkReservedPipe)+  derivingClauses <- MP.many derivingClauseParser+  pure (fromMaybe [] constructors, derivingClauses)++gadtDataDeclParser :: TokParser ([DataConDecl], [DerivingClause])+gadtDataDeclParser = do+  constructors <- gadtWhereClauseParser+  derivingClauses <- MP.many derivingClauseParser+  pure (constructors, derivingClauses)++-- | Report core:+--+-- > topdecl -> 'data' [context '=>'] simpletype ['=' constrs] [deriving]+dataDeclParser :: TokParser Decl+dataDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordData+  ctypePragma <- optionalHiddenPragma Just+  (context, typeHead, inlineKind) <- declHeadPreferringInlineKind typeDeclHeadParser+  -- GADT syntax starts with `where`, traditional syntax starts with `=` or nothing+  (constructors, derivingClauses) <- gadtDataDeclParser <|> traditionalDataDeclParser+  pure $+    DeclData+      DataDecl+        { dataDeclCTypePragma = ctypePragma,+          dataDeclHead = typeHead,+          dataDeclContext = fromMaybe [] context,+          dataDeclKind = inlineKind,+          dataDeclConstructors = constructors,+          dataDeclDeriving = derivingClauses+        }++-- | Parse a @type data@ declaration.+-- Similar to @data@ but with restrictions:+--   - No datatype context+--   - No labelled fields in constructors+--   - No strictness annotations in constructors+--   - No deriving clause+typeDataDeclParser :: TokParser Decl+typeDataDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordType+  expectedTok TkKeywordData+  -- type data may not have a datatype context+  typeHead <- typeDeclHeadParser+  -- Parse optional inline kind signature: @:: Kind@+  inlineKind <- MP.optional (expectedTok TkReservedDoubleColon *> typeParser)+  -- GADT syntax starts with `where`, traditional syntax starts with `=` or nothing+  constructors <- gadtStyleTypeDataDecl <|> traditionalStyleTypeDataDecl+  -- type data may not have a deriving clause+  pure $+    DeclTypeData+      DataDecl+        { dataDeclCTypePragma = Nothing,+          dataDeclHead = typeHead,+          dataDeclContext = [],+          dataDeclKind = inlineKind,+          dataDeclConstructors = constructors,+          dataDeclDeriving = []+        }+  where+    traditionalStyleTypeDataDecl =+      fromMaybe [] <$> MP.optional (expectedTok TkReservedEquals *> typeDataConDeclParser `MP.sepBy1` expectedTok TkReservedPipe)++    gadtStyleTypeDataDecl = gadtTypeDataWhereClauseParser++-- | Parse constructors for type data (traditional style, after `=`)+-- No labelled fields, no strictness annotations+typeDataConDeclParser :: TokParser DataConDecl+typeDataConDeclParser = withSpan $ do+  (_forallVars, context) <- dataConQualifiersParser+  MP.try (typeDataConPrefixParser context) <|> typeDataConInfixParser context++typeDataConPrefixParser :: [Type] -> TokParser (SourceSpan -> DataConDecl)+typeDataConPrefixParser context = do+  conName <- constructorUnqualifiedNameParser <|> parens constructorOperatorUnqualifiedNameParser+  -- Parse arguments (no strictness, no records).+  -- Use typeAtomParser to keep adjacent atoms as separate fields instead of+  -- merging them into a type application.+  args <- MP.many $ BangType [] [] False False <$> typeAtomParser+  -- If a constructor operator follows, this declaration is actually infix.+  MP.notFollowedBy constructorOperatorParser+  pure $ \span' -> DataConAnn (mkAnnotation span') (PrefixCon [] context conName args)++typeDataConInfixParser :: [Type] -> TokParser (SourceSpan -> DataConDecl)+typeDataConInfixParser context = do+  lhs <- typeDataConArgParser+  op <- constructorOperatorUnqualifiedNameParser <|> backtickConstructorUnqualifiedParser+  rhs <- typeDataConArgParser+  pure $ \span' -> DataConAnn (mkAnnotation span') (InfixCon [] context lhs op rhs)+  where+    backtickConstructorUnqualifiedParser = do+      expectedTok TkSpecialBacktick+      name <- constructorUnqualifiedNameParser+      expectedTok TkSpecialBacktick+      pure name++typeDataConArgParser :: TokParser BangType+typeDataConArgParser = BangType [] [] False False <$> typeAtomParser++-- | Parse GADT-style constructors for type data (after `where`)+-- No labelled fields, no strictness annotations+gadtTypeDataWhereClauseParser :: TokParser [DataConDecl]+gadtTypeDataWhereClauseParser = whereClauseItemsParser gadtTypeDataConDeclParser++-- | Parse a GADT constructor for type data+-- Only equality constraints permitted, no strictness, no records+gadtTypeDataConDeclParser :: TokParser DataConDecl+gadtTypeDataConDeclParser = withSpan $ do+  -- Parse constructor names (can be multiple separated by commas)+  names <- gadtConNameParser `MP.sepBy1` expectedTok TkSpecialComma+  expectedTok TkReservedDoubleColon+  -- Parse optional forall+  forallBinders <- MP.many gadtForallParser+  -- Parse context (only equality constraints permitted, but we parse generally)+  context <- contextPrefixDispatchList+  -- Parse the body (prefix only for type data - no record style)+  body <- gadtTypeDataBodyParser+  pure $ \span' -> DataConAnn (mkAnnotation span') (GadtCon forallBinders context names body)++-- | Parse the body of a GADT constructor for type data+-- Only prefix style allowed (no records), no strictness annotations+gadtTypeDataBodyParser :: TokParser GadtBody+gadtTypeDataBodyParser = do+  -- Parse types separated by arrows (may be linear with LinearTypes)+  firstTy <- typeAppParser+  rest <- MP.many ((,) <$> arrowKindParser <*> typeAppParser)+  case rest of+    [] -> pure (GadtPrefixBody [] firstTy)+    _ ->+      let mkBang = BangType [] [] False False+          allTys = firstTy : map snd rest+          arrowKinds = map fst rest+          argTys = init allTys+          resultTy = last allTys+          argsWithKinds = zip (map mkBang argTys) arrowKinds+       in pure (GadtPrefixBody argsWithKinds resultTy)++dataConDeclParser :: TokParser DataConDecl+dataConDeclParser = withSpan $ do+  (forallVars, context) <- dataConQualifiersParser+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    -- `(#` is either the LHS arg of an infix constructor (e.g. @(# #) :. Int@) or a+    -- standalone unboxed tuple/sum constructor (e.g. @(# Int, Bool #)@).+    -- Try infix first to match the original priority; fall back to unboxed.+    TkSpecialUnboxedLParen ->+      MP.try (dataConInfixParser forallVars context)+        <|> unboxedConDeclParser forallVars context+    -- `[ ]` is the list-con; any other `[…` must be a type in infix position.+    TkSpecialLBracket ->+      MP.try (listConDeclParser forallVars context)+        <|> dataConInfixParser forallVars context+    -- General case: skip unboxed/list (wrong leading token), try infix then boxed-tuple then prefix/record.+    _ ->+      MP.try (dataConInfixParser forallVars context)+        <|> MP.try (boxedTupleConDeclParser forallVars context)+        <|> dataConRecordOrPrefixParser forallVars context++listConDeclParser :: [TyVarBinder] -> [Type] -> TokParser (SourceSpan -> DataConDecl)+listConDeclParser forallVars context = do+  expectedTok TkSpecialLBracket+  expectedTok TkSpecialRBracket+  pure $ \span' -> DataConAnn (mkAnnotation span') (ListCon forallVars context)++boxedTupleConDeclParser :: [TyVarBinder] -> [Type] -> TokParser (SourceSpan -> DataConDecl)+boxedTupleConDeclParser forallVars context = do+  expectedTok TkSpecialLParen+  mClose <- MP.optional (expectedTok TkSpecialRParen)+  case mClose of+    Just () ->+      pure $ \span' -> DataConAnn (mkAnnotation span') (TupleCon forallVars context Boxed [])+    Nothing -> do+      firstField <- constructorArgParser+      -- A comma is mandatory: boxed 1-tuples don't exist in Haskell+      -- (e.g. @data C = (Int)@ is invalid). Without this, a+      -- parenthesized infix constructor operand like @(?a :: Int) :+ C@+      -- would be misinterpreted as a 1-tuple constructor.+      expectedTok TkSpecialComma+      rest <- constructorArgParser `MP.sepBy1` expectedTok TkSpecialComma+      expectedTok TkSpecialRParen+      pure $ \span' -> DataConAnn (mkAnnotation span') (TupleCon forallVars context Boxed (firstField : rest))++unboxedConDeclParser :: [TyVarBinder] -> [Type] -> TokParser (SourceSpan -> DataConDecl)+unboxedConDeclParser forallVars context = do+  expectedTok TkSpecialUnboxedLParen+  mClose <- MP.optional (expectedTok TkSpecialUnboxedRParen)+  case mClose of+    Just () ->+      pure $ \span' -> DataConAnn (mkAnnotation span') (TupleCon forallVars context Unboxed [])+    Nothing -> do+      leadingPipes <- MP.many (MP.try (expectedTok TkReservedPipe))+      if not (null leadingPipes)+        then do+          field <- constructorArgParser+          trailingPipes <- MP.many (expectedTok TkReservedPipe)+          expectedTok TkSpecialUnboxedRParen+          let pos = length leadingPipes + 1+              arity = length leadingPipes + 1 + length trailingPipes+          pure $ \span' -> DataConAnn (mkAnnotation span') (UnboxedSumCon forallVars context pos arity field)+        else do+          firstField <- constructorArgParser+          mSep <- MP.optional (MP.try ((Left () <$ expectedTok TkSpecialComma) <|> (Right () <$ expectedTok TkReservedPipe)))+          case mSep of+            Nothing -> do+              expectedTok TkSpecialUnboxedRParen+              pure $ \span' -> DataConAnn (mkAnnotation span') (TupleCon forallVars context Unboxed [firstField])+            Just (Left ()) -> do+              rest <- constructorArgParser `MP.sepBy1` expectedTok TkSpecialComma+              expectedTok TkSpecialUnboxedRParen+              pure $ \span' -> DataConAnn (mkAnnotation span') (TupleCon forallVars context Unboxed (firstField : rest))+            Just (Right ()) -> do+              trailingPipes <- MP.many (expectedTok TkReservedPipe)+              expectedTok TkSpecialUnboxedRParen+              let arity = 1 + 1 + length trailingPipes+              pure $ \span' -> DataConAnn (mkAnnotation span') (UnboxedSumCon forallVars context 1 arity firstField)++-- | Report core:+--+-- > topdecl -> 'newtype' [context '=>'] simpletype '=' newconstr [deriving]+newtypeDeclParser :: TokParser Decl+newtypeDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordNewtype+  ctypePragma <- optionalHiddenPragma Just+  (context, typeHead, inlineKind) <- declHeadPreferringInlineKind typeDeclHeadParser+  -- GADT syntax starts with `where`, traditional syntax starts with `=` or nothing+  (constructor, derivingClauses) <- gadtStyleNewtypeDecl <|> traditionalStyleNewtypeDecl+  pure $+    DeclNewtype+      NewtypeDecl+        { newtypeDeclCTypePragma = ctypePragma,+          newtypeDeclHead = typeHead,+          newtypeDeclContext = fromMaybe [] context,+          newtypeDeclKind = inlineKind,+          newtypeDeclConstructor = constructor,+          newtypeDeclDeriving = derivingClauses+        }+  where+    traditionalStyleNewtypeDecl = do+      constructor <- MP.optional (expectedTok TkReservedEquals *> dataConDeclParser)+      derivingClauses <- MP.many derivingClauseParser+      pure (constructor, derivingClauses)++    gadtStyleNewtypeDecl = do+      constructors <- gadtWhereClauseParser+      -- newtype can only have one constructor+      case constructors of+        [ctor] -> do+          derivingClauses <- MP.many derivingClauseParser+          pure (Just ctor, derivingClauses)+        _ -> fail "newtype must have exactly one constructor"++-- | Parse GADT-style constructors after 'where'+gadtWhereClauseParser :: TokParser [DataConDecl]+gadtWhereClauseParser = whereClauseItemsParser gadtConDeclParser++-- | Parse a GADT constructor declaration: @Con1, Con2 :: forall a. Ctx => Type@+gadtConDeclParser :: TokParser DataConDecl+gadtConDeclParser = withSpan $ do+  -- Parse constructor names (can be multiple separated by commas)+  names <- gadtConNameParser `MP.sepBy1` expectedTok TkSpecialComma+  expectedTok TkReservedDoubleColon+  -- Parse optional forall+  forallBinders <- MP.many gadtForallParser+  -- Parse optional context+  context <- contextPrefixDispatchList+  -- Parse the body (record or prefix style)+  body <- gadtBodyParser+  pure $ \span' -> DataConAnn (mkAnnotation span') (GadtCon forallBinders context names body)++-- | Parse constructor name for GADT - can be regular or operator in parens+gadtConNameParser :: TokParser UnqualifiedName+gadtConNameParser =+  constructorUnqualifiedNameParser+    <|> parens constructorOperatorUnqualifiedNameParser++-- | Parse forall in GADT context: @forall a b.@+gadtForallParser :: TokParser ForallTelescope+gadtForallParser = forallTelescopeParser++-- | Parse the body of a GADT constructor (after :: and optional forall/context)+-- Can be either prefix style: @a -> b -> T a@+-- Or record style: @{ field :: Type } -> T a@+-- Record style is distinguished by the leading @{@ token.+gadtBodyParser :: TokParser GadtBody+gadtBodyParser = gadtRecordBodyParser <|> gadtPrefixBodyParser++-- | Parse record-style GADT body: @{ field :: Type, ... } -> ResultType@+gadtRecordBodyParser :: TokParser GadtBody+gadtRecordBodyParser = do+  fields <- recordFieldsParser+  expectedTok TkReservedRightArrow+  GadtRecordBody fields <$> gadtResultTypeParser++-- | Parse prefix-style GADT body: @!Type1 -> Type2 -> ... -> ResultType@+-- Each argument can have an optional strictness annotation (!).+-- The result type is the final type in a chain of arrows.+gadtPrefixBodyParser :: TokParser GadtBody+gadtPrefixBodyParser = do+  firstBang <- gadtBangTypeParser+  rest <- MP.many ((,) <$> gadtArrowParser <*> gadtBangTypeParser)+  case rest of+    [] -> pure (GadtPrefixBody [] (bangType firstBang))+    _ ->+      let allBangs = firstBang : map snd rest+          arrowKinds = map fst rest+          args = init allBangs+          result = last allBangs+          argsWithKinds = zip args arrowKinds+       in pure (GadtPrefixBody argsWithKinds (bangType result))++-- | Parse the arrow between GADT constructor arguments.+-- Supports unrestricted @->@ and multiplicity-annotated arrows when LinearTypes is enabled.+gadtArrowParser :: TokParser ArrowKind+gadtArrowParser = arrowKindParser++-- | Parse a potentially strict type for GADT prefix body.+-- Uses 'typeInfixParser' so infix type operators (e.g. @key := v@) are+-- accepted as argument types without requiring parentheses.+gadtBangTypeParser :: TokParser BangType+gadtBangTypeParser = bangTypeParserWith typeInfixParser++-- | Parse the result type of a GADT constructor+-- This is a simple type application like @T a b@+gadtResultTypeParser :: TokParser Type+gadtResultTypeParser = typeParser++declContextParser :: TokParser [Type]+declContextParser = contextParserWith typeParser typeAtomParser++-- | Parse a type/class declaration head, parameterised by the infix operator parser.+-- Handles prefix (@T a b@), infix (@a op b@), parenthesised-infix (@(a op b) c@),+-- and parenthesised-prefix (@(T a b) c@) forms.+--+-- > simpletype -> tycon tyvar_1 ... tyvar_k+declHeadParserWith :: TokParser UnqualifiedName -> TokParser (BinderHead UnqualifiedName)+declHeadParserWith opParser =+  MP.try parenthesizedInfixDeclHeadParser+    <|> MP.try parenthesizedPrefixDeclHeadParser+    <|> MP.try infixDeclHeadParser+    <|> prefixDeclHeadParser+  where+    prefixDeclHeadParser = do+      name <- constructorUnqualifiedNameParser <|> parens operatorUnqualifiedNameParser+      params <- MP.many declTypeParamParser+      pure (PrefixBinderHead name params)++    infixDeclHeadParser = do+      lhs <- declTypeParamParser+      op <- opParser+      rhs <- declTypeParamParser+      pure (InfixBinderHead lhs op rhs [])++    parenthesizedInfixDeclHeadParser = do+      expectedTok TkSpecialLParen+      lhs <- declTypeParamParser+      op <- opParser+      rhs <- declTypeParamParser+      expectedTok TkSpecialRParen+      tailParams <- MP.many declTypeParamParser+      pure (InfixBinderHead lhs op rhs tailParams)++    parenthesizedPrefixDeclHeadParser = do+      expectedTok TkSpecialLParen+      name <- constructorUnqualifiedNameParser+      params <- MP.some declTypeParamParser+      expectedTok TkSpecialRParen+      tailParams <- MP.many declTypeParamParser+      pure (PrefixBinderHead name (params <> tailParams))++typeDeclHeadParser :: TokParser (BinderHead UnqualifiedName)+typeDeclHeadParser = declHeadParserWith (unqualifiedNameFromText <$> typeSynonymOperatorParser)++typeSynonymOperatorParser :: TokParser Text+typeSynonymOperatorParser =+  operatorTextParser <|> backtickTypeSynonymIdentifierParser+  where+    backtickTypeSynonymIdentifierParser = do+      expectedTok TkSpecialBacktick+      op <- identifierTextParser+      expectedTok TkSpecialBacktick+      pure op++typeFamilyHeadParser :: TokParser (TypeHeadForm, Type, [TyVarBinder])+typeFamilyHeadParser = withSpan $ do+  binderHead <- declHeadParserWith (nameToUnqualified <$> typeFamilyOperatorParser)+  pure (`binderHeadToTypeFamilyHead` binderHead)++-- | Parse an operator for type family declarations.+-- Unlike 'constructorOperatorParser', this accepts both constructor symbols (@:+:@)+-- and variable symbols (@**@), since type families can use either.+typeFamilyOperatorParser :: TokParser Name+typeFamilyOperatorParser =+  operatorNameParser <|> backtickTypeFamilyIdentifierParser+  where+    backtickTypeFamilyIdentifierParser = do+      expectedTok TkSpecialBacktick+      op <- constructorNameParser+      expectedTok TkSpecialBacktick+      pure op++typeFamilyLhsParser :: TokParser (TypeHeadForm, Type)+typeFamilyLhsParser = do+  lhs <- typeAppParser+  hasInfixTail <- MP.optional (lookAhead typeInfixOperatorParser)+  case hasInfixTail of+    Just _ -> do+      rest <- typeHeadInfixTailParser+      pure (TypeHeadInfix, foldInfixR buildInfixType lhs rest)+    Nothing ->+      pure (TypeHeadPrefix, lhs)+  where+    typeHeadInfixTailParser :: TokParser [((Name, TypePromotion), Type)]+    typeHeadInfixTailParser = MP.many $ MP.try $ do+      op <- typeInfixOperatorParser+      rhs <- typeAppParser+      pure (op, rhs)++    buildInfixType left ((op, promoted), right) = TInfix left op promoted right++classHeadParser :: TokParser (BinderHead UnqualifiedName)+classHeadParser = declHeadParserWith (nameToUnqualified <$> typeFamilyOperatorParser)++nameToUnqualified :: Name -> UnqualifiedName+nameToUnqualified name = mkUnqualifiedName (nameType name) (nameText name)++binderHeadToTypeFamilyHead :: SourceSpan -> BinderHead UnqualifiedName -> (TypeHeadForm, Type, [TyVarBinder])+binderHeadToTypeFamilyHead span' binderHead =+  case binderHead of+    PrefixBinderHead name params ->+      ( TypeHeadPrefix,+        typeAnnSpan span' (TCon (qualifyName Nothing name) Unpromoted),+        params+      )+    InfixBinderHead lhs op rhs tailParams ->+      ( TypeHeadInfix,+        typeAnnSpan span' (TInfix lhsType opName Unpromoted rhsType),+        [lhs, rhs] <> tailParams+      )+      where+        lhsType = TVar (mkUnqualifiedName NameVarId (tyVarBinderName lhs))+        rhsType = TVar (mkUnqualifiedName NameVarId (tyVarBinderName rhs))+        opName = qualifyName Nothing op++explicitForallBinderParser :: TokParser TyVarBinder+explicitForallBinderParser =+  withSpan $+    ( do+        ident <- typeParamBinderNameParser+        pure (\span' -> TyVarBinder [mkAnnotation span'] ident Nothing TyVarBSpecified TyVarBVisible)+    )+      <|> ( do+              expectedTok TkSpecialLParen+              ident <- typeParamBinderNameParser+              expectedTok TkReservedDoubleColon+              kind <- typeParser+              expectedTok TkSpecialRParen+              pure (\span' -> TyVarBinder [mkAnnotation span'] ident (Just kind) TyVarBSpecified TyVarBVisible)+          )++declTypeParamParser :: TokParser TyVarBinder+declTypeParamParser = MP.try invisibleDeclTypeParamParser <|> explicitForallBinderParser++invisibleDeclTypeParamParser :: TokParser TyVarBinder+invisibleDeclTypeParamParser = withSpan $ do+  expectedTok TkTypeApp+  ( do+      ident <- lowerIdentifierParser <|> (expectedTok TkKeywordUnderscore $> "_")+      pure (\span' -> TyVarBinder [mkAnnotation span'] ident Nothing TyVarBSpecified TyVarBInvisible)+    )+    <|> do+      expectedTok TkSpecialLParen+      ident <- lowerIdentifierParser <|> (expectedTok TkKeywordUnderscore $> "_")+      expectedTok TkReservedDoubleColon+      kind <- typeParser+      expectedTok TkSpecialRParen+      pure (\span' -> TyVarBinder [mkAnnotation span'] ident (Just kind) TyVarBSpecified TyVarBInvisible)++isTypeVarName :: Text -> Bool+isTypeVarName name =+  case T.uncons name of+    Just (c, _) -> c == '_' || isLower c+    Nothing -> False++typeParamBinderNameParser :: TokParser Text+typeParamBinderNameParser =+  tokenSatisfy "type parameter binder" $ \tok ->+    case lexTokenKind tok of+      TkVarId name+        | isTypeVarName name -> Just name+      TkKeywordUnderscore -> Just "_"+      _ -> Nothing++derivingClauseParser :: TokParser DerivingClause+derivingClauseParser = do+  expectedTok TkKeywordDeriving+  strategy <- MP.optional derivingStrategyWithoutViaParser+  classes <- parenClasses <|> singleClass+  viaStrategy <- MP.optional (DerivingVia <$> derivingViaTypeParser)+  case (strategy, viaStrategy) of+    (Just _, Just _) -> fail "deriving via cannot be combined with another deriving strategy"+    _ -> pure (DerivingClause (viaStrategy <|> strategy) classes)+  where+    singleClass = Left <$> constructorNameParser+    parenClasses = Right <$> parens (typeParser `MP.sepEndBy` expectedTok TkSpecialComma)++derivingViaTypeParser :: TokParser Type+derivingViaTypeParser = do+  varIdTok "via"+  typeParser++derivingStrategyParser :: TokParser DerivingStrategy+derivingStrategyParser =+  derivingStrategyWithoutViaParser+    <|> (DerivingVia <$> MP.try derivingViaTypeParser)++derivingStrategyWithoutViaParser :: TokParser DerivingStrategy+derivingStrategyWithoutViaParser =+  (varIdTok "stock" >> pure DerivingStock)+    <|> (expectedTok TkKeywordNewtype >> pure DerivingNewtype)+    <|> (varIdTok "anyclass" >> pure DerivingAnyclass)++dataConQualifiersParser :: TokParser ([TyVarBinder], [Type])+dataConQualifiersParser = do+  foralls <- MP.option [] forallBindersParser+  context <- contextPrefixDispatchList+  pure (foralls, context)++data FamilyKeywordMode+  = FamilyKeywordRequired+  | FamilyKeywordOptional++typeFamilyDeclBodyParser :: FamilyKeywordMode -> TokParser TypeFamilyDecl+typeFamilyDeclBodyParser familyKeywordMode = do+  expectedTok TkKeywordType+  explicitFamilyKeyword <- case familyKeywordMode of+    FamilyKeywordRequired -> expectedTok TkVarFamily $> True+    FamilyKeywordOptional -> isJust <$> MP.optional (expectedTok TkVarFamily)+  (headForm, headType, params) <- typeFamilyHeadParser+  resultSig <- typeFamilyResultSigParser explicitFamilyKeyword+  equations <-+    case familyKeywordMode of+      FamilyKeywordRequired -> MP.optional (MP.try closedTypeFamilyWhereParser)+      FamilyKeywordOptional -> pure Nothing+  pure+    TypeFamilyDecl+      { typeFamilyDeclHeadForm = headForm,+        typeFamilyDeclExplicitFamilyKeyword = explicitFamilyKeyword,+        typeFamilyDeclHead = headType,+        typeFamilyDeclParams = params,+        typeFamilyDeclResultSig = resultSig,+        typeFamilyDeclEquations = equations+      }++forallBindersParser :: TokParser [TyVarBinder]+forallBindersParser = do+  expectedTok TkKeywordForall+  binders <- MP.some explicitForallBinderParser+  expectedTok (TkVarSym ".")+  pure binders++dataConRecordOrPrefixParser :: [TyVarBinder] -> [Type] -> TokParser (SourceSpan -> DataConDecl)+dataConRecordOrPrefixParser forallVars context = do+  name <- constructorUnqualifiedNameParser <|> parens operatorUnqualifiedNameParser+  mRecordFields <- MP.optional (MP.try recordFieldsParserAfterLayoutSemicolon)+  case mRecordFields of+    Just fields -> pure (\span' -> DataConAnn (mkAnnotation span') (RecordCon forallVars context name fields))+    Nothing -> do+      args <- MP.many constructorArgParser+      -- Ensure we're not leaving a constructor operator unconsumed.+      -- If there's a constructor operator next, this is actually an infix form+      -- and we should backtrack to let dataConInfixParser handle it.+      MP.notFollowedBy constructorOperatorParser+      pure (\span' -> DataConAnn (mkAnnotation span') (PrefixCon forallVars context name args))+  where+    -- Layout may inject a virtual ';' before a newline-started record field block.+    -- Accept it as part of the constructor declaration.+    recordFieldsParserAfterLayoutSemicolon =+      recordFieldsParser+        <|> (expectedTok TkSpecialSemicolon *> recordFieldsParser)++dataConInfixParser :: [TyVarBinder] -> [Type] -> TokParser (SourceSpan -> DataConDecl)+dataConInfixParser forallVars context = do+  lhs <- infixConstructorArgParser+  op <- constructorOperatorUnqualifiedNameParser <|> backtickConstructorUnqualifiedParser+  rhs <- infixConstructorArgParser+  pure (\span' -> DataConAnn (mkAnnotation span') (InfixCon forallVars context lhs op rhs))+  where+    backtickConstructorUnqualifiedParser = do+      expectedTok TkSpecialBacktick+      name <- constructorUnqualifiedNameParser+      expectedTok TkSpecialBacktick+      pure name++recordFieldsParser :: TokParser [FieldDecl]+recordFieldsParser = braces (recordFieldDeclParser `MP.sepEndBy` expectedTok TkSpecialComma)++recordFieldDeclParser :: TokParser FieldDecl+recordFieldDeclParser = withSpan $ do+  names <- binderNameParser `MP.sepBy1` expectedTok TkSpecialComma+  linearEnabled <- isExtensionEnabled LinearTypes+  mMult <- if linearEnabled then MP.optional fieldMultiplicityParser else pure Nothing+  expectedTok TkReservedDoubleColon+  fieldTy <- recordFieldBangTypeParser+  pure $ \span' ->+    FieldDecl+      { fieldAnns = [mkAnnotation span'],+        fieldNames = names,+        fieldMultiplicity = mMult,+        fieldType = fieldTy+      }++fieldMultiplicityParser :: TokParser Type+fieldMultiplicityParser = do+  expectedTok TkPrefixPercent+  typeAtomParser++constructorArgParser :: TokParser BangType+constructorArgParser = MP.try $ MP.notFollowedBy derivingKeywordParser *> bangTypeParser++infixConstructorArgParser :: TokParser BangType+infixConstructorArgParser = MP.try $ MP.notFollowedBy derivingKeywordParser *> bangTypeParserWith typeAppParser++derivingKeywordParser :: TokParser ()+derivingKeywordParser =+  tokenSatisfy "identifier \"deriving\"" $ \tok ->+    case lexTokenKind tok of+      TkKeywordDeriving -> Just ()+      _ -> Nothing++bangTypeParserWith :: TokParser Type -> TokParser BangType+bangTypeParserWith typeP = withSpan $ do+  pragmas <- MP.option [] (fmap (: []) unpackPragmaParser)+  strict <- MP.option False (expectedTok TkPrefixBang >> pure True)+  lazy <- MP.option False (expectedTok TkPrefixTilde >> pure True)+  ty <- typeP+  pure $ \span' ->+    BangType+      { bangAnns = [mkAnnotation span'],+        bangPragmas = pragmas,+        bangStrict = strict,+        bangLazy = lazy,+        bangType = ty+      }++bangTypeParser :: TokParser BangType+bangTypeParser = bangTypeParserWith typeAtomParser++recordFieldBangTypeParser :: TokParser BangType+recordFieldBangTypeParser = bangTypeParserWith typeParser++unpackPragmaParser :: TokParser Pragma+unpackPragmaParser =+  hiddenPragma "source unpack pragma" $ \p -> case pragmaType p of+    PragmaUnpack _ -> Just p+    _ -> Nothing++constructorOperatorParser :: TokParser Name+constructorOperatorParser =+  symbolicConstructorOperatorParser <|> backtickConstructorIdentifierParser+  where+    symbolicConstructorOperatorParser =+      tokenSatisfy "constructor operator" $ \tok ->+        case lexTokenKind tok of+          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op))+          TkQConSym modName op -> Just (mkName (Just modName) NameConSym op)+          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"))+          _ -> Nothing+    backtickConstructorIdentifierParser = do+      expectedTok TkSpecialBacktick+      op <- constructorNameParser+      expectedTok TkSpecialBacktick+      pure op++-- | Parse a pattern binding declaration like @(x, y) = (1, 2)@.+-- This handles bindings where the LHS is a pattern rather than a function name.+patternBindDeclParser :: TokParser Decl+patternBindDeclParser = MP.try $ withSpanAnn (DeclAnn . mkAnnotation) $ do+  pat <- region "while parsing pattern binding" patternParser+  DeclValue . PatternBind NoMultiplicityTag pat <$> equationRhsParser++valueDeclParser :: TokParser Decl+valueDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  (headForm, name, pats) <- functionHeadParserWith patParser apatParser+  functionBindDecl headForm name pats <$> equationRhsParser++-- ---------------------------------------------------------------------------+-- Pattern synonyms++-- | Parse a pattern synonym declaration or signature.+-- Dispatches between @pattern Name :: Type@ (signature) and+-- @pattern Name args = pat@ / @pattern Name args <- pat [where ...]@ (declaration).+-- Uses a forward scan for @name(s) ::@ to avoid backtracking over a large parse.+patternSynonymParser :: TokParser Decl+patternSynonymParser = MP.try patternSynonymSigDeclParser <|> patternSynonymDeclParser++-- | Parse a pattern synonym type signature: @pattern Name1, Name2 :: Type@+patternSynonymSigDeclParser :: TokParser Decl+patternSynonymSigDeclParser = do+  expectedTok TkKeywordPattern+  names <- patSynNameParser `MP.sepBy1` expectedTok TkSpecialComma+  expectedTok TkReservedDoubleColon+  DeclPatSynSig names <$> typeSignatureParser++patSynNameParser :: TokParser UnqualifiedName+patSynNameParser =+  constructorUnqualifiedNameParser+    <|> do+      op <- parens constructorOperatorParser+      pure (mkUnqualifiedName (nameType op) (nameText op))++-- | Parse a pattern synonym declaration.+-- Handles prefix, infix, and record forms with all three directionalities.+patternSynonymDeclParser :: TokParser Decl+patternSynonymDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  expectedTok TkKeywordPattern+  (name, args) <- patSynLhsParser+  (dir, pat) <- patSynDirAndPatParser name+  pure $+    DeclPatSyn+      PatSynDecl+        { patSynDeclName = name,+          patSynDeclArgs = args,+          patSynDeclPat = pat,+          patSynDeclDir = dir+        }++-- | Parse the LHS of a pattern synonym declaration.+-- Returns the name and the argument form.+patSynLhsParser :: TokParser (UnqualifiedName, PatSynArgs)+patSynLhsParser =+  MP.try patSynInfixLhsParser <|> patSynRecordOrPrefixLhsParser++-- | Parse an infix pattern synonym LHS: @var ConOp var@ or @var \`Con\` var@+patSynInfixLhsParser :: TokParser (UnqualifiedName, PatSynArgs)+patSynInfixLhsParser = do+  lhs <- lowerIdentifierParser+  op <- constructorOperatorParser+  rhs <- lowerIdentifierParser+  pure (mkUnqualifiedName (nameType op) (nameText op), PatSynInfixArgs lhs rhs)++-- | Parse a record or prefix pattern synonym LHS.+-- Record: @Con {field1, field2, ...}@+-- Prefix: @Con var1 var2 ...@+patSynRecordOrPrefixLhsParser :: TokParser (UnqualifiedName, PatSynArgs)+patSynRecordOrPrefixLhsParser = do+  name <- patSynNameParser+  mFields <- MP.optional (MP.try patSynRecordFieldsParser)+  case mFields of+    Just fields -> pure (name, PatSynRecordArgs fields)+    Nothing -> do+      args <- MP.many lowerIdentifierParser+      pure (name, PatSynPrefixArgs args)++-- | Parse the record fields of a pattern synonym: @{field1, field2, ...}@+patSynRecordFieldsParser :: TokParser [Text]+patSynRecordFieldsParser = braces (lowerIdentifierParser `MP.sepEndBy` expectedTok TkSpecialComma)++-- | Parse the direction marker and RHS pattern of a pattern synonym.+patSynDirAndPatParser :: UnqualifiedName -> TokParser (PatSynDir, Pattern)+patSynDirAndPatParser name =+  ( do+      expectedTok TkReservedEquals+      pat <- patternParser+      pure (PatSynBidirectional, pat)+  )+    <|> ( do+            expectedTok TkReservedLeftArrow+            pat <- patternParser+            mMatches <- MP.optional (patSynWhereClauseParser (renderUnqualifiedName name))+            case mMatches of+              Nothing -> pure (PatSynUnidirectional, pat)+              Just matches -> pure (PatSynExplicitBidirectional matches, pat)+        )+    <|> do+      mTok <- MP.optional (lookAhead anySingle)+      MP.customFailure+        UnexpectedTokenExpecting+          { unexpectedFound = mkFoundToken <$> mTok,+            unexpectedExpecting = "'=' or '<-' in pattern synonym declaration",+            unexpectedContext = []+          }++-- | Parse the where clause of an explicitly bidirectional pattern synonym.+-- @where { Name pats = expr; ... }@+patSynWhereClauseParser :: Text -> TokParser [Match]+patSynWhereClauseParser _name = whereClauseItemsParser patSynWhereMatch++-- | Parse one equation in a pattern synonym where clause.+-- Uses 'lpatParser' (not 'patternParser') for the infix head patterns+-- because 'patternParser' would greedily consume the constructor operator+-- that serves as the function head — both 'patParser' and the infix+-- head parser compete for the same constructor operators.+patSynWhereMatch :: TokParser Match+patSynWhereMatch = withSpan $ do+  (headForm, _name, pats) <- patSynWhereHeadParser+  rhs <- equationRhsParser+  pure $ \span' ->+    Match+      { matchAnns = [mkAnnotation span'],+        matchHeadForm = headForm,+        matchPats = pats,+        matchRhs = rhs+      }++patSynWhereHeadParser :: TokParser (MatchHeadForm, UnqualifiedName, [Pattern])+patSynWhereHeadParser =+  MP.try infixHeadParser+    <|> MP.try parenthesizedInfixHeadParser+    <|> prefixHeadParser+  where+    prefixHeadParser = do+      name <- patSynNameParser+      pats <- MP.many apatParser+      pure (MatchHeadPrefix, name, pats)++    infixHeadParser = do+      lhsPat <- lpatParser+      op <- constructorInfixOperatorNameParser+      rhsPat <- lpatParser+      pure (MatchHeadInfix, op, [lhsPat, rhsPat])++    -- Prefer the plain infix form above so a parenthesized infix sub-pattern on+    -- the left-hand side, e.g. @(a :<| b) :> c = ...@, is not mistaken for the+    -- entire function head.+    parenthesizedInfixHeadParser = do+      expectedTok TkSpecialLParen+      lhsPat <- lpatParser+      op <- constructorInfixOperatorNameParser+      rhsPat <- lpatParser+      expectedTok TkSpecialRParen+      tailPats <- MP.many apatParser+      pure (MatchHeadInfix, op, [lhsPat, rhsPat] <> tailPats)
+ src/Aihc/Parser/Internal/Errors.hs view
@@ -0,0 +1,100 @@+module Aihc.Parser.Internal.Errors+  ( parseErrorBundleToSpannedText,+    parseErrorsToSpannedText,+  )+where++import Aihc.Parser.Lex (LexToken (..), TokenOrigin (..))+import Aihc.Parser.Syntax (SourceSpan (..))+import Aihc.Parser.Types (FoundToken (..), ParseErrorBundle, ParserErrorComponent (..), TokStream)+import Data.List qualified as List+import Data.List.NonEmpty qualified as NE+import Data.Maybe (fromMaybe)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Prettyprinter (Doc, defaultLayoutOptions, layoutPretty, pretty, vcat)+import Prettyprinter.Render.Text qualified as RText+import Text.Megaparsec qualified as MP+import Text.Megaparsec.Error (ErrorFancy (..), ErrorItem (..))+import Text.Megaparsec.Error qualified as MPE++parseErrorBundleToSpannedText :: ParseErrorBundle -> [(SourceSpan, Text)]+parseErrorBundleToSpannedText bundle =+  parseErrorsToSpannedText (NE.toList (MPE.bundleErrors bundle))++parseErrorsToSpannedText :: [MPE.ParseError TokStream ParserErrorComponent] -> [(SourceSpan, Text)]+parseErrorsToSpannedText errs =+  [ (fromMaybe NoSourceSpan mSpan, RText.renderStrict (layoutPretty defaultLayoutOptions doc))+  | err <- List.sortOn MP.errorOffset errs,+    (mSpan, doc) <- renderParseErrors err+  ]++renderParseErrors :: MPE.ParseError TokStream ParserErrorComponent -> [(Maybe SourceSpan, Doc ann)]+renderParseErrors err =+  case err of+    MPE.TrivialError _ mUnexpected expected ->+      let mSpan = trivialUnexpectedSpan mUnexpected+       in [(mSpan, vcat (map pretty (renderTrivialError mUnexpected expected)))]+    MPE.FancyError _ fancySet ->+      map renderFancyError (Set.toAscList fancySet)+  where+    trivialUnexpectedSpan :: Maybe (ErrorItem LexToken) -> Maybe SourceSpan+    trivialUnexpectedSpan mItem =+      case mItem of+        Just (Tokens ts) -> Just (lexTokenSpan (NE.head ts))+        _ -> Nothing++    renderFancyError :: ErrorFancy ParserErrorComponent -> (Maybe SourceSpan, Doc ann)+    renderFancyError fancy =+      case fancy of+        ErrorCustom custom ->+          ( customFoundSpan custom,+            vcat (map pretty (customMessageLines custom))+          )+        ErrorFail message -> (Nothing, pretty message)+        _ ->+          ( Nothing,+            pretty (show fancy)+          )++    customFoundSpan :: ParserErrorComponent -> Maybe SourceSpan+    customFoundSpan (UnexpectedTokenExpecting (Just found) _ _) =+      Just (foundTokenSpan found)+    customFoundSpan _ = Nothing++    customMessageLines :: ParserErrorComponent -> [String]+    customMessageLines e@(UnexpectedTokenExpecting mFound _ contexts) =+      [maybe "unexpected end of input" renderUnexpectedToken mFound, MPE.showErrorComponent e]+        <> map (\context -> "context: " <> T.unpack context) contexts++renderTrivialError :: Maybe (ErrorItem LexToken) -> Set.Set (ErrorItem LexToken) -> [String]+renderTrivialError mUnexpected expected =+  maybe [] (\item -> ["unexpected " <> renderErrorItem item]) mUnexpected+    <> ["expecting " <> renderExpectedItems (Set.toAscList expected) | not (Set.null expected)]++renderErrorItem :: ErrorItem LexToken -> String+renderErrorItem item =+  case item of+    Tokens toks -> unwords (map (T.unpack . lexTokenText) (NE.toList toks))+    Label label -> NE.toList label+    EndOfInput -> "end of input"++renderExpectedItems :: [ErrorItem LexToken] -> String+renderExpectedItems items =+  case map renderErrorItem items of+    [] -> ""+    [item] -> item+    [itemA, itemB] -> itemA <> " or " <> itemB+    rendered -> List.intercalate ", " (init rendered) <> ", or " <> last rendered++renderUnexpectedToken :: FoundToken -> String+renderUnexpectedToken found =+  "unexpected " <> tokenDescriptor found++tokenDescriptor :: FoundToken -> String+tokenDescriptor found =+  case foundTokenOrigin found of+    InsertedLayout -> "end of input"+    FromSource ->+      "'" <> T.unpack (foundTokenText found) <> "'"
+ src/Aihc/Parser/Internal/Expr.hs view
@@ -0,0 +1,1404 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Aihc.Parser.Internal.Expr+  ( exprParser,+    atomExprParser,+    cmdArrAppLhsParser,+    lexpParser,+    equationRhsParser,+    caseRhsParserWithBodyParser,+    parseLetDeclsParser,+    parseLetDeclsStmtParser,+  )+where++import Aihc.Parser.Internal.CheckPattern (checkPattern)+import Aihc.Parser.Internal.Cmd (cmdParser)+import Aihc.Parser.Internal.Common+import Aihc.Parser.Internal.Decl (declParser, fixityDeclParser, pragmaDeclParser)+import Aihc.Parser.Internal.Pattern (apatParser, caseAltPatternParser, patParser, patternParser)+import Aihc.Parser.Internal.Type (typeAtomParser, typeParser, typeSignatureParser)+import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..), lexTokenKind, lexTokenSpan, lexTokenText)+import Aihc.Parser.Syntax+import Aihc.Parser.Types (ParserErrorComponent (..), mkFoundToken)+import Control.Monad (guard)+import Data.Functor (($>))+import Data.Text (Text)+import Text.Megaparsec (anySingle, lookAhead, (<|>))+import Text.Megaparsec qualified as MP++-- | Parse an expression, then optionally consume @<-@ and a right-hand side.+-- If the arrow is present, the expression is converted to a pattern via+-- 'checkPattern' and the result is a bind; otherwise it is an expression.+exprOrPatternBindParser ::+  TokParser Expr ->+  TokParser Expr ->+  (Pattern -> Expr -> a) ->+  (Expr -> a) ->+  TokParser a+exprOrPatternBindParser exprP rhsP bindCtor exprCtor = do+  expr <- exprP+  mArrow <- MP.optional (expectedTok TkReservedLeftArrow)+  case mArrow of+    Just () -> do+      pat <- liftCheck (checkPattern expr)+      bindCtor pat <$> rhsP+    Nothing -> pure (exprCtor expr)++-- | Report core:+--+-- > exp -> infixexp ['::' type]+exprParser :: TokParser Expr+exprParser =+  exprParserWithTypeSigParser typeSignatureParser++exprParserWithTypeSigParser :: TokParser Type -> TokParser Expr+exprParserWithTypeSigParser typeSigParser =+  label "expression" $+    exprCoreParserWithTypeSigParser typeSigParser++exprCoreParserWithoutTypeSig :: TokParser Expr+exprCoreParserWithoutTypeSig = do+  mSCC <- optionalHiddenPragma getSCCPragma+  case mSCC of+    Just sccPragma -> EPragma sccPragma <$> exprCoreParserWithoutTypeSig+    Nothing -> exprCoreParserWithoutTypeSigBody++-- | Report core:+--+-- > infixexp -> lexp qop infixexp+-- >          | '-' infixexp+-- >          | lexp+--+-- Extensions reuse the same infix chain shape by swapping the @lexp@+-- parser that supplies operands.+exprCoreParserWithoutTypeSigBody :: TokParser Expr+exprCoreParserWithoutTypeSigBody = exprInfixChainParser lexpParser++exprCoreParserWithTypeSigParser :: TokParser Type -> TokParser Expr+exprCoreParserWithTypeSigParser typeSigParser = do+  optionalSuffix+    (expectedTok TkReservedDoubleColon *> typeSigParser)+    ETypeSig+    exprCoreParserWithoutTypeSig++-- | Parse the command-arrow LHS nonterminal from GHC's @exp_gen(infixexp)@+-- grammar:+--+-- @+-- exp : infixexp -< exp+--     | infixexp -<< exp+-- @+--+-- AIHC parses commands directly rather than through GHC's expression-command+-- disambiguation, so this context removes the bare @proc@ atom. A parenthesized+-- @proc@ expression still parses through the ordinary parenthesized atom rule.+cmdArrAppLhsParser :: TokParser Expr+cmdArrAppLhsParser =+  exprInfixChainParser (lexpParserWith CmdArrAppLhsAtom)++data AtomContext+  = NormalExprAtom+  | CmdArrAppLhsAtom+  deriving (Eq)++-- | The operator name used to represent @->@ in view-pattern expressions.+viewPatArrowName :: Name+viewPatArrowName = qualifyName Nothing (mkUnqualifiedName NameVarSym "->")++-- | Optionally consume a @->@ token and parse the right-hand side as a+-- view-pattern expression.  Returns the original expression unchanged when+-- no @->@ follows.+maybeViewPattern :: Expr -> TokParser Expr+maybeViewPattern lhs = do+  mArrow <- MP.optional (expectedTok TkReservedRightArrow)+  case mArrow of+    Just () -> EInfix lhs viewPatArrowName <$> texprParser+    Nothing -> pure lhs++-- | Like 'exprParser' but also allows the view-pattern arrow @->@ at the+-- top level.  This corresponds to GHC\'s @texp@ production, which is used+-- inside delimited contexts such as parentheses @(…)@ and unboxed parens+-- @(# … #)@.+texprParser :: TokParser Expr+texprParser = exprParser >>= maybeViewPattern++ifExprParser :: TokParser Expr+ifExprParser = do+  expectedTok TkKeywordIf+  multiWayIfExprParser <|> classicIfExprParser++classicIfExprParser :: TokParser Expr+classicIfExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  cond <- exprParser+  skipSemicolons+  expectedTok TkKeywordThen+  yes <- exprParser+  skipSemicolons+  expectedTok TkKeywordElse+  EIf cond yes <$> exprParser++multiWayIfExprParser :: TokParser Expr+multiWayIfExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  EMultiWayIf <$> braces (MP.some multiWayIfAlternative)++multiWayIfAlternative :: TokParser (GuardedRhs Expr)+multiWayIfAlternative = withSpan $ do+  expectedTok TkReservedPipe+  guards <- layoutSepBy1 (guardQualifierParser RhsArrowCase) (expectedTok TkSpecialComma)+  expectedTok TkReservedRightArrow+  body <- exprParser+  pure $ \span' ->+    GuardedRhs+      { guardedRhsAnns = [mkAnnotation span'],+        guardedRhsGuards = guards,+        guardedRhsBody = body+      }++doExprParser :: TokParser Expr+doExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  expectedTok TkKeywordDo+  stmts <- bracedSemiSep1 doStmtParser+  pure (EDo stmts DoPlain)++mdoExprParser :: TokParser Expr+mdoExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  expectedTok TkKeywordMdo+  stmts <- bracedSemiSep1 doStmtParser+  pure (EDo stmts DoMdo)++qualifiedDoExprParser :: TokParser Expr+qualifiedDoExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  modName <- tokenSatisfy "qualified do" $ \tok ->+    case lexTokenKind tok of+      TkQualifiedDo m -> Just m+      _ -> Nothing+  stmts <- bracedSemiSep1 doStmtParser+  pure (EDo stmts (DoQualified modName))++qualifiedMdoExprParser :: TokParser Expr+qualifiedMdoExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  modName <- tokenSatisfy "qualified mdo" $ \tok ->+    case lexTokenKind tok of+      TkQualifiedMdo m -> Just m+      _ -> Nothing+  stmts <- bracedSemiSep1 doStmtParser+  pure (EDo stmts (DoQualifiedMdo modName))++-- | Parse a proc expression: @proc apat -> cmd@+procExprParser :: TokParser Expr+procExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  expectedTok TkKeywordProc+  pat <- region "while parsing proc pattern" apatParser+  expectedTok TkReservedRightArrow+  body <- region "while parsing proc body" cmdParser+  pure (EProc pat body)++doStmtParser :: TokParser (DoStmt Expr)+doStmtParser = do+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkKeywordLet -> MP.try doLetStmtParser <|> doBindOrExprStmtParser+    TkKeywordRec -> doRecStmtParser+    _ -> MP.try doPatBindStmtParser <|> doBindOrExprStmtParser++doBindOrExprStmtParser :: TokParser (DoStmt Expr)+doBindOrExprStmtParser = withSpanAnn (DoAnn . mkAnnotation) $ do+  mExpr <- MP.optional . MP.try $ exprParser+  case mExpr of+    Nothing -> do+      pat <- patternParser+      expectedTok TkReservedLeftArrow+      rhs <- region "while parsing '<-' binding" exprParser+      pure (DoBind pat rhs)+    Just expr -> do+      tok <- lookAhead anySingle+      case lexTokenKind tok of+        TkReservedAt -> do+          pat <- patternParser+          expectedTok TkReservedLeftArrow+          rhs <- region "while parsing '<-' binding" exprParser+          pure (DoBind pat rhs)+        _ -> do+          mArrow <- MP.optional (expectedTok TkReservedLeftArrow)+          case mArrow of+            Just () -> do+              pat <- liftCheck (checkPattern expr)+              rhs <- region "while parsing '<-' binding" exprParser+              pure (DoBind pat rhs)+            Nothing ->+              pure (DoExpr expr)++doPatBindStmtParser :: TokParser (DoStmt Expr)+doPatBindStmtParser = withSpanAnn (DoAnn . mkAnnotation) $ do+  pat <- patternParser+  expectedTok TkReservedLeftArrow+  expr <- region "while parsing '<-' binding" exprParser+  pure (DoBind pat expr)++parseLetDeclsParser :: TokParser [Decl]+parseLetDeclsParser = expectedTok TkKeywordLet *> bracedDeclsMaybeEmpty++parseLetDeclsStmtParser :: TokParser [Decl]+parseLetDeclsStmtParser = parseLetDeclsParser <* MP.notFollowedBy (expectedTok TkKeywordIn)++-- | Parse let bindings that may be empty.+-- Unlike @where@ clauses and @case@ alternatives, @let@ bindings can be+-- empty (e.g. @let {}@ or a bare @let@ with layout). GHC accepts these+-- syntactically, even though they are semantically useless.+bracedDeclsMaybeEmpty :: TokParser [Decl]+bracedDeclsMaybeEmpty = bracedSemiSep localDeclsParser++doLetStmtParser :: TokParser (DoStmt Expr)+doLetStmtParser = withSpanAnn (DoAnn . mkAnnotation) $ do+  DoLetDecls <$> parseLetDeclsStmtParser++-- | Parse a @rec@ statement inside a do-block.+doRecStmtParser :: TokParser (DoStmt Expr)+doRecStmtParser = withSpanAnn (DoAnn . mkAnnotation) $ do+  expectedTok TkKeywordRec+  DoRecStmt <$> bracedSemiSep1 doStmtParser++-- | Shared infix-chain parser used by the report core and contextual+-- expression variants such as TransformListComp.+exprInfixChainParser :: TokParser Expr -> TokParser Expr+exprInfixChainParser lexp = do+  lhs <- lexp+  rest <-+    MP.many+      ( (,)+          <$> infixOperatorParser+          <*> region "after infix operator" lexp+      )+  pure (foldInfixL buildInfix lhs rest)++-- | Report core:+--+-- > lexp -> '\\' apat_1 ... apat_n '->' exp+-- >      | 'let' decls 'in' exp+-- >      | 'if' exp [';'] 'then' exp [';'] 'else' exp+-- >      | 'case' exp 'of' '{' alts '}'+-- >      | 'do' '{' stmts '}'+-- >      | fexp+--+-- Extensions add more block-like forms at this grammar level.+lexpParser :: TokParser Expr+lexpParser = lexpParserWith NormalExprAtom++lexpParserWith :: AtomContext -> TokParser Expr+lexpParserWith atomContext = do+  mSCC <- optionalHiddenPragma getSCCPragma+  case mSCC of+    Just sccPragma -> EPragma sccPragma <$> lexpParserWith atomContext+    Nothing -> lexpBaseParserWith atomContext (appExprParserWith (atomOrRecordExprParserWith atomContext))++lexpBaseParserWith :: AtomContext -> TokParser Expr -> TokParser Expr+lexpBaseParserWith atomContext appParser =+  lexpBlockParserWith atomContext+    <|> MP.try negateExprParser+    <|> appParser++-- | The Haskell report's @lexp@ production: lambda, let, if, case, do, and+-- function application.  GHC extensions add more forms at the same grammar+-- level, such as @proc@ and qualified @do@.+reportLexpParser :: TokParser Expr -> TokParser Expr+reportLexpParser appParser =+  lexpBlockParser+    <|> appParser++-- | Report core block forms:+--+-- > lexp -> '\\' apat_1 ... apat_n '->' exp+-- >      | 'let' decls 'in' exp+-- >      | 'if' exp [';'] 'then' exp [';'] 'else' exp+-- >      | 'case' exp 'of' '{' alts '}'+-- >      | 'do' '{' stmts '}'+--+-- GHC extensions extend this set with @mdo@, qualified @do@, and @proc@.+lexpBlockParser :: TokParser Expr+lexpBlockParser = lexpBlockParserWith NormalExprAtom++lexpBlockParserWith :: AtomContext -> TokParser Expr+lexpBlockParserWith atomContext =+  doExprParser+    <|> mdoExprParser+    <|> qualifiedDoExprParser+    <|> qualifiedMdoExprParser+    <|> ifExprParser+    <|> caseExprParser+    <|> letExprParser+    <|> procBlockParser+    <|> lambdaExprParser+  where+    procBlockParser+      | atomContext == NormalExprAtom = procExprParser+      | otherwise = MP.empty++getSCCPragma :: Pragma -> Maybe Pragma+getSCCPragma p = case pragmaType p of+  PragmaSCC _ -> Just p+  _ -> Nothing++buildInfix :: Expr -> (Name, Expr) -> Expr+buildInfix lhs (op, rhs) =+  EInfix lhs op rhs++intExprParser :: TokParser Expr+intExprParser =+  tokenExprParser "integer literal" $ \tok ->+    case lexTokenKind tok of+      TkInteger i nt -> Just (EInt i nt (lexTokenText tok))+      _ -> Nothing++floatExprParser :: TokParser Expr+floatExprParser =+  tokenExprParser "floating literal" $ \tok ->+    case lexTokenKind tok of+      TkFloat x ft -> Just (EFloat x ft (lexTokenText tok))+      _ -> Nothing++tokenExprParser :: String -> (LexToken -> Maybe Expr) -> TokParser Expr+tokenExprParser expected matchToken =+  withSpanAnn (EAnn . mkAnnotation) (tokenSatisfy expected matchToken)++charExprParser :: TokParser Expr+charExprParser =+  tokenExprParser "character literal" $ \tok ->+    case lexTokenKind tok of+      TkChar x -> Just (EChar x (lexTokenText tok))+      TkCharHash x txt -> Just (ECharHash x txt)+      _ -> Nothing++stringExprParser :: TokParser Expr+stringExprParser =+  tokenExprParser "string literal" $ \tok ->+    case lexTokenKind tok of+      TkString x -> Just (EString x (lexTokenText tok))+      TkStringHash x txt -> Just (EStringHash x txt)+      _ -> Nothing++overloadedLabelExprParser :: TokParser Expr+overloadedLabelExprParser =+  tokenExprParser "overloaded label" $ \tok ->+    case lexTokenKind tok of+      TkOverloadedLabel lbl repr -> Just (EOverloadedLabel lbl repr)+      _ -> Nothing++-- | Report core:+--+-- > fexp -> [fexp] aexp+appExprParser :: TokParser Expr+appExprParser = appExprParserWith atomOrRecordExprParser++-- | Shared application parser used by the report core and contextual+-- variants.  The caller chooses the @aexp@-like atom parser.+appExprParserWith :: TokParser Expr -> TokParser Expr+appExprParserWith atomParser = withSpanAnn (EAnn . mkAnnotation) $ do+  first <- atomParser+  rest <- MP.many appArg+  pure $+    foldl applyArg first rest+  where+    appArg :: TokParser (Either Type Expr)+    appArg = (Left <$> typeAppArg) <|> (Right <$> appExprArgParser)++    typeAppArg :: TokParser Type+    typeAppArg = MP.try $ do+      expectedTok TkTypeApp+      typeAtomParser++    appExprArgParser :: TokParser Expr+    appExprArgParser = do+      tok <- lookAhead anySingle+      case lexTokenKind tok of+        -- GHC rejects bare explicit namespace syntax as a function argument:+        -- @f type T@ is invalid, while @f (type T)@ is accepted syntactically.+        TkKeywordType -> MP.empty+        _ -> atomParser++    applyArg :: Expr -> Either Type Expr -> Expr+    applyArg fn (Left ty) = ETypeApp fn ty+    applyArg fn (Right arg) = EApp fn arg++-- | Parse an atomic expression, including record construction/update syntax.+--+-- Haskell 2010 makes record construction and update part of the @aexp@+-- production:+--+-- > aexp -> qcon { fbind_1, ..., fbind_n }+-- > aexp -> aexp<qcon> { fbind_1, ..., fbind_n }+--+-- So record braces are not a suffix on every expression form that this parser+-- accepts as an application atom.  Extension forms such as bare explicit+-- namespace expressions stay in 'atomExprParser'; they can be record-update+-- bases only after parentheses make them an @aexp@.+atomOrRecordExprParser :: TokParser Expr+atomOrRecordExprParser = atomOrRecordExprParserWith NormalExprAtom++atomOrRecordExprParserWith :: AtomContext -> TokParser Expr+atomOrRecordExprParserWith atomContext =+  recordExprParser <|> atomExprParserWith atomContext+  where+    recordExprParser :: TokParser Expr+    recordExprParser = do+      base <- recordBaseAtomExprParserWith atomContext+      applyRecordSuffixes base++    applyRecordSuffixes :: Expr -> TokParser Expr+    applyRecordSuffixes e = do+      mRecordFields <- MP.optional recordBracesParser+      case mRecordFields of+        Just (fields, hasWildcard) -> do+          let result = case peelExprAnn e of+                EVar name+                  | isConLikeName name ->+                      ERecordCon name (map normalizeField fields) hasWildcard+                _ ->+                  ERecordUpd e (map normalizeField fields)+          applyRecordSuffixes result+        Nothing -> applyRecordDotSuffixes e++    applyRecordDotSuffixes :: Expr -> TokParser Expr+    applyRecordDotSuffixes e = do+      recordDotEnabled <- isExtensionEnabled OverloadedRecordDot+      if not recordDotEnabled || not (recordDotMayFollow e)+        then pure e+        else do+          mDot <- MP.optional (expectedTok TkRecordDot)+          case mDot of+            Nothing -> pure e+            Just () -> do+              fieldName <- recordFieldNameParser+              applyRecordSuffixes (EGetField e fieldName)++    normalizeField :: (Name, Maybe Expr, SourceSpan) -> RecordField Expr+    normalizeField (fieldName, mExpr, sp) =+      case mExpr of+        Just expr' -> RecordField fieldName expr' False+        Nothing -> RecordField fieldName (EAnn (mkAnnotation sp) (EVar fieldName)) True++    recordDotMayFollow :: Expr -> Bool+    recordDotMayFollow expr =+      case expr of+        EAnn _ sub -> recordDotMayFollow sub+        -- GHC rejects unparenthesized explicit namespace expressions before+        -- record-dot syntax, e.g. @type (:+).a@.+        ETypeSyntax TypeSyntaxExplicitNamespace _ -> False+        _ -> True++-- | Parse record braces: { field = value, field2 = value2, ... }+recordBracesParser :: TokParser ([(Name, Maybe Expr, SourceSpan)], Bool)+recordBracesParser =+  braces $+    recordFieldsWithWildcardsParser (layoutSepEndBy recordFieldBindingParser (expectedTok TkSpecialComma))++recordFieldBindingParser :: TokParser (Name, Maybe Expr, SourceSpan)+recordFieldBindingParser = withSpan $ do+  fieldName <- recordFieldNameParser+  mAssign <- MP.optional (expectedTok TkReservedEquals *> exprParser)+  pure (fieldName,mAssign,)++-- | Parse the expression forms that correspond to the report's @aexp@+-- production and can therefore be record construction/update bases.+--+-- > aexp -> qvar+-- >      | gcon+-- >      | literal+-- >      | '(' exp ')'+-- >      | '(' exp_1 ',' ... ',' exp_k ')'+-- >      | '[' exp_1 ',' ... ',' exp_k ']'+-- >      | '[' exp_1 [',' exp_2] '..' [exp_3] ']'+-- >      | '[' exp '|' qual_1 ',' ... ',' qual_n ']'+-- >      | '(' infixexp qop ')'+-- >      | '(' qop infixexp ')'+-- >      | qcon '{' fbind_1 ',' ... ',' fbind_n '}'+-- >      | aexp<qcon> '{' fbind_1 ',' ... ',' fbind_n '}'+recordBaseAtomExprParserWith :: AtomContext -> TokParser Expr+recordBaseAtomExprParserWith atomContext = do+  thAny <- thAnyEnabled+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkImplicitParam {} -> implicitParamExprParser+    _ ->+      MP.try (prefixNegateAtomExprParserWith atomContext)+        <|> MP.try parenOperatorExprParser+        <|> (if thAny then thQuoteExprParser else MP.empty)+        <|> (if thAny then thNameQuoteExprParser else MP.empty)+        <|> (if thAny then thTypedSpliceParser else MP.empty)+        <|> (if thAny then thUntypedSpliceParser else MP.empty)+        <|> quasiQuoteExprParser+        <|> parenExprParser+        <|> listExprParser+        <|> intExprParser+        <|> floatExprParser+        <|> charExprParser+        <|> stringExprParser+        <|> overloadedLabelExprParser+        <|> wildcardExprParser+        <|> varExprParser++-- | Parse an atom without record construction/update syntax.+--+-- > aexp -> qvar | gcon | literal | '(' exp ')' | ...+--+-- This variant also admits extension-only atoms such as block arguments and+-- explicit namespace syntax when the corresponding extensions are enabled.+atomExprParser :: TokParser Expr+atomExprParser = atomExprParserWith NormalExprAtom++atomExprParserWith :: AtomContext -> TokParser Expr+atomExprParserWith atomContext = do+  blockArgsEnabled <- isExtensionEnabled BlockArguments+  thAny <- thAnyEnabled+  explicitNamespacesEnabled <- isExtensionEnabled ExplicitNamespaces+  requiredTypeArgumentsEnabled <- isExtensionEnabled RequiredTypeArguments+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkImplicitParam {} -> implicitParamExprParser+    TkKeywordType+      | explicitNamespacesEnabled || requiredTypeArgumentsEnabled -> explicitTypeExprParser+    TkReservedBackslash -> lambdaExprParser+    TkKeywordLet -> letExprParser+    TkKeywordDo | blockArgsEnabled -> doExprParser+    TkKeywordMdo | blockArgsEnabled -> mdoExprParser+    TkQualifiedDo {} | blockArgsEnabled -> qualifiedDoExprParser+    TkQualifiedMdo {} | blockArgsEnabled -> qualifiedMdoExprParser+    TkKeywordCase | blockArgsEnabled -> caseExprParser+    TkKeywordIf | blockArgsEnabled -> ifExprParser+    TkKeywordProc | blockArgsEnabled && atomContext == NormalExprAtom -> procExprParser+    _ ->+      MP.try (prefixNegateAtomExprParserWith atomContext)+        <|> MP.try parenOperatorExprParser+        <|> (if thAny then thQuoteExprParser else MP.empty)+        <|> (if thAny then thNameQuoteExprParser else MP.empty)+        <|> (if thAny then thTypedSpliceParser else MP.empty)+        <|> (if thAny then thUntypedSpliceParser else MP.empty)+        <|> quasiQuoteExprParser+        <|> parenExprParser+        <|> listExprParser+        <|> intExprParser+        <|> floatExprParser+        <|> charExprParser+        <|> stringExprParser+        <|> overloadedLabelExprParser+        <|> wildcardExprParser+        <|> varExprParser++explicitTypeExprParser :: TokParser Expr+explicitTypeExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  expectedTok TkKeywordType+  ETypeSyntax TypeSyntaxExplicitNamespace <$> typeParser++prefixNegateAtomExprParserWith :: AtomContext -> TokParser Expr+prefixNegateAtomExprParserWith atomContext = withSpanAnn (EAnn . mkAnnotation) $ do+  prefixMinusTokenParser+  ENegate <$> atomExprParserWith atomContext++negateExprParser :: TokParser Expr+negateExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  _ <- minusTokenValueParser+  ENegate <$> negateOperandParser++-- | Parse the immediate operand of prefix negation.  The Haskell report writes+-- negation as @- infixexp@, but GHC's fixity parser treats prefix @-@ like a+-- left-associative precedence-6 operator: it starts with another @lexp@-level+-- operand and then lets the surrounding infix parser consume following+-- operators.+negateOperandParser :: TokParser Expr+negateOperandParser = reportLexpParser appExprParser++minusTokenValueParser :: TokParser LexToken+minusTokenValueParser =+  tokenSatisfy "minus operator" $ \tok ->+    case lexTokenKind tok of+      TkVarSym "-" -> Just tok+      TkMinusOperator -> Just tok+      TkPrefixMinus -> Just tok+      _ -> Nothing++prefixMinusTokenParser :: TokParser ()+prefixMinusTokenParser =+  tokenSatisfy "prefix minus" $ \tok ->+    case lexTokenKind tok of+      TkPrefixMinus -> Just ()+      _ -> Nothing++parenOperatorExprParser :: TokParser Expr+parenOperatorExprParser =+  withSpanAnn (EAnn . mkAnnotation) $+    EVar <$> parens operatorExprNameParser++operatorExprNameParser :: TokParser Name+operatorExprNameParser =+  tokenSatisfy "operator" $ \tok ->+    case lexTokenKind tok of+      TkVarSym sym -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym sym))+      TkConSym sym -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym sym))+      TkQVarSym modName sym -> Just (mkName (Just modName) NameVarSym sym)+      TkQConSym modName sym -> Just (mkName (Just modName) NameConSym sym)+      TkReservedAt -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "@"))+      TkMinusOperator -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "-"))+      TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"))+      TkReservedDoubleColon -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "::"))+      TkReservedEquals -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "="))+      TkReservedPipe -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "|"))+      TkReservedLeftArrow -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "<-"))+      TkReservedRightArrow -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "->"))+      TkReservedDoubleArrow -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "=>"))+      TkReservedDotDot -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym ".."))+      _ -> Nothing++rhsParser :: TokParser (Rhs Expr)+rhsParser = label "right-hand side" (caseRhsParserWithBodyParser exprParser)++-- | Report core:+--+-- > rhs   -> '=' exp ['where' decls]+-- >       | gdrhs ['where' decls]+-- > gdrhs -> guards '=' exp [gdrhs]+equationRhsParser :: TokParser (Rhs Expr)+equationRhsParser = label "equation right-hand side" (rhsParserWithBodyParser RhsArrowEquation exprParser)++caseRhsParserWithBodyParser :: TokParser body -> TokParser (Rhs body)+caseRhsParserWithBodyParser = rhsParserWithBodyParser RhsArrowCase++data RhsArrowKind = RhsArrowCase | RhsArrowEquation++rhsArrowText :: RhsArrowKind -> Text+rhsArrowText RhsArrowCase = "->"+rhsArrowText RhsArrowEquation = "="++rhsArrowTok :: RhsArrowKind -> TokParser ()+rhsArrowTok RhsArrowCase = expectedTok TkReservedRightArrow+rhsArrowTok RhsArrowEquation = expectedTok TkReservedEquals++rhsParserWithBodyParser :: RhsArrowKind -> TokParser body -> TokParser (Rhs body)+rhsParserWithBodyParser arrowKind bodyParser = do+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkReservedPipe -> guardedRhssParserWithBodyParser arrowKind bodyParser+    TkReservedRightArrow | RhsArrowCase <- arrowKind -> unguardedRhsParserWithBodyParser arrowKind bodyParser+    TkReservedEquals | RhsArrowEquation <- arrowKind -> unguardedRhsParserWithBodyParser arrowKind bodyParser+    _ ->+      MP.customFailure+        UnexpectedTokenExpecting+          { unexpectedFound = Just (mkFoundToken tok),+            unexpectedExpecting = rhsArrowText arrowKind <> " or guarded right-hand side",+            unexpectedContext = []+          }++unguardedRhsParserWithBodyParser :: RhsArrowKind -> TokParser body -> TokParser (Rhs body)+unguardedRhsParserWithBodyParser arrowKind bodyParser = withSpan $ do+  rhsArrowTok arrowKind+  body <- region (rhsContextText arrowKind) bodyParser+  whereDecls <- MP.optional whereClauseParser+  pure (\span' -> UnguardedRhs [mkAnnotation span'] body whereDecls)++rhsContextText :: RhsArrowKind -> Text+rhsContextText RhsArrowCase = "while parsing case alternative right-hand side"+rhsContextText RhsArrowEquation = "while parsing equation right-hand side"++guardedRhssParserWithBodyParser :: RhsArrowKind -> TokParser body -> TokParser (Rhs body)+guardedRhssParserWithBodyParser arrowKind bodyParser = withSpan $ do+  grhss <- MP.some (guardedRhsParserWithBodyParser arrowKind bodyParser)+  whereDecls <- MP.optional whereClauseParser+  pure (\span' -> GuardedRhss [mkAnnotation span'] grhss whereDecls)++guardedRhsParserWithBodyParser :: RhsArrowKind -> TokParser body -> TokParser (GuardedRhs body)+guardedRhsParserWithBodyParser arrowKind bodyParser = withSpan $ do+  expectedTok TkReservedPipe+  guards <- layoutSepBy1 (guardQualifierParser arrowKind) (expectedTok TkSpecialComma)+  rhsArrowTok arrowKind+  body <- bodyParser+  pure $ \span' ->+    GuardedRhs+      { guardedRhsAnns = [mkAnnotation span'],+        guardedRhsGuards = guards,+        guardedRhsBody = body+      }++-- | Parse a guard qualifier. The 'RhsArrowKind' controls whether guard+-- expressions may carry a bare top-level type signature before the RHS arrow.+--+-- > guard -> pat '<-' infixexp+-- >       | 'let' decls+-- >       | infixexp+guardQualifierParser :: RhsArrowKind -> TokParser GuardQualifier+guardQualifierParser arrowKind = do+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkKeywordLet -> MP.try guardLetParser <|> guardBindOrExprParser arrowKind+    _ -> MP.try guardPatBindParser <|> guardBindOrExprParser arrowKind++-- | Parse a guard expression or pattern bind.+guardBindOrExprParser :: RhsArrowKind -> TokParser GuardQualifier+guardBindOrExprParser arrowKind =+  withSpanAnn (GuardAnn . mkAnnotation) $+    exprOrPatternBindParser+      (guardExprParser arrowKind)+      exprParser+      GuardPat+      GuardExpr++guardPatBindParser :: TokParser GuardQualifier+guardPatBindParser = withSpanAnn (GuardAnn . mkAnnotation) $ do+  pat <- patternParser+  expectedTok TkReservedLeftArrow+  GuardPat pat <$> exprParser++guardLetParser :: TokParser GuardQualifier+guardLetParser = withSpanAnn (GuardAnn . mkAnnotation) $ do+  GuardLet <$> parseLetDeclsStmtParser++-- | Parse a guard expression.  Equation guards allow a bare top-level type+-- signature before @=@, but GHC rejects the same spelling before a case-style+-- @->@.  Parenthesized signatures still parse through the expression atom+-- grammar, e.g. @case x of _ | (a :: T) -> rhs@.+guardExprParser :: RhsArrowKind -> TokParser Expr+guardExprParser RhsArrowEquation = exprParserWithTypeSigParser typeParser+guardExprParser RhsArrowCase = exprCoreParserWithoutTypeSig++caseAltParser :: TokParser (CaseAlt Expr)+caseAltParser = withSpan $ do+  pat <- region "while parsing case alternative" caseAltPatternParser+  rhs <- region "while parsing case alternative" rhsParser+  pure $ \span' ->+    CaseAlt+      { caseAltAnns = [mkAnnotation span'],+        caseAltPattern = pat,+        caseAltRhs = rhs+      }++lambdaCaseAltParser :: TokParser LambdaCaseAlt+lambdaCaseAltParser = withSpan $ do+  pats <- region "while parsing lambda-cases alternative" (MP.many apatParser)+  rhs <- region "while parsing lambda-cases alternative" rhsParser+  pure $ \span' ->+    LambdaCaseAlt+      { lambdaCaseAltAnns = [mkAnnotation span'],+        lambdaCaseAltPats = pats,+        lambdaCaseAltRhs = rhs+      }++caseExprParser :: TokParser Expr+caseExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  expectedTok TkKeywordCase+  scrutinee <- region "while parsing case expression" exprParser+  expectedTok TkKeywordOf+  ECase scrutinee <$> bracedAlts+  where+    bracedAlts = bracedSemiSep caseAltParser++parenExprParser :: TokParser Expr+parenExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  (tupleFlavor, closeTok) <- tupleDelimsParser+  mClosed <- MP.optional (expectedTok closeTok)+  case mClosed of+    Just () -> pure (ETuple tupleFlavor [])+    Nothing ->+      if tupleFlavor == Boxed+        then MP.try (parseNegateParen closeTok) <|> parseBoxedContent closeTok+        else MP.try (parseUnboxedSumExprLeadingBars closeTok) <|> parseTupleOrParen tupleFlavor closeTok+  where+    parseNegateParen closeTok = do+      minusTok <- minusTokenValueParser+      guard (parenNegateAllowed minusTok)+      -- Parse only the application-level expression as the negation's+      -- immediate operand, plus the block forms GHC permits after prefix+      -- negation.  Negation still binds tighter than any infix operator, so+      -- @(-l - 1)@ is @((negate l) - 1)@, not @(negate (l - 1))@.+      negOperand <- negateOperandParser+      let negBase = ENegate negOperand+      -- Continue with any infix operator chain, type signature, and view+      -- pattern that may follow the negated expression inside the parens.+      rest <-+        MP.many+          ( MP.try+              ( (,)+                  <$> infixOperatorParser+                  <*> region "after infix operator" lexpParser+              )+          )+      let withInfix = foldInfixL buildInfix negBase rest+      mTypeSig <- MP.optional (expectedTok TkReservedDoubleColon *> typeSignatureParser)+      let typed = case mTypeSig of+            Just ty -> ETypeSig withInfix ty+            Nothing -> withInfix+      finalExpr <- maybeViewPattern typed+      expectedTok closeTok+      -- The negation is already embedded in finalExpr (as negBase).+      -- With TkPrefixMinus (LexicalNegation), the surrounding parens are+      -- just grouping — no EParen wrapper.  Otherwise the parens are part+      -- of the negation-section syntax and need an EParen wrapper.+      pure $+        case lexTokenKind minusTok of+          TkPrefixMinus -> finalExpr+          _ -> EParen finalExpr++    parenNegateAllowed minusTok =+      case lexTokenKind minusTok of+        TkPrefixMinus -> True+        TkVarSym "-" -> True+        TkMinusOperator -> False+        _ -> False++    parseBoxedContent closeTok =+      MP.try (parseProjectionSection closeTok)+        <|> MP.try parseSectionR+        <|> do+          mBase <- MP.optional (MP.try negateExprParser <|> lexpParser)+          case mBase of+            Nothing ->+              finishBoxed closeTok Nothing+            Just base -> do+              mOp <- MP.optional infixOperatorParser+              case mOp of+                Nothing -> do+                  mArrowSection <- MP.optional (MP.try (arrowSectionOperatorParser <* expectedTok closeTok))+                  case mArrowSection of+                    Just op ->+                      pure (EParen (ESectionL base op))+                    Nothing -> do+                      mTypeSig <- MP.optional (expectedTok TkReservedDoubleColon *> typeSignatureParser)+                      let typed = case mTypeSig of+                            Just ty -> ETypeSig base ty+                            Nothing -> base+                      -- View pattern arrow: expr -> expr (inside parentheses)+                      finalExpr <- maybeViewPattern typed+                      finishBoxed closeTok (Just finalExpr)+                Just op -> do+                  mClose <- MP.optional (expectedTok closeTok)+                  case mClose of+                    Just () ->+                      pure (EParen (ESectionL base op))+                    Nothing -> do+                      rhs <- region "after infix operator" lexpParser+                      more <-+                        MP.many+                          ( MP.try+                              ( (,)+                                  <$> infixOperatorParser+                                  <*> region "after infix operator" lexpParser+                              )+                          )+                      let fullInfix = foldInfixL buildInfix base ((op, rhs) : more)+                      mTrailingOp <- MP.optional infixOperatorParser+                      case mTrailingOp of+                        Just trailOp -> do+                          expectedTok closeTok+                          pure (EParen (ESectionL fullInfix trailOp))+                        Nothing -> do+                          mTypeSig <- MP.optional (expectedTok TkReservedDoubleColon *> typeSignatureParser)+                          let typed = case mTypeSig of+                                Just ty -> ETypeSig fullInfix ty+                                Nothing -> fullInfix+                          -- View pattern arrow: expr -> expr (inside parentheses)+                          finalExpr <- maybeViewPattern typed+                          finishBoxed closeTok (Just finalExpr)+      where+        parseProjectionSection tok = do+          recordDotEnabled <- isExtensionEnabled OverloadedRecordDot+          guard recordDotEnabled+          fields <- MP.some (expectedTok TkRecordDot *> recordFieldNameParser)+          expectedTok tok+          pure (EParen (EGetFieldProjection fields))++        parseSectionR = do+          op <- reservedAtSectionOperatorParser <|> infixOperatorParser <|> arrowSectionOperatorParser+          rhs <- exprParser+          expectedTok closeTok+          pure (EParen (ESectionR op rhs))++        reservedAtSectionOperatorParser = do+          expectedTok TkReservedAt+          pure (qualifyName Nothing (mkUnqualifiedName NameVarSym "@"))++        arrowSectionOperatorParser =+          tokenSatisfy "operator" $ \tok ->+            case lexTokenKind tok of+              TkArrowTail -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "-<"))+              TkDoubleArrowTail -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "-<<"))+              _ -> Nothing++    finishBoxed closeTok mFirst = do+      mComma <- MP.optional (expectedTok TkSpecialComma)+      case (mFirst, mComma) of+        (Just e, Nothing) -> do+          expectedTok closeTok+          pure (EParen e)+        (_, Just ()) -> do+          rest <- parseTupleElems closeTok+          pure (ETuple Boxed (mFirst : rest))+        (Nothing, Nothing) ->+          fail "expected expression or closing paren"++    parseTupleOrParen tupleFlavor closeTok = do+      first <- MP.optional texprParser+      mComma <- MP.optional (expectedTok TkSpecialComma)+      case (first, mComma) of+        (Just e, Nothing) ->+          case tupleFlavor of+            Boxed -> do+              expectedTok closeTok+              pure (EParen e)+            Unboxed -> do+              mPipe <- MP.optional (expectedTok TkReservedPipe)+              case mPipe of+                Just () -> do+                  trailingBars <- MP.many (expectedTok TkReservedPipe)+                  expectedTok closeTok+                  let arity = 2 + length trailingBars+                  pure (EUnboxedSum 0 arity e)+                Nothing -> do+                  expectedTok closeTok+                  pure (ETuple Unboxed [Just e])+        (_, Just ()) -> do+          rest <- parseTupleElems closeTok+          pure (ETuple tupleFlavor (first : rest))+        (Nothing, Nothing) ->+          fail "expected expression or closing paren"++    parseTupleElems closeTok = do+      e <- MP.optional texprParser+      mComma <- MP.optional (expectedTok TkSpecialComma)+      case mComma of+        Just () -> (e :) <$> parseTupleElems closeTok+        Nothing -> do+          expectedTok closeTok+          pure [e]++    parseUnboxedSumExprLeadingBars closeTok = do+      _ <- expectedTok TkReservedPipe+      leadingBars <- MP.many (expectedTok TkReservedPipe)+      let altIdx = 1 + length leadingBars+      inner <- texprParser+      trailingBars <- MP.many (expectedTok TkReservedPipe)+      expectedTok closeTok+      let arity = altIdx + 1 + length trailingBars+      pure (EUnboxedSum altIdx arity inner)++listExprParser :: TokParser Expr+listExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  expectedTok TkSpecialLBracket+  mClose <- MP.optional (expectedTok TkSpecialRBracket)+  case mClose of+    Just () -> pure (EList [])+    Nothing -> do+      first <- exprParser+      parseListTail first++parseListTail :: Expr -> TokParser Expr+parseListTail first = listCompTailParser <|> arithFromToTailParser <|> commaTailParser <|> singletonTailParser+  where+    listCompTailParser = do+      expectedTok TkReservedPipe+      firstGroup <- compStmtParser `MP.sepBy1` expectedTok TkSpecialComma+      moreGroups <- MP.many (expectedTok TkReservedPipe *> (compStmtParser `MP.sepBy1` expectedTok TkSpecialComma))+      expectedTok TkSpecialRBracket+      pure $+        case moreGroups of+          [] -> EListComp first firstGroup+          _ -> EListCompParallel first (firstGroup : moreGroups)++    arithFromToTailParser = do+      expectedTok TkReservedDotDot+      mTo <- MP.optional exprParser+      expectedTok TkSpecialRBracket+      pure $+        EArithSeq $+          case mTo of+            Nothing -> ArithSeqFrom first+            Just toExpr -> ArithSeqFromTo first toExpr++    commaTailParser = do+      expectedTok TkSpecialComma+      second <- exprParser+      arithFromThenTailParser second <|> listTailParser second++    arithFromThenTailParser second = do+      expectedTok TkReservedDotDot+      mTo <- MP.optional exprParser+      expectedTok TkSpecialRBracket+      pure $+        EArithSeq $+          case mTo of+            Nothing -> ArithSeqFromThen first second+            Just toExpr -> ArithSeqFromThenTo first second toExpr++    listTailParser second = do+      rest <- MP.many (expectedTok TkSpecialComma *> exprParser)+      expectedTok TkSpecialRBracket+      pure (EList (first : second : rest))++    singletonTailParser = do+      expectedTok TkSpecialRBracket+      pure (EList [first])++compStmtParser :: TokParser CompStmt+compStmtParser = do+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkKeywordLet -> MP.try compLetStmtParser <|> compGenOrGuardParser+    TkKeywordThen -> compTransformStmtParser <|> compGenOrGuardParser+    _ -> MP.try compPatGenParser <|> compGenOrGuardParser++-- | Parse a TransformListComp qualifier: @then f@, @then f by e@,+-- @then group by e using f@, or @then group using f@.+-- Only attempted when the 'TransformListComp' extension is enabled.+compTransformStmtParser :: TokParser CompStmt+compTransformStmtParser = MP.try $ withSpanAnn (CompAnn . mkAnnotation) $ do+  enabled <- isExtensionEnabled TransformListComp+  guard enabled+  expectedTok TkKeywordThen+  -- Check for 'group' forms first+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkVarId "group" -> compGroupStmtParser+    _ -> compThenStmtParser++-- | Parse @group by e using f@ or @group using f@ (after 'then' has been consumed).+compGroupStmtParser :: TokParser CompStmt+compGroupStmtParser = do+  varIdTok "group"+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkKeywordBy -> do+      expectedTok TkKeywordBy+      e <- compTransformExprParser+      expectedTok TkKeywordUsing+      CompGroupByUsing e <$> exprParser+    TkKeywordUsing -> do+      expectedTok TkKeywordUsing+      CompGroupUsing <$> exprParser+    _ -> fail "expected 'by' or 'using' after 'group'"++-- | Parse @f@ or @f by e@ (after 'then' has been consumed).+-- Uses a restricted expression parser that excludes 'by' and 'using'+-- from being consumed as variable identifiers at the top level.+compThenStmtParser :: TokParser CompStmt+compThenStmtParser = do+  f <- compTransformExprParser+  mBy <- MP.optional (expectedTok TkKeywordBy)+  case mBy of+    Just () -> CompThenBy f <$> exprParser+    Nothing -> pure (CompThen f)++-- | Expression parser for TransformListComp context.+-- Parses an expression but treats bare 'by' and 'using' as terminators+-- (they are not consumed as variable identifiers at the application level).+compTransformExprParser :: TokParser Expr+compTransformExprParser =+  label "expression" $+    optionalSuffix+      (expectedTok TkReservedDoubleColon *> typeSignatureParser)+      ETypeSig+      compTransformExprWithoutTypeSigParser++-- | Parse the core of a TransformListComp expression (without type signature suffix).+--+-- This reuses the normal @infixexp@ ladder, but with an @aexp@ parser that+-- treats bare @by@ and @using@ as terminators rather than variable atoms.+compTransformExprWithoutTypeSigParser :: TokParser Expr+compTransformExprWithoutTypeSigParser = exprInfixChainParser compTransformLexpParser++-- | TransformListComp still uses the report @lexp@ layering; only its atom+-- parser changes.+compTransformLexpParser :: TokParser Expr+compTransformLexpParser =+  compTransformLambdaExprParser+    <|> lexpBlockParser+    <|> MP.try compTransformNegateExprParser+    <|> compTransformAppExprParser++compTransformLambdaExprParser :: TokParser Expr+compTransformLambdaExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  expectedTok TkReservedBackslash+  lambdaCaseParser <|> lambdaCasesParser <|> lambdaPatsParser+  where+    lambdaCaseParser = do+      expectedTok TkKeywordCase+      ELambdaCase <$> bracedSemiSep compTransformCaseAltParser++    lambdaCasesParser = do+      lambdaCaseEnabled <- isExtensionEnabled LambdaCase+      guard lambdaCaseEnabled+      varIdTok "cases"+      ELambdaCases <$> bracedSemiSep compTransformLambdaCaseAltParser++    lambdaPatsParser = do+      pats <- MP.some apatParser+      expectedTok TkReservedRightArrow+      body <- region "while parsing lambda body" compTransformExprParser+      pure (ELambdaPats pats body)++compTransformCaseAltParser :: TokParser (CaseAlt Expr)+compTransformCaseAltParser = withSpan $ do+  pat <- region "while parsing case alternative" caseAltPatternParser+  rhs <- region "while parsing case alternative" (caseRhsParserWithBodyParser compTransformExprParser)+  pure $ \span' ->+    CaseAlt+      { caseAltAnns = [mkAnnotation span'],+        caseAltPattern = pat,+        caseAltRhs = rhs+      }++compTransformLambdaCaseAltParser :: TokParser LambdaCaseAlt+compTransformLambdaCaseAltParser = withSpan $ do+  pats <- region "while parsing lambda-cases alternative" (MP.many apatParser)+  rhs <- region "while parsing lambda-cases alternative" (caseRhsParserWithBodyParser compTransformExprParser)+  pure $ \span' ->+    LambdaCaseAlt+      { lambdaCaseAltAnns = [mkAnnotation span'],+        lambdaCaseAltPats = pats,+        lambdaCaseAltRhs = rhs+      }++compTransformAppExprParser :: TokParser Expr+compTransformAppExprParser = appExprParserWith compTransformAtomOrRecordExprParser++compTransformNegateExprParser :: TokParser Expr+compTransformNegateExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  _ <- minusTokenValueParser+  ENegate <$> compTransformNegateOperandParser++compTransformNegateOperandParser :: TokParser Expr+compTransformNegateOperandParser = reportLexpParser compTransformAppExprParser++-- | Like 'atomOrRecordExprParser' but rejects bare 'by' and 'using' identifiers.+-- These are treated as contextual keywords in TransformListComp context.+compTransformAtomOrRecordExprParser :: TokParser Expr+compTransformAtomOrRecordExprParser = do+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkKeywordBy -> MP.empty+    TkKeywordUsing -> MP.empty+    _ -> atomOrRecordExprParser++compGenOrGuardParser :: TokParser CompStmt+compGenOrGuardParser =+  withSpanAnn (CompAnn . mkAnnotation) $+    exprOrPatternBindParser exprParser (region "while parsing '<-' generator" exprParser) CompGen CompGuard++compPatGenParser :: TokParser CompStmt+compPatGenParser = withSpanAnn (CompAnn . mkAnnotation) $ do+  pat <- patternParser+  expectedTok TkReservedLeftArrow+  expr <- region "while parsing '<-' generator" exprParser+  pure (CompGen pat expr)++compLetStmtParser :: TokParser CompStmt+compLetStmtParser = withSpanAnn (CompAnn . mkAnnotation) $ do+  CompLetDecls <$> parseLetDeclsStmtParser++-- | Report core:+--+-- > lexp -> '\\' apat_1 ... apat_n '->' exp+lambdaExprParser :: TokParser Expr+lambdaExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  expectedTok TkReservedBackslash+  lambdaCaseParser <|> lambdaCasesParser <|> lambdaPatsParser+  where+    lambdaCaseParser = do+      expectedTok TkKeywordCase+      ELambdaCase <$> bracedCaseAlts++    lambdaCasesParser = do+      lambdaCaseEnabled <- isExtensionEnabled LambdaCase+      guard lambdaCaseEnabled+      varIdTok "cases"+      ELambdaCases <$> bracedLambdaCaseAlts++    lambdaPatsParser = do+      pats <- MP.some apatParser+      expectedTok TkReservedRightArrow+      body <- region "while parsing lambda body" exprParser+      pure (ELambdaPats pats body)++    bracedCaseAlts = bracedSemiSep caseAltParser+    bracedLambdaCaseAlts = bracedSemiSep lambdaCaseAltParser++-- | Report core:+--+-- > lexp -> 'let' decls 'in' exp+letExprParser :: TokParser Expr+letExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  decls <- parseLetDeclsParser+  expectedTok TkKeywordIn+  ELetDecls decls <$> exprParser++whereClauseParser :: TokParser [Decl]+whereClauseParser = do+  expectedTok TkKeywordWhere+  bracedDeclsMaybeEmpty++-- | Report core local declarations:+--+-- > decl -> gendecl+-- >      | (funlhs | pat) rhs+localDeclsParser :: TokParser Decl+localDeclsParser = do+  typeSigPrefix <- startsWithTypeSig+  pragmaDeclParser+    <|> implicitParamDeclParser+    <|> fixityDeclParser+    <|> (if typeSigPrefix then localTypeSigDeclsParser else MP.empty)+    <|> MP.try localFunctionDeclParser+    <|> localPatternDeclParser++localTypeSigDeclsParser :: TokParser Decl+localTypeSigDeclsParser =+  withSpanAnn (DeclAnn . mkAnnotation) $+    typedBindingOrSignatureParser+      typeParser+      DeclTypeSig+      ( \name ty -> do+          rhs <- equationRhsParser+          let pat = PTypeSig (PVar name) ty+          pure (DeclValue (PatternBind NoMultiplicityTag pat rhs))+      )+      "local typed bindings with '=' or guards require exactly one binder"++localFunctionDeclParser :: TokParser Decl+localFunctionDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  (headForm, name, pats) <- functionHeadParserWith patParser apatParser+  functionBindDecl headForm name pats <$> equationRhsParser++localPatternDeclParser :: TokParser Decl+localPatternDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  linearEnabled <- isExtensionEnabled LinearTypes+  multTag <-+    if linearEnabled+      then MP.option NoMultiplicityTag (MP.try localMultiplicityTagParser)+      else pure NoMultiplicityTag+  pat <- patternParser+  DeclValue . PatternBind multTag pat <$> equationRhsParser++localMultiplicityTagParser :: TokParser MultiplicityTag+localMultiplicityTagParser = do+  expectedTok TkPrefixPercent+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkInteger 1 _ -> anySingle $> LinearMultiplicityTag+    _ -> ExplicitMultiplicityTag <$> typeAtomParser++implicitParamDeclParser :: TokParser Decl+implicitParamDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do+  name <- implicitParamNameParser+  expectedTok TkReservedEquals+  rhsExpr <- exprParser+  whereDecls <- MP.optional whereClauseParser+  pure $+    DeclValue+      ( PatternBind+          NoMultiplicityTag+          (PVar (mkUnqualifiedName NameVarId name))+          (UnguardedRhs [] rhsExpr whereDecls)+      )++varExprParser :: TokParser Expr+varExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  EVar <$> identifierNameParser++implicitParamExprParser :: TokParser Expr+implicitParamExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  EVar . qualifyName Nothing . mkUnqualifiedName NameVarId <$> implicitParamNameParser++wildcardExprParser :: TokParser Expr+wildcardExprParser = withSpanAnn (EAnn . mkAnnotation) $ do+  expectedTok TkKeywordUnderscore+  pure (EVar (qualifyName Nothing (mkUnqualifiedName NameVarId "_")))++-- | Parse Template Haskell quote brackets+thQuoteExprParser :: TokParser Expr+thQuoteExprParser =+  thExpQuoteParser+    <|> thTypedQuoteParser+    <|> thDeclQuoteParser+    <|> thTypeQuoteParser+    <|> thPatQuoteParser++thExpQuoteParser :: TokParser Expr+thExpQuoteParser = thQuoteParser (EAnn . mkAnnotation) TkTHExpQuoteOpen TkTHExpQuoteClose exprParser ETHExpQuote++thTypedQuoteParser :: TokParser Expr+thTypedQuoteParser = thQuoteParser (EAnn . mkAnnotation) TkTHTypedQuoteOpen TkTHTypedQuoteClose exprParser ETHTypedQuote++thDeclQuoteParser :: TokParser Expr+thDeclQuoteParser = thQuoteParser (EAnn . mkAnnotation) TkTHDeclQuoteOpen TkTHExpQuoteClose (bracedSemiSep declParser <|> plainSemiSep declParser) ETHDeclQuote++thTypeQuoteParser :: TokParser Expr+thTypeQuoteParser = thQuoteParser (EAnn . mkAnnotation) TkTHTypeQuoteOpen TkTHExpQuoteClose typeParser ETHTypeQuote++thPatQuoteParser :: TokParser Expr+thPatQuoteParser = thQuoteParser (EAnn . mkAnnotation) TkTHPatQuoteOpen TkTHExpQuoteClose patParser ETHPatQuote++thUntypedSpliceParser :: TokParser Expr+thUntypedSpliceParser = withSpanAnn (EAnn . mkAnnotation) $ do+  expectedTok TkTHSplice+  ETHSplice <$> compactSpliceBodyParser++thTypedSpliceParser :: TokParser Expr+thTypedSpliceParser = withSpanAnn (EAnn . mkAnnotation) $ do+  expectedTok TkTHTypedSplice+  ETHTypedSplice <$> compactSpliceBodyParser++compactSpliceBodyParser :: TokParser Expr+compactSpliceBodyParser = do+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkReservedBackslash -> MP.empty+    TkKeywordLet -> MP.empty+    TkKeywordDo -> MP.empty+    TkKeywordMdo -> MP.empty+    TkQualifiedDo {} -> MP.empty+    TkQualifiedMdo {} -> MP.empty+    TkKeywordCase -> MP.empty+    TkKeywordIf -> MP.empty+    TkKeywordProc -> MP.empty+    TkKeywordType -> MP.empty+    _ -> atomExprParser++thNameQuoteExprParser :: TokParser Expr+thNameQuoteExprParser = thValueNameQuoteParser <|> thTypeNameQuoteParser++thValueNameQuoteParser :: TokParser Expr+thValueNameQuoteParser = withSpanAnn (EAnn . mkAnnotation) $ do+  expectedTok TkTHQuoteTick+  body <- atomExprParser+  guard (isTHValueNameQuoteBody body)+  pure (ETHNameQuote body)++isTHValueNameQuoteBody :: Expr -> Bool+isTHValueNameQuoteBody expr =+  case peelExprAnn expr of+    EVar {} -> True+    EList [] -> True+    ETuple _ elems -> all isTupleConstructorSlot elems+    _ -> False+  where+    isTupleConstructorSlot Nothing = True+    isTupleConstructorSlot Just {} = False++thTypeNameQuoteParser :: TokParser Expr+thTypeNameQuoteParser = withSpanAnn (EAnn . mkAnnotation) $ do+  expectedTok TkTHTypeQuoteTick+  body <- typeAtomParser+  guard (isTHTypeNameQuoteBody body)+  pure (ETHTypeNameQuote body)++isTHTypeNameQuoteBody :: Type -> Bool+isTHTypeNameQuoteBody ty =+  case peelTypeAnn ty of+    TVar {} -> True+    TCon {} -> True+    TBuiltinCon {} -> True+    TTuple _ _ [] -> True+    _ -> False++quasiQuoteExprParser :: TokParser Expr+quasiQuoteExprParser =+  tokenSatisfy "quasi quote" $ \tok ->+    case lexTokenKind tok of+      TkQuasiQuote quoter body -> Just (EAnn (mkAnnotation (lexTokenSpan tok)) (EQuasiQuote quoter body))+      _ -> Nothing
+ src/Aihc/Parser/Internal/Expr.hs-boot view
@@ -0,0 +1,30 @@+{-# LANGUAGE Haskell2010 #-}++-- | Boot file for Aihc.Parser.Internal.Expr+-- This breaks circular dependencies between Expr.hs and modules that+-- depend on it (Decl.hs, Type.hs, Pattern.hs, Cmd.hs).+--+-- IMPORTANT: When adding or changing exported function signatures in Expr.hs,+-- this boot file must be updated accordingly.+module Aihc.Parser.Internal.Expr where++import Aihc.Parser.Internal.Common (TokParser)+import Aihc.Parser.Syntax (Decl, Expr, Rhs)++-- | Parse a full expression+exprParser :: TokParser Expr+atomExprParser :: TokParser Expr+cmdArrAppLhsParser :: TokParser Expr+lexpParser :: TokParser Expr++-- | Parse the right-hand side of an equation (guarded or unguarded)+equationRhsParser :: TokParser (Rhs Expr)++-- | Parse a case-style right-hand side with a custom body parser.+caseRhsParserWithBodyParser :: TokParser body -> TokParser (Rhs body)++-- | Parse let declarations (keyword 'let' followed by braced or plain decls)+parseLetDeclsParser :: TokParser [Decl]++-- | Parse let declarations for statement context (no 'in' following)+parseLetDeclsStmtParser :: TokParser [Decl]
+ src/Aihc/Parser/Internal/FromTokens.hs view
@@ -0,0 +1,66 @@+-- |+-- Module      : Aihc.Parser.Internal.FromTokens+-- Description : Internal parsing functions from token streams+-- License     : Unlicense+--+-- @since 0.1.0.0+--+-- __Warning:__ This is an internal module and is not meant to be used directly.+-- The API may change without notice.+--+-- This module exposes parsing functions that work directly on token streams.+-- These are primarily used for testing and internal purposes.+module Aihc.Parser.Internal.FromTokens+  ( parseExprFromTokens,+    parsePatternFromTokens,+    parseSignatureTypeFromTokens,+    parseTypeFromTokens,+    parseModuleFromTokens,+    parseDeclFromTokens,+    parseImportDeclFromTokens,+    parseModuleHeaderFromTokens,+  )+where++import Aihc.Parser.Internal.Common (TokParser, eofTok)+import Aihc.Parser.Internal.Decl (declParser)+import Aihc.Parser.Internal.Errors (parseErrorBundleToSpannedText)+import Aihc.Parser.Internal.Expr (exprParser)+import Aihc.Parser.Internal.Import (importDeclParser, moduleHeaderParser)+import Aihc.Parser.Internal.Module (moduleParser)+import Aihc.Parser.Internal.Pattern (patternParser)+import Aihc.Parser.Internal.Type (typeParser, typeSignatureParser)+import Aihc.Parser.Lex (LexToken)+import Aihc.Parser.Syntax (Decl, Expr, ImportDecl, Module, ModuleHead, Pattern, Type)+import Aihc.Parser.Types+import Text.Megaparsec (runParser)++parseFromTokens :: TokParser a -> FilePath -> [LexToken] -> ParseResult a+parseFromTokens parser sourceName toks =+  case runParser (parser <* eofTok) sourceName (mkTokStreamFromTokens toks) of+    Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)+    Right parsed -> ParseOk parsed++parseExprFromTokens :: FilePath -> [LexToken] -> ParseResult Expr+parseExprFromTokens = parseFromTokens exprParser++parsePatternFromTokens :: FilePath -> [LexToken] -> ParseResult Pattern+parsePatternFromTokens = parseFromTokens patternParser++parseSignatureTypeFromTokens :: FilePath -> [LexToken] -> ParseResult Type+parseSignatureTypeFromTokens = parseFromTokens typeSignatureParser++parseTypeFromTokens :: FilePath -> [LexToken] -> ParseResult Type+parseTypeFromTokens = parseFromTokens typeParser++parseModuleFromTokens :: FilePath -> [LexToken] -> ParseResult Module+parseModuleFromTokens = parseFromTokens moduleParser++parseDeclFromTokens :: FilePath -> [LexToken] -> ParseResult Decl+parseDeclFromTokens = parseFromTokens declParser++parseImportDeclFromTokens :: FilePath -> [LexToken] -> ParseResult ImportDecl+parseImportDeclFromTokens = parseFromTokens importDeclParser++parseModuleHeaderFromTokens :: FilePath -> [LexToken] -> ParseResult ModuleHead+parseModuleHeaderFromTokens = parseFromTokens moduleHeaderParser
+ src/Aihc/Parser/Internal/Import.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++module Aihc.Parser.Internal.Import+  ( languagePragmaParser,+    moduleHeaderParser,+    importDeclParser,+    warningPragmaParser,+  )+where++import Aihc.Parser.Internal.Common+import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind, pattern TkVarAs, pattern TkVarHiding, pattern TkVarQualified, pattern TkVarSafe)+import Aihc.Parser.Syntax+import Aihc.Parser.Types (ParserErrorComponent (..), mkFoundToken)+import Control.Monad (when)+import Data.Char (isUpper)+import Data.Maybe (isJust)+import Data.Text (Text)+import Data.Text qualified as T+import Text.Megaparsec ((<|>))+import Text.Megaparsec qualified as MP++languagePragmaParser :: TokParser [ExtensionSetting]+languagePragmaParser =+  hiddenPragma "LANGUAGE pragma" $ \p -> case pragmaType p of+    PragmaLanguage names -> Just names+    _ -> Nothing++moduleHeaderParser :: TokParser ModuleHead+moduleHeaderParser = withSpan $ do+  expectedTok TkKeywordModule+  name <- moduleNameParser+  mWarning <- MP.optional warningPragmaParser+  exports <- MP.optional exportSpecListParser+  expectedTok TkKeywordWhere+  pure $ \span' ->+    ModuleHead+      { moduleHeadAnns = [mkAnnotation span'],+        moduleHeadName = name,+        moduleHeadWarningPragma = mWarning,+        moduleHeadExports = exports+      }++warningPragmaParser :: TokParser Pragma+warningPragmaParser =+  hiddenPragma "warning pragma" $ \p -> case pragmaType p of+    PragmaWarning _ -> Just p+    PragmaDeprecated _ -> Just p+    _ -> Nothing++exportSpecListParser :: TokParser [ExportSpec]+exportSpecListParser = parens $ exportSpecParser `MP.sepEndBy` expectedTok TkSpecialComma++exportSpecParser :: TokParser ExportSpec+exportSpecParser = withSpanAnn (ExportAnn . mkAnnotation) $ do+  mWarning <- MP.optional warningPragmaParser+  exportModuleParser mWarning <|> exportNameParser mWarning++exportModuleParser :: Maybe Pragma -> TokParser ExportSpec+exportModuleParser mWarning = do+  expectedTok TkKeywordModule+  ExportModule mWarning <$> moduleNameParser++exportNameParser :: Maybe Pragma -> TokParser ExportSpec+exportNameParser mWarning = do+  namespace <- MP.optional exportImportNamespaceParser+  name <- identifierNameParser <|> parens operatorNameParser+  members <- MP.optional exportMembersParser+  pure $+    case members of+      Just MembersAll -> ExportAll mWarning namespace name+      Just (MembersList names) -> ExportWith mWarning namespace name names+      Just (MembersListAll wildcardIndex names) -> ExportWithAll mWarning namespace name wildcardIndex names+      Nothing+        | namespace == Just IEEntityNamespaceType || isTypeName name ->+            ExportAbs mWarning namespace name+        | otherwise ->+            ExportVar mWarning namespace name++data MembersResult+  = MembersAll+  | MembersList [IEBundledMember]+  | MembersListAll Int [IEBundledMember]++exportMembersParser :: TokParser MembersResult+exportMembersParser = membersParser++importMembersParser :: TokParser MembersResult+importMembersParser = membersParser++membersParser :: TokParser MembersResult+membersParser =+  parens (parseDotDotFirst <|> parseMemberList <|> emptyMembers)+  where+    emptyMembers = pure (MembersList [])++    parseDotDotFirst = do+      expectedTok TkReservedDotDot+      MP.optional (expectedTok TkSpecialComma) >>= \case+        Nothing -> pure MembersAll+        Just _ -> do+          trailingMembers <- memberNameParser `MP.sepBy` expectedTok TkSpecialComma+          pure (MembersListAll 0 trailingMembers)++    parseMemberList = do+      firstMember <- memberNameParser+      parseMemberSegments [firstMember]++    parseMemberSegments members =+      MP.optional (expectedTok TkSpecialComma) >>= \case+        Nothing -> pure (MembersList members)+        Just _ ->+          (expectedTok TkReservedDotDot >> parseWildcardTail members)+            <|> do+              nextMember <- memberNameParser+              parseMemberSegments (members <> [nextMember])++    parseWildcardTail members =+      MP.optional (expectedTok TkSpecialComma) >>= \case+        Nothing -> pure (MembersListAll (length members) members)+        Just _ -> do+          trailingMembers <- memberNameParser `MP.sepBy` expectedTok TkSpecialComma+          pure (MembersListAll (length members) (members <> trailingMembers))++    memberNameParser = do+      namespace <- MP.optional bundledNamespaceParser+      name <- identifierNameParser <|> parens operatorNameParser+      pure (IEBundledMember namespace name)++-- | Checks if a name refers to a type/class (as opposed to a variable/function).+-- In Haskell:+-- - Identifiers starting with uppercase letters are type constructors/classes+-- - Symbolic operators starting with ':' are constructor operators (type-level)+isTypeName :: Name -> Bool+isTypeName name =+  case T.uncons (nameText name) of+    Just (c, _) -> isUpper c || c == ':'+    Nothing -> False++importDeclParser :: TokParser ImportDecl+importDeclParser = withSpan $ do+  expectedTok TkKeywordImport+  importedSafe <-+    MP.option False (expectedTok TkVarSafe >> pure True)+  importedSource <- optionalHiddenPragma $ \p -> case pragmaType p of+    PragmaSource {} -> Just p+    _ -> Nothing+  preQualified <-+    MP.option False (expectedTok TkVarQualified >> pure True)+  importedLevel <- MP.optional importLevelParser+  importedPackage <- MP.optional packageNameParser+  importedModule <- moduleNameParser+  postQualified <-+    MP.optional $+      tokenSatisfy "'qualified'" $ \tok ->+        if lexTokenKind tok == TkVarQualified then Just (mkFoundToken tok) else Nothing+  when (preQualified && isJust postQualified) $+    MP.customFailure+      UnexpectedTokenExpecting+        { unexpectedFound = postQualified,+          unexpectedExpecting = "import declaration without duplicate 'qualified'",+          unexpectedContext = []+        }+  importAlias <- MP.optional (expectedTok TkVarAs *> moduleNameParser)+  importSpec <- MP.optional importSpecParser+  let isQualified = preQualified || isJust postQualified+  pure $ \span' ->+    ImportDecl+      { importDeclAnns = [mkAnnotation span'],+        importDeclLevel = importedLevel,+        importDeclPackage = importedPackage,+        importDeclSourcePragma = importedSource,+        importDeclSafe = importedSafe,+        importDeclQualified = isQualified,+        importDeclQualifiedPost = isJust postQualified,+        importDeclModule = importedModule,+        importDeclAs = importAlias,+        importDeclSpec = importSpec+      }++importLevelParser :: TokParser ImportLevel+importLevelParser =+  (varIdTok "quote" >> pure ImportLevelQuote)+    <|> (varIdTok "splice" >> pure ImportLevelSplice)++packageNameParser :: TokParser Text+packageNameParser = stringTextParser++importSpecParser :: TokParser ImportSpec+importSpecParser = withSpan $ do+  isHiding <-+    MP.option False (expectedTok TkVarHiding >> pure True)+  items <- parens $ importItemParser `MP.sepEndBy` expectedTok TkSpecialComma+  pure $ \span' ->+    ImportSpec+      { importSpecAnns = [mkAnnotation span'],+        importSpecHiding = isHiding,+        importSpecItems = items+      }++importItemParser :: TokParser ImportItem+importItemParser = withSpanAnn (ImportAnn . mkAnnotation) $ do+  namespace <- MP.optional exportImportNamespaceParser+  itemName <- identifierUnqualifiedNameParser <|> parens importOperatorParser+  -- When there's no explicit namespace, we still need to try parsing members+  -- for type constructors and type classes (uppercase names or parenthesized operators)+  let shouldTryMembers = case namespace of+        Just _ -> True+        Nothing -> isTypeName (qualifyName Nothing itemName)+  members <- if shouldTryMembers then MP.optional importMembersParser else pure Nothing+  let effectiveNamespace = namespace+  pure $+    case members of+      Just MembersAll -> ImportItemAll effectiveNamespace itemName+      Just (MembersList names) -> ImportItemWith effectiveNamespace itemName names+      Just (MembersListAll wildcardIndex names) -> ImportItemAllWith effectiveNamespace itemName wildcardIndex names+      Nothing+        | effectiveNamespace == Just IEEntityNamespaceType || isTypeName (qualifyName Nothing itemName) -> ImportItemAbs effectiveNamespace itemName+        | otherwise -> ImportItemVar effectiveNamespace itemName++importOperatorParser :: TokParser UnqualifiedName+importOperatorParser = operatorUnqualifiedNameParser++exportImportNamespaceParser :: TokParser IEEntityNamespace+exportImportNamespaceParser =+  (expectedTok TkKeywordType >> pure IEEntityNamespaceType)+    <|> (expectedTok TkKeywordData >> pure IEEntityNamespaceData)+    <|> patternNamespaceParser+  where+    patternNamespaceParser = do+      patSynEnabled <- isExtensionEnabled PatternSynonyms+      if patSynEnabled+        then expectedTok TkKeywordPattern >> pure IEEntityNamespacePattern+        else MP.empty++bundledNamespaceParser :: TokParser IEBundledNamespace+bundledNamespaceParser =+  (expectedTok TkKeywordType >> pure IEBundledNamespaceType)+    <|> (expectedTok TkKeywordData >> pure IEBundledNamespaceData)
+ src/Aihc/Parser/Internal/Module.hs view
@@ -0,0 +1,87 @@+-- |+-- Module      : Aihc.Parser.Internal.Module+-- Description : Internal module parser+-- License     : Unlicense+--+-- Internal module containing the core module parser.+-- This is used by both 'Aihc.Parser' and 'Aihc.Parser.Internal.FromTokens'.+module Aihc.Parser.Internal.Module+  ( moduleParser,+  )+where++import Aihc.Parser.Internal.Common (TokParser, braces, expectedTok, skipSemicolons, withSpan)+import Aihc.Parser.Internal.Decl (declParser)+import Aihc.Parser.Internal.Import (importDeclParser, languagePragmaParser, moduleHeaderParser)+import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind)+import Aihc.Parser.Syntax (Decl, ImportDecl, Module (..), mkAnnotation)+import Control.Monad (void)+import Text.Megaparsec qualified as MP++data RecoverParseStep a+  = RecoverDone+  | RecoverParsed !a+  | RecoverFailed++moduleParser :: TokParser Module+moduleParser = withSpan $ do+  languagePragmas <- MP.many (languagePragmaParser <* MP.many (expectedTok TkSpecialSemicolon))+  mHeader <- MP.optional (moduleHeaderParser <* MP.many (expectedTok TkSpecialSemicolon))+  (imports, decls) <- moduleBodyParser+  pure $ \span' ->+    Module+      { moduleAnns = [mkAnnotation span'],+        moduleHead = mHeader,+        moduleLanguagePragmas = concat languagePragmas,+        moduleImports = imports,+        moduleDecls = decls+      }++moduleBodyParser :: TokParser ([ImportDecl], [Decl])+moduleBodyParser = braces $ do+  skipSemicolons+  imports <- importDeclsWithRecovery+  decls <- declsWithRecovery+  skipSemicolons+  pure (imports, decls)++importDeclsWithRecovery :: TokParser [ImportDecl]+importDeclsWithRecovery = recoverDeclLike importDeclParser++declsWithRecovery :: TokParser [Decl]+declsWithRecovery = recoverDeclLike declParser++recoverDeclLike :: TokParser a -> TokParser [a]+recoverDeclLike parser = go []+  where+    go acc = do+      skipSemicolons+      step <- MP.withRecovery recoverParseError parseStep+      case step of+        RecoverDone -> pure (reverse acc)+        RecoverParsed parsed -> do+          skipSemicolons+          go (parsed : acc)+        RecoverFailed -> do+          skipSemicolons+          go acc++    parseStep = do+      mParsed <- MP.optional parser+      pure $ maybe RecoverDone RecoverParsed mParsed++    recoverParseError err = do+      MP.registerParseError err+      skipUntilDeclBoundary+      pure RecoverFailed++skipUntilDeclBoundary :: TokParser ()+skipUntilDeclBoundary = do+  _ <-+    MP.takeWhileP+      Nothing+      ( \tok ->+          let kind = lexTokenKind tok+           in kind /= TkSpecialSemicolon && kind /= TkSpecialRBrace+      )+  void (MP.optional (expectedTok TkSpecialSemicolon))
+ src/Aihc/Parser/Internal/Pattern.hs view
@@ -0,0 +1,536 @@+{-# LANGUAGE OverloadedStrings #-}++module Aihc.Parser.Internal.Pattern+  ( patternParser,+    patternParserWithTypeSigParser,+    caseAltPatternParser,+    patParser,+    lpatParser,+    apatParser,+    literalParser,+  )+where++import Aihc.Parser.Internal.CheckPattern (checkPattern)+import Aihc.Parser.Internal.Common+import {-# SOURCE #-} Aihc.Parser.Internal.Expr (atomExprParser, exprParser)+import Aihc.Parser.Internal.Type (typeParser)+import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..), lexTokenKind, lexTokenText)+import Aihc.Parser.Syntax+import Aihc.Parser.Types (ParserErrorComponent (..), mkFoundToken)+import Text.Megaparsec (anySingle, lookAhead, (<|>))+import Text.Megaparsec qualified as MP++-- | Report core:+--+-- > pat -> lpat qconop pat+-- >     | lpat+patternParser :: TokParser Pattern+patternParser = patternParserWithTypeSigParser typeParser++patternParserWithTypeSigParser :: TokParser Type -> TokParser Pattern+patternParserWithTypeSigParser typeSigParser =+  label "pattern" $+    optionalSuffix+      (expectedTok TkReservedDoubleColon *> typeSigParser)+      PTypeSig+      patParser++-- | Parse the pattern position of a case alternative.+--+-- GHC does not accept a top-level pattern type signature before the alternative+-- arrow: @case x of _ :: T -> rhs@ is rejected, while @case x of (_ :: T) ->+-- rhs@ is accepted because the signature is parenthesized into an atomic+-- pattern.  Use the report @pat@ level here so the outer @::@ is left for the+-- case RHS parser, which then rejects it.+-- | Case alternatives intentionally use the report @pat@ level rather than+-- the outer typed-pattern wrapper.+caseAltPatternParser :: TokParser Pattern+caseAltPatternParser = patParser++-- | Parse a pattern (@pat@ in the Haskell Report).+--+-- @+-- pat → lpat qconop pat+--     | lpat+-- @+patParser :: TokParser Pattern+patParser = do+  lhs <- lpatParser+  rest <- MP.many ((,) <$> conOperatorParser <*> lpatParser)+  pure (foldInfixL buildInfixPattern lhs rest)++buildInfixPattern :: Pattern -> (Name, Pattern) -> Pattern+buildInfixPattern lhs (op, rhs) =+  PInfix lhs op rhs++conOperatorParser :: TokParser Name+conOperatorParser =+  symbolicConOp <|> backtickConOp+  where+    symbolicConOp =+      tokenSatisfy "constructor operator" $ \tok ->+        case lexTokenKind tok of+          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op))+          TkQConSym modName op -> Just (mkName (Just modName) NameConSym op)+          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"))+          _ -> Nothing+    backtickConOp =+      MP.try $+        expectedTok TkSpecialBacktick *> constructorNameParser <* expectedTok TkSpecialBacktick++-- | Parse a left pattern (@lpat@ in the Haskell Report).+--+-- @+-- lpat → apat+--      | - (integer | float)       (negative literal)+--      | gcon apat₁ … apatₖ       (arity gcon = k, k ≥ 1)+-- @+--+-- Negative literals and constructor application live here, not in+-- 'apatParser' (@apat@).  This distinction is critical: since+-- constructor arguments are @apat@s, @Con - 0@ cannot be misparsed as+-- @Con (-0)@ — the @-@ is not valid inside an @apat@.+lpatParser :: TokParser Pattern+lpatParser =+  negativeLiteralPatternParser <|> do+    first <- apatParser+    if isPatternAppHead first+      then foldl buildPatternApp first <$> MP.many apatParser+      else pure first++buildPatternApp :: Pattern -> Pattern -> Pattern+buildPatternApp lhs rhs =+  case peelPatternAnn lhs of+    PCon name typeArgs args ->+      PAnn+        (mkAnnotation NoSourceSpan)+        (PCon name typeArgs (args <> [rhs]))+    _ -> lhs++-- | Parse an atomic pattern (@apat@ in the Haskell Report).+--+-- This intentionally does NOT handle negative literals (@- integer@),+-- which belong to the @lpat@ level ('lpatParser').+apatParser :: TokParser Pattern+apatParser =+  label "pattern atom" $+    asApatParser <|> nonAsApatParser++-- | Parse an as-pattern as an atomic pattern: @binder\@apat@.+--+-- The binder may be a parenthesized operator, e.g. @(+)\@C@.  Trying this+-- before the parenthesized-pattern parser keeps @(+)\@(+)@C@ in the as-pattern+-- grammar instead of prematurely committing to the bare operator pattern @(+)@.+asApatParser :: TokParser Pattern+asApatParser =+  asPatternParser apatParser++nonAsApatParser :: TokParser Pattern+nonAsApatParser = do+  thAny <- thAnyEnabled+  explicitNamespacesEnabled <- isExtensionEnabled ExplicitNamespaces+  requiredTypeArgumentsEnabled <- isExtensionEnabled RequiredTypeArguments+  typeAbstractionsEnabled <- isExtensionEnabled TypeAbstractions+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkTypeApp+      | typeAbstractionsEnabled -> typeBinderPatternParser+    TkPrefixBang -> strictPatternParser+    TkPrefixTilde -> irrefutablePatternParser+    TkKeywordType+      | explicitNamespacesEnabled || requiredTypeArgumentsEnabled -> explicitTypePatternParser+    TkQuasiQuote {} -> quasiQuotePatternParser+    TkTHSplice | thAny -> thSplicePatternParser+    TkKeywordUnderscore -> wildcardPatternParser+    TkInteger {} -> literalPatternParser+    TkFloat {} -> literalPatternParser+    TkChar {} -> literalPatternParser+    TkCharHash {} -> literalPatternParser+    TkString {} -> literalPatternParser+    TkStringHash {} -> literalPatternParser+    TkSpecialLBracket -> listPatternParser+    TkSpecialLParen -> parenOrTuplePatternParser+    TkSpecialUnboxedLParen -> parenOrTuplePatternParser+    _ -> varOrConPatternParser++typeBinderPatternParser :: TokParser Pattern+typeBinderPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do+  expectedTok TkTypeApp+  PTypeBinder <$> visibleTypeBinderCoreParser++explicitTypePatternParser :: TokParser Pattern+explicitTypePatternParser = withSpanAnn (PAnn . mkAnnotation) $ do+  expectedTok TkKeywordType+  PTypeSyntax TypeSyntaxExplicitNamespace <$> typeParser++strictPatternParser :: TokParser Pattern+strictPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do+  expectedTok TkPrefixBang+  PStrict <$> apatParser++irrefutablePatternParser :: TokParser Pattern+irrefutablePatternParser = withSpanAnn (PAnn . mkAnnotation) $ do+  expectedTok TkPrefixTilde+  PIrrefutable <$> apatParser++negativeLiteralPatternParser :: TokParser Pattern+negativeLiteralPatternParser = MP.try $ withSpanAnn (PAnn . mkAnnotation) $ do+  expectedTok (TkVarSym "-")+  PNegLit <$> numericLiteralParser++-- | Parse only numeric literals (integer or float), used for negative literal+-- patterns where GHC only allows @-@ before numeric literals, not strings or chars.+numericLiteralParser :: TokParser Literal+numericLiteralParser = intLiteralParser <|> floatLiteralParser++wildcardPatternParser :: TokParser Pattern+wildcardPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do+  expectedTok TkKeywordUnderscore+  pure PWildcard++literalPatternParser :: TokParser Pattern+literalPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do+  PLit <$> literalParser++quasiQuotePatternParser :: TokParser Pattern+quasiQuotePatternParser = withSpanAnn (PAnn . mkAnnotation) $ do+  (quoter, body) <- tokenSatisfy "quasi quote" $ \tok ->+    case lexTokenKind tok of+      TkQuasiQuote q b -> Just (q, b)+      _ -> Nothing+  pure (PQuasiQuote quoter body)++literalParser :: TokParser Literal+literalParser = intLiteralParser <|> floatLiteralParser <|> charLiteralParser <|> stringLiteralParser++tokenLiteralParser :: String -> (LexToken -> Maybe Literal) -> TokParser Literal+tokenLiteralParser expected matchToken =+  withSpanAnn (LitAnn . mkAnnotation) (tokenSatisfy expected matchToken)++intLiteralParser :: TokParser Literal+intLiteralParser =+  tokenLiteralParser "integer literal" $ \tok ->+    case lexTokenKind tok of+      TkInteger i nt -> Just (LitInt i nt (lexTokenText tok))+      _ -> Nothing++floatLiteralParser :: TokParser Literal+floatLiteralParser =+  tokenLiteralParser "floating literal" $ \tok ->+    case lexTokenKind tok of+      TkFloat x ft -> Just (LitFloat x ft (lexTokenText tok))+      _ -> Nothing++charLiteralParser :: TokParser Literal+charLiteralParser = withSpanAnn (LitAnn . mkAnnotation) $ do+  (ctor, c, repr) <- tokenSatisfy "character literal" $ \tok ->+    case lexTokenKind tok of+      TkChar x -> Just (LitChar, x, lexTokenText tok)+      TkCharHash x txt -> Just (LitCharHash, x, txt)+      _ -> Nothing+  pure (ctor c repr)++stringLiteralParser :: TokParser Literal+stringLiteralParser = withSpanAnn (LitAnn . mkAnnotation) $ do+  (ctor, s, repr) <- tokenSatisfy "string literal" $ \tok ->+    case lexTokenKind tok of+      TkString x -> Just (LitString, x, lexTokenText tok)+      TkStringHash x txt -> Just (LitStringHash, x, txt)+      _ -> Nothing+  pure (ctor s repr)++-- | Parse Template Haskell pattern splice: $pat or $(pat)+thSplicePatternParser :: TokParser Pattern+thSplicePatternParser = withSpanAnn (PAnn . mkAnnotation) $ do+  expectedTok TkTHSplice+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkKeywordType -> MP.empty+    _ -> PSplice <$> atomExprParser++visibleTypeBinderCoreParser :: TokParser TyVarBinder+visibleTypeBinderCoreParser =+  withSpan $+    ( do+        ident <- tyVarNameParser+        pure (\span' -> TyVarBinder [mkAnnotation span'] ident Nothing TyVarBSpecified TyVarBInvisible)+    )+      <|> ( do+              expectedTok TkSpecialLParen+              ident <- tyVarNameParser+              expectedTok TkReservedDoubleColon+              kind <- typeParser+              expectedTok TkSpecialRParen+              pure (\span' -> TyVarBinder [mkAnnotation span'] ident (Just kind) TyVarBSpecified TyVarBInvisible)+          )++varOrConPatternParser :: TokParser Pattern+varOrConPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do+  name <- identifierNameParser+  mNextTok <- MP.optional (lookAhead anySingle)+  case mNextTok of+    Just nextTok+      | isConLikeName name && lexTokenKind nextTok == TkSpecialLBrace -> do+          (fields, hasWildcard) <- braces recordPatternFieldListParser+          pure (PRecord name fields hasWildcard)+    _ ->+      pure $+        if isConLikeName name+          then PCon name [] []+          else PVar (mkUnqualifiedName (nameType name) (nameText name))++recordFieldPatternParser :: TokParser (RecordField Pattern)+recordFieldPatternParser = do+  field <- recordFieldNameParser+  mEq <- MP.optional (expectedTok TkReservedEquals)+  case mEq of+    Just () -> do+      pat <- subpatternWithBareViewParser+      pure (RecordField field pat False)+    Nothing -> do+      -- NamedFieldPuns: just "field" means "field = field"+      pure (RecordField field (PVar (mkUnqualifiedName (nameType field) (nameText field))) True)++-- | Parse the contents of record pattern braces, supporting RecordWildCards ".."+recordPatternFieldListParser :: TokParser ([RecordField Pattern], Bool)+recordPatternFieldListParser =+  recordFieldsWithWildcardsParser (recordFieldPatternParser `MP.sepEndBy` expectedTok TkSpecialComma)++listPatternParser :: TokParser Pattern+listPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do+  expectedTok TkSpecialLBracket+  elems <- listPatternElementParser `MP.sepBy` expectedTok TkSpecialComma+  expectedTok TkSpecialRBracket+  pure (PList elems)+  where+    -- List elements can contain bare view patterns such as [id -> x].+    -- Try the expr -> pattern form first, then fall back to normal patterns.+    listPatternElementParser :: TokParser Pattern+    listPatternElementParser = subpatternWithBareViewParser++-- | Parse a subpattern position that admits a bare view pattern @expr -> pat@.+-- This is needed in delimited pattern contexts like list elements and record+-- fields, where there is no surrounding pair of parens to disambiguate the+-- view-pattern arrow from the enclosing syntax.+--+-- This parser is recursive so that deeply nested view patterns such as+-- @expr1 -> expr2 -> pat@ are accepted without requiring explicit parentheses+-- around each intermediate view pattern.+subpatternWithBareViewParser :: TokParser Pattern+subpatternWithBareViewParser = do+  mView <- MP.optional . MP.try $ do+    expr <- exprParser+    expectedTok TkReservedRightArrow+    PView expr <$> subpatternWithBareViewParser+  maybe patternParser pure mView++parenOrTuplePatternParser :: TokParser Pattern+parenOrTuplePatternParser = withSpanAnn (PAnn . mkAnnotation) $ do+  (tupleFlavor, closeTok) <- tupleDelimsParser+  mNextTok <- MP.optional (lookAhead anySingle)+  case fmap lexTokenKind mNextTok of+    Just nextKind+      | nextKind == closeTok -> unitPatternParser tupleFlavor closeTok+      | tupleFlavor == Unboxed && nextKind == TkReservedPipe -> parseUnboxedSumPatLeadingBars closeTok+    _ -> do+      -- For boxed parens, try parsing as a top-level view pattern first.+      -- View patterns like (expr -> pat) produce PParen(PView(...)) so that+      -- the explicit source parens are faithfully represented in the AST.+      mView <-+        if tupleFlavor == Boxed+          then viewPatternParser closeTok+          else pure Nothing+      case mView of+        Just mkView -> pure mkView+        Nothing -> tupleOrParenPatternParser tupleFlavor closeTok+  where+    -- When a bare operator like + or :+ appears directly inside parens, the+    -- parens serve as prefix notation (e.g. (+), (:+)), not grouping.+    -- prettyPrefixName already adds parens when printing symbolic names, so+    -- wrapping with PParen would produce double parens.+    --+    -- However, when the inner pattern came from expression reclassification+    -- (e.g. ((:+)) where the expression parser already consumed the inner+    -- prefix-notation parens), the outer parens ARE grouping and must produce+    -- PParen.+    --+    -- The @isBareOperator@ flag distinguishes these two cases:+    --   True  -> parens are prefix notation, strip PParen+    --   False -> parens are grouping, wrap with PParen+    parenOrSymConParser isBareOperator inner = do+      case peelPatternAnn inner of+        PVar name+          | isBareOperator,+            unqualifiedNameType name == NameVarSym ->+              pure inner+        PCon con [] []+          | isBareOperator,+            nameType con == NameConSym -> do+              mBrace <- MP.optional . lookAhead $ anySingle+              case fmap lexTokenKind mBrace of+                Just TkSpecialLBrace -> do+                  (fields, hasWildcard) <- braces recordPatternFieldListParser+                  pure (PRecord con fields hasWildcard)+                _ -> pure inner+        _ -> pure (PParen inner)++    unitPatternParser tupleFlavor closeTok = do+      expectedTok closeTok+      pure (PTuple tupleFlavor [])++    -- Try to parse the paren content as a view pattern: expr -> pat.+    -- Uses exprParser which stops before '->', then checks for the arrow.+    -- Returns Nothing if the content is not a view pattern.+    viewPatternParser :: LexTokenKind -> TokParser (Maybe Pattern)+    viewPatternParser closeTok = MP.optional . MP.try $ do+      expr <- exprParser <* lookAhead (expectedTok TkReservedRightArrow)+      expectedTok TkReservedRightArrow+      inner <- subpatternWithBareViewParser+      expectedTok closeTok+      pure (PParen (PView expr inner))++    -- Parse a single element inside a paren/tuple/unboxed-sum pattern.+    -- Uses "parse as expression, then reclassify" to avoid backtracking+    -- for the common case. Pattern-only prefixes (!, ~, @) are dispatched+    -- to patternParser directly. When exprParser fails (e.g., nested parens+    -- containing pattern-only syntax like as-patterns or view patterns),+    -- we fall back to patternParser.+    --+    -- Operator tokens (TkVarSym, TkConSym, etc.) are handled directly here+    -- because they are valid patterns (binding the operator as a variable or+    -- constructor) but may not parse as expressions on their own.+    --+    -- Returns (isBareOperator, pattern) where isBareOperator indicates the+    -- pattern was parsed as a bare operator token (e.g. :+ in (:+)), meaning+    -- the surrounding parens serve as prefix notation rather than grouping.+    parenPatElementParser :: TokParser (Bool, Pattern)+    parenPatElementParser = do+      tok <- lookAhead anySingle+      case lexTokenKind tok of+        TkPrefixBang -> (False,) <$> patternParser+        TkPrefixTilde -> (False,) <$> patternParser+        -- Operator tokens can be valid patterns when they appear alone in parentheses.+        -- Examples: (+) in "f (+) = ...", (??) in "foldl' (??) z xs = ..."+        -- We detect this by checking if an operator is followed by a closing delimiter.+        TkVarSym {} -> operatorOrExprPatternParser+        TkConSym {} -> operatorOrExprPatternParser+        TkQConSym {} -> operatorOrExprPatternParser+        TkReservedColon -> operatorOrExprPatternParser+        TkReservedAt -> operatorOrExprPatternParser+        _ -> do+          isAs <- startsWithAsPattern+          if isAs+            then (False,) <$> patternParser+            else (False,) <$> exprThenReclassify+      where+        -- Try to parse an operator as a pattern if it's alone (followed by closing delim),+        -- otherwise fall back to parsing as an expression.+        operatorOrExprPatternParser :: TokParser (Bool, Pattern)+        operatorOrExprPatternParser = do+          -- Look ahead to check what comes after the operator+          mNext <- MP.optional . lookAhead . MP.try $ do+            _ <- anySingle -- skip the operator token itself+            lookAhead anySingle+          case fmap lexTokenKind mNext of+            -- If followed by closing delimiters, parse as operator pattern+            Just TkSpecialRParen -> (True,) <$> operatorPatternParser+            Just TkSpecialUnboxedRParen -> (True,) <$> operatorPatternParser+            Just TkSpecialComma -> (True,) <$> operatorPatternParser+            Just TkReservedPipe -> (True,) <$> operatorPatternParser+            -- Otherwise, try parsing as expression (for cases like (x + y))+            _ -> (False,) <$> exprThenReclassify++        -- Parse an operator token as a variable or constructor pattern.+        operatorPatternParser :: TokParser Pattern+        operatorPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do+          tok' <- anySingle+          case lexTokenKind tok' of+            TkVarSym op -> pure (PVar (mkUnqualifiedName NameVarSym op))+            TkConSym op -> pure (PCon (qualifyName Nothing (mkUnqualifiedName NameConSym op)) [] [])+            TkQConSym modName op -> pure (PCon (mkName (Just modName) NameConSym op) [] [])+            TkReservedColon -> pure (PCon (qualifyName Nothing (mkUnqualifiedName NameConSym ":")) [] [])+            TkReservedAt -> pure (PVar (mkUnqualifiedName NameVarSym "@"))+            _ ->+              MP.customFailure+                UnexpectedTokenExpecting+                  { unexpectedFound = Just (mkFoundToken tok'),+                    unexpectedExpecting = "operator token",+                    unexpectedContext = []+                  }++    -- Try to parse as expression, then reclassify via checkPattern.+    -- When exprParser fails, does not consume the full element (e.g.,+    -- '@' from an as-pattern), or checkPattern rejects it (e.g., variable+    -- operator in infix position), fall back to patternParser.+    --+    -- View patterns within tuple elements are also handled here: if '->'+    -- follows the parsed expression, it is a view pattern.+    exprThenReclassify :: TokParser Pattern+    exprThenReclassify = do+      mResult <- MP.optional . MP.try $ do+        expr <- exprParser+        -- Verify the expression consumed the full element: the next token+        -- must be a valid delimiter in paren/tuple/sum context. If not+        -- (e.g., '@' from an as-pattern), the expression parser stopped+        -- too early and we should backtrack to patternParser.+        tok <- lookAhead anySingle+        case lexTokenKind tok of+          TkReservedRightArrow -> pure (Left expr) -- view pattern: defer arrow handling+          TkSpecialComma -> Right <$> liftCheck (checkPattern expr)+          TkSpecialRParen -> Right <$> liftCheck (checkPattern expr)+          TkSpecialUnboxedRParen -> Right <$> liftCheck (checkPattern expr)+          TkReservedPipe -> Right <$> liftCheck (checkPattern expr)+          _ -> fail "incomplete element parse"+      case mResult of+        Just (Left expr) -> do+          -- View pattern: expr -> pattern+          expectedTok TkReservedRightArrow+          PView expr <$> subpatternWithBareViewParser+        Just (Right pat) ->+          pure pat+        Nothing ->+          patternParser++    tupleOrParenPatternParser tupleFlavor closeTok = do+      (isBareOp, first) <- parenPatElementParser+      mComma <- MP.optional (expectedTok TkSpecialComma)+      case mComma of+        Nothing -> do+          -- Check for pipe (unboxed sum: pattern in first slot)+          mPipe <- if tupleFlavor == Unboxed then MP.optional (expectedTok TkReservedPipe) else pure Nothing+          case mPipe of+            Just () -> do+              -- (# pat | ... #) - pattern in first slot of sum+              trailingBars <- MP.many (expectedTok TkReservedPipe)+              expectedTok closeTok+              let arity = 2 + length trailingBars+              pure (PUnboxedSum 0 arity first)+            Nothing -> do+              expectedTok closeTok+              if tupleFlavor == Boxed+                then parenOrSymConParser isBareOp first+                else pure (PTuple Unboxed [first])+        Just () -> do+          (_, second) <- parenPatElementParser+          more <- MP.many (expectedTok TkSpecialComma *> (snd <$> parenPatElementParser))+          expectedTok closeTok+          pure (PTuple tupleFlavor (first : second : more))++    parseUnboxedSumPatLeadingBars closeTok = do+      -- Parse (# | | ... | pat | ... | #) where pattern is not in first slot+      _ <- expectedTok TkReservedPipe+      leadingBars <- MP.many (MP.try (expectedTok TkReservedPipe))+      let altIdx = 1 + length leadingBars+      (_, inner) <- parenPatElementParser+      trailingBars <- MP.many (expectedTok TkReservedPipe)+      expectedTok closeTok+      let arity = altIdx + 1 + length trailingBars+      pure (PUnboxedSum altIdx arity inner)++isPatternAppHead :: Pattern -> Bool+isPatternAppHead pat =+  case peelPatternAnn pat of+    PCon {} -> True+    PVar name -> isConLikeNameType (unqualifiedNameType name)+    _ -> False
+ src/Aihc/Parser/Internal/Type.hs view
@@ -0,0 +1,579 @@+{-# LANGUAGE OverloadedStrings #-}++module Aihc.Parser.Internal.Type+  ( typeParser,+    typeSignatureParser,+    forallTelescopeParser,+    typeInfixParser,+    typeInfixOperatorParser,+    typeHeadInfixParser,+    typeAppParser,+    buildTypeApp,+    buildInfixType,+    typeAtomParser,+    contextItemsParser,+    thSpliceTypeParser,+    arrowKindParser,+  )+where++import Aihc.Parser.Internal.Common+import {-# SOURCE #-} Aihc.Parser.Internal.Expr (exprParser)+import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind, lexTokenSpan, lexTokenText)+import Aihc.Parser.Syntax+import Data.Char (isLower)+import Data.Functor (($>))+import Data.Text qualified as T+import Text.Megaparsec ((<|>))+import Text.Megaparsec qualified as MP++-- | Parse a Template Haskell type splice: $typ or $(typ)+thSpliceTypeParser :: TokParser Type+thSpliceTypeParser = withSpanAnn (TAnn . mkAnnotation) $ do+  expectedTok TkTHSplice+  body <- parenSpliceBody <|> bareSpliceBody+  pure (TSplice body)+  where+    parenSpliceBody = withSpanAnn (EAnn . mkAnnotation) $ do+      body <- parens exprParser+      pure (EParen body)+    bareSpliceBody = withSpanAnn (EAnn . mkAnnotation) $ do+      EVar <$> identifierNameParser++-- | Report core plus outer extension forms:+--+-- > type -> btype ['->' type]+typeParser :: TokParser Type+typeParser = label "type" $ forallTypeParser <|> contextOrKindSigTypeParser++-- | Type syntax accepted after expression signatures. This keeps the same+-- report core while allowing outer @forall@ and context forms.+typeSignatureParser :: TokParser Type+typeSignatureParser = label "type" $ forallSignatureTypeParser <|> contextOrFunSignatureTypeParser++-- | Extension form wrapping the report core with a kind annotation.+kindSigTypeParser :: TokParser Type+kindSigTypeParser =+  optionalSuffix+    (expectedTok TkReservedDoubleColon *> typeSignatureParser)+    TKindSig+    typeFunParser++-- | Extension form:+--+-- > forall a_1 ... a_n . type+forallSignatureTypeParser :: TokParser Type+forallSignatureTypeParser = withSpanAnn (TAnn . mkAnnotation) $ do+  telescope <- forallTelescopeParser+  attachForallBody telescope <$> typeSignatureParser++contextOrFunSignatureTypeParser :: TokParser Type+contextOrFunSignatureTypeParser = do+  isContextType <- startsWithContextType+  if isContextType then contextSignatureTypeParser else typeFunSignatureParser++contextSignatureTypeParser :: TokParser Type+contextSignatureTypeParser = do+  constraints <- contextItemsParserWith typeSignatureParser typeSignatureContextAtomParser+  expectedTok TkReservedDoubleArrow+  TContext constraints <$> typeSignatureParser++-- | Report core plus extension infix-type support:+--+-- > type -> btype ['->' type]+typeFunSignatureParser :: TokParser Type+typeFunSignatureParser = do+  lhs <- typeSignatureInfixParser+  mArrow <- MP.optional arrowKindParser+  case mArrow of+    Nothing -> pure lhs+    Just arrowKind -> TFun arrowKind lhs <$> typeSignatureParser++contextOrKindSigTypeParser :: TokParser Type+contextOrKindSigTypeParser = do+  isContextType <- startsWithContextType+  if isContextType then contextTypeParser else kindSigTypeParser++-- | Extension form:+--+-- > forall a_1 ... a_n . type+forallTypeParser :: TokParser Type+forallTypeParser = withSpanAnn (TAnn . mkAnnotation) $ do+  telescope <- forallTelescopeParser+  attachForallBody telescope <$> typeParser++attachForallBody :: ForallTelescope -> Type -> Type+attachForallBody telescope body =+  case body of+    TAnn ann (TKindSig ty kind) -> TAnn ann (TKindSig (TForall telescope ty) kind)+    TKindSig ty kind -> TKindSig (TForall telescope ty) kind+    _ -> TForall telescope body++-- | Extension form:+--+-- > forall -> 'forall' binder_1 ... binder_n ('.' | '->')+forallTelescopeParser :: TokParser ForallTelescope+forallTelescopeParser = do+  expectedTok TkKeywordForall+  binders <- MP.some forallBinderParser+  visibility <-+    (expectedTok (TkVarSym ".") $> ForallInvisible)+      <|> (expectedTok TkReservedRightArrow $> ForallVisible)+  pure (ForallTelescope visibility binders)++-- | Parse a single forall binder: {k} | (k :: *) | k+forallBinderParser :: TokParser TyVarBinder+forallBinderParser =+  withSpan $+    -- Inferred binder: {k} | {k :: Type}+    ( do+        expectedTok TkSpecialLBrace+        ident <- tyVarNameParser+        mKind <- MP.optional (expectedTok TkReservedDoubleColon *> typeParser)+        expectedTok TkSpecialRBrace+        pure (\span' -> TyVarBinder [mkAnnotation span'] ident mKind TyVarBInferred TyVarBVisible)+    )+      <|> ( do+              expectedTok TkSpecialLParen+              ident <- tyVarNameParser+              expectedTok TkReservedDoubleColon+              kind <- typeParser+              expectedTok TkSpecialRParen+              pure (\span' -> TyVarBinder [mkAnnotation span'] ident (Just kind) TyVarBSpecified TyVarBVisible)+          )+      <|> ( do+              ident <- tyVarNameParser+              pure (\span' -> TyVarBinder [mkAnnotation span'] ident Nothing TyVarBSpecified TyVarBVisible)+          )++contextTypeParser :: TokParser Type+contextTypeParser = contextTypeParserWith typeParser++contextItemsParser :: TokParser [Type]+contextItemsParser = contextItemsParserWith typeParser typeAtomParser++contextTypeParserWith :: TokParser Type -> TokParser Type+contextTypeParserWith rhsParser = do+  constraints <- contextItemsParserWith rhsParser typeAtomParser+  expectedTok TkReservedDoubleArrow+  rhs <- rhsParser+  pure $+    case rhs of+      TAnn ann (TKindSig ty kind) -> TAnn ann (TKindSig (TContext constraints ty) kind)+      TKindSig ty kind -> TKindSig (TContext constraints ty) kind+      _ -> TContext constraints rhs++-- | Report core plus extension infix-type support:+--+-- > type -> btype ['->' type]+-- > btype -> [btype] atype+typeFunParser :: TokParser Type+typeFunParser = typeFunParserWith typeSignatureParser++typeFunParserWith :: TokParser Type -> TokParser Type+typeFunParserWith rhsParser = do+  lhs <- typeInfixParser+  mArrow <- MP.optional arrowKindParser+  case mArrow of+    Nothing -> pure lhs+    Just arrowKind -> TFun arrowKind lhs <$> rhsParser++-- | Parse an arrow annotation and consume the @->@ token.+-- Handles @->@ (unrestricted), @⊸@ (linear), @%1 ->@ (linear), and @%m ->@+-- (explicit multiplicity).  The @%@-prefixed forms are only attempted when+-- @LinearTypes@ is enabled.+arrowKindParser :: TokParser ArrowKind+arrowKindParser = do+  linearEnabled <- isExtensionEnabled LinearTypes+  (expectedTok TkReservedRightArrow $> ArrowUnrestricted)+    <|> (if linearEnabled then linearArrowKindParser else MP.empty)++linearArrowKindParser :: TokParser ArrowKind+linearArrowKindParser =+  (expectedTok TkLinearArrow $> ArrowLinear)+    <|> MP.try multiplicityAnnotatedArrowParser++-- | Parse @%<mult> ->@, consuming all three tokens.+-- Only matches when @%@ is a prefix operator (no space between @%@ and the+-- multiplicity expression), which is how GHC distinguishes @a %1 -> b@ (linear)+-- from @a % 1 -> b@ (type operator applied to @a@ and @1@, then unrestricted arrow).+multiplicityAnnotatedArrowParser :: TokParser ArrowKind+multiplicityAnnotatedArrowParser = do+  expectedTok TkPrefixPercent+  mult <- typeAtomParser+  expectedTok TkReservedRightArrow+  pure (multiplicityToArrowKind mult)++multiplicityToArrowKind :: Type -> ArrowKind+multiplicityToArrowKind ty =+  case peelTypeAnn ty of+    TTypeLit (TypeLitInteger 1 _) -> ArrowLinear+    _ -> ArrowExplicit ty++-- | Extension layer over the report's @btype@ chain:+--+-- > btype -> [btype] atype+typeInfixParser :: TokParser Type+typeInfixParser = do+  lhs <- typeAppParser+  rest <- MP.many ((,) <$> typeInfixOperatorParser <*> typeInfixRhsParser)+  pure (foldInfixR buildInfixType lhs rest)++typeInfixRhsParser :: TokParser Type+typeInfixRhsParser = do+  rhs <- typeAppParser+  rejectBareTypeImplicitParam rhs++typeSignatureInfixParser :: TokParser Type+typeSignatureInfixParser = do+  lhs <- typeSignatureAppParser+  rest <- MP.many ((,) <$> typeInfixOperatorParser <*> typeSignatureInfixRhsParser)+  pure (foldInfixR buildInfixType lhs rest)++typeSignatureInfixRhsParser :: TokParser Type+typeSignatureInfixRhsParser = do+  rhs <- typeSignatureAppParser+  rejectBareSignatureImplicitParam rhs++-- | Parse a type head that may contain infix operators but NOT type applications.+-- Used for type family heads like @type family l `And` r@ where the head is+-- an infix type, but we don't want to consume trailing type parameters.+typeHeadInfixParser :: TokParser Type+typeHeadInfixParser = do+  lhs <- typeAtomParser+  foldInfixR buildInfixType lhs <$> typeHeadInfixLoopParser++typeHeadInfixLoopParser :: TokParser [((Name, TypePromotion), Type)]+typeHeadInfixLoopParser = MP.many $ MP.try $ do+  op <- typeInfixOperatorParser+  atom <- typeAtomParser+  pure (op, atom)++buildInfixType :: Type -> ((Name, TypePromotion), Type) -> Type+buildInfixType lhs ((op, promoted), rhs) = TInfix lhs op promoted rhs++typeInfixOperatorParser :: TokParser (Name, TypePromotion)+typeInfixOperatorParser =+  promotedInfixOperatorParser+    <|> backtickTypeOperatorParser+    <|> unpromotedInfixOperatorParser+  where+    unpromotedInfixOperatorParser =+      tokenSatisfy "type infix operator" $ \tok ->+        case lexTokenKind tok of+          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"), Unpromoted)+          TkVarSym op+            | op /= "."+                && op /= "!"+                && op /= "'" ->+                Just (qualifyName Nothing (mkUnqualifiedName NameVarSym op), Unpromoted)+          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op), Unpromoted)+          TkQVarSym modName op -> Just (mkName (Just modName) NameVarSym op, Unpromoted)+          TkQConSym modName op -> Just (mkName (Just modName) NameConSym op, Unpromoted)+          _ -> Nothing++    backtickTypeOperatorParser = MP.try $ do+      expectedTok TkSpecialBacktick+      op <- typeOperatorIdentifierParser+      expectedTok TkSpecialBacktick+      pure (op, Unpromoted)++    typeOperatorIdentifierParser =+      tokenSatisfy "type operator identifier" $ \tok ->+        case lexTokenKind tok of+          TkVarId name -> Just (qualifyName Nothing (mkUnqualifiedName NameVarId name))+          TkConId name -> Just (qualifyName Nothing (mkUnqualifiedName NameConId name))+          TkQVarId modName name -> Just (mkName (Just modName) NameVarId name)+          TkQConId modName name -> Just (mkName (Just modName) NameConId name)+          _ -> Nothing++    promotedInfixOperatorParser = MP.try $ do+      -- Accept both TkVarSym "'" and TkTHQuoteTick for promoted operators+      expectedTok (TkVarSym "'") <|> expectedTok TkTHQuoteTick+      -- After the quote, accept any symbolic infix operator (e.g., ': for promoted cons,+      -- or ':$$: for a promoted user-defined type operator)+      tokenSatisfy "promoted type infix operator" $ \tok ->+        case lexTokenKind tok of+          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"), Promoted)+          TkVarSym sym+            | sym /= "." && sym /= "!" ->+                Just (qualifyName Nothing (mkUnqualifiedName NameVarSym sym), Promoted)+          TkConSym sym -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym sym), Promoted)+          TkQVarSym modQual sym -> Just (mkName (Just modQual) NameVarSym sym, Promoted)+          TkQConSym modQual sym -> Just (mkName (Just modQual) NameConSym sym, Promoted)+          _ -> Nothing++-- | Report core:+--+-- > btype -> [btype] atype+typeAppParser :: TokParser Type+typeAppParser = do+  first <- typeAtomParser+  rest <- MP.many typeAppArgParser+  pure (foldl applyTypeAppArg first rest)++typeSignatureAppParser :: TokParser Type+typeSignatureAppParser = do+  first <- typeSignatureAtomParser+  rest <- MP.many typeSignatureAppArgParser+  pure (foldl applyTypeAppArg first rest)++buildTypeApp :: Type -> Type -> Type+buildTypeApp = TApp++typeAppArgParser :: TokParser (Either Type Type)+typeAppArgParser =+  (Left <$> MP.try invisibleTypeAppParser)+    <|> (Right <$> (typeAtomParser >>= rejectBareTypeImplicitParam))++invisibleTypeAppParser :: TokParser Type+invisibleTypeAppParser = do+  expectedTok TkTypeApp+  typeAtomParser >>= rejectBareTypeImplicitParam++typeSignatureAppArgParser :: TokParser (Either Type Type)+typeSignatureAppArgParser =+  (Left <$> MP.try invisibleSignatureTypeAppParser)+    <|> (Right <$> (typeSignatureAtomParser >>= rejectBareSignatureImplicitParam))++typeSignatureContextAtomParser :: TokParser Type+typeSignatureContextAtomParser = typeSignatureAtomParser >>= rejectBareSignatureImplicitParam++rejectBareSignatureImplicitParam :: Type -> TokParser Type+rejectBareSignatureImplicitParam = rejectBareTypeImplicitParam++rejectBareTypeImplicitParam :: Type -> TokParser Type+rejectBareTypeImplicitParam ty =+  case peelTypeAnn ty of+    TImplicitParam {} -> fail "implicit parameter type must be parenthesized"+    _ -> pure ty++invisibleSignatureTypeAppParser :: TokParser Type+invisibleSignatureTypeAppParser = do+  expectedTok TkTypeApp+  typeSignatureAtomParser >>= rejectBareSignatureImplicitParam++applyTypeAppArg :: Type -> Either Type Type -> Type+applyTypeAppArg fn (Left ty) = TTypeApp fn ty+applyTypeAppArg fn (Right ty) = TApp fn ty++-- | Report core:+--+-- > atype -> gtycon+-- >       | tyvar+-- >       | '(' type_1 ',' ... ',' type_k ')'+-- >       | '[' type ']'+-- >       | '(' type ')'+--+-- This parser also admits extension atoms such as promoted types,+-- quasi-quotes, splices, wildcards, and implicit-parameter types.+typeAtomParser :: TokParser Type+typeAtomParser = do+  thAny <- thAnyEnabled+  ipEnabled <- isExtensionEnabled ImplicitParams+  MP.try promotedTypeParser+    <|> typeLiteralTypeParser+    <|> typeQuasiQuoteParser+    <|> (if thAny then thSpliceTypeParser else MP.empty)+    <|> (if ipEnabled then typeImplicitParamParser else MP.empty)+    <|> typeListParser+    <|> MP.try typeParenOperatorParser+    <|> typeParenOrTupleParser+    <|> typeStarParser+    <|> typeWildcardParser+    <|> typeIdentifierParser++typeSignatureAtomParser :: TokParser Type+typeSignatureAtomParser = do+  thAny <- thAnyEnabled+  ipEnabled <- isExtensionEnabled ImplicitParams+  MP.try promotedTypeParser+    <|> typeLiteralTypeParser+    <|> typeQuasiQuoteParser+    <|> (if thAny then thSpliceTypeParser else MP.empty)+    <|> (if ipEnabled then typeImplicitParamParser else MP.empty)+    <|> typeListParser+    <|> MP.try typeParenOperatorParser+    <|> typeParenOrTupleParser+    <|> typeStarParser+    <|> typeWildcardParser+    <|> typeIdentifierParser++-- | Parse an implicit parameter type.+--+-- The body uses 'typeSignatureParser' so @?x :: (T :: K)@ is accepted+-- through the parenthesized atom grammar, but @?x :: T :: K@ is left for an+-- outer kind-signature parser in a plain type context and rejected in a+-- signature context.+typeImplicitParamParser :: TokParser Type+typeImplicitParamParser = withSpanAnn (TAnn . mkAnnotation) $ do+  name <- implicitParamNameParser+  expectedTok TkReservedDoubleColon+  TImplicitParam name <$> typeSignatureParser++typeWildcardParser :: TokParser Type+typeWildcardParser = withSpanAnn (TAnn . mkAnnotation) $ do+  expectedTok TkKeywordUnderscore+  pure TWildcard++typeLiteralTypeParser :: TokParser Type+typeLiteralTypeParser = withSpanAnn (TAnn . mkAnnotation) $ do+  lit <- tokenSatisfy "type literal" $ \tok ->+    case lexTokenKind tok of+      TkInteger n _ -> Just (TypeLitInteger n (lexTokenText tok))+      TkString s -> Just (TypeLitSymbol s (lexTokenText tok))+      TkChar c -> Just (TypeLitChar c (lexTokenText tok))+      _ -> Nothing+  pure (TTypeLit lit)++promotedTypeParser :: TokParser Type+promotedTypeParser = withSpanAnn (TAnn . mkAnnotation) $ do+  -- Accept both TkVarSym "'" and TkTHQuoteTick for promoted types+  -- This handles ambiguity between TH value quotes and promoted types+  expectedTok (TkVarSym "'") <|> expectedTok TkTHQuoteTick+  ty <- typeAtomParser+  maybe (fail "promoted type") pure (markTypePromoted ty)++typeParenOperatorParser :: TokParser Type+typeParenOperatorParser = withSpanAnn (TAnn . mkAnnotation) $ do+  expectedTok TkSpecialLParen+  starIsType <- isExtensionEnabled StarIsType+  unicodeSyntax <- isExtensionEnabled UnicodeSyntax+  op <- tokenSatisfy "type operator" $ \tok ->+    case lexTokenKind tok of+      TkVarSym sym | not (isStarTypeSymbol starIsType unicodeSyntax sym) -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym sym))+      TkConSym sym | not (isStarTypeSymbol starIsType unicodeSyntax sym) -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym sym))+      TkQVarSym modQual sym -> Just (mkName (Just modQual) NameVarSym sym)+      TkQConSym modQual sym -> Just (mkName (Just modQual) NameConSym sym)+      -- Handle reserved operators that can be used as type constructors+      TkReservedRightArrow -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "->"))+      TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"))+      -- Note: ~ is now lexed as TkVarSym "~" so TkVarSym case handles it+      _ -> Nothing+  expectedTok TkSpecialRParen+  pure $+    case (nameQualifier op, nameType op, nameText op) of+      (Nothing, NameVarSym, "->") -> TBuiltinCon TBuiltinArrow+      (Nothing, NameConSym, ":") -> TBuiltinCon TBuiltinCons+      _ -> TCon op Unpromoted++typeQuasiQuoteParser :: TokParser Type+typeQuasiQuoteParser =+  tokenSatisfy "type quasi quote" $ \tok ->+    case lexTokenKind tok of+      TkQuasiQuote quoter body -> Just (typeAnnSpan (lexTokenSpan tok) (TQuasiQuote quoter body))+      _ -> Nothing++typeIdentifierParser :: TokParser Type+typeIdentifierParser = withSpanAnn (TAnn . mkAnnotation) $ do+  name <- identifierNameParser+  pure $+    case (nameQualifier name, nameType name, T.uncons (nameText name)) of+      (Nothing, NameVarId, Just (c, _))+        | isLower c || c == '_' ->+            TVar (mkUnqualifiedName NameVarId (nameText name))+      _ -> TCon name Unpromoted++typeStarParser :: TokParser Type+typeStarParser = withSpanAnn (TAnn . mkAnnotation) $ do+  starIsType <- isExtensionEnabled StarIsType+  unicodeSyntax <- isExtensionEnabled UnicodeSyntax+  if starIsType+    then do+      spelling <- tokenSatisfy "star kind" $ \tok ->+        case lexTokenKind tok of+          TkVarSym sym | isStarTypeSymbol starIsType unicodeSyntax sym -> Just (lexTokenText tok)+          TkConSym sym | isStarTypeSymbol starIsType unicodeSyntax sym -> Just (lexTokenText tok)+          _ -> Nothing+      pure (TStar spelling)+    else MP.empty++isStarTypeSymbol :: Bool -> Bool -> T.Text -> Bool+isStarTypeSymbol starIsType unicodeSyntax sym =+  starIsType && (sym == "*" || (unicodeSyntax && sym == "★"))++typeListParser :: TokParser Type+typeListParser = withSpanAnn (TAnn . mkAnnotation) $ do+  expectedTok TkSpecialLBracket+  mClosed <- MP.optional (expectedTok TkSpecialRBracket)+  case mClosed of+    Just () -> pure (TBuiltinCon TBuiltinList)+    Nothing -> do+      elems <- typeParser `MP.sepBy1` expectedTok TkSpecialComma+      expectedTok TkSpecialRBracket+      pure (TList Unpromoted elems)++typeParenOrTupleParser :: TokParser Type+typeParenOrTupleParser = withSpanAnn (TAnn . mkAnnotation) $ do+  (tupleFlavor, closeTok) <- tupleDelimsParser+  mClosed <- MP.optional (expectedTok closeTok)+  case mClosed of+    Just () -> pure (TTuple tupleFlavor Unpromoted [])+    Nothing -> do+      MP.try (tupleConstructorParser tupleFlavor closeTok) <|> parenthesizedTypeOrTupleParser tupleFlavor closeTok+  where+    tupleConstructorParser tupleFlavor closeTok = do+      _ <- expectedTok TkSpecialComma+      moreCommas <- MP.many (expectedTok TkSpecialComma)+      expectedTok closeTok+      let arity = 2 + length moreCommas+      case tupleFlavor of+        Boxed -> pure (TBuiltinCon (TBuiltinTuple arity))+        Unboxed -> do+          let tupleConName = "(#" <> T.replicate (arity - 1) "," <> "#)"+          pure (TCon (qualifyName Nothing (mkUnqualifiedName NameConId tupleConName)) Unpromoted)++    parenthesizedTypeOrTupleParser tupleFlavor closeTok = do+      first <- typeParser+      mKind <- if tupleFlavor == Boxed then MP.optional (expectedTok TkReservedDoubleColon *> typeParser) else pure Nothing+      case mKind of+        Just kind -> do+          expectedTok closeTok+          pure (TParen (TKindSig first kind))+        Nothing -> do+          mComma <- MP.optional (expectedTok TkSpecialComma)+          case mComma of+            Nothing -> do+              -- Check for pipe (unboxed sum type)+              mPipe <- if tupleFlavor == Unboxed then MP.optional (expectedTok TkReservedPipe) else pure Nothing+              case mPipe of+                Just () -> do+                  -- (# Type1 | Type2 | ... #) - unboxed sum type+                  rest <- typeParser `MP.sepBy1` expectedTok TkReservedPipe+                  expectedTok closeTok+                  pure (TUnboxedSum (first : rest))+                Nothing -> do+                  expectedTok closeTok+                  case tupleFlavor of+                    Boxed -> pure (TParen first)+                    Unboxed -> pure (TTuple Unboxed Unpromoted [first])+            Just () -> do+              second <- typeParser+              more <- MP.many (expectedTok TkSpecialComma *> typeParser)+              expectedTok closeTok+              pure (TTuple tupleFlavor Unpromoted (first : second : more))++markTypePromoted :: Type -> Maybe Type+markTypePromoted ty =+  case ty of+    TAnn ann sub+      | Just inner <- markTypePromoted sub ->+          Just (TAnn ann inner)+    TCon name _ -> Just (TCon name Promoted)+    TBuiltinCon con -> Just (promoteBuiltinCon con)+    TList _ elems -> Just (TList Promoted elems)+    TTuple tupleFlavor _ elems -> Just (TTuple tupleFlavor Promoted elems)+    TTypeApp fn arg -> TTypeApp <$> markTypePromoted fn <*> pure arg+    _ -> Nothing++promoteBuiltinCon :: TypeBuiltinCon -> Type+promoteBuiltinCon con =+  TCon+    ( qualifyName Nothing $+        case con of+          TBuiltinTuple arity -> mkUnqualifiedName NameConId ("(" <> T.replicate (max 0 (arity - 1)) "," <> ")")+          TBuiltinArrow -> mkUnqualifiedName NameVarSym "->"+          TBuiltinList -> mkUnqualifiedName NameConId "[]"+          TBuiltinCons -> mkUnqualifiedName NameConSym ":"+    )+    Promoted
+ src/Aihc/Parser/Lex.hs view
@@ -0,0 +1,1084 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++module Aihc.Parser.Lex+  ( TokenOrigin (..),+    Pragma (..),+    PragmaUnpackKind (..),+    LexToken (..),+    LexTokenKind (..),+    pattern TkVarRole,+    pattern TkVarFamily,+    pattern TkVarAs,+    pattern TkVarHiding,+    pattern TkVarQualified,+    pattern TkVarSafe,+    readModuleHeaderExtensions,+    readModuleHeaderPragmas,+    lexTokensWithExtensions,+    lexModuleTokensWithExtensions,+    lexTokensWithSourceNameAndExtensions,+    lexModuleTokensWithSourceNameAndExtensions,+    lexTokens,+    lexModuleTokens,+    LexerEnv (..),+    LexerState (..),+    LayoutState (..),+    LayoutContext (..),+    mkLexerEnv,+    mkInitialLexerState,+    mkInitialLayoutState,+    scanAllTokens,+    layoutTransition,+    stepNextToken,+    closeImplicitLayoutContext,+  )+where++import Aihc.Parser.Lex.Header+  ( readModuleHeaderExtensionsFromTokens,+    separateEditionAndExtensions,+  )+import Aihc.Parser.Lex.Layout+  ( applyLayoutTokens,+    closeImplicitLayoutContext,+    layoutTransition,+  )+import Aihc.Parser.Lex.Numbers+  ( lexFloat,+    lexHexFloat,+    lexInt,+    lexIntBase,+    withOptionalMagicHashSuffix,+  )+import Aihc.Parser.Lex.Pragmas (tryParsePragma)+import Aihc.Parser.Lex.Quoted+  ( decodeStringBody,+    processMultilineString,+    readMaybeChar,+    scanMultilineString,+    scanQuoted,+  )+import Aihc.Parser.Lex.Trivia+  ( consumeBlockCommentTokenOrError,+    consumeLineCommentToken,+    isHaskellWhitespace,+    isLineComment,+    tryConsumeControlPragma,+    tryConsumeLineDirective,+  )+import Aihc.Parser.Lex.Types+import Aihc.Parser.Syntax+import Control.Applicative ((<|>))+import Data.Char (GeneralCategory (..), generalCategory, isAscii, isAsciiLower, isAsciiUpper, isDigit)+import Data.Maybe (fromMaybe, isJust)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text, pattern Empty, pattern (:<))+import Data.Text qualified as T++lexTokens :: Text -> [LexToken]+lexTokens = lexTokensWithSourceNameAndExtensions "<input>" []++lexModuleTokens :: Text -> [LexToken]+lexModuleTokens = lexModuleTokensWithSourceNameAndExtensions "<input>" []++lexTokensWithExtensions :: [Extension] -> Text -> [LexToken]+lexTokensWithExtensions = lexTokensWithSourceNameAndExtensions "<input>"++lexModuleTokensWithExtensions :: [Extension] -> Text -> [LexToken]+lexModuleTokensWithExtensions = lexModuleTokensWithSourceNameAndExtensions "<input>"++lexTokensWithSourceNameAndExtensions :: FilePath -> [Extension] -> Text -> [LexToken]+lexTokensWithSourceNameAndExtensions = lexTextWithExtensions False++lexModuleTokensWithSourceNameAndExtensions :: FilePath -> [Extension] -> Text -> [LexToken]+lexModuleTokensWithSourceNameAndExtensions sourceName baseExts input =+  lexTextWithExtensions True sourceName effectiveExts input+  where+    headerSettings = readModuleHeaderExtensions input+    effectiveExts = applyImpliedExtensions (foldr applyExtensionSetting baseExts headerSettings)++lexTextWithExtensions :: Bool -> FilePath -> [Extension] -> Text -> [LexToken]+lexTextWithExtensions enableModuleLayout sourceName exts input =+  applyLayoutTokens enableModuleLayout exts (scanTokens env initialLexerState)+  where+    (env, initialLexerState) = mkInitialLexerState sourceName exts input++readModuleHeaderExtensions :: Text -> [ExtensionSetting]+readModuleHeaderExtensions input =+  readModuleHeaderExtensionsFromTokens (scanTokens env initialLexerState)+  where+    (env, initialLexerState) = mkInitialLexerState "<input>" [] input++readModuleHeaderPragmas :: Text -> ModuleHeaderPragmas+readModuleHeaderPragmas input =+  separateEditionAndExtensions (readModuleHeaderExtensions input)++scanTokens :: LexerEnv -> LexerState -> [LexToken]+scanTokens env st0 =+  case skipTrivia st0 of+    SkipToken tok st ->+      tok : scanTokens env (recordScannedToken tok st)+    SkipDone st+      | T.null (lexerInput st) -> [eofToken st]+      | otherwise ->+          let (tok, st') = nextToken env st+           in tok : scanTokens env (recordScannedToken tok st')++data SkipResult = SkipDone !LexerState | SkipToken !LexToken !LexerState++-- | Skip whitespace, line comments, block comments, and control pragmas ({-# LINE/COLUMN #-}).+-- Regular pragmas ({-# ... #-}) are left for 'nextToken' to handle.+-- Returns 'SkipToken' only for error tokens from malformed/unterminated constructs.+skipTrivia :: LexerState -> SkipResult+skipTrivia = go+  where+    go st =+      let inp = lexerInput st+       in case inp of+            Empty -> SkipDone st+            c :< _+              | isHaskellWhitespace c ->+                  go (markHadTrivia (consumeWhile isHaskellWhitespace st))+            _+              | Just rest <- T.stripPrefix "--" inp,+                isLineComment rest ->+                  let (tok, st') = consumeLineCommentToken st+                   in SkipToken tok (markHadTrivia st')+            -- Check {-# before {- so control pragmas are handled first and+            -- block comment handler does not eat pragma tokens.+            _+              | "{-#" `T.isPrefixOf` inp ->+                  case tryConsumeControlPragma st of+                    Just (Nothing, st') -> go (markHadTrivia st')+                    Just (Just tok, st') -> SkipToken tok (markHadTrivia st')+                    Nothing -> SkipDone st -- not a control pragma; let nextToken handle it+              | "{-" `T.isPrefixOf` inp ->+                  case consumeBlockCommentTokenOrError st of+                    Right (tok, st') -> SkipToken tok (markHadTrivia st')+                    Left (tok, st') -> SkipToken tok (markHadTrivia st')+            _ ->+              case tryConsumeLineDirective st of+                Just (Nothing, st') -> go (markHadTrivia st')+                Just (Just tok, st') -> SkipToken tok (markHadTrivia st')+                Nothing -> SkipDone st++markHadTrivia :: LexerState -> LexerState+markHadTrivia st = st {lexerHadTrivia = True}++isCommentTokenKind :: LexTokenKind -> Bool+isCommentTokenKind kind =+  case kind of+    TkLineComment -> True+    TkBlockComment -> True+    _ -> False++recordScannedToken :: LexToken -> LexerState -> LexerState+recordScannedToken tok st+  | isCommentTokenKind (lexTokenKind tok) = st {lexerHadTrivia = True}+  | otherwise = st {lexerPrevTokenKind = Just (lexTokenKind tok), lexerHadTrivia = False}++-- | Lex a regular pragma token ({-# ... #-}).+-- Control pragmas (LINE, COLUMN) are handled in 'skipTrivia' and never reach here.+-- Falls back to a 'TkError' token when the pragma has no closing "#-}".+lexPragma :: LexerState -> Maybe (LexToken, LexerState)+lexPragma st+  | "{-#" `T.isPrefixOf` lexerInput st =+      Just $ case tryParsePragma st of+        Just result -> result+        Nothing ->+          -- Malformed pragma with no closing "#-}"+          let consumed = lexerInput st+              st' = advanceChars consumed st+           in (mkToken st st' consumed (TkError "malformed pragma"), st')+  | otherwise = Nothing++nextToken :: LexerEnv -> LexerState -> (LexToken, LexerState)+nextToken env st =+  -- Inline chain of alternatives with no intermediate list or closure allocation.+  -- (<|>) for Maybe short-circuits on the first Just without allocating.+  fromMaybe (lexErrorToken st "unexpected character") $+    lexPragma st+      <|> lexTHQuoteBracket env st+      <|> lexQuasiQuote st+      <|> lexHexFloat env st+      <|> lexFloat env st+      <|> lexIntBase env st+      <|> lexInt env st+      <|> lexTHNameQuote env st+      <|> lexPromotedQuote env st+      <|> lexChar env st+      <|> lexString env st+      <|> lexTHCloseQuote env st+      <|> lexSymbol env st+      <|> lexIdentifier env st+      <|> lexNegativeLiteralOrMinus env st+      <|> lexBangOrTildeOperator st+      <|> lexTypeApplication env st+      <|> lexOverloadedLabel env st+      <|> lexPrefixDollar env st+      <|> lexImplicitParam env st+      <|> lexOperator env st++stepNextToken :: LexerEnv -> LexerState -> LayoutState -> Maybe (LexToken, LexerState, LayoutState)+stepNextToken env lexSt laySt =+  case layoutBuffer laySt of+    tok : rest ->+      Just (tok, lexSt, laySt {layoutBuffer = rest})+    [] ->+      case scanOneToken env lexSt of+        Nothing -> Nothing+        Just (rawTok, lexSt') ->+          let (allToks, laySt') = layoutTransition laySt rawTok+           in case allToks of+                [] -> Just (rawTok, lexSt', laySt')+                [first] -> Just (first, lexSt', laySt')+                first : rest -> Just (first, lexSt', laySt' {layoutBuffer = rest})++scanOneToken :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+scanOneToken env st0 =+  case skipTrivia st0 of+    SkipToken tok st ->+      Just (tok, recordScannedToken tok st)+    SkipDone st+      | T.null (lexerInput st) ->+          case lexerPrevTokenKind st of+            Just TkEOF -> Nothing+            _ ->+              let tok = eofToken st+                  st' = st {lexerPrevTokenKind = Just TkEOF, lexerHadTrivia = False}+               in Just (tok, st')+      | otherwise ->+          let (tok, st') = nextToken env st+           in Just (tok, recordScannedToken tok st')++scanAllTokens :: LexerEnv -> LexerState -> [LexToken]+scanAllTokens env st =+  case scanOneToken env st of+    Nothing -> []+    Just (tok, st') -> tok : scanAllTokens env st'++lexIdentifier :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexIdentifier env st =+  case lexerInput st of+    c :< rest+      | isIdentStart c ->+          let hasMagicHash = hasExt MagicHash env+              (seg, rest0) = consumeIdentTail hasMagicHash rest+              firstChunk = T.take (1 + T.length seg) (lexerInput st)+              (consumed, rest1, isQualified) = gatherQualified hasMagicHash firstChunk rest0+           in case (isQualified || isConIdStart c, rest1) of+                (True, '.' :< dotRest@(opChar :< _))+                  | isSymbolicOpChar opChar ->+                      let opChars = T.takeWhile isSymbolicOpChar dotRest+                          fullOp = consumed <> "." <> opChars+                          (modName, opName) = splitQualified (consumed <> ".") opChars+                          kind =+                            if opChar == ':'+                              then TkQConSym modName opName+                              else TkQVarSym modName opName+                          st' = advanceChars fullOp st+                       in Just (mkToken st st' fullOp kind, st')+                _ ->+                  let kind = classifyIdentifier c isQualified consumed+                      st' = advanceChars consumed st+                   in Just (mkToken st st' consumed kind, st')+    _ -> Nothing+  where+    gatherQualified :: Bool -> Text -> Text -> (Text, Text, Bool)+    gatherQualified hasMH acc chars =+      case chars of+        '.' :< dotRest@(c' :< more)+          | isIdentStart c',+            not (T.isSuffixOf "#" acc),+            isConIdStart (T.head acc) ->+              let (seg, rest) = consumeIdentTail hasMH more+                  segWithHead = T.take (1 + T.length seg) dotRest+               in gatherQualified hasMH (acc <> "." <> segWithHead) rest+        _ -> (acc, chars, T.any (== '.') acc)++    -- Split a qualified identifier into (module part, name part).+    -- E.g. "Data.Maybe." ++ "++" -> ("Data.Maybe", "++")+    splitQualified :: Text -> Text -> (Text, Text)+    splitQualified modWithDot name =+      (T.dropEnd 1 modWithDot, name)++    classifyIdentifier firstChar isQualified ident+      | isQualified =+          let rev = T.reverse ident+              (revName, revRest) = T.span (/= '.') rev+              modName = T.reverse (T.drop 1 revRest)+              name = T.reverse revName+           in case T.uncons name of+                Just (c', _)+                  | isConIdStart c' -> TkQConId modName name+                  | name == "do" && hasExt QualifiedDo env -> TkQualifiedDo modName+                  | name == "mdo" && hasExt QualifiedDo env && hasExt RecursiveDo env -> TkQualifiedMdo modName+                Just _ -> TkQVarId modName name+                Nothing -> TkQVarId modName name+      | otherwise =+          case keywordTokenKind (lexerExtensions env) ident of+            Just kw -> kw+            Nothing+              | isConIdStart firstChar -> TkConId ident+              | otherwise -> TkVarId ident++consumeIdentTail :: Bool -> Text -> (Text, Text)+consumeIdentTail hasMH inp =+  let (tailPart, rest) = T.span isIdentTail inp+   in case rest of+        '#' :< _+          | hasMH ->+              let hashes = T.takeWhile (== '#') rest+               in (tailPart <> hashes, T.drop (T.length hashes) rest)+        _ -> (tailPart, rest)++lexImplicitParam :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexImplicitParam env st+  | not (hasExt ImplicitParams env) = Nothing+  | otherwise =+      case lexerInput st of+        '?' :< rest0@(c :< _)+          | isVarIdentifierStartChar c ->+              let hasMagicHash = hasExt MagicHash env+                  (tailChars, _rest) = consumeIdentTail hasMagicHash (T.tail rest0)+                  txt = T.take (2 + T.length tailChars) (lexerInput st)+                  st' = advanceChars txt st+               in Just (mkToken st st' txt (TkImplicitParam txt), st')+        _ -> Nothing++lexNegativeLiteralOrMinus :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexNegativeLiteralOrMinus env st+  | not hasNegExt && not hasMH = Nothing+  | not (isStandaloneMinus (lexerInput st)) = Nothing+  | otherwise =+      let prevAllows = allowsMergeOrPrefix (lexerPrevTokenKind st) (lexerHadTrivia st)+          rest = T.drop 1 (lexerInput st)+       in if hasExt NegativeLiterals env && prevAllows+            then case tryLexNumberAfterMinus env st of+              Just result -> Just result+              Nothing -> lexMinusOperator env st rest prevAllows+            else+              -- GHC merges minus into primitive unboxed literals (Int#, Word#,+              -- Float#, Double#, and ExtendedLiterals types) even without+              -- NegativeLiterals.  When only MagicHash is active, speculatively+              -- lex the number after the minus and keep the merged token only+              -- when the result carries a primitive suffix.+              if hasMH && prevAllows+                then case tryLexNumberAfterMinus env st of+                  Just (tok, st')+                    | isPrimitiveNumericToken (lexTokenKind tok) -> Just (tok, st')+                  _ ->+                    if hasNegExt+                      then lexMinusOperator env st rest prevAllows+                      else Nothing+                else+                  if hasNegExt+                    then lexMinusOperator env st rest prevAllows+                    else Nothing+  where+    hasNegExt =+      hasExt NegativeLiterals env+        || hasExt LexicalNegation env+    hasMH = hasExt MagicHash env++isStandaloneMinus :: Text -> Bool+isStandaloneMinus input =+  case input of+    '-' :< (c :< _) | isSymbolicOpChar c && c /= '-' -> False+    '-' :< _ -> True+    _ -> False++tryLexNumberAfterMinus :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+tryLexNumberAfterMinus env st = do+  let stAfterMinus = advanceChars "-" st+  (numTok, stFinal) <-+    lexHexFloat env stAfterMinus+      <|> lexFloat env stAfterMinus+      <|> lexIntBase env stAfterMinus+      <|> lexInt env stAfterMinus+  Just (negateToken st numTok, stFinal)++negateToken :: LexerState -> LexToken -> LexToken+negateToken stBefore numTok =+  LexToken+    { lexTokenKind = negateKind (lexTokenKind numTok),+      lexTokenText = "-" <> lexTokenText numTok,+      lexTokenSpan = extendSpanLeft (lexTokenSpan numTok),+      lexTokenOrigin = lexTokenOrigin numTok,+      lexTokenAtLineStart = lexerAtLineStart stBefore+    }+  where+    negateKind k =+      case k of+        TkInteger n nt -> TkInteger (negate n) nt+        TkFloat n ft -> TkFloat (negate n) ft+        other -> other++    extendSpanLeft sp =+      case sp of+        SourceSpan {sourceSpanSourceName, sourceSpanEndLine = endLine, sourceSpanEndCol = endCol, sourceSpanEndOffset} ->+          SourceSpan+            { sourceSpanSourceName = sourceSpanSourceName,+              sourceSpanStartLine = lexerLine stBefore,+              sourceSpanStartCol = lexerCol stBefore,+              sourceSpanEndLine = endLine,+              sourceSpanEndCol = endCol,+              sourceSpanStartOffset = lexerByteOffset stBefore,+              sourceSpanEndOffset = sourceSpanEndOffset+            }+        NoSourceSpan -> NoSourceSpan++-- | Does the token kind represent a primitive (unboxed) numeric literal?+-- These are MagicHash types (Int#, Word#, Float#, Double#) and ExtendedLiterals+-- types (Int8#, Int16#, etc.).  Plain boxed types (TInteger, TFractional) return+-- False.+isPrimitiveNumericToken :: LexTokenKind -> Bool+isPrimitiveNumericToken k =+  case k of+    TkInteger _ nt -> nt /= TInteger+    TkFloat _ ft -> ft /= TFractional+    _ -> False++lexMinusOperator :: LexerEnv -> LexerState -> Text -> Bool -> Maybe (LexToken, LexerState)+lexMinusOperator env st rest prevAllows+  | not (hasExt LexicalNegation env) = Nothing+  | otherwise =+      let st' = advanceChars "-" st+          kind =+            if prevAllows && canStartNegatedAtom rest+              then TkPrefixMinus+              else TkMinusOperator+       in Just (mkToken st st' "-" kind, st')++allowsMergeOrPrefix :: Maybe LexTokenKind -> Bool -> Bool+allowsMergeOrPrefix prev hadTrivia =+  case prev of+    Nothing -> True+    Just _ | hadTrivia -> True+    Just prevKind -> prevTokenAllowsTightPrefix prevKind++prevTokenAllowsTightPrefix :: LexTokenKind -> Bool+prevTokenAllowsTightPrefix kind =+  case kind of+    TkTHTypeQuoteOpen -> True+    TkTHExpQuoteOpen -> True+    TkTHTypedQuoteOpen -> True+    TkTHDeclQuoteOpen -> True+    TkTHPatQuoteOpen -> True+    TkSpecialLParen -> True+    TkSpecialLBracket -> True+    TkSpecialLBrace -> True+    TkSpecialComma -> True+    TkSpecialSemicolon -> True+    TkVarSym _ -> True+    TkConSym _ -> True+    TkQVarSym _ _ -> True+    TkQConSym _ _ -> True+    TkMinusOperator -> True+    TkPrefixMinus -> True+    TkReservedEquals -> True+    TkReservedLeftArrow -> True+    TkReservedRightArrow -> True+    TkReservedDoubleArrow -> True+    TkReservedDoubleColon -> True+    TkReservedPipe -> True+    TkReservedBackslash -> True+    TkTypeApp -> True+    TkPragma _ -> True+    _ -> False++-- | Returns True for tokens after which a '.' can begin a record field access+-- or a projection section. This includes expression-ending tokens (the+-- 'not prevTokenAllowsTightPrefix' cases) and '(' for projection sections+-- like @(.field)@.+prevTokenAllowsRecordDot :: LexTokenKind -> Bool+prevTokenAllowsRecordDot TkSpecialLParen = True+prevTokenAllowsRecordDot kind =+  not (tokenEndsWithHash kind) && not (prevTokenAllowsTightPrefix kind)++-- | Bare @#.@ is an operator continuation, not record-dot syntax.  Require+-- parentheses around hash-ending tokens before field access, e.g. @('a'#).x@.+tokenEndsWithHash :: LexTokenKind -> Bool+tokenEndsWithHash kind =+  case kind of+    TkInteger _ nt -> nt /= TInteger+    TkFloat _ ft -> ft /= TFractional+    TkCharHash {} -> True+    TkStringHash {} -> True+    TkVarId name -> T.isSuffixOf "#" name+    TkConId name -> T.isSuffixOf "#" name+    TkQVarId _ name -> T.isSuffixOf "#" name+    TkQConId _ name -> T.isSuffixOf "#" name+    _ -> False++canStartNegatedAtom :: Text -> Bool+canStartNegatedAtom rest =+  case rest of+    c :< _+      | isIdentStart c -> True+      | isDigit c -> True+      | c == '\'' -> True+      | c == '"' -> True+      | c == '(' -> True+      | c == '[' -> True+      | c == '\\' -> True+      | c == '-' -> True+      | otherwise -> False+    _ -> False++lexTypeApplication :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexTypeApplication _env st =+  case lexerInput st of+    '@' :< rest+      | startsWithSplice rest -> Just (emitToken st "@" TkTypeApp)+      | not (startsWithSymOp rest) ->+          -- GHC lexes visible type application syntax based on layout, not on+          -- whether TypeApplications is enabled. Extension validity is checked+          -- later, after parsing.+          if lexerHadTrivia st+            then+              let kind+                    | canStartTypeAtomT rest = TkTypeApp+                    | otherwise = TkVarSym "@"+               in Just (emitToken st "@" kind)+            else Just (emitToken st "@" TkReservedAt)+    _ -> Nothing+  where+    canStartTypeAtomT t =+      case t of+        c :< _+          | isIdentStart c -> True+          | isDigit c -> True+          | c == '(' -> True+          | c == '[' -> True+          | c == '_' -> True+          | c == '\'' -> True+          | c == '"' -> True+        _ -> False+    startsWithSplice t =+      case t of+        '$' :< ('$' :< rest) -> canStartSpliceAtomT rest+        '$' :< rest -> canStartSpliceAtomT rest+        _ -> False+    canStartSpliceAtomT t =+      case t of+        c :< _ -> isIdentStart c || c == '('+        _ -> False++lexOverloadedLabel :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexOverloadedLabel env st+  | not (hasExt OverloadedLabels env) = Nothing+  | otherwise =+      case lexerInput st of+        '#' :< rest+          | Just (label, raw) <- parseOverloadedLabel rest ->+              let fullRaw = "#" <> raw+                  st' = advanceChars fullRaw st+               in Just (mkToken st st' fullRaw (TkOverloadedLabel label fullRaw), st')+          | "\"" `T.isPrefixOf` rest ->+              let consumed = "#" <> takeMalformedString rest+                  st' = advanceChars consumed st+               in Just (mkErrorToken st st' consumed "invalid overloaded label", st')+        _ -> Nothing+  where+    parseOverloadedLabel chars =+      case chars of+        '"' :< rest ->+          case scanQuoted '"' rest of+            Right (body, _) ->+              let raw = "\"" <> body <> "\""+                  decoded =+                    case reads (T.unpack raw) of+                      [(str, "")] | not (null str) -> Just (T.pack str)+                      _ -> Nothing+               in (,raw) <$> decoded+            Left _ -> Nothing+        c :< rest+          | isVarIdentifierStartChar c ->+              let label = T.take (1 + T.length (T.takeWhile isIdentTail rest)) chars+               in Just (label, label)+        _ -> Nothing++    takeMalformedString chars =+      case scanQuoted '"' (T.drop 1 chars) of+        Right (body, _) -> "\"" <> body <> "\""+        Left raw -> "\"" <> raw++lexBangOrTildeOperator :: LexerState -> Maybe (LexToken, LexerState)+lexBangOrTildeOperator st =+  case lexerInput st of+    '!' :< rest -> lexPrefixSensitiveOp st '!' TkPrefixBang rest+    '~' :< rest -> lexPrefixSensitiveOp st '~' TkPrefixTilde rest+    '%' :< rest -> lexPrefixSensitiveOp st '%' TkPrefixPercent rest+    _ -> Nothing++isPrefixPosition :: LexerState -> Bool+isPrefixPosition st =+  case lexerPrevTokenKind st of+    Nothing -> True+    Just prevKind+      | lexerHadTrivia st -> True+      | otherwise -> prevTokenAllowsTightPrefix prevKind++lexPrefixDollar :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexPrefixDollar env st+  | not (hasExt TemplateHaskellQuotes env || hasExt TemplateHaskell env) = Nothing+  | otherwise =+      case lexerInput st of+        '$' :< ('$' :< rest)+          | not (startsWithSymOp rest),+            isPrefixPosition st,+            canStartSpliceAtomT rest ->+              Just (emitToken st "$$" TkTHTypedSplice)+        '$' :< rest+          | not (startsWithSymOp rest),+            isPrefixPosition st,+            canStartSpliceAtomT rest ->+              Just (emitToken st "$" TkTHSplice)+        _ -> Nothing+  where+    canStartSpliceAtomT t =+      case t of+        c :< _ -> isIdentStart c || c == '('+        _ -> False++lexPrefixSensitiveOp :: LexerState -> Char -> LexTokenKind -> Text -> Maybe (LexToken, LexerState)+lexPrefixSensitiveOp st opChar prefixKind rest+  | startsWithSymOp rest = Nothing+  | isPrefixPosition st && canStartPrefixPatternAtom rest =+      Just (emitToken st (T.singleton opChar) prefixKind)+  | otherwise = Nothing++canStartPrefixPatternAtom :: Text -> Bool+canStartPrefixPatternAtom rest =+  case rest of+    c :< _+      | isIdentStart c -> True+      | isDigit c -> True+      | c == '\'' -> True+      | c == '"' -> True+      | c == '(' -> True+      | c == '[' -> True+      | c == '_' -> True+      | c == '!' -> True+      | c == '~' -> True+      | c == '$' -> True+      | otherwise -> False+    _ -> False++lexOperator :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexOperator env st =+  let inp = lexerInput st+      opText = T.takeWhile isSymbolicOpChar inp+      hasArrows = hasExt Arrows env+   in case opText of+        Empty -> Nothing+        c :< _ ->+          case (hasArrows, opText, T.drop (T.length opText) inp) of+            (True, "|", ')' :< _) ->+              let bananaText = "|)"+                  st' = advanceChars bananaText st+               in Just (mkToken st st' bananaText TkBananaClose, st')+            _+              | opText == ".",+                not (lexerHadTrivia st),+                Just prevKind <- lexerPrevTokenKind st,+                tokenEndsWithHash prevKind,+                nextC :< _ <- T.drop 1 inp,+                isVarIdentifierStartChar nextC ->+                  let st' = advanceChars opText st+                   in Just (mkErrorToken st st' opText "unexpected record-dot access after hash-ending token", st')+            _+              | hasExt OverloadedRecordDot env,+                opText == ".",+                not (lexerHadTrivia st),+                Just prevKind <- lexerPrevTokenKind st,+                prevTokenAllowsRecordDot prevKind,+                nextC :< _ <- T.drop 1 inp,+                isVarIdentifierStartChar nextC ->+                  let st' = advanceChars opText st+                   in Just (mkToken st st' opText TkRecordDot, st')+            _ ->+              let st' = advanceChars opText st+                  hasUnicode = hasExt UnicodeSyntax env+                  kind =+                    case reservedOpTokenKind opText of+                      Just reserved -> reserved+                      Nothing+                        | hasArrows, Just arrowKind <- arrowOpTokenKind opText -> arrowKind+                        | hasUnicode -> unicodeOpTokenKind hasArrows opText c+                        | c == ':' -> TkConSym opText+                        | otherwise -> TkVarSym opText+               in Just (mkToken st st' opText kind, st')++unicodeOpTokenKind :: Bool -> Text -> Char -> LexTokenKind+unicodeOpTokenKind hasArrows txt firstChar+  | txt == "∷" = TkReservedDoubleColon+  | txt == "⇒" = TkReservedDoubleArrow+  | txt == "→" = TkReservedRightArrow+  | txt == "←" = TkReservedLeftArrow+  | txt == "∀" = TkKeywordForall+  | txt == "⤙" = if hasArrows then TkArrowTail else TkVarSym "-<"+  | txt == "⤚" = if hasArrows then TkArrowTailReverse else TkVarSym ">-"+  | txt == "⤛" = if hasArrows then TkDoubleArrowTail else TkVarSym "-<<"+  | txt == "⤜" = if hasArrows then TkDoubleArrowTailReverse else TkVarSym ">>-"+  | txt == "⦇" = if hasArrows then TkBananaOpen else TkVarSym "(|"+  | txt == "⦈" = if hasArrows then TkBananaClose else TkVarSym "|)"+  | txt == "⟦" = TkVarSym "[|"+  | txt == "⟧" = TkVarSym "|]"+  | txt == "⊸" = TkLinearArrow+  | firstChar == ':' = TkConSym txt+  | otherwise = TkVarSym txt++lexSymbol :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexSymbol env st =+  firstTextKind st symbols+  where+    symbols =+      ( if hasExt UnboxedTuples env || hasExt UnboxedSums env+          then [("(#", TkSpecialUnboxedLParen), ("#)", TkSpecialUnboxedRParen)]+          else []+      )+        <> [("(|", TkBananaOpen) | hasExt Arrows env, bananaOpenAllowed]+        <> [ ("(", TkSpecialLParen),+             (")", TkSpecialRParen),+             ("[", TkSpecialLBracket),+             ("]", TkSpecialRBracket),+             ("{", TkSpecialLBrace),+             ("}", TkSpecialRBrace),+             (",", TkSpecialComma),+             (";", TkSpecialSemicolon),+             ("`", TkSpecialBacktick)+           ]++    bananaOpenAllowed =+      case T.drop 2 (lexerInput st) of+        c :< _ -> not (isSymbolicOpChar c)+        _ -> True++isValidCharLiteral :: Text -> Bool+isValidCharLiteral chars =+  case scanQuoted '\'' chars of+    Right (body, _) -> isJust (readMaybeChar ("'" <> body <> "'"))+    Left _ -> False++lexPromotedQuote :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexPromotedQuote _env st =+  case lexerInput st of+    '\'' :< rest+      | isValidCharLiteral rest -> Nothing+      | isPromotionStart rest ->+          let st' = advanceChars "'" st+           in Just (mkToken st st' "'" (TkVarSym "'"), st')+      | otherwise -> Nothing+    _ -> Nothing+  where+    isPromotionStart chars =+      case skipHorizontalWhitespace chars of+        c :< _+          | c == '[' -> True+          | c == '(' -> True+          | c == ':' -> True+          | isConIdStart c -> True+          | isSymbolicOpChar c -> True+        _ -> False++    skipHorizontalWhitespace = T.dropWhile (\c -> c == ' ' || c == '\t')++lexChar :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexChar env st =+  case lexerInput st of+    '\'' :< rest ->+      case scanQuoted '\'' rest of+        Right (body, _) ->+          let rawT = "'" <> body <> "'"+           in case readMaybeChar rawT of+                Just c ->+                  let (tokTxt, tokKind, st') =+                        withOptionalMagicHashSuffix 1 env st rawT (TkChar c) (TkCharHash c)+                   in Just (mkToken st st' tokTxt tokKind, st')+                Nothing ->+                  let st' = advanceChars rawT st+                   in Just (mkErrorToken st st' rawT "invalid char literal", st')+        Left raw ->+          let full = "'" <> raw+              st' = advanceChars full st+           in Just (mkErrorToken st st' full "unterminated char literal", st')+    _ -> Nothing++lexString :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexString env st =+  let inp = lexerInput st+   in case T.stripPrefix "\"\"\"" inp of+        Just restText | hasExt MultilineStrings env ->+          case scanMultilineString restText of+            Right (body, _) ->+              let raw = "\"\"\"" <> body <> "\"\"\""+                  decoded = T.pack (processMultilineString (T.unpack body))+                  (tokTxt, tokKind, st') =+                    withOptionalMagicHashSuffix 1 env st raw (TkString decoded) (TkStringHash decoded)+               in Just (mkToken st st' tokTxt tokKind, st')+            Left raw ->+              let full = "\"\"\"" <> raw+                  st' = advanceChars full st+               in Just (mkErrorToken st st' full "unterminated multiline string literal", st')+        _ ->+          case inp of+            '"' :< rest ->+              case scanQuoted '"' rest of+                Right (body, _) ->+                  let rawT = "\"" <> body <> "\""+                      decoded = fromMaybe body (decodeStringBody body)+                      (tokTxt, tokKind, st') =+                        withOptionalMagicHashSuffix 1 env st rawT (TkString decoded) (TkStringHash decoded)+                   in Just (mkToken st st' tokTxt tokKind, st')+                Left raw ->+                  let full = "\"" <> raw+                      st' = advanceChars full st+                   in Just (mkErrorToken st st' full "unterminated string literal", st')+            _ -> Nothing++lexQuasiQuote :: LexerState -> Maybe (LexToken, LexerState)+lexQuasiQuote st =+  case lexerInput st of+    '[' :< rest ->+      case parseQuasiQuote rest of+        Just (quoter, body) ->+          let raw = "[" <> quoter <> "|" <> body <> "|]"+              st' = advanceChars raw st+           in Just (mkToken st st' raw (TkQuasiQuote quoter body), st')+        Nothing -> Nothing+    _ -> Nothing+  where+    parseQuasiQuote chars =+      let (quoter, rest0) = takeQuoter chars+       in if T.null quoter+            then Nothing+            else case rest0 of+              '|' :< rest1 ->+                let (body, rest2) = T.breakOn "|]" rest1+                 in if T.null rest2+                      then Nothing+                      else Just (quoter, body)+              _ -> Nothing++emitToken :: LexerState -> Text -> LexTokenKind -> (LexToken, LexerState)+emitToken st raw kind =+  let st' = advanceChars raw st+   in (mkToken st st' raw kind, st')++firstTextKind :: LexerState -> [(Text, LexTokenKind)] -> Maybe (LexToken, LexerState)+firstTextKind _ [] = Nothing+firstTextKind st ((sym, kind) : rest)+  | sym `T.isPrefixOf` lexerInput st = Just (emitToken st sym kind)+  | otherwise = firstTextKind st rest++lexTHQuoteBracket :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexTHQuoteBracket env st+  | not (thBracketQuotesEnabled env) = Nothing+  | otherwise =+      case lexerInput st of+        '[' :< _ -> firstTextKind st brackets+        _ -> Nothing+  where+    brackets =+      [ ("[e||", TkTHTypedQuoteOpen),+        ("[||", TkTHTypedQuoteOpen),+        ("[e|", TkTHExpQuoteOpen),+        ("[|", TkTHExpQuoteOpen),+        ("[d|", TkTHDeclQuoteOpen),+        ("[t|", TkTHTypeQuoteOpen),+        ("[p|", TkTHPatQuoteOpen)+      ]++lexTHCloseQuote :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexTHCloseQuote env st+  | not (thBracketQuotesEnabled env) = Nothing+  | "||]" `T.isPrefixOf` lexerInput st = Just (emitToken st "||]" TkTHTypedQuoteClose)+  | "|]" `T.isPrefixOf` lexerInput st = Just (emitToken st "|]" TkTHExpQuoteClose)+  | otherwise = Nothing++lexTHNameQuote :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexTHNameQuote env st+  | not (thNameQuotesEnabled env) = Nothing+  | otherwise =+      case lexerInput st of+        '\'' :< ('\'' :< rest)+          | Just c <- nextNonTriviaChar rest,+            isIdentStart c || c == '(' || c == '[' ->+              Just (emitToken st "''" TkTHTypeQuoteTick)+        '\'' :< rest0+          | not (isValidCharLiteral rest0) ->+              Just (emitToken st "'" TkTHQuoteTick)+        _ -> Nothing+  where+    nextNonTriviaChar chars =+      case skipTrivia (st {lexerInput = chars}) of+        SkipDone st' ->+          case lexerInput st' of+            c :< _ -> Just c+            _ -> Nothing+        SkipToken _ st' ->+          case lexerInput st' of+            c :< _ -> Just c+            _ -> Nothing++thBracketQuotesEnabled :: LexerEnv -> Bool+thBracketQuotesEnabled env =+  hasExt TemplateHaskellQuotes env+    || hasExt TemplateHaskell env++thNameQuotesEnabled :: LexerEnv -> Bool+thNameQuotesEnabled = thBracketQuotesEnabled++lexErrorToken :: LexerState -> Text -> (LexToken, LexerState)+lexErrorToken st msg =+  let rawTxt =+        case lexerInput st of+          c :< _ -> T.singleton c+          _ -> "<eof>"+      st' = if T.null rawTxt || rawTxt == "<eof>" then st else advanceChars rawTxt st+   in (mkErrorToken st st' rawTxt msg, st')++eofToken :: LexerState -> LexToken+eofToken st =+  let eofSpan =+        SourceSpan+          { sourceSpanSourceName = lexerLogicalSourceName st,+            sourceSpanStartLine = lexerLine st,+            sourceSpanStartCol = lexerCol st,+            sourceSpanEndLine = lexerLine st,+            sourceSpanEndCol = lexerCol st,+            sourceSpanStartOffset = lexerByteOffset st,+            sourceSpanEndOffset = lexerByteOffset st+          }+   in LexToken+        { lexTokenKind = TkEOF,+          lexTokenText = "",+          lexTokenSpan = eofSpan,+          lexTokenOrigin = FromSource,+          lexTokenAtLineStart = lexerAtLineStart st+        }++takeQuoter :: Text -> (Text, Text)+takeQuoter input =+  case input of+    c :< rest+      | isIdentStart c ->+          let tailChars = T.takeWhile isIdentTail rest+              firstSeg = T.take (1 + T.length tailChars) input+              rest0 = T.drop (T.length tailChars) rest+           in go (T.length firstSeg) rest0+    _ -> ("", input)+  where+    go !n chars =+      case chars of+        '.' :< (c' :< more)+          | isIdentStart c' ->+              let tailChars = T.takeWhile isIdentTail more+                  segLen = 1 + 1 + T.length tailChars+               in go (n + segLen) (T.drop (T.length tailChars) more)+        _ -> (T.take n input, chars)++isIdentStart :: Char -> Bool+isIdentStart c = isAsciiUpper c || isAsciiLower c || c == '_' || isUniSmall c || isUniLarge c || isUniOtherLetter c++isVarIdentifierStartChar :: Char -> Bool+isVarIdentifierStartChar c = c == '_' || isAsciiLower c || isUniSmall c++isIdentTail :: Char -> Bool+isIdentTail c = isIdentStart c || isIdentContinue c || c == '\''++isConIdStart :: Char -> Bool+isConIdStart c = isAsciiUpper c || isUniLarge c++isUniSmall :: Char -> Bool+isUniSmall c = not (isAscii c) && generalCategory c `elem` [LowercaseLetter, OtherLetter]++isUniLarge :: Char -> Bool+isUniLarge c = not (isAscii c) && generalCategory c `elem` [UppercaseLetter, TitlecaseLetter]++isUniOtherLetter :: Char -> Bool+isUniOtherLetter c = not (isAscii c) && generalCategory c == OtherLetter++isIdentNumber :: Char -> Bool+isIdentNumber c =+  isDigit c+    || generalCategory c == DecimalNumber+    || generalCategory c == OtherNumber++isIdentContinue :: Char -> Bool+isIdentContinue c =+  case generalCategory c of+    LetterNumber -> True+    ModifierLetter -> True+    NonSpacingMark -> True+    _ -> isIdentNumber c++startsWithSymOp :: Text -> Bool+startsWithSymOp t =+  case t of+    c :< _ -> isSymbolicOpChar c+    _ -> False++keywordTokenKind :: Set Extension -> Text -> Maybe LexTokenKind+keywordTokenKind exts txt =+  case txt of+    "case" -> Just TkKeywordCase+    "class" -> Just TkKeywordClass+    "data" -> Just TkKeywordData+    "default" -> Just TkKeywordDefault+    "deriving" -> Just TkKeywordDeriving+    "do" -> Just TkKeywordDo+    "else" -> Just TkKeywordElse+    "forall" -> Just TkKeywordForall+    "foreign" -> Just TkKeywordForeign+    "if" -> Just TkKeywordIf+    "import" -> Just TkKeywordImport+    "in" -> Just TkKeywordIn+    "infix" -> Just TkKeywordInfix+    "infixl" -> Just TkKeywordInfixl+    "infixr" -> Just TkKeywordInfixr+    "instance" -> Just TkKeywordInstance+    "let" -> Just TkKeywordLet+    "module" -> Just TkKeywordModule+    "newtype" -> Just TkKeywordNewtype+    "of" -> Just TkKeywordOf+    "then" -> Just TkKeywordThen+    "type" -> Just TkKeywordType+    "where" -> Just TkKeywordWhere+    "_" -> Just TkKeywordUnderscore+    "proc" | Set.member Arrows exts -> Just TkKeywordProc+    "rec" | Set.member Arrows exts || Set.member RecursiveDo exts -> Just TkKeywordRec+    "mdo" | Set.member RecursiveDo exts -> Just TkKeywordMdo+    "pattern" | Set.member PatternSynonyms exts -> Just TkKeywordPattern+    "by" | Set.member TransformListComp exts -> Just TkKeywordBy+    "using" | Set.member TransformListComp exts -> Just TkKeywordUsing+    _ -> Nothing++reservedOpTokenKind :: Text -> Maybe LexTokenKind+reservedOpTokenKind txt =+  case txt of+    ".." -> Just TkReservedDotDot+    ":" -> Just TkReservedColon+    "::" -> Just TkReservedDoubleColon+    "=" -> Just TkReservedEquals+    "\\" -> Just TkReservedBackslash+    "|" -> Just TkReservedPipe+    "<-" -> Just TkReservedLeftArrow+    "->" -> Just TkReservedRightArrow+    "@" -> Just TkReservedAt+    "=>" -> Just TkReservedDoubleArrow+    _ -> Nothing++arrowOpTokenKind :: Text -> Maybe LexTokenKind+arrowOpTokenKind txt =+  case txt of+    "-<" -> Just TkArrowTail+    ">-" -> Just TkArrowTailReverse+    "-<<" -> Just TkDoubleArrowTail+    ">>-" -> Just TkDoubleArrowTailReverse+    _ -> Nothing
+ src/Aihc/Parser/Lex/Header.hs view
@@ -0,0 +1,53 @@+module Aihc.Parser.Lex.Header+  ( readModuleHeaderExtensionsFromTokens,+    separateEditionAndExtensions,+  )+where++import Aihc.Parser.Lex.Types+import Aihc.Parser.Syntax+import Data.List qualified as List++readModuleHeaderExtensionsFromTokens :: [LexToken] -> [ExtensionSetting]+readModuleHeaderExtensionsFromTokens = go+  where+    go toks =+      case toks of+        LexToken {lexTokenKind = TkPragma Pragma {pragmaType = PragmaLanguage settings}} : rest -> settings <> go rest+        LexToken {lexTokenKind = TkPragma Pragma {pragmaType = PragmaWarning _}} : rest -> go rest+        LexToken {lexTokenKind = TkPragma Pragma {pragmaType = PragmaDeprecated _}} : rest -> go rest+        LexToken {lexTokenKind = TkPragma Pragma {pragmaType = PragmaUnknown _}} : rest -> go rest+        LexToken {lexTokenKind = TkLineComment} : rest -> go rest+        LexToken {lexTokenKind = TkBlockComment} : rest -> go rest+        LexToken {lexTokenKind = TkError _} : _ -> []+        _ -> []++separateEditionAndExtensions :: [ExtensionSetting] -> ModuleHeaderPragmas+separateEditionAndExtensions settings =+  let (editions, extensions) = List.partition isEditionSetting settings+      lastEdition = case reverse editions of+        EnableExtension ext : _ -> extensionToEdition ext+        _ -> Nothing+   in ModuleHeaderPragmas+        { headerLanguageEdition = lastEdition,+          headerExtensionSettings = extensions+        }++isEditionSetting :: ExtensionSetting -> Bool+isEditionSetting setting =+  case setting of+    EnableExtension ext -> isEditionExtension ext+    DisableExtension ext -> isEditionExtension ext++isEditionExtension :: Extension -> Bool+isEditionExtension ext =+  ext `elem` [Haskell98, Haskell2010, GHC2021, GHC2024]++extensionToEdition :: Extension -> Maybe LanguageEdition+extensionToEdition ext =+  case ext of+    Haskell98 -> Just Haskell98Edition+    Haskell2010 -> Just Haskell2010Edition+    GHC2021 -> Just GHC2021Edition+    GHC2024 -> Just GHC2024Edition+    _ -> Nothing
+ src/Aihc/Parser/Lex/Layout.hs view
@@ -0,0 +1,476 @@+{-# LANGUAGE OverloadedStrings #-}++module Aihc.Parser.Lex.Layout+  ( applyLayoutTokens,+    layoutTransition,+    closeImplicitLayoutContext,+  )+where++import Aihc.Parser.Lex.Types+import Aihc.Parser.Syntax (Extension, SourceSpan (..))+import Data.Maybe (fromMaybe)++ordinaryLayout :: ImplicitLayoutSpec+ordinaryLayout =+  ImplicitLayoutSpec+    { implicitLayoutSemicolons = LayoutEmitSemicolons,+      implicitLayoutIndentPolicy = LayoutAllowNondecreasingIndent,+      implicitLayoutBaseline = LayoutCurrentIndent,+      implicitLayoutChildBaseline = LayoutCurrentIndent,+      implicitLayoutThenElseDepth = Nothing,+      implicitLayoutFlushEmptyAtEOF = False+    }++strictLayout :: ImplicitLayoutSpec+strictLayout = ordinaryLayout {implicitLayoutIndentPolicy = LayoutStrictIndent}++caseAlternativeLayout :: LayoutState -> ImplicitLayoutSpec+caseAlternativeLayout st =+  strictLayout+    { implicitLayoutBaseline = currentChildBaseline (layoutContexts st),+      implicitLayoutFlushEmptyAtEOF = True+    }++multiWayIfLayout :: ImplicitLayoutSpec+multiWayIfLayout =+  strictLayout+    { implicitLayoutSemicolons = LayoutSuppressSemicolons+    }++thenElseDoLayout :: ImplicitLayoutSpec+thenElseDoLayout =+  ordinaryLayout+    { implicitLayoutThenElseDepth = Just 0+    }++thDeclQuoteLayout :: ImplicitLayoutSpec+thDeclQuoteLayout =+  strictLayout+    { implicitLayoutChildBaseline = LayoutColumnZero+    }++applyLayoutTokens :: Bool -> [Extension] -> [LexToken] -> [LexToken]+applyLayoutTokens enableModuleLayout exts =+  go (mkInitialLayoutState enableModuleLayout exts)+  where+    go st toks =+      case toks of+        [] ->+          let eofAnchor = NoSourceSpan+              (moduleInserted, stAfterModule) = finalizeModuleLayoutAtEOF st eofAnchor+              (pendingInserted, stAfterPending) = flushPendingCaseLayoutAtEOF stAfterModule eofAnchor+           in moduleInserted <> pendingInserted <> closeAllImplicit (layoutContexts stAfterPending) eofAnchor+        tok : rest ->+          let (emitted, stNext) = layoutTransition st tok+           in emitted <> go stNext rest++finalizeModuleLayoutAtEOF :: LayoutState -> SourceSpan -> ([LexToken], LayoutState)+finalizeModuleLayoutAtEOF st anchor =+  case layoutModuleMode st of+    mode+      | mode == ModuleLayoutSeekStart || mode == ModuleLayoutAwaitBody ->+          ( [virtualSymbolToken "{" anchor, virtualSymbolToken "}" anchor],+            st {layoutModuleMode = ModuleLayoutDone, layoutPendingLayout = Nothing}+          )+    _ -> ([], st)++{-# INLINE noteModuleLayoutBeforeToken #-}+noteModuleLayoutBeforeToken :: LayoutState -> LexToken -> LayoutState+noteModuleLayoutBeforeToken st tok =+  case layoutModuleMode st of+    ModuleLayoutAwaitBody -> st {layoutModuleMode = ModuleLayoutDone}+    ModuleLayoutSeekStart ->+      case lexTokenKind tok of+        TkPragma _ -> st+        TkLineComment -> st+        TkBlockComment -> st+        TkKeywordModule -> st {layoutModuleMode = ModuleLayoutAwaitWhere}+        _ -> st {layoutModuleMode = ModuleLayoutDone, layoutPendingLayout = Just (PendingImplicitLayout ordinaryLayout)}+    _ -> st++{-# INLINE noteModuleLayoutAfterToken #-}+noteModuleLayoutAfterToken :: LayoutState -> LexToken -> LayoutState+noteModuleLayoutAfterToken st tok =+  case layoutModuleMode st of+    ModuleLayoutAwaitWhere+      | lexTokenKind tok == TkKeywordWhere ->+          st {layoutModuleMode = ModuleLayoutAwaitBody, layoutPendingLayout = Just (PendingImplicitLayout ordinaryLayout)}+    _ -> st++{-# INLINE openPendingLayout #-}+openPendingLayout :: LayoutState -> LexToken -> ([LexToken], LayoutState, Bool)+openPendingLayout st tok =+  case layoutPendingLayout st of+    Nothing -> ([], st, False)+    Just pending ->+      case pending of+        PendingMaybeMultiWayIf ->+          case lexTokenKind tok of+            TkReservedPipe -> openImplicitLayout multiWayIfLayout st tok+            _ -> ([], noteClassicIfInAfterThenElse (st {layoutPendingLayout = Nothing}), False)+        PendingMaybeLambdaCases ->+          case lexTokenKind tok of+            TkSpecialLBrace -> ([], st {layoutPendingLayout = Nothing}, False)+            tkKind+              | closesDelimiter tkKind ->+                  let anchor = lexTokenSpan tok+                      openTok = virtualSymbolToken "{" anchor+                      closeTok = virtualSymbolToken "}" anchor+                   in ([openTok, closeTok], st {layoutPendingLayout = Nothing}, False)+            _ -> openImplicitLayout (caseAlternativeLayout st) st tok+        PendingImplicitLayout spec ->+          case lexTokenKind tok of+            TkSpecialLBrace -> ([], st {layoutPendingLayout = Nothing}, False)+            tkKind+              | closesDelimiter tkKind ->+                  -- Closing delimiter immediately after layout-opener (e.g. [d| |])+                  -- produces empty implicit layout {}, then the closer proceeds normally.+                  let anchor = lexTokenSpan tok+                      openTok = virtualSymbolToken "{" anchor+                      closeTok = virtualSymbolToken "}" anchor+                   in ([openTok, closeTok], st {layoutPendingLayout = Nothing}, False)+            _ -> openImplicitLayout spec st tok++openImplicitLayout :: ImplicitLayoutSpec -> LayoutState -> LexToken -> ([LexToken], LayoutState, Bool)+openImplicitLayout spec st tok =+  let col = tokenStartCol tok+      parentIndent =+        case implicitLayoutBaseline spec of+          LayoutCurrentIndent -> currentLayoutIndent (layoutContexts st)+          LayoutColumnZero -> 0+      openTok = virtualSymbolToken "{" (lexTokenSpan tok)+      closeTok = virtualSymbolToken "}" (lexTokenSpan tok)+      newContext =+        LayoutImplicit+          LayoutFrame+            { layoutFrameIndent = col,+              layoutFrameSemicolons = implicitLayoutSemicolons spec,+              layoutFrameChildBaseline = implicitLayoutChildBaseline spec,+              layoutFrameThenElseDepth = implicitLayoutThenElseDepth spec+            }+      opensEmpty =+        case implicitLayoutIndentPolicy spec of+          LayoutAllowNondecreasingIndent+            | layoutNondecreasingIndent st -> col < parentIndent+          _ -> col <= parentIndent+   in if opensEmpty+        then ([openTok, closeTok], st {layoutPendingLayout = Nothing}, False)+        else+          ( [openTok],+            st+              { layoutPendingLayout = Nothing,+                layoutContexts = newContext : layoutContexts st+              },+            True+          )++{-# INLINE closeBeforeToken #-}+closeBeforeToken :: LayoutState -> LexToken -> ([LexToken], LayoutState)+closeBeforeToken st tok =+  case lexTokenKind tok of+    kind+      | closesImplicitBeforeDelimiter kind ->+          let (pendingInserted, st0) = flushPendingImplicitLayout st anchor+              (inserted, ctxs') = closeImplicitLayouts anchor (\_ _ -> True) (layoutContexts st0)+           in (pendingInserted <> inserted, st0 {layoutContexts = ctxs'})+      | closesImplicitBeforeLayoutKeyword kind ->+          closeBeforeLayoutKeyword+    _ -> ([], st)+  where+    anchor = lexTokenSpan tok++    closeBeforeLayoutKeyword =+      let col = tokenStartCol tok+          (pendingInserted, st0) = flushPendingImplicitLayout st anchor+          (inserted, ctxs') = closeImplicitLayouts anchor (shouldClose col) (layoutContexts st0)+       in (pendingInserted <> inserted, st0 {layoutContexts = ctxs'})++    shouldClose col indent kind =+      col < indent || (col == indent && closesSameColumnLayout kind)++    closesSameColumnLayout kind =+      case (lexTokenKind tok, kind) of+        (TkKeywordThen, LayoutFrame {layoutFrameThenElseDepth = Just nestedIfs}) -> nestedIfs == 0+        (TkKeywordElse, LayoutFrame {layoutFrameThenElseDepth = Just nestedIfs}) -> nestedIfs == 0+        (TkKeywordThen, _) -> False+        (TkKeywordElse, _) -> False+        _ -> True++flushPendingImplicitLayout :: LayoutState -> SourceSpan -> ([LexToken], LayoutState)+flushPendingImplicitLayout st anchor =+  case layoutPendingLayout st of+    Just (PendingImplicitLayout _) ->+      ( [virtualSymbolToken "{" anchor, virtualSymbolToken "}" anchor],+        st {layoutPendingLayout = Nothing}+      )+    _ -> ([], st)++flushPendingCaseLayoutAtEOF :: LayoutState -> SourceSpan -> ([LexToken], LayoutState)+flushPendingCaseLayoutAtEOF st anchor =+  case layoutPendingLayout st of+    Just (PendingImplicitLayout spec)+      | implicitLayoutFlushEmptyAtEOF spec ->+          ( [virtualSymbolToken "{" anchor, virtualSymbolToken "}" anchor],+            st {layoutPendingLayout = Nothing}+          )+    Just PendingMaybeLambdaCases ->+      ( [virtualSymbolToken "{" anchor, virtualSymbolToken "}" anchor],+        st {layoutPendingLayout = Nothing}+      )+    _ -> ([], st)++{-# INLINE bolLayout #-}+bolLayout :: LayoutState -> LexToken -> ([LexToken], LayoutState)+bolLayout st tok+  | not (isBOL st tok) = ([], st)+  | otherwise =+      let col = tokenStartCol tok+          (inserted, contexts') = closeImplicitLayouts (lexTokenSpan tok) (\indent _ -> col < indent) (layoutContexts st)+          semiAnchor = fromMaybe (lexTokenSpan tok) (layoutPrevTokenEndSpan st)+          eqSemi =+            case currentLayoutIndentMaybe contexts' of+              Just indent+                | col == indent,+                  currentLayoutAllowsSemicolon contexts',+                  lexTokenKind tok /= TkKeywordWhere ->+                    [virtualSymbolToken ";" semiAnchor]+              _ -> []+       in (inserted <> eqSemi, st {layoutContexts = contexts'})++currentLayoutAllowsSemicolon :: [LayoutContext] -> Bool+currentLayoutAllowsSemicolon contexts =+  case contexts of+    LayoutImplicit LayoutFrame {layoutFrameSemicolons = LayoutSuppressSemicolons} : _ -> False+    LayoutImplicit _ : _ -> True+    _ -> False++closeImplicitLayouts :: SourceSpan -> (Int -> LayoutFrame -> Bool) -> [LayoutContext] -> ([LexToken], [LayoutContext])+closeImplicitLayouts anchor shouldClose = go []+  where+    closeTok = virtualSymbolToken "}" anchor++    go acc contexts =+      case contexts of+        LayoutImplicit frame : rest+          | shouldClose (layoutFrameIndent frame) frame -> go (closeTok : acc) rest+        _ -> (reverse acc, contexts)++closeAllImplicit :: [LayoutContext] -> SourceSpan -> [LexToken]+closeAllImplicit contexts anchor =+  [virtualSymbolToken "}" anchor | ctx <- contexts, isImplicitLayoutContext ctx]++{-# INLINE stepTokenContext #-}+stepTokenContext :: LayoutState -> LexToken -> LayoutState+stepTokenContext st tok =+  case lexTokenKind tok of+    TkKeywordDo+      | layoutPrevTokenKind st == Just TkKeywordThen+          || layoutPrevTokenKind st == Just TkKeywordElse ->+          st {layoutPendingLayout = Just (PendingImplicitLayout thenElseDoLayout)}+      | otherwise -> st {layoutPendingLayout = Just (PendingImplicitLayout ordinaryLayout)}+    TkKeywordMdo -> st {layoutPendingLayout = Just (PendingImplicitLayout ordinaryLayout)}+    TkQualifiedDo {}+      | layoutPrevTokenKind st == Just TkKeywordThen+          || layoutPrevTokenKind st == Just TkKeywordElse ->+          st {layoutPendingLayout = Just (PendingImplicitLayout thenElseDoLayout)}+      | otherwise -> st {layoutPendingLayout = Just (PendingImplicitLayout ordinaryLayout)}+    TkQualifiedMdo {} -> st {layoutPendingLayout = Just (PendingImplicitLayout ordinaryLayout)}+    TkKeywordOf -> st {layoutPendingLayout = Just (PendingImplicitLayout (caseAlternativeLayout st))}+    TkKeywordCase+      | layoutPrevTokenKind st == Just TkReservedBackslash ->+          st {layoutPendingLayout = Just (PendingImplicitLayout (caseAlternativeLayout st))}+      | otherwise -> st+    TkVarId "cases"+      | layoutLambdaCase st && layoutPrevTokenKind st == Just TkReservedBackslash ->+          st {layoutPendingLayout = Just PendingMaybeLambdaCases}+      | otherwise -> st+    TkKeywordLet -> st {layoutPendingLayout = Just (PendingImplicitLayout strictLayout)}+    TkKeywordRec -> st {layoutPendingLayout = Just (PendingImplicitLayout ordinaryLayout)}+    TkKeywordWhere -> st {layoutPendingLayout = Just (PendingImplicitLayout strictLayout)}+    TkKeywordElse -> decrementAfterThenElseClassicIfDepth st+    TkKeywordIf -> st {layoutPendingLayout = Just PendingMaybeMultiWayIf}+    TkTHDeclQuoteOpen ->+      st+        { layoutContexts = LayoutDelimiter : layoutContexts st,+          layoutPendingLayout = Just (PendingImplicitLayout thDeclQuoteLayout)+        }+    kind+      | opensDelimiter kind ->+          st {layoutContexts = LayoutDelimiter : layoutContexts st}+    kind+      | closesDelimiter kind ->+          st {layoutContexts = popToDelimiter (layoutContexts st)}+    TkSpecialLBrace -> st {layoutContexts = LayoutExplicit : layoutContexts st}+    TkSpecialRBrace -> st {layoutContexts = popOneContext (layoutContexts st)}+    _ -> st++mapAfterThenElse :: (Int -> Int) -> [LayoutContext] -> [LayoutContext]+mapAfterThenElse f = go+  where+    go contexts =+      case contexts of+        LayoutImplicit frame@LayoutFrame {layoutFrameThenElseDepth = Just nestedIfs} : rest ->+          LayoutImplicit frame {layoutFrameThenElseDepth = Just (f nestedIfs)} : rest+        ctx : rest -> ctx : go rest+        [] -> []++noteClassicIfInAfterThenElse :: LayoutState -> LayoutState+noteClassicIfInAfterThenElse st = st {layoutContexts = mapAfterThenElse (+ 1) (layoutContexts st)}++decrementAfterThenElseClassicIfDepth :: LayoutState -> LayoutState+decrementAfterThenElseClassicIfDepth st = st {layoutContexts = mapAfterThenElse (max 0 . subtract 1) (layoutContexts st)}++popToDelimiter :: [LayoutContext] -> [LayoutContext]+popToDelimiter contexts =+  case contexts of+    LayoutDelimiter : rest -> rest+    _ : rest -> popToDelimiter rest+    [] -> []++popOneContext :: [LayoutContext] -> [LayoutContext]+popOneContext contexts =+  case contexts of+    _ : rest -> rest+    [] -> []++currentLayoutIndent :: [LayoutContext] -> Int+currentLayoutIndent contexts = fromMaybe 0 (currentLayoutIndentMaybe contexts)++currentLayoutIndentMaybe :: [LayoutContext] -> Maybe Int+currentLayoutIndentMaybe contexts =+  case contexts of+    LayoutImplicit LayoutFrame {layoutFrameIndent = indent} : _ -> Just indent+    _ -> Nothing++currentChildBaseline :: [LayoutContext] -> LayoutBaseline+currentChildBaseline contexts =+  case contexts of+    LayoutImplicit LayoutFrame {layoutFrameChildBaseline = baseline} : _ -> baseline+    _ -> LayoutCurrentIndent++isImplicitLayoutContext :: LayoutContext -> Bool+isImplicitLayoutContext ctx =+  case ctx of+    LayoutImplicit _ -> True+    LayoutExplicit -> False+    LayoutDelimiter -> False++-- | Tokens that open a delimiter context (parens, brackets, TH quotes,+-- unboxed parens).  These push 'LayoutDelimiter' to suppress implicit-layout+-- closures inside the delimited group.+--+-- Note: 'TkTHDeclQuoteOpen' is intentionally absent here because it is handled+-- explicitly in 'stepTokenContext', where it both pushes 'LayoutDelimiter' and+-- sets up a pending implicit layout for the declaration splice body.+opensDelimiter :: LexTokenKind -> Bool+opensDelimiter kind =+  case kind of+    TkSpecialLParen -> True+    TkSpecialLBracket -> True+    TkTHExpQuoteOpen -> True+    TkTHTypedQuoteOpen -> True+    TkTHTypeQuoteOpen -> True+    TkTHPatQuoteOpen -> True+    TkSpecialUnboxedLParen -> True+    _ -> False++-- | Tokens that close a delimiter context (parens, brackets, TH quotes,+-- unboxed parens).  These pop the context stack back to the matching+-- 'LayoutDelimiter' via 'popToDelimiter' in 'stepTokenContext'.+--+-- Related: 'closesImplicitBeforeDelimiter' determines which closing tokens+-- also force all intervening implicit layouts to emit virtual @}@ tokens+-- before the delimiter is popped.  'TkSpecialRBrace' is present there (but+-- absent here) because it closes 'LayoutExplicit', not 'LayoutDelimiter'.+closesDelimiter :: LexTokenKind -> Bool+closesDelimiter kind =+  case kind of+    TkSpecialRParen -> True+    TkSpecialUnboxedRParen -> True+    TkSpecialRBracket -> True+    TkTHExpQuoteClose -> True+    TkTHTypedQuoteClose -> True+    _ -> False++-- | Tokens before which all intervening implicit layouts must be closed+-- (emitting virtual @}@ tokens).  See 'closesDelimiter' for the relationship+-- between these two predicates.+closesImplicitBeforeDelimiter :: LexTokenKind -> Bool+closesImplicitBeforeDelimiter kind =+  case kind of+    TkSpecialRParen -> True+    TkSpecialUnboxedRParen -> True+    TkSpecialRBracket -> True+    TkTHExpQuoteClose -> True+    TkTHTypedQuoteClose -> True+    TkSpecialRBrace -> True+    _ -> False++-- | Reserved words that cannot start an item in the currently open layout list.+-- At the same column as that layout they trigger the report's parse-error rule:+-- inserting @}@ makes the keyword legal where inserting @;@ would not.+closesImplicitBeforeLayoutKeyword :: LexTokenKind -> Bool+closesImplicitBeforeLayoutKeyword kind =+  case kind of+    TkKeywordWhere -> True+    TkKeywordIn -> True+    TkKeywordThen -> True+    TkKeywordElse -> True+    _ -> False++isBOL :: LayoutState -> LexToken -> Bool+isBOL _ = lexTokenAtLineStart++layoutTransition :: LayoutState -> LexToken -> ([LexToken], LayoutState)+layoutTransition st tok =+  case lexTokenKind tok of+    TkLineComment -> ([tok], st)+    TkBlockComment -> ([tok], st)+    TkEOF ->+      let eofAnchor = fromMaybe (lexTokenSpan tok) (layoutPrevTokenEndSpan st)+          (moduleInserted, stAfterModule) = finalizeModuleLayoutAtEOF st eofAnchor+          (pendingInserted, stAfterPending) = flushPendingCaseLayoutAtEOF stAfterModule eofAnchor+       in ( moduleInserted <> pendingInserted <> closeAllImplicit (layoutContexts stAfterPending) eofAnchor <> [tok],+            stAfterPending {layoutContexts = [], layoutBuffer = []}+          )+    _ ->+      let stModule = noteModuleLayoutBeforeToken st tok+          (preInserted, stBeforePending) = closeBeforeToken stModule tok+          (pendingInserted, stAfterPending, skipBOL) = openPendingLayout stBeforePending tok+          (bolInserted, stAfterBOL) = if skipBOL then ([], stAfterPending) else bolLayout stAfterPending tok+          stAfterToken = noteModuleLayoutAfterToken (stepTokenContext stAfterBOL tok) tok+          newEndSpan =+            if lexTokenOrigin tok == FromSource+              then Just (lexTokenSpan tok)+              else layoutPrevTokenEndSpan stAfterToken+          stNext =+            stAfterToken+              { layoutPrevTokenKind = Just (lexTokenKind tok),+                layoutPrevTokenEndSpan = newEndSpan,+                layoutBuffer = []+              }+       in (preInserted <> pendingInserted <> bolInserted <> [tok], stNext)++closeImplicitLayoutContext :: LayoutState -> Maybe LayoutState+closeImplicitLayoutContext st =+  case layoutContexts st of+    LayoutImplicit _ : rest -> Just (closeWith rest)+    _ -> Nothing+  where+    anchor = fromMaybe noSpan (layoutPrevTokenEndSpan st)+    noSpan =+      SourceSpan+        { sourceSpanSourceName = "",+          sourceSpanStartLine = 0,+          sourceSpanStartCol = 0,+          sourceSpanEndLine = 0,+          sourceSpanEndCol = 0,+          sourceSpanStartOffset = 0,+          sourceSpanEndOffset = 0+        }+    closeWith rest =+      st+        { layoutContexts = rest,+          layoutBuffer = virtualSymbolToken "}" anchor : layoutBuffer st+        }
+ src/Aihc/Parser/Lex/Numbers.hs view
@@ -0,0 +1,377 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++module Aihc.Parser.Lex.Numbers+  ( lexFloat,+    lexHexFloat,+    lexInt,+    lexIntBase,+    withOptionalMagicHashSuffix,+  )+where++import Aihc.Parser.Lex.Types+import Aihc.Parser.Syntax (Extension (ExtendedLiterals, MagicHash, NumericUnderscores), FloatType (..), NumericType (..))+import Data.Char (digitToInt, isAsciiLower, isAsciiUpper, isDigit, isHexDigit, isOctDigit)+import Data.Maybe (fromMaybe)+import Data.Ratio ((%))+import Data.Text (Text, pattern (:<))+import Data.Text qualified as T+import Numeric (readHex, readInt, readOct)+import Text.Read (readMaybe)++lexIntBase :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexIntBase env st =+  case lexerInput st of+    '0' :< (base :< rest)+      | base `elem` ("xXoObB" :: String) ->+          let allowUnderscores = hasExt NumericUnderscores env+              isDigitChar+                | base `elem` ("xX" :: String) = isHexDigit+                | base `elem` ("oO" :: String) = isOctDigit+                | otherwise = (`elem` ("01" :: String))+              (digitsRaw, _) = takeDigitsWithUnderscores allowUnderscores isDigitChar rest+           in if T.null digitsRaw+                then Nothing+                else+                  let raw = "0" <> T.singleton base <> digitsRaw+                      n+                        | base `elem` ("xX" :: String) = readHexLiteral raw+                        | base `elem` ("oO" :: String) = readOctLiteral raw+                        | otherwise = readBinLiteral raw+                      (tokTxt, tokKind, st') =+                        lexIntSuffix env st raw n+                   in Just (mkToken st st' tokTxt tokKind, st')+    _ -> Nothing++lexHexFloat :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexHexFloat env st =+  case lexerInput st of+    '0' :< (x :< rest1)+      | x `elem` ("xX" :: String),+        let (intDigits, rest2) = T.span isHexDigit rest1,+        not (T.null intDigits) -> do+          let (mFracDigits, rest3) =+                case rest2 of+                  '.' :< more ->+                    let (frac, rest') = T.span isHexDigit more+                     in if T.null frac+                          then (Nothing, rest2)+                          else (Just frac, rest')+                  _ -> (Nothing, rest2)+          case (mFracDigits, takeHexExponent rest3) of+            (Nothing, Nothing) -> Nothing+            (mFrac, mExpo) ->+              let dotAndFrac = maybe "" ("." <>) mFrac+                  expo = fromMaybe "" mExpo+                  fracDigits = fromMaybe "" mFrac+                  raw = "0" <> T.singleton x <> intDigits <> dotAndFrac <> expo+                  value = parseHexFloatLiteral (T.unpack intDigits) (T.unpack fracDigits) (T.unpack expo)+                  (tokTxt, tokKind, st') =+                    lexFloatSuffix env st raw value+               in Just (mkToken st st' tokTxt tokKind, st')+    _ -> Nothing++lexFloat :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexFloat env st =+  let allowUnderscores = hasExt NumericUnderscores env+      input = lexerInput st+      startsWithUnderscore =+        case input of+          '_' :< _ -> True+          _ -> False+      (lhsRaw, rest) = takeDigitsWithUnderscores allowUnderscores isDigit input+   in if T.null lhsRaw || startsWithUnderscore+        then Nothing+        else case rest of+          '.' :< dotRest@(d :< _)+            | isDigit d ->+                let (rhsRaw, rest') = takeDigitsWithUnderscores allowUnderscores isDigit dotRest+                    (expo, _) = takeExponent allowUnderscores rest'+                    raw = lhsRaw <> "." <> rhsRaw <> expo+                    normalized = T.filter (/= '_') raw+                    value = parseDecimalFloatLiteral normalized+                    (tokTxt, tokKind, st') =+                      lexFloatSuffix env st raw value+                 in Just (mkToken st st' tokTxt tokKind, st')+          _ ->+            case takeExponent allowUnderscores rest of+              (expo, _)+                | T.null expo -> Nothing+                | otherwise ->+                    let raw = lhsRaw <> expo+                        normalized = T.filter (/= '_') raw+                        value = parseDecimalFloatLiteral normalized+                        (tokTxt, tokKind, st') =+                          lexFloatSuffix env st raw value+                     in Just (mkToken st st' tokTxt tokKind, st')++lexInt :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)+lexInt env st =+  let allowUnderscores = hasExt NumericUnderscores env+      input = lexerInput st+      startsWithUnderscore =+        case input of+          '_' :< _ -> True+          _ -> False+      (digitsRaw, _) = takeDigitsWithUnderscores allowUnderscores isDigit input+   in if T.null digitsRaw || startsWithUnderscore+        then Nothing+        else+          let digits = T.filter (/= '_') digitsRaw+              n = read (T.unpack digits) :: Integer+              (tokTxt, tokKind, st') =+                lexIntSuffix env st digitsRaw n+           in Just (mkToken st st' tokTxt tokKind, st')++-- | Parse optional MagicHash suffix (# or ##) and return the hash text and new state.+magicHashSuffix :: LexerEnv -> LexerState -> Maybe (Text, LexerState)+magicHashSuffix env st =+  case lexerInput st of+    '#' :< rest+      | hasExt MagicHash env ->+          case rest of+            '#' :< _ -> Just ("##", advanceN 2 st)+            _ -> Just ("#", advanceN 1 st)+    _ -> Nothing++-- | Parse optional MagicHash and ExtendedLiterals suffix for integers.+-- Handles: (nothing), #, ##, #Int8, #Int16, #Int32, #Int64, #Int, #Word8, #Word16, #Word32, #Word64, #Word+lexIntSuffix :: LexerEnv -> LexerState -> Text -> Integer -> (Text, LexTokenKind, LexerState)+lexIntSuffix env st raw n =+  let st' = advanceChars raw st+      input = lexerInput st'+      withMagicHash =+        case magicHashSuffix env st' of+          Just ("##", st'') -> (raw <> "##", TkInteger n TWordHash, st'')+          Just ("#", st'') -> (raw <> "#", TkInteger n TIntHash, st'')+          _ -> (raw, TkInteger n TInteger, st')+   in case input of+        '#' :< rest+          | hasExt ExtendedLiterals env ->+              case parseExtendedIntSuffix rest of+                Just (typeName, suffixLen) ->+                  let fullRaw = raw <> T.take (1 + suffixLen) input+                      st'' = advanceN (1 + suffixLen) st'+                   in (fullRaw, TkInteger n typeName, st'')+                Nothing -> withMagicHash+          | otherwise -> withMagicHash+        _ -> (raw, TkInteger n TInteger, st')++-- | Parse optional MagicHash and ExtendedLiterals suffix for floats.+-- Handles: (nothing), #, ##+lexFloatSuffix :: LexerEnv -> LexerState -> Text -> Rational -> (Text, LexTokenKind, LexerState)+lexFloatSuffix env st raw value =+  let st' = advanceChars raw st+   in case magicHashSuffix env st' of+        Just ("##", st'') -> (raw <> "##", TkFloat value TDoubleHash, st'')+        Just ("#", st'') -> (raw <> "#", TkFloat value TFloatHash, st'')+        _ -> (raw, TkFloat value TFractional, st')++-- | Parse an ExtendedLiterals type suffix after the initial '#'.+-- Returns (NumericType, length of type name without the '#').+-- e.g. "Word8" -> (TWord8Hash, 5), "Int" -> (TIntHash, 3)+parseExtendedIntSuffix :: Text -> Maybe (NumericType, Int)+parseExtendedIntSuffix input =+  case matchType input of+    Just ("Int8", len) -> Just (TInt8Hash, len)+    Just ("Int16", len) -> Just (TInt16Hash, len)+    Just ("Int32", len) -> Just (TInt32Hash, len)+    Just ("Int64", len) -> Just (TInt64Hash, len)+    Just ("Int", len) -> Just (TIntHash, len)+    Just ("Word8", len) -> Just (TWord8Hash, len)+    Just ("Word16", len) -> Just (TWord16Hash, len)+    Just ("Word32", len) -> Just (TWord32Hash, len)+    Just ("Word64", len) -> Just (TWord64Hash, len)+    Just ("Word", len) -> Just (TWordHash, len)+    _ -> Nothing++-- | Try to match one of the known type names at the start of the text.+-- Returns (matched name, length) if the match is followed by a non-identifier char+-- or end of input.+matchType :: Text -> Maybe (Text, Int)+matchType input =+  let candidates = ["Int8", "Int16", "Int32", "Int64", "Int", "Word8", "Word16", "Word32", "Word64", "Word"]+   in firstMatch candidates input++firstMatch :: [Text] -> Text -> Maybe (Text, Int)+firstMatch [] _ = Nothing+firstMatch (name : rest) input =+  let len = T.length name+   in case T.stripPrefix name input of+        Just remaining+          | T.null remaining || not (isIdentChar (T.head remaining)) ->+              Just (name, len)+        _ -> firstMatch rest input++isIdentChar :: Char -> Bool+isIdentChar c = isDigit c || isAsciiUpper c || c == '_' || isAsciiLower c++-- Scan ([_]*[digit])* and return a zero-copy split.+takeDigitsWithUnderscores :: Bool -> (Char -> Bool) -> Text -> (Text, Text)+takeDigitsWithUnderscores False isDigitChar = T.span isDigitChar+takeDigitsWithUnderscores True isDigitChar = \chars ->+  let (consumed, rest) = T.span (\c -> isDigitChar c || c == '_') chars+   in if T.null consumed || T.last consumed /= '_'+        then (consumed, rest)+        else+          let trimmed = T.dropWhileEnd (== '_') consumed+           in (trimmed, T.drop (T.length trimmed) chars)++takeExponent :: Bool -> Text -> (Text, Text)+takeExponent allowUnderscores chars =+  case chars of+    '_' :< _+      | allowUnderscores ->+          let (_allUnderscores, rest') = T.span (== '_') chars+           in case rest' of+                marker :< rest2+                  | marker `elem` ("eE" :: String) ->+                      let (_signPart, rest3) =+                            case rest2 of+                              sign :< more | sign `elem` ("+-" :: String) -> (T.singleton sign, more)+                              _ -> ("", rest2)+                          digitsStartWithUnderscore =+                            case rest3 of+                              '_' :< _ -> True+                              _ -> False+                          (digits, rest4) = takeDigitsWithUnderscores allowUnderscores isDigit rest3+                       in if T.null digits || digitsStartWithUnderscore+                            then ("", chars)+                            else+                              let consumed = T.take (T.length chars - T.length rest4) chars+                               in (consumed, rest4)+                _ -> ("", chars)+    marker :< rest+      | marker `elem` ("eE" :: String) ->+          let (_signPart, rest1) =+                case rest of+                  sign :< more | sign `elem` ("+-" :: String) -> (T.singleton sign, more)+                  _ -> ("", rest)+              digitsStartWithUnderscore =+                case rest1 of+                  '_' :< _ -> True+                  _ -> False+              (digits, rest2) = takeDigitsWithUnderscores allowUnderscores isDigit rest1+           in if T.null digits || digitsStartWithUnderscore then ("", chars) else let consumed = T.take (T.length chars - T.length rest2) chars in (consumed, rest2)+    _ -> ("", chars)++takeHexExponent :: Text -> Maybe Text+takeHexExponent chars =+  case chars of+    marker :< rest+      | marker `elem` ("pP" :: String) ->+          let (_signPart, rest1) =+                case rest of+                  sign :< more | sign `elem` ("+-" :: String) -> (T.singleton sign, more)+                  _ -> ("", rest)+              (digits, _) = T.span isDigit rest1+           in if T.null digits then Nothing else Just (T.take (T.length chars - T.length rest1 + T.length digits) chars)+    _ -> Nothing++readBaseLiteral :: String -> (String -> [(Integer, String)]) -> Text -> Integer+readBaseLiteral label parser txt =+  case parser (T.unpack (T.filter (/= '_') (T.drop 2 txt))) of+    [(n, "")] -> n+    _ -> error ("invalid " ++ label ++ " literal: " ++ T.unpack txt)++readHexLiteral :: Text -> Integer+readHexLiteral = readBaseLiteral "hex" readHex++readOctLiteral :: Text -> Integer+readOctLiteral = readBaseLiteral "octal" readOct++readBinLiteral :: Text -> Integer+readBinLiteral = readBaseLiteral "binary" (readInt 2 (`elem` ("01" :: String)) digitToInt)++parseDecimalFloatLiteral :: Text -> Rational+parseDecimalFloatLiteral txt =+  case parseSignedDecimalRational txt of+    Just value -> value+    Nothing -> error ("invalid decimal float literal: " ++ T.unpack txt)++parseSignedDecimalRational :: Text -> Maybe Rational+parseSignedDecimalRational txt = do+  let (sign, unsigned) =+        case T.uncons txt of+          Just ('-', rest) -> (-1, rest)+          Just ('+', rest) -> (1, rest)+          _ -> (1, txt)+      (mantissaTxt, exponentTxt0) = T.break (`elem` ['e', 'E']) unsigned+      exponentTxt = T.drop 1 exponentTxt0+  mantissa <- parseDecimalMantissa mantissaTxt+  exponentN <-+    if T.null exponentTxt0+      then Just 0+      else parseSignedInteger exponentTxt+  pure (applyDecimalExponent (fromInteger sign * mantissa) exponentN)++parseDecimalMantissa :: Text -> Maybe Rational+parseDecimalMantissa txt = do+  let (whole, frac0) = T.break (== '.') txt+      frac = T.drop 1 frac0+  if T.null whole && T.null frac+    then Nothing+    else do+      wholeDigits <- parseDecimalDigits whole+      fracDigits <- parseDecimalDigits frac+      let fracScale = 10 ^ T.length frac+      pure ((wholeDigits * fracScale + fracDigits) % fracScale)++parseDecimalDigits :: Text -> Maybe Integer+parseDecimalDigits digits+  | T.null digits = Just 0+  | T.all isDigit digits = readMaybe (T.unpack digits)+  | otherwise = Nothing++parseSignedInteger :: Text -> Maybe Integer+parseSignedInteger digits =+  case T.uncons digits of+    Just ('+', rest) -> parseDecimalDigits rest+    Just ('-', rest) -> negate <$> parseDecimalDigits rest+    _ -> parseDecimalDigits digits++applyDecimalExponent :: Rational -> Integer -> Rational+applyDecimalExponent value exponentN+  | exponentN >= 0 = value * fromInteger (10 ^ exponentN)+  | otherwise = value / fromInteger (10 ^ negate exponentN)++parseHexFloatLiteral :: String -> String -> String -> Rational+parseHexFloatLiteral intDigits fracDigits expo =+  (parseHexDigits intDigits + parseHexFraction fracDigits) * (2 ^^ exponentValue expo)++parseHexDigits :: String -> Rational+parseHexDigits = foldl (\acc d -> acc * 16 + fromIntegral (digitToInt d)) 0++parseHexFraction :: String -> Rational+parseHexFraction ds =+  sum [fromIntegral (digitToInt d) % (16 ^ i) | (d, i) <- zip ds [1 :: Integer ..]]++exponentValue :: String -> Int+exponentValue expo =+  case expo of+    _ : '-' : ds | not (null ds) -> negate (fromMaybe 0 (readMaybe ds))+    _ : '+' : ds | not (null ds) -> fromMaybe 0 (readMaybe ds)+    _ : ds | not (null ds) -> fromMaybe 0 (readMaybe ds)+    _ -> 0++withOptionalMagicHashSuffix ::+  Int ->+  LexerEnv ->+  LexerState ->+  Text ->+  LexTokenKind ->+  (Text -> LexTokenKind) ->+  (Text, LexTokenKind, LexerState)+withOptionalMagicHashSuffix maxHashes env st raw plainKind hashKind =+  let st' = advanceChars raw st+      hashCount =+        if hasExt MagicHash env+          then min maxHashes (T.length (T.takeWhile (== '#') (lexerInput st')))+          else 0+   in case hashCount of+        0 -> (raw, plainKind, st')+        _ ->+          let hashes = T.replicate hashCount "#"+              rawHash = raw <> hashes+           in (rawHash, hashKind rawHash, advanceChars hashes st')
+ src/Aihc/Parser/Lex/Pragmas.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++module Aihc.Parser.Lex.Pragmas+  ( tryParsePragma,+    parsePragmaType,+    parseControlPragma,+  )+where++import Aihc.Parser.Lex.Types+  ( DirectiveUpdate (..),+    LexToken (..),+    LexTokenKind (..),+    LexerState (..),+    advanceN,+    mkToken,+  )+import Aihc.Parser.Syntax+import Data.Char (isDigit, isSpace)+import Data.Maybe (mapMaybe)+import Data.Text (Text, pattern Empty, pattern (:<))+import Data.Text qualified as T+import Text.Read (readMaybe)++-- | Single entry point for pragma parsing.+-- Scans "{-# ... #-}" once, then parses the body to determine which Pragma it is.+tryParsePragma :: LexerState -> Maybe (LexToken, LexerState)+tryParsePragma st = do+  (rawBody, consumedLen) <- extractPragmaBody (lexerInput st)+  let fullText = "{-#" <> rawBody <> "#-}"+      pragma = Pragma {pragmaType = parsePragmaType rawBody, pragmaRawText = fullText}+      st' = advanceN consumedLen st+  Just (mkToken st st' fullText (TkPragma pragma), st')++-- | Extract the raw body text between "{-#" and "#-}".+-- Returns (body_text, total_consumed_length) where total includes "{-#" and "#-}".+extractPragmaBody :: Text -> Maybe (Text, Int)+extractPragmaBody input = do+  rest0 <- T.stripPrefix "{-#" input+  let (body, marker) = T.breakOn "#-}" rest0+  if T.null marker+    then Nothing+    else+      let consumedLen = T.length input - T.length (T.drop 3 marker)+       in Just (body, consumedLen)++-- | Parse pragma body text into a structured PragmaType.+-- The body is the text between "{-#" and "#-}" (not including the delimiters).+parsePragmaType :: Text -> PragmaType+parsePragmaType rawBody =+  let trimmed = T.strip rawBody+      upperBody = T.toUpper trimmed+   in case tryParseNamedPragma trimmed upperBody of+        Just pt -> pt+        Nothing -> PragmaUnknown ("{-#" <> rawBody <> "#-}")++tryParseNamedPragma :: Text -> Text -> Maybe PragmaType+tryParseNamedPragma body upperBody+  | Just pt <- parseLanguagePragma body upperBody = Just pt+  | Just pt <- parseInstanceOverlapPragma body upperBody = Just pt+  | Just pt <- parseOptionsPragma body upperBody = Just pt+  | Just pt <- parseWarningPragma body upperBody = Just pt+  | Just pt <- parseDeprecatedPragma body upperBody = Just pt+  | Just pt <- parseInlinePragma body upperBody = Just pt+  | Just pt <- parseUnpackPragma body upperBody = Just pt+  | Just pt <- parseSourcePragma body upperBody = Just pt+  | Just pt <- parseSCCPragma body upperBody = Just pt+  | otherwise = Nothing++parseLanguagePragma :: Text -> Text -> Maybe PragmaType+parseLanguagePragma body upperBody+  | Just rest <- T.stripPrefix "LANGUAGE" upperBody,+    isPragmaBodyEnd rest =+      let names = parseLanguagePragmaNames (dropPragmaName "LANGUAGE" body)+       in Just (PragmaLanguage names)+  | otherwise = Nothing++parseInstanceOverlapPragma :: Text -> Text -> Maybe PragmaType+parseInstanceOverlapPragma _body upperBody+  | Just rest <- T.stripPrefix "OVERLAPPING" upperBody,+    isPragmaBodyEnd rest =+      Just (PragmaInstanceOverlap Overlapping)+  | Just rest <- T.stripPrefix "OVERLAPPABLE" upperBody,+    isPragmaBodyEnd rest =+      Just (PragmaInstanceOverlap Overlappable)+  | Just rest <- T.stripPrefix "OVERLAPS" upperBody,+    isPragmaBodyEnd rest =+      Just (PragmaInstanceOverlap Overlaps)+  | Just rest <- T.stripPrefix "INCOHERENT" upperBody,+    isPragmaBodyEnd rest =+      Just (PragmaInstanceOverlap Incoherent)+  | otherwise = Nothing++parseOptionsPragma :: Text -> Text -> Maybe PragmaType+parseOptionsPragma body upperBody+  | Just rest <- T.stripPrefix "OPTIONS_GHC" upperBody,+    isPragmaBodyEnd rest =+      let settings = parseOptionsPragmaSettings (dropPragmaName "OPTIONS_GHC" body)+       in Just (PragmaLanguage settings)+  | Just rest <- T.stripPrefix "OPTIONS" upperBody,+    isPragmaBodyEnd rest =+      let settings = parseOptionsPragmaSettings (dropPragmaName "OPTIONS" body)+       in Just (PragmaLanguage settings)+  | otherwise = Nothing++parseWarningPragma :: Text -> Text -> Maybe PragmaType+parseWarningPragma body upperBody+  | Just rest <- T.stripPrefix "WARNING" upperBody,+    isPragmaBodyEnd rest =+      let msgBody = dropPragmaName "WARNING" body+          txt = T.strip msgBody+          msg = extractPragmaMessage txt+       in Just (PragmaWarning msg)+  | otherwise = Nothing++parseDeprecatedPragma :: Text -> Text -> Maybe PragmaType+parseDeprecatedPragma body upperBody+  | Just rest <- T.stripPrefix "DEPRECATED" upperBody,+    isPragmaBodyEnd rest =+      let msgBody = dropPragmaName "DEPRECATED" body+          txt = T.strip msgBody+          msg = extractPragmaMessage txt+       in Just (PragmaDeprecated msg)+  | otherwise = Nothing++parseInlinePragma :: Text -> Text -> Maybe PragmaType+parseInlinePragma body upperBody+  | Just rest <- T.stripPrefix "INLINEABLE" upperBody,+    isPragmaBodyEnd rest =+      let fullBody = T.strip (dropPragmaName "INLINEABLE" body)+       in Just (PragmaInline "INLINEABLE" fullBody)+  | Just rest <- T.stripPrefix "INLINABLE" upperBody,+    isPragmaBodyEnd rest =+      let fullBody = T.strip (dropPragmaName "INLINABLE" body)+       in Just (PragmaInline "INLINABLE" fullBody)+  | Just rest <- T.stripPrefix "NOINLINEABLE" upperBody,+    isPragmaBodyEnd rest =+      let fullBody = T.strip (dropPragmaName "NOINLINEABLE" body)+       in Just (PragmaInline "NOINLINEABLE" fullBody)+  | Just rest <- T.stripPrefix "NOINLINABLE" upperBody,+    isPragmaBodyEnd rest =+      let fullBody = T.strip (dropPragmaName "NOINLINABLE" body)+       in Just (PragmaInline "NOINLINABLE" fullBody)+  | Just rest <- T.stripPrefix "INLINE" upperBody,+    isPragmaBodyEnd rest =+      let fullBody = T.strip (dropPragmaName "INLINE" body)+       in Just (PragmaInline "INLINE" fullBody)+  | Just rest <- T.stripPrefix "NOINLINE" upperBody,+    isPragmaBodyEnd rest =+      let fullBody = T.strip (dropPragmaName "NOINLINE" body)+       in Just (PragmaInline "NOINLINE" fullBody)+  | Just rest <- T.stripPrefix "CONLIKE" upperBody,+    isPragmaBodyEnd rest =+      let fullBody = T.strip (dropPragmaName "CONLIKE" body)+       in Just (PragmaInline "CONLIKE" fullBody)+  | otherwise = Nothing++parseUnpackPragma :: Text -> Text -> Maybe PragmaType+parseUnpackPragma _body upperBody+  | Just rest <- T.stripPrefix "UNPACK" upperBody,+    isPragmaBodyEnd rest =+      Just (PragmaUnpack UnpackPragma)+  | Just rest <- T.stripPrefix "NOUNPACK" upperBody,+    isPragmaBodyEnd rest =+      Just (PragmaUnpack NoUnpackPragma)+  | otherwise = Nothing++parseSourcePragma :: Text -> Text -> Maybe PragmaType+parseSourcePragma body upperBody+  | Just rest <- T.stripPrefix "SOURCE" upperBody,+    isPragmaBodyEnd rest =+      let fullBody = T.strip (dropPragmaName "SOURCE" body)+       in Just (PragmaSource fullBody fullBody)+  | otherwise = Nothing++parseSCCPragma :: Text -> Text -> Maybe PragmaType+parseSCCPragma body upperBody+  | Just rest <- T.stripPrefix "SCC" upperBody,+    isPragmaBodyEnd rest =+      let label = T.strip (dropPragmaName "SCC" body)+       in Just (PragmaSCC label)+  | otherwise = Nothing++dropPragmaName :: Text -> Text -> Text+dropPragmaName name = T.drop (T.length name)++-- | Check if the remaining text after a pragma name is valid (whitespace or end).+isPragmaBodyEnd :: Text -> Bool+isPragmaBodyEnd text =+  case text of+    Empty -> True+    c :< _ -> isSpace c++-- | Extract message text from pragma body, handling quoted strings.+extractPragmaMessage :: Text -> Text+extractPragmaMessage txt =+  case txt of+    '"' :< _ ->+      case reads (T.unpack txt) of+        [(decoded, "")] -> T.pack decoded+        _ -> txt+    _ -> txt++-- | Parse the body of a LANGUAGE pragma into extension settings.+parseLanguagePragmaNames :: Text -> [ExtensionSetting]+parseLanguagePragmaNames body =+  mapMaybe (parseExtensionSettingName . T.strip . T.takeWhile (/= '#')) (T.splitOn "," body)++-- | Parse the body of an OPTIONS pragma into extension settings.+parseOptionsPragmaSettings :: Text -> [ExtensionSetting]+parseOptionsPragmaSettings body = go (pragmaWords body)+  where+    go ws =+      case ws of+        [] -> []+        "-cpp" : rest -> EnableExtension CPP : go rest+        "-fffi" : rest -> EnableExtension ForeignFunctionInterface : go rest+        "-fglasgow-exts" : rest -> glasgowExtsSettings <> go rest+        opt : rest+          | Just ext <- T.stripPrefix "-X" opt,+            not (T.null ext) ->+              case parseExtensionSettingName ext of+                Just setting -> setting : go rest+                Nothing -> go rest+        _ : rest -> go rest++glasgowExtsSettings :: [ExtensionSetting]+glasgowExtsSettings =+  map+    EnableExtension+    [ ConstrainedClassMethods,+      DeriveDataTypeable,+      DeriveFoldable,+      DeriveFunctor,+      DeriveGeneric,+      DeriveTraversable,+      EmptyDataDecls,+      ExistentialQuantification,+      ExplicitNamespaces,+      FlexibleContexts,+      FlexibleInstances,+      ForeignFunctionInterface,+      FunctionalDependencies,+      GeneralizedNewtypeDeriving,+      ImplicitParams,+      InterruptibleFFI,+      KindSignatures,+      LiberalTypeSynonyms,+      MagicHash,+      MultiParamTypeClasses,+      ParallelListComp,+      PatternGuards,+      PostfixOperators,+      RankNTypes,+      RecursiveDo,+      ScopedTypeVariables,+      StandaloneDeriving,+      TypeOperators,+      TypeSynonymInstances,+      UnboxedTuples,+      UnicodeSyntax,+      UnliftedFFITypes+    ]++-- | Split pragma text into words, respecting quoted strings.+pragmaWords :: Text -> [Text]+pragmaWords txt = go [] [] Nothing (T.unpack txt)+  where+    go acc current quote chars =+      case chars of+        [] ->+          let acc' = pushCurrent acc current+           in reverse acc'+        c : rest ->+          case quote of+            Just q+              | c == q -> go acc current Nothing rest+              | c == '\\' ->+                  case rest of+                    escaped : rest' -> go acc (escaped : current) quote rest'+                    [] -> go acc current quote []+              | otherwise -> go acc (c : current) quote rest+            Nothing+              | c == '"' || c == '\'' -> go acc current (Just c) rest+              | c == '\\' ->+                  case rest of+                    escaped : rest' -> go acc (escaped : current) Nothing rest'+                    [] -> go acc current Nothing []+              | c `elem` [' ', '\n', '\r', '\t'] ->+                  let acc' = pushCurrent acc current+                   in go acc' [] Nothing rest+              | otherwise -> go acc (c : current) Nothing rest++    pushCurrent acc current =+      case reverse current of+        [] -> acc+        token -> T.pack token : acc++parseControlPragma :: Text -> Maybe (Text, Either Text DirectiveUpdate)+parseControlPragma input = do+  (body, _) <- extractPragmaBody input+  let trimmed = T.strip body+      upperBody = T.toUpper trimmed+  case () of+    _+      | Just rest <- T.stripPrefix "LINE" upperBody,+        isPragmaBodyEnd rest ->+          let bodyAfter = dropPragmaName "LINE" trimmed+              ws = T.words bodyAfter+           in case ws of+                lineNo : _+                  | T.all isDigit lineNo ->+                      case readBoundedInt lineNo of+                        Just parsedLine ->+                          Just+                            ( "{-#" <> body <> "#-}",+                              Right+                                DirectiveUpdate+                                  { directiveLine = Just parsedLine,+                                    directiveCol = Just 1,+                                    directiveSourceName = parseDirectiveSourceName (T.dropWhile isSpace (T.drop (T.length lineNo) bodyAfter))+                                  }+                            )+                        Nothing -> Just ("{-#" <> body <> "#-}", Left "malformed LINE pragma")+                _ -> Just ("{-#" <> body <> "#-}", Left "malformed LINE pragma")+    _+      | Just rest <- T.stripPrefix "COLUMN" upperBody,+        isPragmaBodyEnd rest ->+          let bodyAfter = dropPragmaName "COLUMN" trimmed+              ws = T.words bodyAfter+           in case ws of+                colNo : _+                  | T.all isDigit colNo ->+                      case readBoundedInt colNo of+                        Just parsedCol ->+                          Just+                            ( "{-#" <> body <> "#-}",+                              Right DirectiveUpdate {directiveLine = Nothing, directiveCol = Just parsedCol, directiveSourceName = Nothing}+                            )+                        Nothing -> Just ("{-#" <> body <> "#-}", Left "malformed COLUMN pragma")+                _ -> Just ("{-#" <> body <> "#-}", Left "malformed COLUMN pragma")+    _ -> Nothing++parseDirectiveSourceName :: Text -> Maybe FilePath+parseDirectiveSourceName rest =+  let rest' = T.dropWhile isSpace rest+   in case rest' of+        '"' :< more ->+          let (name, trailing) = T.break (== '"') more+           in case trailing of+                '"' :< _ -> Just (T.unpack name)+                _ -> Nothing+        _ -> Nothing++readBoundedInt :: Text -> Maybe Int+readBoundedInt txt = do+  n <- readMaybe (T.unpack txt) :: Maybe Integer+  if n >= fromIntegral (minBound :: Int) && n <= fromIntegral (maxBound :: Int)+    then Just (fromInteger n)+    else Nothing
+ src/Aihc/Parser/Lex/Quoted.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Aihc.Parser.Lex.Quoted+  ( decodeStringBody,+    processMultilineString,+    readMaybeChar,+    scanMultilineString,+    scanQuoted,+  )+where++import Data.Char (chr, digitToInt, isDigit, isHexDigit, isSpace, ord)+import Data.List qualified as List+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder qualified as TLB++-- | Scan a quoted string body (after the opening delimiter) until the+-- unescaped closing character.  Returns @Right (body, rest)@ on success or+-- @Left body@ if the input ends without a closing delimiter.+scanQuoted :: Char -> Text -> Either Text (Text, Text)+scanQuoted endCh input = go 0 input+  where+    go consumed rest =+      case T.findIndex (\c -> c == '\\' || c == endCh) rest of+        Nothing -> Left (T.take (consumed + T.length rest) input)+        Just i ->+          let consumed' = consumed + i+              special = T.drop i rest+           in if T.null special+                then Left (T.take consumed' input)+                else case T.head special of+                  c+                    | c == endCh -> Right (T.take consumed' input, T.drop 1 special)+                    | otherwise ->+                        case consumedEscapeTail (T.drop 1 special) of+                          Just tailLen -> go (consumed' + 1 + tailLen) (T.drop tailLen (T.drop 1 special))+                          Nothing -> Left (T.take (consumed' + 1) input)++-- | Scan a multiline string body (after the opening @\"\"\"@) until an+-- unescaped closing @\"\"\"@.  Returns @Right (body, rest)@ on success or+-- @Left body@ if the input ends without a closing delimiter.+scanMultilineString :: Text -> Either Text (Text, Text)+scanMultilineString input = go 0 input+  where+    go consumed rest =+      case T.findIndex (\c -> c == '\\' || c == '"') rest of+        Nothing -> Left (T.take (consumed + T.length rest) input)+        Just i ->+          let consumed' = consumed + i+              special = T.drop i rest+           in if T.null special+                then Left (T.take consumed' input)+                else case T.head special of+                  '\\' ->+                    case consumedEscapeTail (T.drop 1 special) of+                      Just tailLen -> go (consumed' + 1 + tailLen) (T.drop tailLen (T.drop 1 special))+                      Nothing -> Left (T.take (consumed' + 1) input)+                  '"' ->+                    if "\"\"\"" `T.isPrefixOf` special+                      then Right (T.take consumed' input, T.drop 3 special)+                      else+                        if "\"\"" `T.isPrefixOf` special+                          then go (consumed' + 2) (T.drop 2 special)+                          else go (consumed' + 1) (T.drop 1 special)+                  _ -> error "unreachable: findIndex only returns backslash or quote"++-- | Determine how much text after a backslash belongs to the current+-- escape-like sequence for delimiter scanning purposes.+--+-- We intentionally recognize string gaps here so a gap-closing backslash does+-- not incorrectly escape the following quote.+consumedEscapeTail :: Text -> Maybe Int+consumedEscapeTail rest =+  if T.null rest+    then Nothing+    else do+      (_, rest') <- parseEscape rest+      pure (T.length rest - T.length rest')++-- | Decode the body of a Haskell string literal (content between the quotes,+-- without the surrounding @\"@ characters) natively on 'Text', avoiding the+-- round-trip through 'String'.  Returns 'Nothing' if the body contains an+-- invalid escape sequence, in which case the caller should fall back to the+-- raw body.+decodeStringBody :: Text -> Maybe Text+decodeStringBody inp+  | not ('\\' `T.elem` inp) = Just inp -- fast path: no escapes, no allocation+  | otherwise = TL.toStrict . TLB.toLazyText <$> go mempty inp+  where+    go :: TLB.Builder -> Text -> Maybe TLB.Builder+    go !acc t =+      let (plain, rest) = T.break (== '\\') t+          acc' = acc <> TLB.fromText plain+       in case T.uncons rest of+            Nothing -> Just acc'+            Just ('\\', after) -> case parseEscape after of+              Nothing -> Nothing+              Just (mc, rest') ->+                go (maybe acc' (\c -> acc' <> TLB.singleton c) mc) rest'+            _ -> Just acc' -- unreachable: T.break stops at '\\'++isOctDigit :: Char -> Bool+isOctDigit c = c >= '0' && c <= '7'++parseEscape :: Text -> Maybe (Maybe Char, Text)+parseEscape t = case T.uncons t of+  Nothing -> Nothing+  Just (c, rest) -> case c of+    'a' -> Just (Just '\a', rest)+    'b' -> Just (Just '\b', rest)+    'f' -> Just (Just '\f', rest)+    'n' -> Just (Just '\n', rest)+    'r' -> Just (Just '\r', rest)+    't' -> Just (Just '\t', rest)+    'v' -> Just (Just '\v', rest)+    '\\' -> Just (Just '\\', rest)+    '"' -> Just (Just '"', rest)+    '\'' -> Just (Just '\'', rest)+    '&' -> Just (Nothing, rest) -- empty escape+    '^' -> case T.uncons rest of -- control character \^X+      Just (cc, rest')+        | cc >= '@' && cc <= '_' ->+            Just (Just (chr (ord cc - 64)), rest')+      _ -> Nothing+    'x' ->+      -- hex escape \xNN  (use Integer to prevent Int overflow on long inputs)+      let (digits, rest') = T.span isHexDigit rest+       in if T.null digits+            then Nothing+            else decodeNumericEscape 16 digits rest'+    'o' ->+      -- octal escape \oNN  (use Integer to prevent Int overflow on long inputs)+      let (digits, rest') = T.span isOctDigit rest+       in if T.null digits+            then Nothing+            else decodeNumericEscape 8 digits rest'+    _+      | isDigit c -> -- decimal escape \NNN  (use Integer to prevent Int overflow on long inputs)+          let (moreDigits, rest') = T.span isDigit rest+              digits = T.cons c moreDigits+           in decodeNumericEscape 10 digits rest'+      | isSpace c -> -- gap escape \ whitespace \+          let rest' = T.dropWhile isSpace rest+           in case T.uncons rest' of+                Just ('\\', rest'') -> Just (Nothing, rest'')+                _ -> Nothing+      | otherwise -> parseNamedEscape t+  where+    decodeNumericEscape :: Integer -> Text -> Text -> Maybe (Maybe Char, Text)+    decodeNumericEscape !base digits rest' =+      let n = T.foldl' (\a d -> a * base + toInteger (digitToInt d)) (0 :: Integer) digits+       in if n > 0x10FFFF then Nothing else Just (Just (chr (fromIntegral n)), rest')++parseNamedEscape :: Text -> Maybe (Maybe Char, Text)+parseNamedEscape t = foldr tryMatch Nothing namedEscapeTable+  where+    tryMatch (name, ch) fallback =+      case T.stripPrefix name t of+        Just rest -> Just (Just ch, rest)+        Nothing -> fallback++-- Named ASCII escape sequences per the Haskell 2010 report.+-- SOH must appear before SO so the longest prefix wins.+namedEscapeTable :: [(Text, Char)]+namedEscapeTable =+  [ ("NUL", '\NUL'),+    ("SOH", '\SOH'), -- must precede SO+    ("STX", '\STX'),+    ("ETX", '\ETX'),+    ("EOT", '\EOT'),+    ("ENQ", '\ENQ'),+    ("ACK", '\ACK'),+    ("BEL", '\BEL'),+    ("BS", '\BS'),+    ("HT", '\HT'),+    ("LF", '\LF'),+    ("VT", '\VT'),+    ("FF", '\FF'),+    ("CR", '\CR'),+    ("SO", '\SO'),+    ("SI", '\SI'),+    ("DLE", '\DLE'),+    ("DC1", '\DC1'),+    ("DC2", '\DC2'),+    ("DC3", '\DC3'),+    ("DC4", '\DC4'),+    ("NAK", '\NAK'),+    ("SYN", '\SYN'),+    ("ETB", '\ETB'),+    ("CAN", '\CAN'),+    ("EM", '\EM'),+    ("SUB", '\SUB'),+    ("ESC", '\ESC'),+    ("FS", '\FS'),+    ("GS", '\GS'),+    ("RS", '\RS'),+    ("US", '\US'),+    ("SP", '\SP'),+    ("DEL", '\DEL')+  ]++processMultilineString :: String -> String+processMultilineString =+  resolveEscapes+    . stripTrailingNewline+    . stripLeadingNewline+    . List.intercalate "\n"+    . map blankToEmpty+    . stripCommonIndent+    . map expandLeadingTabs+    . splitMultilineNewlines+    . collapseStringGaps++collapseStringGaps :: String -> String+collapseStringGaps [] = []+collapseStringGaps ('\\' : rest)+  | not (null ws), '\\' : rest'' <- rest' = collapseStringGaps rest''+  where+    (ws, rest') = span (\c -> c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f') rest+collapseStringGaps (c : rest) = c : collapseStringGaps rest++splitMultilineNewlines :: String -> [String]+splitMultilineNewlines = go []+  where+    go acc [] = [reverse acc]+    go acc ('\r' : '\n' : rest) = reverse acc : go [] rest+    go acc ('\r' : rest) = reverse acc : go [] rest+    go acc ('\n' : rest) = reverse acc : go [] rest+    go acc ('\f' : rest) = reverse acc : go [] rest+    go acc (c : rest) = go (c : acc) rest++expandLeadingTabs :: String -> String+expandLeadingTabs = go 0+  where+    go col ('\t' : rest) =+      let spaces = 8 - (col `mod` 8)+       in replicate spaces ' ' ++ go (col + spaces) rest+    go col (' ' : rest) = ' ' : go (col + 1) rest+    go _ rest = rest++stripCommonIndent :: [String] -> [String]+stripCommonIndent lns =+  case mapMaybe indentOf nonBlank of+    [] -> lns+    indents -> map (dropPrefix (minimum indents)) lns+  where+    nonBlank = filter (not . all isSpace) (drop 1 lns)+    indentOf s = Just (length (takeWhile isSpace s))+    dropPrefix = drop++blankToEmpty :: String -> String+blankToEmpty s+  | all isSpace s = ""+  | otherwise = s++stripLeadingNewline :: String -> String+stripLeadingNewline ('\n' : rest) = rest+stripLeadingNewline s = s++stripTrailingNewline :: String -> String+stripTrailingNewline s+  | not (null s) && last s == '\n' = init s+  | otherwise = s++resolveEscapes :: String -> String+resolveEscapes s =+  case reads ('"' : s ++ "\"") of+    [(str, "")] -> str+    _ -> s++readMaybeChar :: Text -> Maybe Char+readMaybeChar raw =+  case reads (T.unpack raw) of+    [(c, "")] -> Just c+    _ -> Nothing
+ src/Aihc/Parser/Lex/Trivia.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++module Aihc.Parser.Lex.Trivia+  ( consumeBlockCommentTokenOrError,+    consumeLineCommentToken,+    isHaskellWhitespace,+    isLineComment,+    tryConsumeControlPragma,+    tryConsumeLineDirective,+  )+where++import Aihc.Parser.Lex.Pragmas (parseControlPragma)+import Aihc.Parser.Lex.Types+import Data.Char (isDigit, isSpace)+import Data.Maybe (fromMaybe)+import Data.Text (Text, pattern (:<))+import Data.Text qualified as T+import Text.Read (readMaybe)++isHaskellWhitespace :: Char -> Bool+isHaskellWhitespace c =+  c == ' ' || c == '\t' || c == '\r' || c == '\f' || c == '\v' || isSpace c++tryConsumeLineDirective :: LexerState -> Maybe (Maybe LexToken, LexerState)+tryConsumeLineDirective st+  | not (lexerAtLineStart st) = Nothing+  | otherwise =+      let inp = lexerInput st+          (spaces, rest) = T.span (\c -> c == ' ' || c == '\t') inp+          -- CPP #line directives require '#' at column 1 (no leading+          -- whitespace).  GHC enforces the same rule: an indented '#' is+          -- never a line directive.  Shebangs, however, are allowed with+          -- optional leading whitespace.+          --+          -- Note: skipTrivia may have already consumed leading whitespace+          -- before calling us, so we check lexerCol rather than whether+          -- 'spaces' is empty.  The column after consuming 'spaces' is+          -- where '#' would sit.+          hashCol = lexerCol st + T.length spaces+          atColumn1 = hashCol == 1+       in case rest of+            '#' :< more ->+              let lineText = "#" <> takeLineRemainder more+                  consumed = spaces <> lineText+                  isFirstLine = lexerLine st == 1+               in case classifyHashLineTrivia atColumn1 isFirstLine lineText of+                    Just (HashLineDirective update) ->+                      Just (Nothing, applyDirectiveAdvance consumed update st)+                    Just HashLineShebang ->+                      let st' = advanceChars consumed st+                       in Just (Nothing, st')+                    Just HashLineMalformed ->+                      let st' = advanceChars consumed st+                       in Just (Just (mkToken st st' consumed (TkError "malformed line directive")), st')+                    Nothing -> Nothing+            _ -> Nothing++tryConsumeControlPragma :: LexerState -> Maybe (Maybe LexToken, LexerState)+tryConsumeControlPragma st =+  let inp = lexerInput st+   in case parseControlPragma inp of+        Just (consumedT, Right update0) ->+          let (consumedT', update) =+                case directiveLine update0 of+                  Just lineNo ->+                    case T.drop (T.length consumedT) (lexerInput st) of+                      '\n' :< _ ->+                        (consumedT <> "\n", update0 {directiveLine = Just lineNo, directiveCol = Just 1})+                      _ -> (consumedT, update0)+                  Nothing -> (consumedT, update0)+           in Just (Nothing, applyDirectiveAdvance consumedT' update st)+        Just (consumedT, Left msg) ->+          let st' = advanceChars consumedT st+           in Just (Just (mkToken st st' consumedT (TkError msg)), st')+        Nothing -> Nothing++consumeLineCommentToken :: LexerState -> (LexToken, LexerState)+consumeLineCommentToken st =+  let inp = lexerInput st+      rest = T.drop 2 inp+      consumed = "--" <> T.takeWhile (/= '\n') rest+      st' = advanceChars consumed st+   in (mkToken st st' consumed TkLineComment, st')++consumeBlockCommentToken :: LexerState -> Maybe (LexToken, LexerState)+consumeBlockCommentToken st =+  case scanNestedBlockComment 1 (T.drop 2 (lexerInput st)) of+    Just consumedTail ->+      let consumed = "{-" <> consumedTail+          st' = advanceChars consumed st+          st'' =+            if T.any (== '\n') consumed+              then st'+              else st' {lexerAtLineStart = lexerAtLineStart st}+       in Just (mkToken st st'' consumed TkBlockComment, st'')+    Nothing -> Nothing++consumeBlockCommentTokenOrError :: LexerState -> Either (LexToken, LexerState) (LexToken, LexerState)+consumeBlockCommentTokenOrError st =+  case consumeBlockCommentToken st of+    Just result -> Right result+    Nothing ->+      let consumed = lexerInput st+          st' = advanceChars consumed st+          tok = mkToken st st' consumed (TkError "unterminated block comment")+       in Left (tok, st')++scanNestedBlockComment :: Int -> Text -> Maybe Text+scanNestedBlockComment depth0 input = go depth0 0 input+  where+    -- Skip characters that can't start a nesting change in bulk, then+    -- inspect the stopping character.  Allocation is O(nesting changes)+    -- instead of O(length).+    go depth !n remaining+      | depth <= 0 = Just (T.take n input)+      | otherwise =+          let (prefix, rest0) = T.span (\c -> c /= '{' && c /= '-') remaining+              n' = n + T.length prefix+           in case T.uncons rest0 of+                Nothing -> Nothing+                Just (c, rest1) ->+                  case T.uncons rest1 of+                    Nothing -> Nothing -- truncated escape sequence, unterminated+                    Just (c2, rest2)+                      | c == '{' && c2 == '-' -> go (depth + 1) (n' + 2) rest2+                      | c == '-' && c2 == '}' ->+                          if depth == 1+                            then Just (T.take (n' + 2) input)+                            else go (depth - 1) (n' + 2) rest2+                      | otherwise ->+                          -- c was '{' or '-' but not a nesting pair; advance by 1+                          -- and re-examine rest1 (which still starts with c2)+                          go depth (n' + 1) rest1++applyDirectiveAdvance :: Text -> DirectiveUpdate -> LexerState -> LexerState+applyDirectiveAdvance consumed update st =+  let hasTrailingNewline = T.isSuffixOf "\n" consumed+      st' = advanceChars consumed st+   in st'+        { lexerLogicalSourceName = fromMaybe (lexerLogicalSourceName st') (directiveSourceName update),+          lexerLine = maybe (lexerLine st') (max 1) (directiveLine update),+          lexerCol = maybe (lexerCol st') (max 1) (directiveCol update),+          lexerAtLineStart = hasTrailingNewline || (Just 1 == directiveCol update)+        }++-- | Classify a line beginning with @#@.+--+-- @atColumn1@ is 'True' when @#@ sits at column 1 of the physical source+-- line (no leading whitespace).  @isFirstLine@ is 'True' on line 1.+-- Shebangs are accepted at column 1 on any line (for mid-file shebangs+-- as in some polyglot scripts) or anywhere on line 1 (GHC also accepts+-- an optional leading space before the initial shebang).+-- An indented @#!@ past line 1 is left for the operator lexer.+-- CPP @#line@ directives are only recognised at column 1, matching GHC.+classifyHashLineTrivia :: Bool -> Bool -> Text -> Maybe HashLineTrivia+classifyHashLineTrivia atColumn1 isFirstLine raw+  | (atColumn1 || isFirstLine) && isHashBangLine raw = Just HashLineShebang+  | not atColumn1 = Nothing+  | looksLikeHashLineDirective raw =+      case parseHashLineDirective raw of+        Just update -> Just (HashLineDirective update)+        Nothing -> Just HashLineMalformed+  | otherwise = Nothing++parseHashLineDirective :: Text -> Maybe DirectiveUpdate+parseHashLineDirective raw =+  let trimmed = T.dropWhile isSpace (T.drop 1 (T.dropWhile isSpace raw))+      trimmed' =+        case T.stripPrefix "line" trimmed of+          Just afterLine -> T.dropWhile isSpace afterLine+          Nothing -> trimmed+      (digits, rest) = T.span isDigit trimmed'+   in if T.null digits+        then Nothing+        else do+          lineNo <- readBoundedInt digits+          Just+            DirectiveUpdate+              { directiveLine = Just lineNo,+                directiveCol = Just 1,+                directiveSourceName = parseDirectiveSourceName rest+              }++isHashBangLine :: Text -> Bool+isHashBangLine raw =+  "#!" `T.isPrefixOf` T.dropWhile isSpace raw++looksLikeHashLineDirective :: Text -> Bool+looksLikeHashLineDirective raw =+  let afterHash = T.dropWhile isSpace (T.drop 1 (T.dropWhile isSpace raw))+   in case afterHash of+        c :< _ | isDigit c -> True+        _ -> "line" `T.isPrefixOf` afterHash++parseDirectiveSourceName :: Text -> Maybe FilePath+parseDirectiveSourceName rest =+  let rest' = T.dropWhile isSpace rest+   in case rest' of+        '"' :< more ->+          let (name, trailing) = T.break (== '"') more+           in case trailing of+                '"' :< _ -> Just (T.unpack name)+                _ -> Nothing+        _ -> Nothing++takeLineRemainder :: Text -> Text+takeLineRemainder chars =+  let (prefix, rest) = T.break (== '\n') chars+   in case rest of+        '\n' :< _ -> prefix <> "\n"+        _ -> prefix++isLineComment :: Text -> Bool+isLineComment rest =+  case rest of+    c :< _+      | c == '-' -> isLineComment (T.dropWhile (== '-') rest)+      | isSymbolicOpChar c -> False+      | otherwise -> True+    _ -> True++readBoundedInt :: Text -> Maybe Int+readBoundedInt txt = do+  n <- readMaybe (T.unpack txt) :: Maybe Integer+  if n >= fromIntegral (minBound :: Int) && n <= fromIntegral (maxBound :: Int)+    then Just (fromInteger n)+    else Nothing
+ src/Aihc/Parser/Lex/Types.hs view
@@ -0,0 +1,468 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++module Aihc.Parser.Lex.Types+  ( LexTokenKind (..),+    pattern TkVarRole,+    pattern TkVarFamily,+    pattern TkVarAs,+    pattern TkVarHiding,+    pattern TkVarQualified,+    pattern TkVarSafe,+    TokenOrigin (..),+    LexToken (..),+    LexerEnv (..),+    hasExt,+    LexerState (..),+    LayoutContext (..),+    LayoutFrame (..),+    LayoutSemicolons (..),+    LayoutIndentPolicy (..),+    LayoutBaseline (..),+    ImplicitLayoutSpec (..),+    PendingLayout (..),+    ModuleLayoutMode (..),+    LayoutState (..),+    DirectiveUpdate (..),+    HashLineTrivia (..),+    mkLexerEnv,+    mkInitialLexerState,+    mkInitialLayoutState,+    mkToken,+    mkErrorToken,+    mkSpan,+    advanceChars,+    advanceN,+    consumeWhile,+    tokenStartCol,+    virtualSymbolToken,+    isSymbolicOpChar,+    isUnicodeSymbol,+    isUnicodeSymbolCategory,+  )+where++import Aihc.Parser.Syntax+import Aihc.Parser.Syntax qualified as Syntax+import Control.DeepSeq (NFData)+import Data.Char (GeneralCategory (..), generalCategory, isAscii, isSpace, ord)+import Data.Data (Data)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)++data LexTokenKind+  = -- Keywords (reserved identifiers per Haskell Report Section 2.4)+    TkKeywordCase+  | TkKeywordClass+  | TkKeywordData+  | TkKeywordDefault+  | TkKeywordDeriving+  | TkKeywordDo+  | TkKeywordElse+  | TkKeywordForall+  | TkKeywordForeign+  | TkKeywordIf+  | TkKeywordImport+  | TkKeywordIn+  | TkKeywordInfix+  | TkKeywordInfixl+  | TkKeywordInfixr+  | TkKeywordInstance+  | TkKeywordLet+  | TkKeywordModule+  | TkKeywordNewtype+  | TkKeywordOf+  | TkKeywordThen+  | TkKeywordType+  | TkKeywordWhere+  | TkKeywordUnderscore+  | -- Extension-conditional keywords+    TkKeywordProc+  | TkKeywordRec+  | TkKeywordMdo+  | TkKeywordPattern+  | TkKeywordBy+  | TkKeywordUsing+  | -- QualifiedDo tokens (extension-conditional)++    -- | @M.do@ — carries the module qualifier+    TkQualifiedDo Text+  | -- | @M.mdo@ — carries the module qualifier+    TkQualifiedMdo Text+  | -- Reserved operators (per Haskell Report Section 2.4)+    TkReservedDotDot+  | TkReservedColon+  | TkReservedDoubleColon+  | TkReservedEquals+  | TkReservedBackslash+  | TkReservedPipe+  | TkReservedLeftArrow+  | TkReservedRightArrow+  | TkReservedAt+  | TkReservedDoubleArrow+  | -- LinearTypes multiplicity prefix (e.g. @%1@, @%m@, @%'Many@)+    TkPrefixPercent+  | -- LinearTypes arrow operator+    TkLinearArrow+  | -- Arrow notation reserved operators (Arrows extension)+    TkArrowTail+  | TkArrowTailReverse+  | TkDoubleArrowTail+  | TkDoubleArrowTailReverse+  | TkBananaOpen+  | TkBananaClose+  | -- Identifiers (per Haskell Report Section 2.4)+    TkVarId Text+  | TkConId Text+  | TkQVarId Text Text+  | TkQConId Text Text+  | TkImplicitParam Text+  | -- Operators (per Haskell Report Section 2.4)+    TkVarSym Text+  | TkConSym Text+  | TkQVarSym Text Text+  | TkQConSym Text Text+  | -- Literals+    TkInteger Integer NumericType+  | TkFloat Rational FloatType+  | TkChar Char+  | TkCharHash Char Text+  | TkString Text+  | TkStringHash Text Text+  | TkOverloadedLabel Text Text+  | -- Special characters (per Haskell Report Section 2.2)+    TkSpecialLParen+  | TkSpecialRParen+  | TkSpecialUnboxedLParen+  | TkSpecialUnboxedRParen+  | TkSpecialComma+  | TkSpecialSemicolon+  | TkSpecialLBracket+  | TkSpecialRBracket+  | TkSpecialBacktick+  | TkSpecialLBrace+  | TkSpecialRBrace+  | -- LexicalNegation support+    TkMinusOperator+  | TkPrefixMinus+  | -- Whitespace-sensitive operator support (GHC proposal 0229)+    TkPrefixBang+  | TkPrefixTilde+  | -- OverloadedRecordDot: '.' immediately after an expression, before a lowercase ident+    TkRecordDot+  | -- TypeApplications support+    TkTypeApp+  | -- Pragmas+    TkPragma Pragma+  | -- TemplateHaskellQuotes bracket tokens+    TkTHExpQuoteOpen+  | TkTHExpQuoteClose+  | TkTHTypedQuoteOpen+  | TkTHTypedQuoteClose+  | TkTHDeclQuoteOpen+  | TkTHTypeQuoteOpen+  | TkTHPatQuoteOpen+  | TkTHQuoteTick+  | TkTHTypeQuoteTick+  | -- TemplateHaskell splice tokens (prefix $ and $$)+    TkTHSplice+  | TkTHTypedSplice+  | -- Other+    TkQuasiQuote Text Text+  | TkLineComment+  | TkBlockComment+  | TkError Text+  | TkEOF+  deriving (Data, Eq, Ord, Show, Read, Generic, NFData)++pattern TkVarRole :: LexTokenKind+pattern TkVarRole = TkVarId "role"++pattern TkVarFamily :: LexTokenKind+pattern TkVarFamily = TkVarId "family"++pattern TkVarAs :: LexTokenKind+pattern TkVarAs = TkVarId "as"++pattern TkVarHiding :: LexTokenKind+pattern TkVarHiding = TkVarId "hiding"++pattern TkVarQualified :: LexTokenKind+pattern TkVarQualified = TkVarId "qualified"++pattern TkVarSafe :: LexTokenKind+pattern TkVarSafe = TkVarId "safe"++data TokenOrigin+  = FromSource+  | InsertedLayout+  deriving (Eq, Ord, Show, Read, Generic, NFData)++data LexToken = LexToken+  { lexTokenKind :: !LexTokenKind,+    lexTokenText :: !Text,+    lexTokenSpan :: !SourceSpan,+    lexTokenOrigin :: !TokenOrigin,+    lexTokenAtLineStart :: !Bool+  }+  deriving (Eq, Ord, Show, Generic, NFData)++newtype LexerEnv = LexerEnv+  { lexerExtensions :: Set Extension+  }+  deriving (Eq, Show)++hasExt :: Extension -> LexerEnv -> Bool+hasExt ext env = Set.member ext (lexerExtensions env)++data LexerState = LexerState+  { lexerInput :: !Text,+    lexerLogicalSourceName :: !FilePath,+    lexerLine :: !Int,+    lexerCol :: !Int,+    lexerByteOffset :: !Int,+    lexerAtLineStart :: !Bool,+    lexerPrevTokenKind :: !(Maybe LexTokenKind),+    lexerHadTrivia :: !Bool+  }+  deriving (Eq, Show)++data LayoutContext+  = LayoutExplicit+  | LayoutImplicit !LayoutFrame+  | LayoutDelimiter+  deriving (Eq, Show)++data LayoutFrame = LayoutFrame+  { layoutFrameIndent :: !Int,+    layoutFrameSemicolons :: !LayoutSemicolons,+    layoutFrameChildBaseline :: !LayoutBaseline,+    -- do-block opened directly by a preceding 'then'/'else'; tracks nested+    -- classic ifs inside the block while the lexer still approximates this+    -- parse-error close.+    layoutFrameThenElseDepth :: !(Maybe Int)+  }+  deriving (Eq, Show)++data LayoutSemicolons+  = LayoutEmitSemicolons+  | LayoutSuppressSemicolons+  deriving (Eq, Show)++data LayoutIndentPolicy+  = LayoutStrictIndent+  | LayoutAllowNondecreasingIndent+  deriving (Eq, Show)++data LayoutBaseline+  = LayoutCurrentIndent+  | LayoutColumnZero+  deriving (Eq, Show)++data ImplicitLayoutSpec = ImplicitLayoutSpec+  { implicitLayoutSemicolons :: !LayoutSemicolons,+    implicitLayoutIndentPolicy :: !LayoutIndentPolicy,+    implicitLayoutBaseline :: !LayoutBaseline,+    implicitLayoutChildBaseline :: !LayoutBaseline,+    implicitLayoutThenElseDepth :: !(Maybe Int),+    implicitLayoutFlushEmptyAtEOF :: !Bool+  }+  deriving (Eq, Show)++data PendingLayout+  = PendingImplicitLayout !ImplicitLayoutSpec+  | PendingMaybeMultiWayIf+  | PendingMaybeLambdaCases+  deriving (Eq, Show)++data ModuleLayoutMode+  = ModuleLayoutOff+  | ModuleLayoutSeekStart+  | ModuleLayoutAwaitWhere+  | ModuleLayoutAwaitBody+  | ModuleLayoutDone+  deriving (Eq, Show)++data LayoutState = LayoutState+  { layoutContexts :: [LayoutContext],+    layoutPendingLayout :: !(Maybe PendingLayout),+    layoutPrevTokenKind :: !(Maybe LexTokenKind),+    layoutModuleMode :: !ModuleLayoutMode,+    layoutPrevTokenEndSpan :: !(Maybe SourceSpan),+    layoutBuffer :: [LexToken],+    layoutNondecreasingIndent :: !Bool,+    layoutLambdaCase :: !Bool+  }+  deriving (Eq, Show)++data DirectiveUpdate = DirectiveUpdate+  { directiveLine :: !(Maybe Int),+    directiveCol :: !(Maybe Int),+    directiveSourceName :: !(Maybe FilePath)+  }+  deriving (Eq, Show)++data HashLineTrivia+  = HashLineDirective !DirectiveUpdate+  | HashLineShebang+  | HashLineMalformed+  deriving (Eq, Show)++mkLexerEnv :: [Extension] -> LexerEnv+mkLexerEnv exts = LexerEnv {lexerExtensions = Set.fromList exts}++mkInitialLexerState :: FilePath -> [Extension] -> Text -> (LexerEnv, LexerState)+mkInitialLexerState sourceName exts input =+  ( mkLexerEnv exts,+    LexerState+      { lexerInput = input,+        lexerLogicalSourceName = sourceName,+        lexerLine = 1,+        lexerCol = 1,+        lexerByteOffset = 0,+        lexerAtLineStart = True,+        lexerPrevTokenKind = Nothing,+        lexerHadTrivia = True+      }+  )++mkInitialLayoutState :: Bool -> [Extension] -> LayoutState+mkInitialLayoutState enableModuleLayout exts =+  LayoutState+    { layoutContexts = [],+      layoutPendingLayout = Nothing,+      layoutPrevTokenKind = Nothing,+      layoutModuleMode =+        if enableModuleLayout+          then ModuleLayoutSeekStart+          else ModuleLayoutOff,+      layoutPrevTokenEndSpan = Nothing,+      layoutBuffer = [],+      layoutNondecreasingIndent = Syntax.NondecreasingIndentation `elem` exts,+      layoutLambdaCase = Syntax.LambdaCase `elem` exts+    }++mkToken :: LexerState -> LexerState -> Text -> LexTokenKind -> LexToken+mkToken start end tokTxt kind =+  LexToken+    { lexTokenKind = kind,+      lexTokenText = tokTxt,+      lexTokenSpan = mkSpan start end,+      lexTokenOrigin = FromSource,+      lexTokenAtLineStart = lexerAtLineStart start+    }++mkErrorToken :: LexerState -> LexerState -> Text -> Text -> LexToken+mkErrorToken start end rawTxt msg = mkToken start end rawTxt (TkError msg)++mkSpan :: LexerState -> LexerState -> SourceSpan+mkSpan start end =+  SourceSpan+    { sourceSpanSourceName = lexerLogicalSourceName start,+      sourceSpanStartLine = lexerLine start,+      sourceSpanStartCol = lexerCol start,+      sourceSpanEndLine = lexerLine end,+      sourceSpanEndCol = lexerCol end,+      sourceSpanStartOffset = lexerByteOffset start,+      sourceSpanEndOffset = lexerByteOffset end+    }++advanceChars :: Text -> LexerState -> LexerState+advanceChars consumed st =+  let !n = T.length consumed+      go (!line, !col, !byteOff, !atLineStart) ch =+        case ch of+          '\n' -> (line + 1, 1, byteOff + 1, True)+          '\t' ->+            let nextTabStop = 8 - ((col - 1) `mod` 8)+             in (line, col + nextTabStop, byteOff + 1, atLineStart)+          ' ' -> (line, col + 1, byteOff + 1, atLineStart)+          _+            | isSpace ch -> (line, col + 1, byteOff + utf8CharWidth ch, atLineStart)+            | otherwise -> (line, col + 1, byteOff + utf8CharWidth ch, False)+      (!finalLine, !finalCol, !finalByteOff, !finalAtLineStart) =+        T.foldl' go (lexerLine st, lexerCol st, lexerByteOffset st, lexerAtLineStart st) consumed+   in st+        { lexerInput = T.drop n (lexerInput st),+          lexerLine = finalLine,+          lexerCol = finalCol,+          lexerByteOffset = finalByteOff,+          lexerAtLineStart = finalAtLineStart+        }++advanceN :: Int -> LexerState -> LexerState+advanceN n st = advanceChars (T.take n (lexerInput st)) st++consumeWhile :: (Char -> Bool) -> LexerState -> LexerState+consumeWhile f st =+  let consumed = T.takeWhile f (lexerInput st)+   in advanceChars consumed st++tokenStartCol :: LexToken -> Int+tokenStartCol tok =+  case lexTokenSpan tok of+    SourceSpan {sourceSpanStartCol = col} -> col+    NoSourceSpan -> 1++virtualSymbolToken :: Text -> SourceSpan -> LexToken+virtualSymbolToken sym span' =+  LexToken+    { lexTokenKind = case sym of+        "{" -> TkSpecialLBrace+        "}" -> TkSpecialRBrace+        ";" -> TkSpecialSemicolon+        _ -> error ("virtualSymbolToken: unknown symbol: " ++ show sym),+      lexTokenText = sym,+      lexTokenSpan = span',+      lexTokenOrigin = InsertedLayout,+      lexTokenAtLineStart = False+    }++utf8CharWidth :: Char -> Int+utf8CharWidth ch =+  case ord ch of+    code+      | code <= 0x7F -> 1+      | code <= 0x7FF -> 2+      | code <= 0xFFFF -> 3+      | otherwise -> 4++isSymbolicOpChar :: Char -> Bool+isSymbolicOpChar c = c `elem` (":!#$%&*+./<=>?@\\^|-~" :: String) || isUnicodeSymbol c++isUnicodeSymbol :: Char -> Bool+isUnicodeSymbol c =+  isUnicodeSymbolCategory c+    || c == '∷'+    || c == '⇒'+    || c == '→'+    || c == '←'+    || c == '∀'+    || c == '⤙'+    || c == '⤚'+    || c == '⤛'+    || c == '⤜'+    || c == '⦇'+    || c == '⦈'+    || c == '⟦'+    || c == '⟧'+    || c == '⊸'++isUnicodeSymbolCategory :: Char -> Bool+isUnicodeSymbolCategory c =+  case generalCategory c of+    MathSymbol -> True+    CurrencySymbol -> True+    ModifierSymbol -> not (isAscii c)+    OtherSymbol -> True+    ConnectorPunctuation -> not (isAscii c)+    DashPunctuation -> not (isAscii c)+    OtherPunctuation -> not (isAscii c)+    _ -> False
+ src/Aihc/Parser/Parens.hs view
@@ -0,0 +1,2160 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Aihc.Parser.Parens+-- Description : Parenthesization pass for AST+--+-- This module provides a parenthesization pass that inserts 'EParen', 'PParen',+-- 'TParen', and 'CmdPar' nodes at all required positions in the AST. After this+-- pass, the pretty-printer can format code without worrying about parentheses.+--+-- The pass is __idempotent__: calling it twice produces the same result as+-- calling it once. It never adds unnecessary parentheses, so parsed code+-- (which already has explicit paren nodes from the source) is not modified.+--+-- __Entry points:__+--+-- * 'addModuleParens'  — parenthesise an entire module+-- * 'addDeclParens'    — parenthesise a declaration+-- * 'addExprParens'    — parenthesise an expression+-- * 'addPatternParens' — parenthesise a pattern+-- * 'addSignatureTypeParens' — parenthesise a signature type+-- * 'addTypeParens'          — parenthesise a plain type+module Aihc.Parser.Parens+  ( addModuleParens,+    addDeclParens,+    addExprParens,+    addPatternParens,+    addSignatureTypeParens,+    addTypeParens,+  )+where++import Aihc.Parser.Syntax+import Data.Bifunctor (bimap)+import Data.Char (isHexDigit)+import Data.Maybe (isJust, isNothing)+import Data.Text qualified as T++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Aihc.Parser.Shorthand (Shorthand(..))+-- >>> import Aihc.Parser.Syntax++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++-- | Wrap an expression in 'EParen' if the predicate holds, unless it is+-- already parenthesised.+wrapExpr :: Bool -> Expr -> Expr+wrapExpr True (EAnn ann sub) = EAnn ann (wrapExpr True sub)+wrapExpr True e@EParen {} = e+wrapExpr True e = EParen e+wrapExpr False e = e++wrapCmd :: Bool -> Cmd -> Cmd+wrapCmd True (CmdAnn ann sub) = CmdAnn ann (wrapCmd True sub)+wrapCmd True c@CmdPar {} = c+wrapCmd True c = CmdPar c+wrapCmd False c = c++-- | Wrap a pattern in 'PParen' if the predicate holds, unless already wrapped.+wrapPat :: Bool -> Pattern -> Pattern+wrapPat True (PAnn ann sub) = PAnn ann (wrapPat True sub)+wrapPat True p@PParen {} = p+wrapPat True p = PParen p+wrapPat False p = p++-- | Wrap a type in 'TParen' if the predicate holds, unless already wrapped.+wrapTy :: Bool -> Type -> Type+wrapTy True (TAnn ann sub) = TAnn ann (wrapTy True sub)+wrapTy True t@TParen {} = t+wrapTy True t = TParen t+wrapTy False t = t++-- ---------------------------------------------------------------------------+-- Expression classification helpers (mirrored from Pretty.hs)+-- ---------------------------------------------------------------------------++-- | Check if an expression is a "block expression" that can appear without+-- parentheses as a function argument when BlockArguments is enabled.+isBlockExpr :: Expr -> Bool+isBlockExpr = \case+  EAnn _ sub -> isBlockExpr sub+  EIf {} -> True+  EMultiWayIf {} -> True+  ECase {} -> True+  EDo {} -> True+  ELambdaPats {} -> True+  ELambdaCase {} -> True+  ELambdaCases {} -> True+  ELetDecls {} -> True+  EProc {} -> True+  _ -> False++-- | Check if an expression is "greedy" - i.e., it could consume trailing syntax.+isGreedyExpr :: Expr -> Bool+isGreedyExpr = \case+  EAnn _ sub -> isGreedyExpr sub+  ECase {} -> True+  EIf {} -> True+  EMultiWayIf {} -> True+  ELambdaPats {} -> True+  ELambdaCase {} -> True+  ELambdaCases {} -> True+  ELetDecls {} -> True+  EDo {} -> True+  EProc {} -> True+  EApp _ arg | isBlockExpr arg -> isOpenEnded arg+  EApp _ arg -> isGreedyExpr arg+  _ -> False++-- | Check if an expression is "open-ended" - its rightmost component can+-- capture a trailing where clause.+isOpenEnded :: Expr -> Bool+isOpenEnded = \case+  EAnn _ sub -> isOpenEnded sub+  ECase _ alts -> not (null alts)+  EIf {} -> True+  EMultiWayIf {} -> True+  ELambdaPats {} -> True+  ELetDecls {} -> True+  EProc {} -> True+  ENegate inner -> isOpenEnded inner+  EInfix _ _ rhs -> isOpenEnded rhs+  EApp _ arg | isBlockExpr arg -> isOpenEnded arg+  _ -> False++-- | Does the pretty-printed form of an expression end with @:: Type@?+endsWithTypeSig :: Expr -> Bool+endsWithTypeSig = \case+  EAnn _ sub -> endsWithTypeSig sub+  ETypeSig {} -> True+  ELetDecls _ body -> endsWithTypeSig body+  ELambdaPats _ body -> endsWithTypeSig body+  EMultiWayIf rhss ->+    case reverse rhss of+      grhs : _ -> endsWithTypeSig (guardedRhsBody grhs)+      [] -> False+  ENegate inner -> endsWithTypeSig inner+  EInfix _ _ rhs -> endsWithTypeSig rhs+  EApp _ arg -> endsWithTypeSig arg+  EIf _ _ no -> endsWithTypeSig no+  _ -> False++-- | Check whether an expression needs parenthesization before a record dot.+-- Qualified variables (e.g., @A.x@), ambiguous TH name quotes, TH splices+-- (@$x@, @$$x@), primitive literals, MagicHash literals, and identifiers ending in @#@ all+-- need parens to prevent ambiguity:+-- - Qualified names: @A.x.field@ looks like the qualified name @A.x.field@+-- - TH quotes: @'M.x.field@ looks like quoting the qualified name @M.x.field@+-- - TH splices: @$x.field@ and @$$x.field@ parse as a splice followed by an+--   unexpected @.@+-- - Primitive numeric literals: @10#.field@ makes @#.@ part of an operator+-- - MagicHash: @'c'#.field@ or @x#.field@ — the @#.@ merges into an operator+needsParensBeforeDot :: Expr -> Bool+needsParensBeforeDot = \case+  EAnn _ sub -> needsParensBeforeDot sub+  ENegate inner -> startsWithPrimitiveLiteral inner+  EVar name -> nameNeedsParensBeforeDot name+  ETHSplice body -> spliceBodyNeedsParensBeforeDot body+  ETHTypedSplice body -> spliceBodyNeedsParensBeforeDot body+  -- Most TH value name quotes are already delimited enough for record dot:+  -- @'x.field@, @'().field@, and @'(M.+).field@ parse as field access.+  -- Qualified identifiers are different: @'M.x.field@ quotes @M.x.field@.+  -- Hash-ending names also need grouping because @'x#.field@ does not parse+  -- as record-dot access on the quoted name.+  ETHNameQuote body -> thNameQuoteNeedsParensBeforeDot body+  -- TH type name quotes need the same distinction.  Built-in type+  -- constructors are accepted as @''().field@ and @''[].field@, while+  -- @''T.field@ and @''(T).field@ are rejected unless the quote is grouped.+  ETHTypeNameQuote ty -> thTypeNameQuoteNeedsParensBeforeDot ty+  EInt _ nt _ -> nt /= TInteger+  EFloat _ ft _ -> ft /= TFractional+  -- MagicHash literals: the trailing # merges with . to form an operator+  ECharHash {} -> True+  EStringHash {} -> True+  _ -> False++spliceBodyNeedsParensBeforeDot :: Expr -> Bool+spliceBodyNeedsParensBeforeDot = \case+  EAnn _ sub -> spliceBodyNeedsParensBeforeDot sub+  EVar name ->+    T.isSuffixOf "#" (nameText name)+      || ( isJust (nameQualifier name)+             && case nameType name of+               NameVarId -> True+               NameConId -> True+               NameVarSym -> False+               NameConSym -> False+         )+  EInt _ nt _ -> nt /= TInteger+  EFloat _ ft _ -> ft /= TFractional+  ECharHash {} -> True+  EStringHash {} -> True+  _ -> False++nameNeedsParensBeforeDot :: Name -> Bool+nameNeedsParensBeforeDot name =+  T.isSuffixOf "#" (nameText name)+    || ( isJust (nameQualifier name)+           && case nameType name of+             NameVarId -> True+             NameConId -> True+             NameVarSym -> False+             NameConSym -> False+       )++thNameQuoteNeedsParensBeforeDot :: Expr -> Bool+thNameQuoteNeedsParensBeforeDot = \case+  EAnn _ sub -> thNameQuoteNeedsParensBeforeDot sub+  EVar name ->+    T.isSuffixOf "#" (nameText name)+      || ( isJust (nameQualifier name)+             && case nameType name of+               NameVarId -> True+               NameConId -> True+               NameVarSym -> False+               NameConSym -> False+         )+  _ -> False++thTypeNameQuoteNeedsParensBeforeDot :: Type -> Bool+thTypeNameQuoteNeedsParensBeforeDot = \case+  TAnn _ sub -> thTypeNameQuoteNeedsParensBeforeDot sub+  TCon name _ ->+    case nameType name of+      NameVarSym -> False+      NameConSym -> False+      _ -> True+  TTuple {} -> False+  TBuiltinCon {} -> False+  TList _ [] -> False+  _ -> True++-- | Check whether an expression's pretty-printed form starts with a block form.+startsWithBlockExpr :: Expr -> Bool+startsWithBlockExpr = \case+  EAnn _ sub -> startsWithBlockExpr sub+  EInfix lhs _ _ -> startsWithBlockExpr lhs+  EApp fn _ -> startsWithBlockExpr fn+  ERecordUpd base _ -> startsWithBlockExpr base+  EGetField base _ -> startsWithBlockExpr base+  ETypeSig inner _ -> startsWithBlockExpr inner+  ETypeApp fn _ -> startsWithBlockExpr fn+  expr -> isBlockExpr expr++-- | Check whether an expression starts with a primitive (unboxed) numeric+-- literal.  This matters before record-dot syntax: @10#.field@ is tokenized+-- differently from @(10#).field@.  Negation itself prints with a separating+-- space, so @- 10#@ does not merge into a negative primitive literal token.+startsWithPrimitiveLiteral :: Expr -> Bool+startsWithPrimitiveLiteral = go+  where+    go (EAnn _ sub) = go sub+    go (EInt _ nt _) = nt /= TInteger+    go (EFloat _ ft _) = ft /= TFractional+    go (EApp fn _) = go fn+    go (ERecordUpd base _) = go base+    go (ETypeApp fn _) = go fn+    go (ETypeSig inner _) = go inner+    go _ = False++-- ---------------------------------------------------------------------------+-- Expression contexts+-- ---------------------------------------------------------------------------++data ExprCtx+  = CtxInfixRhs Bool+  | CtxInfixLhs+  | CtxAppFun+  | CtxAppArg+  | CtxAppArgNoParens+  | CtxAppArgGreedy+  | CtxSectionRhs+  | CtxTypeSigBody+  | CtxGuarded++needsExprParens :: ExprCtx -> Expr -> Bool+needsExprParens ctx (EAnn _ sub) = needsExprParens ctx sub+needsExprParens ctx expr =+  case ctx of+    CtxInfixRhs protectOpenEnded ->+      case expr of+        -- The expression parser builds left-associated chains, so a nested+        -- infix expression on the RHS only appears when the source had+        -- explicit parentheses.+        EInfix {} -> True+        ETypeSig {} -> True+        _ | protectOpenEnded && absorbsFollowingInfix expr -> True+        -- ENegate does NOT need parenthesization in infix RHS position.+        -- GHC already rejects `x + - 1` (precedence >= 6) at parse time,+        -- so any ENegate appearing as the RHS of an infix operator in a+        -- successfully parsed module is guaranteed to be valid without+        -- parentheses. Wrapping in EParen would introduce a spurious HsPar+        -- in the GHC AST, causing roundtrip fingerprint mismatches.+        _ -> False+    CtxInfixLhs ->+      case expr of+        ETypeSig {} -> True+        EMultiWayIf {} -> False+        -- ENegate needs parenthesization when its inner expression is+        -- open-ended (e.g. ends with a `let` body).  Without parens, the+        -- parser re-reads `- f let {} in x \`op\` y` as+        -- `-(f (let {} in (x \`op\` y)))` because the `let` body greedily+        -- consumes the infix.  For non-greedy inner expressions (plain+        -- variables, literals, etc.) no parens are needed: `-x + 1` is+        -- correctly re-parsed as `(-x) + 1`.+        ENegate inner -> isOpenEnded inner+        ECase {} -> False+        _ -> isOpenEnded expr+    CtxAppFun ->+      case expr of+        ENegate {} -> True+        _ -> False+    CtxAppArg ->+      case expr of+        _ | endsWithTypeSig expr -> True+        _ | isBlockExpr expr -> False+        -- A pragma as a function argument needs parens: `fn {-# P #-} x` is+        -- ambiguous; `fn ({-# P #-} x)` is unambiguous.+        EPragma {} -> True+        _ -> False+    CtxAppArgNoParens ->+      False+    CtxAppArgGreedy ->+      case expr of+        ECase {} -> False+        EPragma {} -> True+        _ -> isGreedyExpr expr+    CtxSectionRhs ->+      case expr of+        ETypeSig {} -> True+        _ -> False+    CtxTypeSigBody ->+      case expr of+        ETypeSig {} -> True+        ENegate inner -> isGreedyExpr inner || isOpenEnded inner || endsWithTypeSig inner+        ELambdaPats {} -> True+        ECase {} -> False+        EMultiWayIf {} -> False+        EDo {} -> False+        ELambdaCase {} -> False+        ELambdaCases {} -> False+        _ -> isOpenEnded expr+    CtxGuarded -> isGreedyExpr expr++exprCtxPrec :: ExprCtx -> Expr -> Int+exprCtxPrec ctx expr =+  case ctx of+    CtxInfixRhs _+      | isGreedyExpr expr -> 0+      | otherwise -> 1+    CtxInfixLhs+      | isBlockExpr expr -> 0+      | otherwise -> 1+    CtxAppFun -> 2+    CtxAppArg+      | isBlockExpr expr -> 0+      | otherwise -> 3+    CtxAppArgNoParens -> 0+    CtxAppArgGreedy+      | isBlockExpr expr -> 0+      | otherwise -> 3+    CtxSectionRhs -> 0+    CtxTypeSigBody+      | ECase {} <- peelExprAnn expr -> 0+      | EMultiWayIf {} <- peelExprAnn expr -> 0+      | EDo {} <- peelExprAnn expr -> 0+      | otherwise -> 1+    CtxGuarded -> 0++-- | Parenthesize a left section operand while protecting any rightmost infix+-- RHS from reassociating with the section operator.+addSectionLhsParens :: Expr -> Expr+addSectionLhsParens expr =+  case peelExprAnn expr of+    EInfix lhs op rhs ->+      EInfix+        (addExprParensIn CtxInfixLhs lhs)+        op+        (addSectionInfixRhsParens rhs)+    ENegate inner+      | isGreedyExpr inner || isOpenEnded inner ->+          wrapExpr True (addExprParens expr)+    _ -> addExprParensPrec 1 expr+  where+    addSectionInfixRhsParens rhs =+      case peelExprAnn rhs of+        EInfix {} -> wrapExpr True (addSectionLhsParens rhs)+        _ | isOpenEnded rhs -> wrapExpr True (addExprParens rhs)+        _ -> addExprParensIn (CtxInfixRhs False) rhs++-- ---------------------------------------------------------------------------+-- Type contexts+-- ---------------------------------------------------------------------------++data TypeCtx+  = CtxTypeFunArg+  | CtxTypeInfixRhs+  | CtxTypeDelimitedInfixRhs+  | CtxTypeAppFun+  | CtxTypeAppArg+  | CtxTypeDelimitedAppArg+  | CtxTypeAppVisibleArg+  | CtxTypeDelimitedAppVisibleArg+  | CtxTypeFamilyOperand+  | CtxTypeAtom+  | CtxKindSig++needsTypeParens :: TypeCtx -> Type -> Bool+needsTypeParens ctx (TAnn _ sub) = needsTypeParens ctx sub+needsTypeParens ctx ty =+  case ctx of+    CtxTypeFunArg ->+      case ty of+        TForall {} -> True+        TFun {} -> True+        TContext {} -> True+        -- TImplicitParam parses greedily: ?x :: T -> U absorbs -> U into the+        -- implicit param type, so TFun (TImplicitParam ..) .. needs parens.+        TImplicitParam {} -> True+        _ -> False+    CtxTypeInfixRhs ->+      case ty of+        TForall {} -> True+        TFun {} -> True+        TContext {} -> True+        TImplicitParam {} -> True+        _ -> False+    CtxTypeDelimitedInfixRhs ->+      case ty of+        TForall {} -> True+        TFun {} -> True+        TContext {} -> True+        TImplicitParam {} -> True+        _ -> False+    CtxTypeAppFun ->+      case ty of+        TForall {} -> True+        TFun {} -> True+        TContext {} -> True+        TInfix {} -> True+        TImplicitParam {} -> True+        _ -> False+    CtxTypeAppArg ->+      case ty of+        TQuasiQuote {} -> False+        TApp {} -> True+        TTypeApp {} -> True+        TForall {} -> True+        TFun {} -> True+        TContext {} -> True+        TInfix {} -> True+        TImplicitParam {} -> True+        TSplice {} -> False+        _ -> False+    CtxTypeDelimitedAppArg ->+      case ty of+        TQuasiQuote {} -> False+        TApp {} -> True+        TTypeApp {} -> True+        TForall {} -> True+        TFun {} -> True+        TContext {} -> True+        TInfix {} -> True+        TImplicitParam {} -> True+        TSplice {} -> False+        _ -> False+    CtxTypeAppVisibleArg ->+      case ty of+        TQuasiQuote {} -> False+        TApp {} -> True+        TTypeApp {} -> True+        TForall {} -> True+        TFun {} -> True+        TContext {} -> True+        TInfix {} -> True+        -- TStar renders as @*@, which merges with the preceding @\@@ in+        -- visible type application to form a single operator token @\@*@.+        TStar {} -> True+        -- TSplice renders with a leading '$', which merges with the preceding+        -- visible type-application '@' into an operator token.+        TSplice {} -> True+        -- TImplicitParam parses greedily: as a TApp argument ?x :: T -> U absorbs+        -- the surrounding -> U into the implicit param type.+        TImplicitParam {} -> True+        _ -> False+    CtxTypeDelimitedAppVisibleArg ->+      case ty of+        TQuasiQuote {} -> False+        TApp {} -> True+        TTypeApp {} -> True+        TForall {} -> True+        TFun {} -> True+        TContext {} -> True+        TInfix {} -> True+        TStar {} -> True+        TSplice {} -> True+        TImplicitParam {} -> True+        _ -> False+    CtxTypeFamilyOperand ->+      case ty of+        TForall {} -> True+        TFun {} -> True+        TContext {} -> True+        TInfix {} -> True+        TImplicitParam {} -> True+        TKindSig {} -> True+        _ -> False+    CtxTypeAtom ->+      case ty of+        TVar {} -> False+        TCon {} -> False+        TBuiltinCon {} -> False+        TImplicitParam {} -> False+        TTypeLit {} -> False+        TStar {} -> False+        TQuasiQuote {} -> False+        TList {} -> False+        TTuple {} -> False+        TUnboxedSum {} -> False+        TParen {} -> False+        TKindSig {} -> False+        TWildcard {} -> False+        TInfix {} -> True+        _ -> True+    CtxKindSig ->+      case ty of+        TKindSig {} -> False+        _ -> True++-- ---------------------------------------------------------------------------+-- Guard contexts+-- ---------------------------------------------------------------------------++data GuardArrow = GuardArrow | GuardEquals++guardExprNeedsParensWith :: (Type -> Bool) -> GuardArrow -> Expr -> Bool+guardExprNeedsParensWith typeSigNeedsParens arrow = \case+  EAnn _ sub -> guardExprNeedsParensWith typeSigNeedsParens arrow sub+  ETypeSig _ ty ->+    case arrow of+      GuardArrow -> typeSigNeedsParens ty+      GuardEquals -> False+  EApp _ arg | isBlockExpr arg -> guardExprNeedsParensWith typeSigNeedsParens arrow arg+  expr ->+    case arrow of+      GuardArrow -> trailingTypeSigNeedsParens typeSigNeedsParens expr+      GuardEquals -> False++trailingTypeSigNeedsParens :: (Type -> Bool) -> Expr -> Bool+trailingTypeSigNeedsParens typeSigNeedsParens expr =+  case expr of+    EAnn _ sub -> trailingTypeSigNeedsParens typeSigNeedsParens sub+    ETypeSig _ ty -> typeSigNeedsParens ty+    ELetDecls _ body -> trailingTypeSigNeedsParens typeSigNeedsParens body+    ELambdaPats _ body -> trailingTypeSigNeedsParens typeSigNeedsParens body+    EInfix _ _ rhs -> trailingTypeSigNeedsParens typeSigNeedsParens rhs+    EApp _ arg -> trailingTypeSigNeedsParens typeSigNeedsParens arg+    EIf _ _ no -> trailingTypeSigNeedsParens typeSigNeedsParens no+    _ -> False++typeHasFunctionArrow :: Type -> Bool+typeHasFunctionArrow ty =+  case ty of+    TAnn _ sub -> typeHasFunctionArrow sub+    TParen sub -> typeHasFunctionArrow sub+    TForall _ inner -> typeHasFunctionArrow inner+    TContext _ inner -> typeHasFunctionArrow inner+    TKindSig lhs rhs -> typeHasFunctionArrow lhs || typeHasFunctionArrow rhs+    TFun {} -> True+    _ -> False++-- ---------------------------------------------------------------------------+-- Module+-- ---------------------------------------------------------------------------++-- | Parenthesise an entire module.+--+-- >>> shorthand $ addModuleParens (Module [] Nothing [] [] [DeclTypeSig ["f"] (TKindSig TWildcard TWildcard)])+-- Module {[DeclTypeSig ["f"] (TParen (TKindSig (TWildcard) (TWildcard)))]}+--+-- >>> shorthand $ addModuleParens (Module [] Nothing [] [] [DeclTypeSig ["f"] (TCon "Int" Unpromoted)])+-- Module {[DeclTypeSig ["f"] (TCon "Int")]}+addModuleParens :: Module -> Module+addModuleParens modu =+  modu+    { moduleDecls = map addDeclParens (moduleDecls modu)+    }++-- ---------------------------------------------------------------------------+-- Declarations+-- ---------------------------------------------------------------------------++-- | Parenthesise a declaration.+--+-- >>> shorthand $ addDeclParens (DeclTypeSig ["f"] (TKindSig TWildcard TWildcard))+-- DeclTypeSig ["f"] (TParen (TKindSig (TWildcard) (TWildcard)))+--+-- >>> shorthand $ addDeclParens (DeclTypeSig ["f"] (TCon "Int" Unpromoted))+-- DeclTypeSig ["f"] (TCon "Int")+addDeclParens :: Decl -> Decl+addDeclParens decl =+  case decl of+    DeclAnn ann sub -> DeclAnn ann (addDeclParens sub)+    DeclValue vdecl -> DeclValue (addValueDeclParens vdecl)+    DeclTypeSig names ty -> DeclTypeSig names (addSignatureTypeParens ty)+    DeclPatSyn ps -> DeclPatSyn (addPatSynDeclParens ps)+    DeclPatSynSig names ty -> DeclPatSynSig names (addSignatureTypeParens ty)+    DeclStandaloneKindSig name kind -> DeclStandaloneKindSig name (addStandaloneKindSigParens kind)+    DeclFixity {} -> decl+    DeclRoleAnnotation {} -> decl+    DeclTypeSyn synDecl ->+      DeclTypeSyn (synDecl {typeSynBody = addTypeParens (typeSynBody synDecl)})+    DeclData dataDecl -> DeclData (addDataDeclParens dataDecl)+    DeclTypeData dataDecl -> DeclTypeData (addDataDeclParens dataDecl)+    DeclNewtype newtypeDecl -> DeclNewtype (addNewtypeDeclParens newtypeDecl)+    DeclClass classDecl -> DeclClass (addClassDeclParens classDecl)+    DeclInstance instanceDecl -> DeclInstance (addInstanceDeclParens instanceDecl)+    DeclStandaloneDeriving derivingDecl -> DeclStandaloneDeriving (addStandaloneDerivingParens derivingDecl)+    DeclDefault tys -> DeclDefault (map addSignatureTypeParens tys)+    DeclForeign foreignDecl -> DeclForeign (addForeignDeclParens foreignDecl)+    DeclSplice body -> DeclSplice (addDeclSpliceParens body)+    DeclTypeFamilyDecl tf -> DeclTypeFamilyDecl (addTypeFamilyDeclParens tf)+    DeclDataFamilyDecl df -> DeclDataFamilyDecl (addDataFamilyDeclParens df)+    DeclTypeFamilyInst tfi -> DeclTypeFamilyInst (addTypeFamilyInstParens tfi)+    DeclDataFamilyInst dfi -> DeclDataFamilyInst (addDataFamilyInstParens dfi)+    DeclPragma {} -> decl++addDeclSpliceParens :: Expr -> Expr+addDeclSpliceParens = addExprParens++addValueDeclParens :: ValueDecl -> ValueDecl+addValueDeclParens vdecl =+  case vdecl of+    PatternBind multTag pat rhs -> PatternBind multTag (addPatternBindLhsParens pat rhs) (addRhsParens rhs)+    FunctionBind name matches -> FunctionBind name (map (addMatchParens name) matches)++addPatternBindLhsParens :: Pattern -> Rhs Expr -> Pattern+addPatternBindLhsParens pat rhs =+  case pat of+    PAnn ann sub -> PAnn ann (addPatternBindLhsParens sub rhs)+    PTypeSig inner ty ->+      wrapPat+        (typedPatternBindLhsNeedsParens inner)+        (PTypeSig (addPatternInfixOperandParens inner) (addSignatureTypeParens ty))+    _ -> addPatternParens pat++typedPatternBindLhsNeedsParens :: Pattern -> Bool+typedPatternBindLhsNeedsParens (PAnn _ sub) = typedPatternBindLhsNeedsParens sub+typedPatternBindLhsNeedsParens (PCon name typeArgs args) =+  not (null typeArgs) || not (null args) || isNothing (nameQualifier name)+typedPatternBindLhsNeedsParens _ = False++addMatchParens :: UnqualifiedName -> Match -> Match+addMatchParens name match =+  match+    { matchPats = addFunctionHeadPats name (matchHeadForm match) (matchPats match),+      matchRhs = addRhsParens (matchRhs match)+    }++addFunctionHeadPats :: UnqualifiedName -> MatchHeadForm -> [Pattern] -> [Pattern]+addFunctionHeadPats _name headForm pats =+  case headForm of+    MatchHeadPrefix -> map addFunctionHeadPatternAtomParens pats+    MatchHeadInfix ->+      case pats of+        lhs : rhs : tailPats ->+          let lhs' = addInfixFunctionHeadPatternAtomParens lhs+              rhs' = addInfixFunctionHeadPatternAtomParens rhs+           in case tailPats of+                [] -> [lhs', rhs']+                _ ->+                  -- When infix head has tail pats, the infix part is wrapped in parens+                  -- and tail pats use function head atom rules+                  lhs' : rhs' : map addFunctionHeadPatternAtomParens tailPats+        _ -> map addFunctionHeadPatternAtomParens pats++addRhsParens :: Rhs Expr -> Rhs Expr+addRhsParens rhs =+  case rhs of+    UnguardedRhs sp body whereDecls ->+      UnguardedRhs sp (addExprParens body) (fmap (map addDeclParens) whereDecls)+    GuardedRhss sp guards whereDecls ->+      GuardedRhss sp (map (addGuardedRhsParens GuardEquals) guards) (fmap (map addDeclParens) whereDecls)++addGuardedRhsParens :: GuardArrow -> GuardedRhs Expr -> GuardedRhs Expr+addGuardedRhsParens arrow grhs =+  grhs+    { guardedRhsGuards = addGuardQualifiersParens arrow (guardedRhsGuards grhs),+      guardedRhsBody = addExprParens (guardedRhsBody grhs)+    }++addGuardQualifiersParens :: GuardArrow -> [GuardQualifier] -> [GuardQualifier]+addGuardQualifiersParens arrow quals =+  case quals of+    [] -> []+    [qual] -> [addGuardQualifierParens arrow True qual]+    qual : rest -> addGuardQualifierParens arrow False qual : addGuardQualifiersParens arrow rest++addGuardQualifierParens :: GuardArrow -> Bool -> GuardQualifier -> GuardQualifier+addGuardQualifierParens arrow isLast qual =+  case qual of+    GuardAnn ann inner -> GuardAnn ann (addGuardQualifierParens arrow isLast inner)+    GuardExpr expr -> GuardExpr (addGuardExprParens arrow expr)+    GuardPat pat expr -> GuardPat (addPatternParens pat) (addPatternGuardExprParens arrow isLast expr)+    GuardLet decls -> GuardLet (map addDeclParens decls)++addGuardExprParens :: GuardArrow -> Expr -> Expr+addGuardExprParens arrow expr =+  wrapExpr (guardExprNeedsParensWith (const True) arrow expr) (addExprParens expr)++addPatternGuardExprParens :: GuardArrow -> Bool -> Expr -> Expr+addPatternGuardExprParens arrow isLast expr =+  let typeSigNeedsParens+        | isLast = const True+        | otherwise = typeHasFunctionArrow+   in wrapExpr (guardExprNeedsParensWith typeSigNeedsParens arrow expr) (addExprParens expr)++addPatSynDeclParens :: PatSynDecl -> PatSynDecl+addPatSynDeclParens ps =+  ps+    { patSynDeclPat = addPatternParens (patSynDeclPat ps),+      patSynDeclDir = addPatSynDirParens (patSynDeclName ps) (patSynDeclDir ps)+    }++addPatSynDirParens :: UnqualifiedName -> PatSynDir -> PatSynDir+addPatSynDirParens _ PatSynBidirectional = PatSynBidirectional+addPatSynDirParens _ PatSynUnidirectional = PatSynUnidirectional+addPatSynDirParens name (PatSynExplicitBidirectional matches) =+  PatSynExplicitBidirectional (map (addMatchParens name) matches)++addDataDeclParens :: DataDecl -> DataDecl+addDataDeclParens decl =+  decl+    { dataDeclCTypePragma = fmap stripPragmaRawText (dataDeclCTypePragma decl),+      dataDeclContext = addContextConstraints (dataDeclContext decl),+      dataDeclKind = fmap addSignatureTypeParens (dataDeclKind decl),+      dataDeclConstructors = map addDataConDeclParens (dataDeclConstructors decl),+      dataDeclDeriving = map addDerivingClauseParens (dataDeclDeriving decl)+    }++addNewtypeDeclParens :: NewtypeDecl -> NewtypeDecl+addNewtypeDeclParens decl =+  decl+    { newtypeDeclCTypePragma = fmap stripPragmaRawText (newtypeDeclCTypePragma decl),+      newtypeDeclContext = addContextConstraints (newtypeDeclContext decl),+      newtypeDeclKind = fmap addSignatureTypeParens (newtypeDeclKind decl),+      newtypeDeclConstructor = fmap addDataConDeclParens (newtypeDeclConstructor decl),+      newtypeDeclDeriving = map addDerivingClauseParens (newtypeDeclDeriving decl)+    }++stripPragmaRawText :: Pragma -> Pragma+stripPragmaRawText pragma = pragma {pragmaRawText = ""}++addDerivingClauseParens :: DerivingClause -> DerivingClause+addDerivingClauseParens dc =+  dc+    { derivingClasses =+        case derivingClasses dc of+          Left name -> Left name+          Right classes -> Right (map addSignatureTypeParens classes),+      derivingStrategy = fmap addDerivingStrategyParens (derivingStrategy dc)+    }++addDerivingStrategyParens :: DerivingStrategy -> DerivingStrategy+addDerivingStrategyParens strategy =+  case strategy of+    DerivingVia ty -> DerivingVia (addSignatureTypeParens ty)+    _ -> strategy++addDataConDeclParens :: DataConDecl -> DataConDecl+addDataConDeclParens con =+  case con of+    DataConAnn ann inner -> DataConAnn ann (addDataConDeclParens inner)+    PrefixCon forallVars constraints name fields ->+      PrefixCon (map addTyVarBinderParens forallVars) (addContextConstraints constraints) name (map addPrefixConBangTypeParens fields)+    InfixCon forallVars constraints lhs op rhs ->+      InfixCon (map addTyVarBinderParens forallVars) (addContextConstraints constraints) (addInfixConBangTypeParens lhs) op (addInfixConBangTypeParens rhs)+    RecordCon forallVars constraints name fields ->+      RecordCon (map addTyVarBinderParens forallVars) (addContextConstraints constraints) name (map addRecordFieldDeclParens fields)+    GadtCon forallBinders constraints names body ->+      GadtCon forallBinders (addContextConstraints constraints) names (addGadtBodyParens body)+    TupleCon forallVars constraints flavor fields ->+      TupleCon (map addTyVarBinderParens forallVars) (addContextConstraints constraints) flavor (map addPrefixConBangTypeParens fields)+    UnboxedSumCon forallVars constraints pos arity field ->+      UnboxedSumCon (map addTyVarBinderParens forallVars) (addContextConstraints constraints) pos arity (addPrefixConBangTypeParens field)+    ListCon forallVars constraints ->+      ListCon (map addTyVarBinderParens forallVars) (addContextConstraints constraints)++addBangTypeParens :: BangType -> BangType+addBangTypeParens bt =+  bt+    { bangType =+        wrapTy+          ( (bangStrict bt || bangLazy bt)+              && bangTypeNeedsPrefixParens (bangType bt)+          )+          (addTypeIn CtxTypeAtom (bangType bt))+    }++-- | Determine whether a type, when directly following a bang (!) or lazy (~)+-- prefix, needs to be parenthesized to avoid lexer ambiguity. This happens+-- when the type's rendering starts with a symbol character that would fuse+-- with the ! or ~ to form a single operator token.+bangTypeNeedsPrefixParens :: Type -> Bool+bangTypeNeedsPrefixParens (TAnn _ sub) = bangTypeNeedsPrefixParens sub+bangTypeNeedsPrefixParens (TParen _) = False+bangTypeNeedsPrefixParens TStar {} = True+bangTypeNeedsPrefixParens (TCon _ Promoted) = True+bangTypeNeedsPrefixParens (TBuiltinCon TBuiltinCons) = True+bangTypeNeedsPrefixParens (TBuiltinCon _) = False+bangTypeNeedsPrefixParens TImplicitParam {} = True+bangTypeNeedsPrefixParens TSplice {} = True+-- Compound types: the first rendered character comes from the head/lhs.+bangTypeNeedsPrefixParens (TApp f _) = bangTypeNeedsPrefixParens f+bangTypeNeedsPrefixParens (TTypeApp f _) = bangTypeNeedsPrefixParens f+bangTypeNeedsPrefixParens (TFun _ a _) = bangTypeNeedsPrefixParens a+bangTypeNeedsPrefixParens (TKindSig ty _) = bangTypeNeedsPrefixParens ty+bangTypeNeedsPrefixParens (TContext cs _) = case cs of+  [] -> False+  (c : _) -> bangTypeNeedsPrefixParens c+bangTypeNeedsPrefixParens (TForall {}) = True+-- Promoted tuples/lists start with a tick mark.+bangTypeNeedsPrefixParens (TTuple _ promoted _) = promoted == Promoted+bangTypeNeedsPrefixParens (TList promoted _) = promoted == Promoted+-- Infix types render lhs first.+bangTypeNeedsPrefixParens (TInfix lhs _ _ _) = bangTypeNeedsPrefixParens lhs+bangTypeNeedsPrefixParens _ = False++addPrefixConBangTypeParens :: BangType -> BangType+addPrefixConBangTypeParens bt =+  let inner = addBangTypeParens bt+   in inner+        { bangType =+            wrapTy (prefixConBangTypeNeedsParens (bangType bt)) (bangType inner)+        }++addInfixConBangTypeParens :: BangType -> BangType+addInfixConBangTypeParens bt =+  bt+    { bangType =+        wrapTy+          ( ( (bangStrict bt || bangLazy bt)+                && bangTypeNeedsPrefixParens (bangType bt)+            )+              || needsTypeParens CtxTypeFunArg (bangType bt)+              || infixConOperandNeedsParens (bangType bt)+          )+          (addTypeIn CtxTypeFunArg (bangType bt))+    }++-- | Types that would be misinterpreted as data constructor declarations+-- (unboxed sum-con or list-con) when used as an infix constructor operand.+-- Tuple operands are left bare so the raw surface syntax is preserved. The+-- data-con parsers are tried before the infix parser, so the remaining types+-- must be parenthesized to prevent ambiguity.+infixConOperandNeedsParens :: Type -> Bool+infixConOperandNeedsParens (TAnn _ sub) = infixConOperandNeedsParens sub+infixConOperandNeedsParens (TParen _) = False+infixConOperandNeedsParens (TTuple Boxed _ _) = False+infixConOperandNeedsParens (TTuple Unboxed _ _) = False+infixConOperandNeedsParens (TUnboxedSum {}) = True+infixConOperandNeedsParens (TList _ []) = True+infixConOperandNeedsParens (TBuiltinCon TBuiltinList) = True+infixConOperandNeedsParens (TInfix {}) = True+-- Application head determines what the parser sees first.+infixConOperandNeedsParens (TApp f _) = infixConOperandNeedsParens f+infixConOperandNeedsParens (TTypeApp _ TSplice {}) = True+infixConOperandNeedsParens (TTypeApp f _) = infixConOperandNeedsParens f+infixConOperandNeedsParens _ = False++prefixConBangTypeNeedsParens :: Type -> Bool+prefixConBangTypeNeedsParens (TAnn _ sub) = prefixConBangTypeNeedsParens sub+prefixConBangTypeNeedsParens TImplicitParam {} = True+prefixConBangTypeNeedsParens _ = False++addRecordFieldDeclParens :: FieldDecl -> FieldDecl+addRecordFieldDeclParens fd =+  fd+    { fieldMultiplicity = fmap addSignatureTypeParens (fieldMultiplicity fd),+      fieldType = addRecordFieldBangTypeParens (fieldType fd)+    }++addRecordFieldBangTypeParens :: BangType -> BangType+addRecordFieldBangTypeParens bt =+  bt+    { bangType =+        wrapTy+          ( (bangStrict bt || bangLazy bt)+              && bangTypeNeedsPrefixParens (bangType bt)+          )+          (addSignatureTypeParens (bangType bt))+    }++addGadtBodyParens :: GadtBody -> GadtBody+addGadtBodyParens body =+  case body of+    GadtPrefixBody args resultTy ->+      -- The GADT prefix body parser splits on -> arrows (using typeInfixParser+      -- per component). A result type that is itself a TFun, TForall, TContext,+      -- TImplicitParam, or TKindSig would be misinterpreted as additional+      -- constructor arguments, so we use addTypeIn CtxTypeFunArg to wrap it.+      GadtPrefixBody (map (Data.Bifunctor.bimap addGadtBangTypeParens addArrowKindParens) args) (addTypeIn CtxTypeFunArg resultTy)+    GadtRecordBody fields resultTy ->+      -- Record GADT result type uses typeParser so any type is fine here.+      GadtRecordBody (map addRecordFieldDeclParens fields) (addSignatureTypeParens resultTy)++addGadtBangTypeParens :: BangType -> BangType+addGadtBangTypeParens bt =+  bt+    { bangType =+        wrapTy+          ( (bangStrict bt || bangLazy bt)+              && bangTypeNeedsPrefixParens (bangType bt)+          )+          (addTypeIn CtxTypeFunArg (bangType bt))+    }++addClassDeclParens :: ClassDecl -> ClassDecl+addClassDeclParens decl =+  decl+    { classDeclContext = fmap addContextConstraints (classDeclContext decl),+      classDeclItems = map addClassItemParens (classDeclItems decl)+    }++addClassItemParens :: ClassDeclItem -> ClassDeclItem+addClassItemParens item =+  case item of+    ClassItemAnn ann sub -> ClassItemAnn ann (addClassItemParens sub)+    ClassItemTypeSig names ty -> ClassItemTypeSig names (addSignatureTypeParens ty)+    ClassItemDefaultSig name ty -> ClassItemDefaultSig name (addSignatureTypeParens ty)+    ClassItemFixity {} -> item+    ClassItemDefault vdecl -> ClassItemDefault (addValueDeclParens vdecl)+    ClassItemTypeFamilyDecl tf -> ClassItemTypeFamilyDecl (addTypeFamilyDeclParens tf)+    ClassItemDataFamilyDecl df -> ClassItemDataFamilyDecl (addDataFamilyDeclParens df)+    ClassItemDefaultTypeInst tfi -> ClassItemDefaultTypeInst (addTypeFamilyInstParens tfi)+    ClassItemPragma {} -> item++addInstanceDeclParens :: InstanceDecl -> InstanceDecl+addInstanceDeclParens decl =+  decl+    { instanceDeclContext = addContextConstraints (instanceDeclContext decl),+      instanceDeclHead = addSignatureTypeParens (instanceDeclHead decl),+      instanceDeclItems = map addInstanceItemParens (instanceDeclItems decl)+    }++addInstanceItemParens :: InstanceDeclItem -> InstanceDeclItem+addInstanceItemParens item =+  case item of+    InstanceItemAnn ann inner -> InstanceItemAnn ann (addInstanceItemParens inner)+    InstanceItemBind vdecl -> InstanceItemBind (addValueDeclParens vdecl)+    InstanceItemTypeSig names ty -> InstanceItemTypeSig names (addSignatureTypeParens ty)+    InstanceItemFixity {} -> item+    InstanceItemTypeFamilyInst tfi -> InstanceItemTypeFamilyInst (addTypeFamilyInstParens tfi)+    InstanceItemDataFamilyInst dfi -> InstanceItemDataFamilyInst (addDataFamilyInstParens dfi)+    InstanceItemPragma {} -> item++addStandaloneDerivingParens :: StandaloneDerivingDecl -> StandaloneDerivingDecl+addStandaloneDerivingParens decl =+  decl+    { standaloneDerivingStrategy = fmap addDerivingStrategyParens (standaloneDerivingStrategy decl),+      standaloneDerivingContext = addContextConstraints (standaloneDerivingContext decl),+      standaloneDerivingHead = addSignatureTypeParens (standaloneDerivingHead decl)+    }++addForeignDeclParens :: ForeignDecl -> ForeignDecl+addForeignDeclParens decl =+  decl+    { foreignType = addSignatureTypeParens (foreignType decl)+    }++addTypeFamilyDeclParens :: TypeFamilyDecl -> TypeFamilyDecl+addTypeFamilyDeclParens tf =+  tf+    { typeFamilyDeclExplicitFamilyKeyword = typeFamilyDeclExplicitFamilyKeyword tf,+      typeFamilyDeclHead = addSignatureTypeParens (typeFamilyDeclHead tf),+      typeFamilyDeclResultSig = fmap addTypeFamilyResultSigParens (typeFamilyDeclResultSig tf),+      typeFamilyDeclEquations = fmap (map addTypeFamilyEqParens) (typeFamilyDeclEquations tf)+    }++addTypeFamilyResultSigParens :: TypeFamilyResultSig -> TypeFamilyResultSig+addTypeFamilyResultSigParens sig =+  case sig of+    TypeFamilyKindSig kind -> TypeFamilyKindSig (addSignatureTypeParens kind)+    TypeFamilyTyVarSig result -> TypeFamilyTyVarSig (addTyVarBinderParens result)+    TypeFamilyInjectiveSig result injectivity -> TypeFamilyInjectiveSig (addTyVarBinderParens result) injectivity++addTypeFamilyEqParens :: TypeFamilyEq -> TypeFamilyEq+addTypeFamilyEqParens eq =+  eq+    { typeFamilyEqLhs = addTypeFamilyLhsParens (typeFamilyEqHeadForm eq) (typeFamilyEqLhs eq),+      typeFamilyEqRhs = addTypeFamilyRhsParens (typeFamilyEqRhs eq)+    }++addDataFamilyDeclParens :: DataFamilyDecl -> DataFamilyDecl+addDataFamilyDeclParens df =+  df+    { dataFamilyDeclKind = fmap addSignatureTypeParens (dataFamilyDeclKind df)+    }++addTypeFamilyInstParens :: TypeFamilyInst -> TypeFamilyInst+addTypeFamilyInstParens tfi =+  tfi+    { typeFamilyInstLhs = addTypeFamilyLhsParens (typeFamilyInstHeadForm tfi) (typeFamilyInstLhs tfi),+      typeFamilyInstRhs = addTypeFamilyRhsParens (typeFamilyInstRhs tfi)+    }++addTypeFamilyLhsParens :: TypeHeadForm -> Type -> Type+addTypeFamilyLhsParens headForm ty =+  case headForm of+    TypeHeadPrefix -> addSignatureTypeParens ty+    TypeHeadInfix ->+      case peelTypeAnn ty of+        TApp l r ->+          case peelTypeAnn l of+            TApp op lhs ->+              TApp+                (TApp (addSignatureTypeParens op) (addTypeIn CtxTypeFamilyOperand lhs))+                (addTypeIn CtxTypeFamilyOperand r)+            _ -> addSignatureTypeParens ty+        _ -> addSignatureTypeParens ty++addTypeFamilyRhsParens :: Type -> Type+addTypeFamilyRhsParens = addTypeParens++addDataFamilyInstParens :: DataFamilyInst -> DataFamilyInst+addDataFamilyInstParens dfi =+  dfi+    { dataFamilyInstHead = addDataFamilyInstHeadParens (isJust (dataFamilyInstKind dfi)) (dataFamilyInstHead dfi),+      dataFamilyInstKind = fmap addSignatureTypeParens (dataFamilyInstKind dfi),+      dataFamilyInstConstructors = map addDataConDeclParens (dataFamilyInstConstructors dfi),+      dataFamilyInstDeriving = map addDerivingClauseParens (dataFamilyInstDeriving dfi)+    }++addDataFamilyInstHeadParens :: Bool -> Type -> Type+addDataFamilyInstHeadParens followedByKindSig ty =+  case (followedByKindSig, peelTypeAnn ty) of+    (True, TImplicitParam {}) -> wrapTy True (addSignatureTypeParens ty)+    _ -> addSignatureTypeParens ty++-- ---------------------------------------------------------------------------+-- Expressions+-- ---------------------------------------------------------------------------++-- | Add parentheses to an expression at all required positions.+--+-- >>> shorthand $ addExprParens (EApp (EVar "f") (EInfix (EVar "x") "+" (EVar "y")))+-- EApp (EVar "f") (EParen (EInfix (EVar "x") "+" (EVar "y")))+--+-- >>> shorthand $ addExprParens (EApp (EVar "f") (EVar "x"))+-- EApp (EVar "f") (EVar "x")+addExprParens :: Expr -> Expr+addExprParens = addExprParensPrec 0++addExprParensIn :: ExprCtx -> Expr -> Expr+addExprParensIn ctx@(CtxInfixRhs protectOpenEnded) expr@EInfix {} =+  wrapExpr (needsExprParens ctx expr) (addInfixRhsParens protectOpenEnded expr)+addExprParensIn ctx expr =+  wrapExpr (needsExprParens ctx expr) (addExprParensPrec (exprCtxPrec ctx expr) expr)++-- | Flatten a left-nested application chain.+flattenApps :: Expr -> (Expr, [Expr])+flattenApps = go []+  where+    go args (EAnn _ x) = go args x+    go args (EApp fn arg) = go (arg : args) fn+    go args root = (root, args)++addExprParensPrec :: Int -> Expr -> Expr+addExprParensPrec prec expr =+  case expr of+    EApp {} -> addAppsChainPrec prec expr+    ETypeApp fn ty ->+      let fn' = wrapExpr (isGreedyExpr fn) (addExprParensIn CtxAppFun fn)+       in wrapExpr (prec > 2) (ETypeApp fn' (addTypeIn CtxTypeAppVisibleArg ty))+    ETypeSyntax form ty -> wrapExpr (prec > 2) (ETypeSyntax form (addSignatureTypeParens ty))+    EVar {} -> expr+    EInt {} -> expr+    EFloat {} -> expr+    EChar {} -> expr+    ECharHash {} -> expr+    EString {} -> expr+    EStringHash {} -> expr+    EOverloadedLabel {} -> expr+    EQuasiQuote {} -> expr+    ETHExpQuote body -> ETHExpQuote (addExprParens body)+    ETHTypedQuote body -> ETHTypedQuote (addExprParens body)+    ETHDeclQuote decls -> ETHDeclQuote (map addDeclParens decls)+    ETHTypeQuote ty -> ETHTypeQuote (addTypeParens ty)+    ETHPatQuote pat -> ETHPatQuote (addTHPatQuoteParens pat)+    ETHNameQuote body -> ETHNameQuote (addExprParens body)+    ETHTypeNameQuote ty -> ETHTypeNameQuote (addSignatureTypeParens ty)+    ETHSplice body -> ETHSplice (addSpliceBodyParens body)+    ETHTypedSplice body -> ETHTypedSplice (addSpliceBodyParens body)+    EIf cond yes no ->+      wrapExpr+        (prec > 0)+        (EIf (addExprParens cond) (addExprParens yes) (addExprParens no))+    EMultiWayIf rhss ->+      wrapExpr (prec > 0) (EMultiWayIf (map (addGuardedRhsParens GuardArrow) rhss))+    ELambdaPats pats body ->+      wrapExpr (prec > 0) (ELambdaPats (map addArrowBndrPatternParens pats) (addExprParens body))+    ELambdaCase alts ->+      wrapExpr (prec > 0) (ELambdaCase (map addCaseAltParens alts))+    ELambdaCases alts ->+      wrapExpr (prec > 0) (ELambdaCases (map addLambdaCaseAltParens alts))+    EInfix lhs op rhs ->+      wrapExpr+        (prec > 1)+        ( EInfix+            (addTopLevelInfixLhsParens prec lhs)+            op+            (addExprParensIn (CtxInfixRhs (prec == 1)) rhs)+        )+    ENegate inner ->+      wrapExpr (prec > 2) (ENegate (addNegateParens inner))+    ESectionL lhs op ->+      -- Sections always require surrounding parens in source syntax.+      -- Wrap in EParen so the AST matches what the parser produces.+      let lhs' =+            if isGreedyExpr lhs || isTypeSig lhs+              then wrapExpr True (addExprParens lhs)+              else addSectionLhsParens lhs+       in EParen (ESectionL lhs' op)+    ESectionR op rhs ->+      -- Right sections accept ordinary expressions as operands. Only explicit+      -- type signatures need extra grouping to avoid @(`op` x :: T)@.+      EParen (ESectionR op (addExprParensIn CtxSectionRhs rhs))+    ELetDecls decls body ->+      wrapExpr (prec > 0) (ELetDecls (map addDeclParens decls) (addExprParens body))+    ECase scrutinee alts ->+      wrapExpr (prec > 0) (ECase (addExprParens scrutinee) (map addCaseAltParens alts))+    EDo stmts flavor ->+      wrapExpr (prec > 0) (EDo (map addDoStmtParens stmts) flavor)+    EListComp body quals ->+      EListComp (addExprParens body) (map addCompStmtParens quals)+    EListCompParallel body qualifierGroups ->+      EListCompParallel (addExprParens body) (map (map addCompStmtParens) qualifierGroups)+    EArithSeq seqInfo -> EArithSeq (addArithSeqParens seqInfo)+    ERecordCon name fields hasWildcard ->+      ERecordCon name [field {recordFieldValue = addExprParens (recordFieldValue field)} | field <- fields] hasWildcard+    ERecordUpd base fields ->+      ERecordUpd (addExprParensPrec 3 base) [field {recordFieldValue = addExprParens (recordFieldValue field)} | field <- fields]+    EGetField base field ->+      -- Qualified names (A.a) must be parenthesized because A.a.field would be+      -- parsed as the qualified name A.a.field rather than field access on A.a.+      let base' = addExprParensPrec 3 base+       in EGetField (wrapExpr (needsParensBeforeDotField base' field) base') field+    EGetFieldProjection {} -> EParen expr+    ETypeSig inner ty ->+      wrapExpr (prec > 1) (ETypeSig (addTypeSigBodyParens inner) (addSignatureTypeParens ty))+    EParen inner ->+      -- If inner is a section or projection, addExprParens(inner) already produces EParen(section/projection).+      -- Delegating avoids double-wrapping and maintains idempotency.+      case peelExprAnn inner of+        ESectionL {} -> addExprParens inner+        ESectionR {} -> addExprParens inner+        EGetFieldProjection {} -> addExprParens inner+        _ -> EParen (addExprParens inner)+    EList values -> EList (map addDelimitedExprParens values)+    ETuple tupleFlavor values -> ETuple tupleFlavor (map (fmap addDelimitedExprParens) values)+    EUnboxedSum altIdx arity inner -> EUnboxedSum altIdx arity (addDelimitedExprParens inner)+    EProc pat body ->+      wrapExpr (prec > 0) (EProc (addArrowBndrPatternParens pat) (addCmdParensIn CtxCmdTop body))+    EPragma pragma inner ->+      -- EPragma is transparent w.r.t. precedence: wrapping decisions are made+      -- by the outer context via needsExprParens, not by a self-prec check.+      EPragma pragma (addExprParens inner)+    EAnn ann sub -> EAnn ann (addExprParensPrec prec sub)+  where+    isTypeSig :: Expr -> Bool+    isTypeSig (EAnn _ sub) = isTypeSig sub+    isTypeSig (ETypeSig {}) = True+    isTypeSig _ = False++-- | Handle application chains, preserving original EApp spans.+addAppsChainPrec :: Int -> Expr -> Expr+addAppsChainPrec prec expr =+  let (root, args) = flattenApps expr+      root' = addExprParensIn CtxAppFun root+      nArgs = length args+      args' =+        [ let isLast = i == nArgs - 1+              canStayBare = isBlockExpr a && not (endsWithTypeSig a) && (isLast || not (isOpenEnded a))+              ctx+                | canStayBare = CtxAppArgNoParens+                | isLast = CtxAppArg+                | isGreedyExpr a = CtxAppArgGreedy+                | otherwise = CtxAppArg+           in addExprParensIn ctx a+        | (i, a) <- Prelude.zip [0 :: Int ..] args+        ]+      rebuilt = foldl EApp root' args'+   in wrapExpr (prec > 2) rebuilt++addSpliceBodyParens :: Expr -> Expr+addSpliceBodyParens body =+  case body of+    EAnn ann sub -> EAnn ann (addSpliceBodyParens sub)+    -- Bare variable names, including qualified names like $A.a, use the+    -- compact splice syntax. Symbolic names still render with their own+    -- operator parentheses, e.g. $(A.+).+    EVar {} -> body+    -- Tuple and unboxed-sum syntax is already delimited, so the splice marker+    -- can attach directly: $(), $$(1, 2), $(# | x #).+    ETuple tupleFlavor values -> ETuple tupleFlavor (map (fmap addExprParens) values)+    EUnboxedSum altIdx arity inner -> EUnboxedSum altIdx arity (addExprParens inner)+    -- For everything else (including sections, which addExprParens now wraps+    -- in EParen): wrap in one outer EParen so the body prints as $(expr).+    -- A body that was already parenthesized keeps exactly one wrapper for+    -- sections/projections, whose addExprParens result is itself an EParen.+    EParen inner ->+      case peelExprAnn inner of+        ESectionL {} -> addExprParens inner+        ESectionR {} -> addExprParens inner+        EGetFieldProjection {} -> addExprParens inner+        _ -> EParen (addExprParens inner)+    _ -> EParen (addExprParens body)++needsParensBeforeDotField :: Expr -> Name -> Bool+needsParensBeforeDotField base field =+  needsParensBeforeDot base || hexIntegerLiteralDotNeedsParens base field++-- @0x5e.a@ is tokenized by GHC as a hexadecimal fractional literal, not as+-- record-dot access. Other integer bases, and non-hex field initials, are safe.+hexIntegerLiteralDotNeedsParens :: Expr -> Name -> Bool+hexIntegerLiteralDotNeedsParens expr field =+  case expr of+    EAnn _ sub -> hexIntegerLiteralDotNeedsParens sub field+    EInt _ TInteger repr -> isHexIntegerLiteral repr && fieldStartsWithHexDigit field+    _ -> False+  where+    isHexIntegerLiteral repr =+      "0x" `T.isPrefixOf` repr || "0X" `T.isPrefixOf` repr+    fieldStartsWithHexDigit name =+      case T.uncons (nameText name) of+        Just (c, _) -> isHexDigit c+        Nothing -> False++addNegateParens :: Expr -> Expr+addNegateParens inner =+  case peelExprAnn inner of+    -- `-(518# {}).a` and similar forms must keep the field access grouped;+    -- otherwise `-518# {}.a` is lexed as a negative primitive literal record update.+    EGetField base _ | startsWithPrimitiveLiteral base -> wrapExpr True (addExprParens inner)+    -- "- - x" is invalid. Tested by `test_parenthesesInsertion`+    ENegate {} -> wrapExpr True (addExprParens inner)+    -- Prefix negation accepts block-shaped operands directly, including+    -- `proc`, so `- \x -> x`, `- do ...`, and `- proc ...` do not need an+    -- extra HsPar around the operand.+    _ | isBareNegateOperand inner -> addExprParens inner+    -- Application and type-application bind tighter than negation, so `-f x`+    -- does not need parens around `f x`.+    _ -> addExprParensPrec 2 inner++isBareNegateOperand :: Expr -> Bool+isBareNegateOperand = \case+  EAnn _ sub -> isBareNegateOperand sub+  EProc {} -> True+  expr -> isBlockExpr expr++addTypeSigBodyParens :: Expr -> Expr+addTypeSigBodyParens expr =+  case expr of+    EAnn ann sub -> EAnn ann (addTypeSigBodyParens sub)+    ELambdaCase alts -> ELambdaCase (map addCaseAltParens alts)+    ELambdaCases alts -> ELambdaCases (map addLambdaCaseAltParens alts)+    _ -> addExprParensIn CtxTypeSigBody expr++addDelimitedExprParens :: Expr -> Expr+addDelimitedExprParens expr =+  case expr of+    EAnn ann sub -> EAnn ann (addDelimitedExprParens sub)+    ETypeSig inner ty -> ETypeSig (addDelimitedTypeSigBodyParens inner) (addSignatureTypeParens ty)+    _ -> addExprParens expr++addDelimitedTypeSigBodyParens :: Expr -> Expr+addDelimitedTypeSigBodyParens expr =+  case expr of+    EAnn ann sub -> EAnn ann (addDelimitedTypeSigBodyParens sub)+    _ -> addTypeSigBodyParens expr++addDoTypeSigBodyParens :: Expr -> Expr+addDoTypeSigBodyParens expr =+  case expr of+    EAnn ann sub -> EAnn ann (addDoTypeSigBodyParens sub)+    EMultiWayIf {} -> wrapExpr True (addExprParens expr)+    _ -> addTypeSigBodyParens expr++addCaseAltParens :: CaseAlt Expr -> CaseAlt Expr+addCaseAltParens (CaseAlt sp pat rhs) =+  CaseAlt sp (addCaseAltPatternParens pat) (addCaseAltRhsParens rhs)++addCaseAltPatternParens :: Pattern -> Pattern+addCaseAltPatternParens pat@(PTypeSig {}) = wrapPat True (addPatternParens pat)+addCaseAltPatternParens (PAnn ann sub) = PAnn ann (addCaseAltPatternParens sub)+addCaseAltPatternParens pat = addPatternParens pat++addLambdaCaseAltParens :: LambdaCaseAlt -> LambdaCaseAlt+addLambdaCaseAltParens (LambdaCaseAlt sp pats rhs) =+  let pats' = case pats of+        [] -> []+        [_] -> map addFunctionHeadPatternAtomParens pats+        _ -> map addPatternAtomParens pats+   in LambdaCaseAlt sp pats' (addCaseAltRhsParens rhs)++addCaseAltRhsParens :: Rhs Expr -> Rhs Expr+addCaseAltRhsParens rhs =+  case rhs of+    UnguardedRhs sp body whereDecls ->+      UnguardedRhs sp (addExprParens body) (fmap (map addDeclParens) whereDecls)+    GuardedRhss sp guards whereDecls ->+      GuardedRhss sp (map (addGuardedRhsParens GuardArrow) guards) (fmap (map addDeclParens) whereDecls)++addDoStmtParens :: DoStmt Expr -> DoStmt Expr+addDoStmtParens stmt =+  case stmt of+    DoAnn ann inner -> DoAnn ann (addDoStmtParens inner)+    DoBind pat e -> DoBind (addPatternParens pat) (addDoExprParens e)+    DoLetDecls decls -> DoLetDecls (map addDeclParens decls)+    DoExpr e -> DoExpr (addDoExprParens e)+    DoRecStmt stmts -> DoRecStmt (map addDoStmtParens stmts)++addDoExprParens :: Expr -> Expr+addDoExprParens expr =+  case expr of+    EAnn ann sub -> EAnn ann (addDoExprParens sub)+    ETypeSig inner ty -> ETypeSig (addDoTypeSigBodyParens inner) (addSignatureTypeParens ty)+    _ -> addExprParens expr++addCompStmtParens :: CompStmt -> CompStmt+addCompStmtParens stmt =+  case stmt of+    CompAnn ann inner -> CompAnn ann (addCompStmtParens inner)+    CompGen pat e -> CompGen (addPatternParens pat) (addExprParens e)+    CompGuard e -> CompGuard (addExprParens e)+    CompLetDecls decls -> CompLetDecls (map addDeclParens decls)+    CompThen f -> CompThen (addExprParens f)+    -- In 'then f by e', the expression 'f' must not be greedy (let/if/lambda/etc.)+    -- because the parser's compTransformExprParser dispatches let/if/lambda to their+    -- standard parsers which consume 'by' as part of the body. Parenthesize greedy+    -- expressions to prevent 'by' from being swallowed.+    CompThenBy f e -> CompThenBy (addCompTransformExprParens f) (addExprParens e)+    CompGroupUsing f -> CompGroupUsing (addExprParens f)+    -- Same issue: 'then group by e using f' — 'e' must not swallow 'using'.+    CompGroupByUsing e f -> CompGroupByUsing (addCompTransformExprParens e) (addExprParens f)++-- | Parenthesize an expression for use in TransformListComp positions where+-- a trailing keyword ('by'/'using') must not be consumed by the expression.+-- The parser's compTransformExprParser has its own infix parser, so ordinary+-- infix expressions can stay bare.  We only need to protect transform+-- expressions whose right edge can consume the following keyword.+addCompTransformExprParens :: Expr -> Expr+addCompTransformExprParens expr =+  let parenthesized = addExprParens expr+   in if needsCompTransformParens parenthesized+        then wrapExpr True parenthesized+        else parenthesized++-- | Check if an expression needs parenthesization in a TransformListComp+-- position before 'by' or 'using'. The boundary is safe when the expression+-- has a closed right edge. Parentheses are only required when that right edge+-- can consume the trailing keyword as part of a body, application, or type.+needsCompTransformParens :: Expr -> Bool+needsCompTransformParens = \case+  EAnn _ sub -> needsCompTransformParens sub+  ETypeSig {} -> True+  EParen {} -> False+  EInfix _ _ rhs -> needsCompTransformInfixRhsParens rhs+  EApp _ arg -> needsCompTransformParens arg+  ETypeApp fn _ -> needsCompTransformParens fn+  ENegate inner -> needsCompTransformParens inner+  EPragma _ inner -> needsCompTransformParens inner+  expr -> isGreedyExpr expr++needsCompTransformInfixRhsParens :: Expr -> Bool+needsCompTransformInfixRhsParens = \case+  EAnn _ sub -> needsCompTransformInfixRhsParens sub+  EPragma _ inner -> needsCompTransformInfixRhsParens inner+  -- TransformListComp has a contextual lambda-case parser whose alternatives+  -- stop before the following transform keyword.+  ELambdaCase {} -> False+  ELambdaCases {} -> False+  expr -> needsCompTransformParens expr++addArithSeqParens :: ArithSeq -> ArithSeq+addArithSeqParens seqInfo =+  case seqInfo of+    ArithSeqAnn ann inner -> ArithSeqAnn ann (addArithSeqParens inner)+    ArithSeqFrom fromE -> ArithSeqFrom (addExprParens fromE)+    ArithSeqFromThen fromE thenE -> ArithSeqFromThen (addExprParens fromE) (addExprParens thenE)+    ArithSeqFromTo fromE toE -> ArithSeqFromTo (addExprParens fromE) (addExprParens toE)+    ArithSeqFromThenTo fromE thenE toE -> ArithSeqFromThenTo (addExprParens fromE) (addExprParens thenE) (addExprParens toE)++-- | Parenthesize the left operand of a top-level infix expression.+addTopLevelInfixLhsParens :: Int -> Expr -> Expr+addTopLevelInfixLhsParens _prec = addInfixLhsParens++addInfixLhsParens :: Expr -> Expr+addInfixLhsParens expr =+  case expr of+    EAnn ann sub -> EAnn ann (addInfixLhsParens sub)+    EInfix lhs op rhs ->+      EInfix+        (addInfixLhsParens lhs)+        op+        (addExprParensIn (CtxInfixRhs True) rhs)+    _ -> addExprParensIn CtxInfixLhs expr++addInfixRhsParens :: Bool -> Expr -> Expr+addInfixRhsParens protectOpenEnded expr =+  case expr of+    EAnn ann sub -> EAnn ann (addInfixRhsParens protectOpenEnded sub)+    EInfix lhs op rhs ->+      EInfix+        (addInfixLhsParens lhs)+        op+        (addExprParensIn (CtxInfixRhs protectOpenEnded) rhs)+    _ -> addExprParensPrec (exprCtxPrec (CtxInfixRhs protectOpenEnded) expr) expr++absorbsFollowingInfix :: Expr -> Bool+absorbsFollowingInfix = \case+  EAnn _ sub -> absorbsFollowingInfix sub+  EIf {} -> True+  ELambdaPats {} -> True+  ELetDecls {} -> True+  EProc {} -> True+  ENegate inner -> absorbsFollowingInfix inner+  EApp _ arg | isBlockExpr arg -> absorbsFollowingInfix arg+  EInfix _ _ rhs -> absorbsFollowingInfix rhs+  _ -> False++-- ---------------------------------------------------------------------------+-- Types+-- ---------------------------------------------------------------------------++-- | Add parentheses to a signature type at all required positions.+--+-- >>> shorthand $ addSignatureTypeParens (TKindSig TWildcard TWildcard)+-- TParen (TKindSig (TWildcard) (TWildcard))+--+-- >>> shorthand $ addSignatureTypeParens (TFun ArrowUnrestricted (TCon "A" Unpromoted) (TCon "B" Unpromoted))+-- TFun (TCon "A") (TCon "B")+addSignatureTypeParens :: Type -> Type+addSignatureTypeParens = addSignatureTypeParensShared CtxTypeAtom 0++-- | Add parentheses to a plain type at all required positions.+--+-- >>> shorthand $ addTypeParens (TApp (TCon "Proxy" Unpromoted) (TFun ArrowUnrestricted (TCon "A" Unpromoted) (TCon "B" Unpromoted)))+-- TApp (TCon "Proxy") (TParen (TFun (TCon "A") (TCon "B")))+--+-- >>> shorthand $ addTypeParens (TApp (TCon "Proxy" Unpromoted) (TCon "A" Unpromoted))+-- TApp (TCon "Proxy") (TCon "A")+addTypeParens :: Type -> Type+addTypeParens = addTypeTopLevelParens++addTypeTopLevelParens :: Type -> Type+addTypeTopLevelParens (TAnn ann sub) = TAnn ann (addTypeTopLevelParens sub)+addTypeTopLevelParens (TImplicitParam name inner) =+  TImplicitParam name (addImplicitParamBodyParens inner)+addTypeTopLevelParens (TKindSig ty kind) = TKindSig (addSignatureTypeParensShared CtxTypeAtom 0 ty) (addTypeTopLevelParens kind)+addTypeTopLevelParens (TForall telescope inner) =+  TForall+    (telescope {forallTelescopeBinders = map addTyVarBinderParens (forallTelescopeBinders telescope)})+    (addForallBodyParens inner)+addTypeTopLevelParens (TContext constraints inner) =+  TContext (map addContextConstraintDelimitedParens constraints) (addContextBodyParens inner)+addTypeTopLevelParens (TParen inner) =+  TParen (addTypeTopLevelParens inner)+addTypeTopLevelParens ty = addSignatureTypeParens ty++addStandaloneKindSigParens :: Type -> Type+addStandaloneKindSigParens (TAnn ann sub) = TAnn ann (addStandaloneKindSigParens sub)+addStandaloneKindSigParens (TForall telescope inner) =+  TForall+    (telescope {forallTelescopeBinders = map addTyVarBinderParens (forallTelescopeBinders telescope)})+    (addForallBodyParens inner)+addStandaloneKindSigParens ty = addTypeTopLevelParens ty++addTypeIn :: TypeCtx -> Type -> Type+addTypeIn ctx ty =+  wrapTy (needsTypeParens ctx ty) (addSignatureTypeParensShared ctx 0 ty)++addSignatureTypeParensShared :: TypeCtx -> Int -> Type -> Type+addSignatureTypeParensShared ctx prec ty =+  let atom = addSignatureTypeParensShared CtxTypeAtom+   in case ty of+        TAnn ann sub -> TAnn ann (addSignatureTypeParensShared ctx prec sub)+        TVar {} -> ty+        TCon name promoted -> TCon name promoted+        TBuiltinCon {} -> ty+        TImplicitParam name inner -> TImplicitParam name (addImplicitParamBodyParens inner)+        TTypeLit {} -> ty+        TStar {} -> ty+        TQuasiQuote {} -> ty+        TForall telescope inner ->+          -- forallTypeParser uses contextOrFunTypeParser (not typeParser) for its+          -- body, so a bare nested TForall would fail to parse. Wrap it in TParen.+          wrapTy+            (prec > 0)+            ( TForall+                (telescope {forallTelescopeBinders = map addTyVarBinderParens (forallTelescopeBinders telescope)})+                (addForallBodyParens inner)+            )+        TInfix lhs op promoted rhs ->+          -- Type operators are right-associative in GHC, so the RHS can contain+          -- nested TInfix without parens (a `op1` b `op2` c = a `op1` (b `op2` c)).+          -- The LHS needs parens for nested TInfix to prevent left-association.+          wrapTy (prec > 0) (TInfix (addTypeIn CtxTypeAppFun lhs) op promoted (addTypeIn CtxTypeInfixRhs rhs))+        TApp f x ->+          wrapTy (prec > 2) (TApp (addTypeIn CtxTypeAppFun f) (addTypeIn CtxTypeAppArg x))+        TTypeApp f x ->+          wrapTy (prec > 2) (TTypeApp (addTypeIn CtxTypeAppFun f) (addTypeIn CtxTypeAppVisibleArg x))+        TFun arrowKind a b ->+          wrapTy (prec > 0) (TFun (addArrowKindParens arrowKind) (addTypeIn CtxTypeFunArg a) (atom 0 b))+        TTuple tupleFlavor promoted elems ->+          TTuple tupleFlavor promoted (map addSignatureTypeParensInner elems)+        TUnboxedSum elems -> TUnboxedSum (map addSignatureTypeParensInner elems)+        TList promoted elems -> TList promoted (map addSignatureTypeParensInner elems)+        -- Inside an explicit TParen, TKindSig does not need an additional+        -- TParen wrapper since the enclosing delimiter already provides it.+        TParen inner -> TParen (addTypeInExplicitParenParens inner)+        -- TKindSig always needs parens in most contexts. The parser absorbs+        -- (ty :: kind) as TKindSig directly, so the TParen is not preserved+        -- through roundtrips. The pretty-printer relies on the TParen wrapper+        -- to produce the required parentheses.+        TKindSig ty' kind ->+          wrapTy True (TKindSig (atom 0 ty') (atom 0 kind))+        TContext constraints inner ->+          wrapTy (prec > 0) (TContext (addContextConstraints constraints) (atom 0 inner))+        TSplice body -> TSplice (addSpliceBodyParens body)+        TWildcard {} -> ty++addArrowKindParens :: ArrowKind -> ArrowKind+addArrowKindParens ArrowUnrestricted = ArrowUnrestricted+addArrowKindParens ArrowLinear = ArrowLinear+addArrowKindParens (ArrowExplicit ty) = ArrowExplicit (addSignatureTypeParens ty)++addTyVarBinderParens :: TyVarBinder -> TyVarBinder+addTyVarBinderParens tvb =+  tvb {tyVarBinderKind = fmap addSignatureTypeParens (tyVarBinderKind tvb)}++-- | Process the body of a TForall. The forall body is parsed by+-- 'typeParser'. A bare kind signature usually changes attachment:+-- @forall a. t :: k@ parses as @(forall a. t) :: k@, not+-- @forall a. (t :: k)@. When the kind-signature subject is itself a forall,+-- however, @forall a. forall b. t :: k@ preserves the nested forall body and+-- does not need an extra TParen.+addForallBodyParens :: Type -> Type+addForallBodyParens (TAnn ann sub) = TAnn ann (addForallBodyParens sub)+addForallBodyParens (TKindSig ty kind)+  | typeStartsWithForall ty =+      TKindSig (addSignatureTypeParensShared CtxTypeAtom 0 ty) (addSignatureTypeParensShared CtxTypeAtom 0 kind)+addForallBodyParens ty@(TForall {}) = addSignatureTypeParensShared CtxTypeAtom 0 ty+addForallBodyParens ty = addSignatureTypeParensShared CtxTypeAtom 0 ty++typeStartsWithForall :: Type -> Bool+typeStartsWithForall (TAnn _ sub) = typeStartsWithForall sub+typeStartsWithForall TForall {} = True+typeStartsWithForall _ = False++-- | Process the body of a TImplicitParam.+addImplicitParamBodyParens :: Type -> Type+addImplicitParamBodyParens (TAnn ann sub) = TAnn ann (addImplicitParamBodyParens sub)+addImplicitParamBodyParens ty = addSignatureTypeParensShared CtxTypeAtom 0 ty++-- | Process the body to the right of a constraint arrow in a top-level type+-- RHS. A bare kind signature there applies to the whole constrained type:+-- @type X = C => T :: K@ parses like @type X = (C => T) :: K@.+-- Parenthesize inner kind signatures to preserve @C => (T :: K)@.+addContextBodyParens :: Type -> Type+addContextBodyParens (TAnn ann sub) = TAnn ann (addContextBodyParens sub)+addContextBodyParens ty =+  case ty of+    TForall telescope inner ->+      TForall+        (telescope {forallTelescopeBinders = map addTyVarBinderParens (forallTelescopeBinders telescope)})+        (addContextBodyParens inner)+    TKindSig ty' kind ->+      wrapTy+        True+        (TKindSig (addSignatureTypeParensShared CtxTypeAtom 0 ty') (addSignatureTypeParensShared CtxTypeAtom 0 kind))+    TContext constraints inner ->+      TContext (map addContextConstraintDelimitedParens constraints) (addContextBodyParens inner)+    _ -> addSignatureTypeParensShared CtxTypeAtom 0 ty++-- | Process a type inside explicit delimiters (TParen, TTuple, etc.).+-- TKindSig does not need wrapping here because the enclosing delimiter+-- already provides the necessary parenthesization.+addSignatureTypeParensInner :: Type -> Type+addSignatureTypeParensInner = addTypeDelimitedParens++addTypeDelimitedParens :: Type -> Type+addTypeDelimitedParens (TAnn ann sub) = TAnn ann (addTypeDelimitedParens sub)+addTypeDelimitedParens (TImplicitParam name inner) =+  TImplicitParam name (addImplicitParamBodyParens inner)+addTypeDelimitedParens (TKindSig ty kind) =+  TKindSig (addSignatureTypeParensShared CtxTypeAtom 0 ty) (addSignatureTypeParensShared CtxTypeAtom 0 kind)+addTypeDelimitedParens (TForall telescope inner) =+  TForall+    (telescope {forallTelescopeBinders = map addTyVarBinderParens (forallTelescopeBinders telescope)})+    (addForallBodyParens inner)+addTypeDelimitedParens (TContext constraints inner) =+  TContext (map addContextConstraintDelimitedParens constraints) (addContextBodyParens inner)+addTypeDelimitedParens (TInfix lhs op promoted rhs) =+  TInfix (addTypeIn CtxTypeAppFun lhs) op promoted (addTypeIn CtxTypeDelimitedInfixRhs rhs)+addTypeDelimitedParens (TApp f x) =+  TApp (addTypeIn CtxTypeAppFun f) (addTypeIn CtxTypeDelimitedAppArg x)+addTypeDelimitedParens (TTypeApp f x) =+  TTypeApp (addTypeIn CtxTypeAppFun f) (addTypeIn CtxTypeDelimitedAppVisibleArg x)+addTypeDelimitedParens (TFun arrowKind a b) =+  TFun (addArrowKindParens arrowKind) (addTypeIn CtxTypeFunArg a) (addSignatureTypeParensShared CtxTypeAtom 0 b)+addTypeDelimitedParens (TTuple tupleFlavor promoted elems) =+  TTuple tupleFlavor promoted (map addTypeDelimitedParens elems)+addTypeDelimitedParens (TUnboxedSum elems) =+  TUnboxedSum (map addTypeDelimitedParens elems)+addTypeDelimitedParens (TList promoted elems) =+  TList promoted (map addTypeDelimitedParens elems)+addTypeDelimitedParens (TParen inner) =+  TParen (addTypeInExplicitParenParens inner)+addTypeDelimitedParens ty = addSignatureTypeParensShared CtxTypeAtom 0 ty++addTypeInExplicitParenParens :: Type -> Type+addTypeInExplicitParenParens (TAnn ann sub) = TAnn ann (addTypeInExplicitParenParens sub)+addTypeInExplicitParenParens (TKindSig ty kind) =+  TKindSig (addSignatureTypeParensShared CtxTypeAtom 0 ty) (addSignatureTypeParensShared CtxTypeAtom 0 kind)+addTypeInExplicitParenParens ty = addSignatureTypeParensShared CtxTypeAtom 0 ty++addContextConstraintDelimitedParens :: Type -> Type+addContextConstraintDelimitedParens (TAnn ann sub) = TAnn ann (addContextConstraintDelimitedParens sub)+addContextConstraintDelimitedParens (TImplicitParam name inner) =+  TImplicitParam name (addImplicitParamBodyParens inner)+addContextConstraintDelimitedParens (TInfix lhs op promoted rhs) =+  TInfix (addTypeIn CtxTypeAppFun lhs) op promoted (addContextConstraintDelimitedParens rhs)+addContextConstraintDelimitedParens (TApp f x) =+  TApp (addTypeIn CtxTypeAppFun f) (addContextConstraintDelimitedParens x)+addContextConstraintDelimitedParens (TTypeApp f x) =+  TTypeApp (addTypeIn CtxTypeAppFun f) (addTypeIn CtxTypeDelimitedAppVisibleArg x)+addContextConstraintDelimitedParens ty = addTypeDelimitedParens ty++-- | Process constraint types in a TContext.+-- In multi-constraint contexts, TKindSig doesn't need individual parens+-- (commas delimit). In single-constraint contexts, TKindSig needs parens.+addContextConstraints :: [Type] -> [Type]+addContextConstraints constraints =+  case constraints of+    [single] -> [addContextConstraintSingle single]+    _ -> map addContextConstraintMulti constraints++-- | Add parens to a single constraint in a context.+-- TKindSig needs wrapping here because there's no comma delimiter.+addContextConstraintSingle :: Type -> Type+addContextConstraintSingle = addSignatureTypeParens++-- | Add parens to a constraint in a multi-constraint context.+-- TKindSig doesn't need extra wrapping because commas delimit.+-- Strip TParen around TKindSig since it's unnecessary here.+addContextConstraintMulti :: Type -> Type+addContextConstraintMulti ty =+  case ty of+    TAnn ann sub ->+      TAnn ann (addContextConstraintMulti sub)+    TKindSig ty' kind ->+      -- In multi-constraint context, TKindSig doesn't need wrapping+      TKindSig (addSignatureTypeParensShared CtxTypeAtom 0 ty') (addSignatureTypeParensShared CtxTypeAtom 0 kind)+    TParen inner@(TKindSig {}) ->+      -- Strip TParen around TKindSig in multi-constraint context+      addContextConstraintMulti inner+    _ -> addSignatureTypeParens ty++-- ---------------------------------------------------------------------------+-- Patterns+-- ---------------------------------------------------------------------------++-- | Add parentheses to a pattern at all required positions.+--+-- >>> shorthand $ addPatternParens (PAs "xs" (PNegLit (LitInt 1 TInteger "1")))+-- PAs UnqualifiedName {"xs"} (PParen (PNegLit (LitInt 1 TInteger)))+--+-- >>> shorthand $ addPatternParens (PAs "xs" (PVar "x"))+-- PAs UnqualifiedName {"xs"} (PVar "x")+addPatternParens :: Pattern -> Pattern+addPatternParens pat =+  case pat of+    PAnn sp sub -> PAnn sp (addPatternParens sub)+    PVar {} -> pat+    PTypeBinder binder -> PTypeBinder (addTyVarBinderParens binder)+    PTypeSyntax form ty -> PTypeSyntax form (addSignatureTypeParens ty)+    PWildcard {} -> pat+    PLit lit -> PLit lit+    PQuasiQuote {} -> pat+    PTuple tupleFlavor elems -> PTuple tupleFlavor (map addPatternInDelimited elems)+    PUnboxedSum altIdx arity inner -> PUnboxedSum altIdx arity (addPatternInUnboxedSum altIdx inner)+    PList elems -> PList (map addPatternInDelimited elems)+    PCon con typeArgs args -> PCon con (map (addTypeIn CtxTypeAtom) typeArgs) (map addPatternAtomParens args)+    PInfix lhs op rhs -> PInfix (addPatternInfixOperandParens lhs) op (addPatternInfixRhsOperandParens rhs)+    PView viewExpr inner ->+      wrapPat True (PView (addViewExprParens viewExpr) (addPatternViewInnerParens inner))+    PAs name inner -> PAs name (addApatParens inner)+    PStrict inner -> PStrict (addApatParens inner)+    PIrrefutable inner -> PIrrefutable (addApatParens inner)+    PNegLit lit -> PNegLit lit+    PParen inner -> PParen (addPatternInDelimited inner)+    PRecord con fields hasWildcard ->+      PRecord con [field {recordFieldValue = addPatternInRecordField (recordFieldValue field)} | field <- fields] hasWildcard+    PTypeSig inner ty -> PTypeSig (addPatternInfixOperandParens inner) (addSignatureTypeParens ty)+    PSplice body -> PSplice (addSpliceBodyParens body)++-- | Add parens for a pattern inside a delimited context (tuples, lists, etc.).+-- View patterns don't need extra parens there.+addPatternInDelimited :: Pattern -> Pattern+addPatternInDelimited = addPatternInDelimitedWith True++addPatternInDelimitedWith :: Bool -> Pattern -> Pattern+addPatternInDelimitedWith allowLayoutTypeSig pat =+  case peelPatternAnn pat of+    PView viewExpr inner ->+      PView+        ((if allowLayoutTypeSig then addViewExprParensAllowLayoutTypeSig else addViewExprParens) viewExpr)+        (addPatternViewInnerParens inner)+    PAs name inner -> PAs name (addApatParens inner)+    PStrict inner -> PStrict (addApatParens inner)+    PIrrefutable inner -> PIrrefutable (addApatParens inner)+    _ -> addPatternParens pat++addPatternInUnboxedSum :: Int -> Pattern -> Pattern+addPatternInUnboxedSum altIdx = addPatternInDelimitedWith (altIdx > 0)++addPatternInRecordField :: Pattern -> Pattern+addPatternInRecordField = addPatternInDelimitedWith True++-- | Template Haskell pattern quotes accept typed patterns only when they are+-- parenthesized: @[p| (a :: T) |]@ parses, but @[p| a :: T |]@ does not.+addTHPatQuoteParens :: Pattern -> Pattern+addTHPatQuoteParens pat =+  let pat' = addPatternParens pat+   in case peelPatternAnn pat' of+        PTypeSig {} -> wrapPat True pat'+        _ -> pat'++-- | Add parens for a pattern nested inside a view pattern.+-- Nested view patterns do not need extra parens.+addPatternViewInnerParens :: Pattern -> Pattern+addPatternViewInnerParens pat =+  case pat of+    PAnn sp sub -> PAnn sp (addPatternViewInnerParens sub)+    PView viewExpr inner ->+      PView (addViewExprParens viewExpr) (addPatternViewInnerParens inner)+    _ -> addPatternParens pat++addViewExprParens :: Expr -> Expr+addViewExprParens = addViewExprParensWith False++addViewExprParensAllowLayoutTypeSig :: Expr -> Expr+addViewExprParensAllowLayoutTypeSig = addViewExprParensWith True++addViewExprParensWith :: Bool -> Expr -> Expr+addViewExprParensWith allowLayoutTypeSig expr =+  wrapExpr (viewExprNeedsOuterParens expr) (addViewExprBodyParens expr)+  where+    -- View-pattern expressions are followed by @-> pat@ inside a pattern, and+    -- that arrow gives the expression parser a hard boundary.  That lets block+    -- arguments stay bare in application chains where ordinary expression+    -- printing would add parens to protect the following syntax.+    --+    -- With MultiWayIf, UnboxedSums, ViewPatterns, and BlockArguments enabled,+    -- this is valid in a pattern context:+    --+    --   f (# [] if | let {} -> [] [] -> _ | #) = ()+    --+    -- and parses like:+    --+    --   f (# ([] (if | let {} -> []) [] -> _) | #) = ()+    --+    -- The same unboxed-sum spelling is not valid as an expression RHS; GHC is+    -- the source of truth, so this exception only applies while printing view+    -- patterns.+    --+    -- Type signatures remain different.  A block argument ending in @:: T@+    -- can still capture the following arrow or change the parsed shape, so it+    -- stays parenthesized:+    --+    --   f (([] (if | [] -> [] :: T)) -> p) = ()+    addViewExprBodyParens e =+      case e of+        EAnn ann sub -> EAnn ann (addViewExprBodyParens sub)+        EInfix {} -> addViewExprInfixParens e+        EApp {} -> addViewExprAppChainParens e+        _ -> addExprParens e++    addViewExprInfixParens e =+      case e of+        EAnn ann sub -> EAnn ann (addViewExprInfixParens sub)+        EInfix lhs op rhs ->+          EInfix+            (addViewExprInfixLhsParens lhs)+            op+            (addExprParensIn (CtxInfixRhs False) rhs)+        _ -> addExprParens e++    addViewExprInfixLhsParens e =+      case e of+        EAnn ann sub -> EAnn ann (addViewExprInfixLhsParens sub)+        EInfix lhs op rhs ->+          EInfix+            (addViewExprInfixLhsParens lhs)+            op+            (addExprParensIn (CtxInfixRhs True) rhs)+        _+          | viewExprInfixLhsCanStayBare e ->+              addViewExprAppChainParens e+          | otherwise ->+              addExprParensIn CtxInfixLhs e++    addViewExprAppChainParens e =+      let (root, args) = flattenApps e+          root' = addExprParensIn CtxAppFun root+          args' = [addExprParensIn (viewExprAppArgCtx isLast arg) arg | (isLast, arg) <- markLast args]+       in foldl EApp root' args'++    viewExprAppArgCtx isLast arg+      | viewExprAppArgCanStayBare isLast arg = CtxAppArgNoParens+      | isLast = CtxAppArg+      | isGreedyExpr arg = CtxAppArgGreedy+      | otherwise = CtxAppArg++    viewExprAppArgCanStayBare isLast arg =+      isBlockExpr arg+        && not (endsWithTypeSig arg)+        && (isLast || not (viewExprBlockArgAbsorbsFollowingAppArg arg))++    viewExprBlockArgAbsorbsFollowingAppArg arg =+      case peelExprAnn arg of+        EIf {} -> True+        ELambdaPats {} -> True+        ELetDecls {} -> True+        EProc {} -> True+        _ -> False++    viewExprInfixLhsCanStayBare e =+      case peelExprAnn e of+        EApp {} ->+          case reverse (snd (flattenApps e)) of+            arg : _ -> viewExprBlockArgCanPrecedeInfixOp arg+            [] -> False+        _ -> False++    viewExprBlockArgCanPrecedeInfixOp arg =+      case peelExprAnn arg of+        EMultiWayIf {} -> not (endsWithTypeSig arg)+        _ -> False++    markLast [] = []+    markLast [x] = [(True, x)]+    markLast (x : xs) = (False, x) : markLast xs++    viewExprNeedsOuterParens e =+      isTypeSyntaxExpr e || (endsWithTypeSig e && not (viewExprTypeSigCanStayBare e))++    viewExprTypeSigCanStayBare e =+      allowLayoutTypeSig && isBareViewExprBlock e && not (classicIfTypeSigNeedsParens e)++    isTypeSyntaxExpr e =+      case peelExprAnn e of+        ETypeSyntax {} -> True+        _ -> False++    isBareViewExprBlock e =+      case peelExprAnn e of+        ECase {} -> True+        EIf {} -> True+        EMultiWayIf {} -> True+        ELambdaCase {} -> True+        ELambdaCases {} -> True+        _ -> False++    classicIfTypeSigNeedsParens e =+      case peelExprAnn e of+        EIf _ _ no -> elseBranchHasDirectTypeSig no+        _ -> False++    elseBranchHasDirectTypeSig branch =+      case peelExprAnn branch of+        ETypeSig {} -> True+        _ -> False++addPatternAtomParens :: Pattern -> Pattern+addPatternAtomParens pat =+  case pat of+    PAnn ann sub -> PAnn ann (addPatternAtomParens sub)+    PVar {} -> addPatternParens pat+    PTypeBinder {} -> addPatternParens pat+    PTypeSyntax {} -> addPatternParens pat+    PWildcard {} -> addPatternParens pat+    PLit {} -> addPatternParens pat+    PQuasiQuote {} -> addPatternParens pat+    PNegLit {} -> wrapPat True (addPatternParens pat)+    PList {} -> addPatternParens pat+    PTuple {} -> addPatternParens pat+    PUnboxedSum {} -> addPatternParens pat+    PParen {} -> addPatternParens pat+    PStrict {} -> addPatternParens pat+    PIrrefutable {} -> addPatternParens pat+    PView {} -> addPatternParens pat+    PAs {} -> addPatternParens pat+    PSplice {} -> addPatternParens pat+    PRecord {} -> addPatternParens pat+    PCon _ [] [] -> addPatternParens pat+    PInfix {} -> wrapPat True (addPatternParens pat)+    _ -> wrapPat True (addPatternParens pat)++-- | Add parens for a pattern in infix-pattern operand position.+-- In Haskell's grammar, infix patterns have the form @pat10 conop pat10@,+-- where @pat10@ allows constructor application patterns. Non-nullary 'PCon'+-- does not need wrapping here because constructor application binds tighter+-- than infix operators.+addPatternInfixOperandParens :: Pattern -> Pattern+addPatternInfixOperandParens pat =+  case pat of+    PAnn ann sub -> PAnn ann (addPatternInfixOperandParens sub)+    PNegLit _ -> addPatternParens pat+    PCon {} -> addPatternParens pat+    PInfix {} -> addPatternParens pat+    _ -> addPatternAtomParens pat++-- | Add parens for the right operand of a 'PInfix' pattern.+-- The parser builds left-associated chains, so a nested 'PInfix' on the RHS+-- needs explicit grouping.+addPatternInfixRhsOperandParens :: Pattern -> Pattern+addPatternInfixRhsOperandParens pat =+  case pat of+    PAnn ann sub -> PAnn ann (addPatternInfixRhsOperandParens sub)+    -- Negative literal patterns are pat10/lpat forms, so they can appear+    -- directly as either operand of an infix pattern.+    PNegLit {} -> addPatternParens pat+    PCon {} -> addPatternParens pat+    PInfix {} -> wrapPat True (addPatternParens pat)+    _ -> addPatternAtomParens pat++-- | Add parens for a pattern in arrow binder position (lambda/proc).+-- Type-signatured, negated literal, infix, and non-nullary constructor patterns+-- must be parenthesized to avoid ambiguity.+addArrowBndrPatternParens :: Pattern -> Pattern+addArrowBndrPatternParens p@(PTypeSig {}) = wrapPat True (addPatternParens p)+addArrowBndrPatternParens p@(PNegLit {}) = wrapPat True (addPatternParens p)+addArrowBndrPatternParens p@(PInfix {}) = wrapPat True (addPatternParens p)+addArrowBndrPatternParens p@(PCon _ (_ : _) _) = wrapPat True (addPatternParens p)+addArrowBndrPatternParens p@(PCon _ [] (_ : _)) = wrapPat True (addPatternParens p)+addArrowBndrPatternParens pat = addPatternParens pat++-- | Add parens for a pattern in function-head argument position.+addFunctionHeadPatternAtomParens :: Pattern -> Pattern+addFunctionHeadPatternAtomParens pat =+  case pat of+    PAnn ann sub -> PAnn ann (addFunctionHeadPatternAtomParens sub)+    PParen (PTypeSig inner@(PVar {}) ty) ->+      PParen (PTypeSig (addPatternInfixOperandParens inner) (addSignatureTypeParens ty))+    PNegLit {} -> wrapPat True (addPatternParens pat)+    PTypeSyntax {} -> wrapPat True (addPatternParens pat)+    PCon _ typeArgs args+      | not (null typeArgs) || not (null args) -> wrapPat True (addPatternParens pat)+    PTypeSig inner@(PVar {}) ty ->+      wrapPat True (PTypeSig (addPatternInfixOperandParens inner) (addSignatureTypeParens ty))+    PTypeSig {} -> wrapPat True (addPatternParens pat)+    PAs {} -> addPatternParens pat+    PRecord {} -> addPatternParens pat+    _ -> addPatternAtomParens pat++-- | Add parens for infix function-head operands.+addInfixFunctionHeadPatternAtomParens :: Pattern -> Pattern+addInfixFunctionHeadPatternAtomParens pat =+  case pat of+    PAnn ann sub -> PAnn ann (addInfixFunctionHeadPatternAtomParens sub)+    -- Infix function heads use infix-pattern operand grammar, where negative+    -- literal patterns do not require apat parentheses.+    PNegLit {} -> addPatternParens pat+    PAs {} -> addPatternParens pat+    PTypeSig {} -> wrapPat True (addPatternParens pat)+    PInfix {} -> addPatternParens pat+    _ -> addPatternParens pat++-- | Add parens for the inner pattern of @, !, ~.+--+-- A nullary constructor without type arguments (e.g., @EQ@) is an atom and+-- needs no wrapping: @!EQ@, @~EQ@, @y\@EQ@ are all valid Haskell. However,+-- a constructor with type arguments (e.g., @Nothing \@Int@) must be wrapped+-- because @!Nothing \@Int@ is a parse error in GHC — it needs @!(Nothing \@Int)@.+addPatternAtomStrictParens :: Pattern -> Pattern+addPatternAtomStrictParens pat =+  case pat of+    PAnn ann sub -> PAnn ann (addPatternAtomStrictParens sub)+    PNegLit {} -> wrapPat True (addPatternParens pat)+    PTypeSyntax {} -> wrapPat True (addPatternParens pat)+    PCon _ (_ : _) [] -> wrapPat True (addPatternParens pat)+    PAs {} -> addPatternParens pat+    PStrict {} -> wrapPat True (addPatternParens pat)+    PIrrefutable {} -> wrapPat True (addPatternParens pat)+    PRecord {} -> addPatternParens pat+    PSplice {} -> wrapPat True (addPatternParens pat)+    _ -> addPatternAtomParens pat++-- | Add parens for an atomic pattern (@apat@) context.+--+-- As-patterns and the @!@ / @~@ prefixes accept another @apat@ as their body,+-- including symbolic binders such as @(+)\@C@.+addApatParens :: Pattern -> Pattern+addApatParens pat =+  case pat of+    PAnn ann sub -> PAnn ann (addApatParens sub)+    PAs name inner -> PAs name (addApatParens inner)+    _ -> addPatternAtomStrictParens pat++-- ---------------------------------------------------------------------------+-- Arrow commands+-- ---------------------------------------------------------------------------++data CmdCtx+  = CtxCmdTop+  | CtxCmdDoStmt++addCmdParens :: Cmd -> Cmd+addCmdParens = addCmdParensIn CtxCmdTop++addCmdParensIn :: CmdCtx -> Cmd -> Cmd+addCmdParensIn ctx cmd =+  case cmd of+    CmdAnn ann inner -> CmdAnn ann (addCmdParensIn ctx inner)+    CmdArrApp lhs appTy rhs ->+      CmdArrApp (addCmdArrAppLhsParens lhs) appTy (addCmdArrAppRhsParens ctx rhs)+    CmdInfix l op r ->+      CmdInfix (addCmdInfixLhsParens l) op (addCmdInfixRhsParens False r)+    CmdDo stmts ->+      CmdDo (map addCmdDoStmtParens stmts)+    CmdIf cond yes no ->+      CmdIf (addExprParens cond) (addCmdParens yes) (addCmdParens no)+    CmdCase scrut alts ->+      CmdCase (addExprParens scrut) (map addCmdCaseAltParens alts)+    CmdLet decls body ->+      CmdLet (map addDeclParens decls) (addCmdParens body)+    CmdLam pats body ->+      CmdLam (map addPatternAtomParens pats) (addCmdParens body)+    CmdApp c e ->+      CmdApp (addCmdParens c) (addExprParensPrec 3 e)+    CmdPar c ->+      CmdPar (addCmdParens c)+  where+    addCmdInfixLhsParens inner =+      case inner of+        CmdAnn ann sub -> CmdAnn ann (addCmdInfixLhsParens sub)+        CmdInfix l op r ->+          CmdInfix+            (addCmdInfixLhsParens l)+            op+            (addCmdInfixRhsParens True r)+        _ -> wrapCmdInfixLhs (addCmdParens inner)++    addCmdInfixRhsParens protectFollowingInfix inner =+      let inner' = addCmdParens inner+       in wrapCmd+            ( case peelCmdAnn inner' of+                CmdArrApp {} -> True+                CmdInfix {} -> True+                _ -> protectFollowingInfix && cmdAbsorbsFollowingInfix inner'+            )+            inner'++    wrapCmdInfixLhs inner =+      case peelCmdAnn inner of+        CmdArrApp {} -> CmdPar inner+        CmdIf {} -> CmdPar inner+        CmdLet {} -> CmdPar inner+        CmdLam {} -> CmdPar inner+        _ -> inner++    cmdAbsorbsFollowingInfix inner =+      case peelCmdAnn inner of+        CmdLam {} -> True+        CmdLet {} -> True+        CmdIf {} -> True+        CmdCase {} -> True+        CmdDo {} -> True+        CmdInfix _ _ rhs -> cmdAbsorbsFollowingInfix rhs+        _ -> False++addCmdArrAppLhsParens :: Expr -> Expr+addCmdArrAppLhsParens lhs =+  wrapExpr (cmdArrAppLhsNeedsParens lhs) (addExprParensPrec 1 lhs)++cmdArrAppLhsNeedsParens :: Expr -> Bool+cmdArrAppLhsNeedsParens expr =+  startsWithBlockExpr expr+    || isOpenEnded expr+    || endsWithTypeSig expr+    || endsWithCmdLayoutTail expr++-- | Arrow tails are parsed outside the expression grammar, so a command lhs that+-- ends in a layout block needs explicit grouping even when the same expression+-- can stay bare before ordinary expression suffixes like @::@ or @\@-type apps.+endsWithCmdLayoutTail :: Expr -> Bool+endsWithCmdLayoutTail = \case+  EAnn _ sub -> endsWithCmdLayoutTail sub+  expr | endsWithCmdLayoutBlock expr -> True+  EInfix _ _ rhs -> endsWithCmdLayoutTail rhs+  ENegate inner -> endsWithCmdLayoutTail inner+  EPragma _ inner -> endsWithCmdLayoutTail inner+  EApp _ arg -> endsWithCmdLayoutBlock arg+  _ -> False++endsWithCmdLayoutBlock :: Expr -> Bool+endsWithCmdLayoutBlock = \case+  EAnn _ sub -> endsWithCmdLayoutBlock sub+  EDo {} -> True+  ELambdaCase {} -> True+  ELambdaCases {} -> True+  EApp _ arg -> endsWithCmdLayoutBlock arg+  _ -> False++addCmdArrAppRhsParens :: CmdCtx -> Expr -> Expr+addCmdArrAppRhsParens ctx rhs =+  wrapExpr (cmdTopNeedsRhsParens && endsWithTypeSig rhs) (addExprParens rhs)+  where+    cmdTopNeedsRhsParens =+      case ctx of+        CtxCmdTop -> True+        CtxCmdDoStmt -> False++addCmdDoStmtParens :: DoStmt Cmd -> DoStmt Cmd+addCmdDoStmtParens stmt =+  case stmt of+    DoAnn ann inner -> DoAnn ann (addCmdDoStmtParens inner)+    DoBind pat cmd' -> DoBind (addPatternParens pat) (addCmdParensIn CtxCmdDoStmt cmd')+    DoLetDecls decls -> DoLetDecls (map addDeclParens decls)+    DoExpr cmd' -> DoExpr (wrapCmd (isLetCmd cmd') (addCmdParensIn CtxCmdDoStmt cmd'))+    DoRecStmt stmts -> DoRecStmt (map addCmdDoStmtParens stmts)+  where+    isLetCmd CmdLet {} = True+    isLetCmd (CmdAnn _ sub) = isLetCmd sub+    isLetCmd _ = False++addCmdCaseAltParens :: CaseAlt Cmd -> CaseAlt Cmd+addCmdCaseAltParens (CaseAlt anns pat rhs) =+  CaseAlt anns (addCaseAltPatternParens pat) (addCmdCaseAltRhsParens rhs)++addCmdCaseAltRhsParens :: Rhs Cmd -> Rhs Cmd+addCmdCaseAltRhsParens rhs =+  case rhs of+    UnguardedRhs sp body whereDecls ->+      UnguardedRhs sp (addCmdParens body) (fmap (map addDeclParens) whereDecls)+    GuardedRhss sp guards whereDecls ->+      GuardedRhss sp (map addCmdGuardedRhsParens guards) (fmap (map addDeclParens) whereDecls)++addCmdGuardedRhsParens :: GuardedRhs Cmd -> GuardedRhs Cmd+addCmdGuardedRhsParens grhs =+  grhs+    { guardedRhsGuards = addGuardQualifiersParens GuardArrow (guardedRhsGuards grhs),+      guardedRhsBody = addCmdParens (guardedRhsBody grhs)+    }
+ src/Aihc/Parser/Pretty.hs view
@@ -0,0 +1,1733 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- |+-- Module      : Aihc.Parser.Pretty+-- Description : Pretty-printing of AST to Haskell source code+--+-- This module provides pretty-printing of parsed AST back to valid Haskell+-- source code. It is used for round-trip testing and code generation.+--+-- The 'Pretty' instances from 'Prettyprinter' are provided for the main+-- AST types, allowing direct use of 'pretty' from @Prettyprinter@.+--+-- __Parenthesization__ is handled by the 'Aihc.Parser.Parens' module, which+-- inserts 'EParen', 'PParen', 'TParen', and 'CmdPar' nodes at all required+-- positions. The Pretty instances call the paren-insertion pass before+-- formatting, so the formatting code here does not need to worry about+-- operator precedence or context-sensitive parenthesization.+--+-- Import this module to bring the 'Pretty' instances into scope. The exported+-- helpers render AST nodes without first inserting additional parentheses,+-- which is useful for tests that need to inspect parenthesization directly.+--+-- __Provided instances:__ 'Pretty' for 'Module', 'Expr', 'Pattern', 'Type'.+module Aihc.Parser.Pretty+  ( prettyExpr,+    prettyPattern,+    prettyType,+  )+where++import Aihc.Parser.Parens (addDeclParens, addExprParens, addModuleParens, addPatternParens, addTypeParens)+import Aihc.Parser.Syntax+import Data.Maybe (catMaybes, isJust)+import Data.Text (Text)+import Data.Text qualified as T+import Prettyprinter+  ( Doc,+    Pretty (pretty),+    align,+    braces,+    brackets,+    comma,+    hang,+    hardline,+    hsep,+    indent,+    nest,+    nesting,+    parens,+    punctuate,+    semi,+    vsep,+    (<+>),+  )++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Aihc.Parser.Shorthand (Shorthand(..))+-- >>> import Aihc.Parser.Syntax+-- >>> import Prettyprinter (defaultLayoutOptions, layoutPretty)+-- >>> import Prettyprinter.Render.String (renderString)+-- >>> let renderDoc = renderString . layoutPretty defaultLayoutOptions++-- | Wrap a document in braces with interior spaces: @{ content }@.+-- Unlike 'braces' which produces @{content}@, this version avoids the+-- @{-@ block-comment ambiguity that occurs when the content starts with a+-- minus sign (e.g. a negated literal pattern in a let binding).+spacedBraces :: Doc ann -> Doc ann+spacedBraces d = "{" <+> d <+> "}"++prettyRawText :: Text -> Doc ann+prettyRawText raw+  | T.isInfixOf "\n" raw = nesting $ \level -> nest (negate level) (pretty raw)+  | otherwise = pretty raw++prettySpliceBody :: Expr -> Doc ann+prettySpliceBody = nest 2 . prettyExpr++-- | Pretty instance for Module - renders to valid Haskell source code.+instance Pretty Module where+  pretty = prettyModuleDoc . addModuleParens++-- | Pretty instance for Expr - renders to valid Haskell source code.+instance Pretty Expr where+  pretty = prettyExpr . addExprParens++-- | Pretty instance for Pattern - renders to valid Haskell source code.+instance Pretty Pattern where+  pretty = prettyPattern . addPatternParens++-- | Pretty instance for Decl - renders to valid Haskell source code.+instance Pretty Decl where+  pretty decl = vsep (prettyDeclLines (addDeclParens decl))++-- | Pretty instance for Type - renders to valid Haskell source code.+instance Pretty Type where+  pretty = prettyType . addTypeParens++instance Pretty Name where+  pretty = pretty . renderName++instance Pretty UnqualifiedName where+  pretty = pretty . renderUnqualifiedName++prettyModuleDoc :: Module -> Doc ann+prettyModuleDoc modu =+  vsep (pragmaLines <> headerLines <> importLines <> declLines)+  where+    pragmaLines =+      map+        (\ext -> "{-# LANGUAGE" <+> pretty (extensionSettingName ext) <+> "#-}")+        (moduleLanguagePragmas modu)+    headerLines =+      case moduleName modu of+        Just name ->+          [ hsep+              ( ["module", pretty name]+                  <> maybe [] (\p -> [prettyPragma p]) (moduleWarningPragma modu)+                  <> maybe [] (\specs -> [prettyExportSpecList specs]) (moduleExports modu)+                  <> ["where"]+              )+          ]+        Nothing -> []+    importLines = map prettyImportDecl (moduleImports modu)+    declLines = concatMap prettyDeclLines (moduleDecls modu)++prettyExportSpecList :: [ExportSpec] -> Doc ann+prettyExportSpecList specs =+  parens (hsep (punctuate comma (map prettyExportSpec specs)))++prettyExportSpec :: ExportSpec -> Doc ann+prettyExportSpec spec =+  case spec of+    ExportAnn _ sub -> prettyExportSpec sub+    ExportModule mWarning modName -> prettyExportWarning mWarning ("module" <+> pretty modName)+    ExportVar mWarning namespace name ->+      prettyExportWarning mWarning (prettyNamespacePrefix namespace <> prettyName name)+    ExportAbs mWarning namespace name ->+      prettyExportWarning mWarning (prettyNamespacePrefix namespace <> prettyName name)+    ExportAll mWarning namespace name ->+      prettyExportWarning mWarning (prettyNamespacePrefix namespace <> prettyName name <> "(..)")+    ExportWith mWarning namespace name members ->+      prettyExportWarning+        mWarning+        (prettyNamespacePrefix namespace <> prettyName name <> parens (hsep (punctuate comma (map prettyExportMember members))))+    ExportWithAll mWarning namespace name wildcardIndex members ->+      prettyExportWarning+        mWarning+        (prettyNamespacePrefix namespace <> prettyName name <> parens (hsep (punctuate comma (insertWildcard wildcardIndex (map prettyExportMember members)))))++prettyExportWarning :: Maybe Pragma -> Doc ann -> Doc ann+prettyExportWarning mWarning doc =+  case mWarning of+    Nothing -> doc+    Just p -> hsep [prettyPragma p, doc]++prettyImportDecl :: ImportDecl -> Doc ann+prettyImportDecl decl =+  let renderPostQualified =+        importDeclQualifiedPost decl+          && importDeclQualified decl+   in hsep+        ( ["import"]+            <> ["safe" | importDeclSafe decl]+            <> maybe [] (\p -> [prettyPragma p]) (importDeclSourcePragma decl)+            <> ["qualified" | importDeclQualified decl && not renderPostQualified]+            <> maybe [] (\level -> [prettyImportLevel level]) (importDeclLevel decl)+            <> maybe [] (\pkg -> [prettyQuotedText pkg]) (importDeclPackage decl)+            <> [pretty (importDeclModule decl)]+            <> ["qualified" | importDeclQualified decl && renderPostQualified]+            <> maybe [] (\alias -> ["as", pretty alias]) (importDeclAs decl)+            <> maybe [] (\spec -> [prettyImportSpec spec]) (importDeclSpec decl)+        )++prettyImportLevel :: ImportLevel -> Doc ann+prettyImportLevel level =+  case level of+    ImportLevelQuote -> "quote"+    ImportLevelSplice -> "splice"++-- | Pretty-print a top-level declaration splice.+-- The expression is printed as-is; explicit TH splices appear as @$expr@ or+-- @$(expr)@ through the normal 'ETHSplice' pretty-printer.+-- Nested continuation lines keep infix operators from starting in top-level+-- layout column one, where GHC can read them as a new declaration.+prettyDeclSpliceExpr :: Expr -> Doc ann+prettyDeclSpliceExpr = nest 2 . prettyExpr++prettyQuotedText :: Text -> Doc ann+prettyQuotedText txt = "\"" <> pretty txt <> "\""++prettyImportSpec :: ImportSpec -> Doc ann+prettyImportSpec spec =+  hsep+    ( ["hiding" | importSpecHiding spec]+        <> [parens (hsep (punctuate comma (map prettyImportItem (importSpecItems spec))))]+    )++prettyImportItem :: ImportItem -> Doc ann+prettyImportItem item =+  case item of+    ImportAnn _ sub -> prettyImportItem sub+    ImportItemVar namespace name -> prettyNamespacePrefix namespace <> prettyBinderUName name+    ImportItemAbs namespace name -> prettyNamespacePrefix namespace <> prettyConstructorUName name+    ImportItemAll namespace name -> prettyNamespacePrefix namespace <> prettyConstructorUName name <> "(..)"+    ImportItemWith namespace name members ->+      prettyNamespacePrefix namespace <> prettyConstructorUName name <> parens (hsep (punctuate comma (map prettyExportMember members)))+    ImportItemAllWith namespace name wildcardIndex members ->+      prettyNamespacePrefix namespace <> prettyConstructorUName name <> parens (hsep (punctuate comma (insertWildcard wildcardIndex (map prettyExportMember members))))++insertWildcard :: Int -> [Doc ann] -> [Doc ann]+insertWildcard wildcardIndex members =+  let (before, after) = splitAt wildcardIndex members+   in before <> [".."] <> after++prettyExportMember :: IEBundledMember -> Doc ann+prettyExportMember (IEBundledMember namespace name) =+  prettyMemberNamespacePrefix namespace <> prettyBundledMemberName name++prettyNamespacePrefix :: Maybe IEEntityNamespace -> Doc ann+prettyNamespacePrefix namespace =+  case namespace of+    Just ns -> prettyNamespace ns <> " "+    Nothing -> mempty++prettyNamespace :: IEEntityNamespace -> Doc ann+prettyNamespace namespace =+  case namespace of+    IEEntityNamespaceType -> "type"+    IEEntityNamespacePattern -> "pattern"+    IEEntityNamespaceData -> "data"++prettyMemberNamespacePrefix :: Maybe IEBundledNamespace -> Doc ann+prettyMemberNamespacePrefix namespace =+  case namespace of+    Just ns -> prettyMemberNamespace ns <> " "+    Nothing -> mempty++prettyMemberNamespace :: IEBundledNamespace -> Doc ann+prettyMemberNamespace namespace =+  case namespace of+    IEBundledNamespaceType -> "type"+    IEBundledNamespaceData -> "data"++prettyDeclLines :: Decl -> [Doc ann]+prettyDeclLines decl =+  case decl of+    DeclAnn _ sub -> prettyDeclLines sub+    DeclValue valueDecl -> prettyValueDeclLines valueDecl+    DeclTypeSig names ty -> [hsep [hsep (punctuate comma (map prettyBinderName names)), "::", prettyType ty]]+    DeclPatSyn patSynDecl -> [prettyPatSynDecl patSynDecl]+    DeclPatSynSig names ty -> [hsep ["pattern", hsep (punctuate comma (map prettyConstructorUName names)), "::", prettyType ty]]+    DeclStandaloneKindSig name kind -> [hsep ["type", prettyConstructorUName name, "::", prettyType kind]]+    DeclFixity assoc mNamespace prec ops ->+      [ hsep+          ( [prettyFixityAssoc assoc]+              <> maybe [] (pure . pretty . show) prec+              <> maybe [] (pure . prettyNamespace) mNamespace+              <> punctuate comma (map prettyInfixOp ops)+          )+      ]+    DeclRoleAnnotation ann -> [prettyRoleAnnotation ann]+    DeclTypeSyn synDecl ->+      [hsep (["type"] <> prettyDeclBinderHead [] (typeSynHead synDecl) <> ["=", prettyType (typeSynBody synDecl)])]+    DeclData dataDecl -> [prettyDataDecl dataDecl]+    DeclTypeData dataDecl -> [prettyTypeDataDecl dataDecl]+    DeclNewtype newtypeDecl -> [prettyNewtypeDecl newtypeDecl]+    DeclClass classDecl -> [prettyClassDecl classDecl]+    DeclInstance instanceDecl -> [prettyInstanceDecl instanceDecl]+    DeclStandaloneDeriving derivingDecl -> [prettyStandaloneDeriving derivingDecl]+    DeclDefault tys -> ["default" <+> parens (hsep (punctuate comma (map prettyType tys)))]+    DeclForeign foreignDecl -> [prettyForeignDecl foreignDecl]+    DeclSplice body -> [prettyDeclSpliceExpr body]+    DeclTypeFamilyDecl tf -> [prettyTypeFamilyDecl tf]+    DeclDataFamilyDecl df -> [prettyDataFamilyDecl df]+    DeclTypeFamilyInst tfi -> [prettyTopTypeFamilyInst tfi]+    DeclDataFamilyInst dfi -> [prettyTopDataFamilyInst dfi]+    DeclPragma pragma -> [prettyPragma pragma]++prettyRoleAnnotation :: RoleAnnotation -> Doc ann+prettyRoleAnnotation ann =+  hsep+    ( [ "type",+        "role",+        prettyConstructorUName (roleAnnotationName ann)+      ]+        <> map prettyRole (roleAnnotationRoles ann)+    )++prettyRole :: Role -> Doc ann+prettyRole role =+  case role of+    RoleNominal -> "nominal"+    RoleRepresentational -> "representational"+    RolePhantom -> "phantom"+    RoleInfer -> "_"++prettyValueDeclLines :: ValueDecl -> [Doc ann]+prettyValueDeclLines valueDecl = map (nest 2) $+  case valueDecl of+    PatternBind multTag pat rhs -> [prettyMultiplicityTag multTag <> prettyPattern pat <+> prettyRhs rhs]+    FunctionBind name matches ->+      concatMap (prettyFunctionMatchLines name) matches++-- | Pretty-print a value declaration on a single line.+prettyValueDeclSingleLine :: ValueDecl -> Doc ann+prettyValueDeclSingleLine valueDecl =+  case valueDecl of+    PatternBind multTag pat rhs -> prettyMultiplicityTag multTag <> prettyPattern pat <+> prettyRhs rhs+    FunctionBind name matches ->+      hsep (punctuate semi (map (prettyFunctionMatch name) matches))++prettyMultiplicityTag :: MultiplicityTag -> Doc ann+prettyMultiplicityTag NoMultiplicityTag = mempty+prettyMultiplicityTag LinearMultiplicityTag = "%1" <+> mempty+prettyMultiplicityTag (ExplicitMultiplicityTag ty) = "%" <> prettyType ty <+> mempty++-- | Pretty-print a pattern synonym declaration.+prettyPatSynDecl :: PatSynDecl -> Doc ann+prettyPatSynDecl ps =+  hang 2 $+    hsep+      ( ["pattern"]+          <> prettyPatSynLhs (patSynDeclName ps) (patSynDeclArgs ps)+          <> [dirArrow (patSynDeclDir ps)]+          <> [prettyPattern (patSynDeclPat ps)]+          <> prettyPatSynWhere (patSynDeclName ps) (patSynDeclDir ps)+      )+  where+    dirArrow PatSynBidirectional = "="+    dirArrow PatSynUnidirectional = "<-"+    dirArrow (PatSynExplicitBidirectional _) = "<-"++prettyPatSynLhs :: UnqualifiedName -> PatSynArgs -> [Doc ann]+prettyPatSynLhs name args =+  case args of+    PatSynPrefixArgs vars ->+      prettyConstructorUName name : map pretty vars+    PatSynInfixArgs lhs rhs ->+      [pretty lhs, prettyInfixOp name, pretty rhs]+    PatSynRecordArgs fields ->+      [prettyConstructorUName name <+> braces (hsep (punctuate comma (map pretty fields)))]++prettyPatSynWhere :: UnqualifiedName -> PatSynDir -> [Doc ann]+prettyPatSynWhere _ PatSynBidirectional = []+prettyPatSynWhere _ PatSynUnidirectional = []+prettyPatSynWhere _ (PatSynExplicitBidirectional []) = ["where", spacedBraces mempty]+prettyPatSynWhere name (PatSynExplicitBidirectional matches) =+  ["where" <> hardline <> indent 2 (vsep (map (prettyFunctionMatch name) matches))]++prettyFunctionMatchLines :: UnqualifiedName -> Match -> [Doc ann]+prettyFunctionMatchLines name match =+  case matchRhs match of+    UnguardedRhs {} -> [prettyFunctionMatch name match]+    GuardedRhss _ grhss mWhereDecls ->+      prettyFunctionHead name (matchHeadForm match) (matchPats match)+        : map+          (indent 2)+          ( map prettyGuardedRhsBlock grhss+              <> [prettyWhereClauseBare mWhereDecls | isJust mWhereDecls]+          )++prettyFunctionMatch :: UnqualifiedName -> Match -> Doc ann+prettyFunctionMatch name match =+  prettyFunctionHead name (matchHeadForm match) (matchPats match) <+> prettyRhs (matchRhs match)++prettyFunctionHead :: UnqualifiedName -> MatchHeadForm -> [Pattern] -> Doc ann+prettyFunctionHead name headForm pats =+  case headForm of+    MatchHeadPrefix ->+      hsep (prettyBinderUName name : map prettyPattern pats)+    MatchHeadInfix ->+      case pats of+        lhs : rhsPat : tailPats ->+          let infixHead = prettyPattern lhs <+> prettyInfixOp name <+> prettyPattern rhsPat+           in case tailPats of+                [] -> infixHead+                _ -> hsep (parens infixHead : map prettyPattern tailPats)+        _ ->+          hsep (prettyBinderUName name : map prettyPattern pats)++prettyRhs :: Rhs Expr -> Doc ann+prettyRhs rhs =+  case rhs of+    UnguardedRhs _ body whereDecls ->+      "="+        <+> nest 4 (prettyExpr body)+        <> prettyIndentedWhereClause whereDecls+    GuardedRhss _ guards whereDecls ->+      hardline <> indent 2 (prettyGuardedRhssBlock guards whereDecls)++prettyWhereClauseBare :: Maybe [Decl] -> Doc ann+prettyWhereClauseBare Nothing = mempty+prettyWhereClauseBare (Just []) = "where" <+> spacedBraces mempty+prettyWhereClauseBare (Just decls) =+  "where" <> hardline <> indent 2 (vsep (concatMap prettyDeclLines decls))++prettyIndentedWhereClause :: Maybe [Decl] -> Doc ann+prettyIndentedWhereClause Nothing = mempty+prettyIndentedWhereClause whereDecls = hardline <> indent 2 (prettyWhereClauseBare whereDecls)++prettyTHDeclQuote :: [Decl] -> Doc ann+prettyTHDeclQuote [] =+  hang 2 $+    "[d|"+      <> hardline+      <> "|]"+prettyTHDeclQuote decls =+  hang 2 $+    "[d|"+      <> hardline+      <> vsep (concatMap prettyDeclLines decls)+      <> hardline+      <> "|]"++-- | Infix type-family heads use @l \`Op\` r@ with a 'NameConId' operator (e.g.+-- @\`And\`@), so 'isSymbolicTypeName' is false; 'TypeHeadInfix' already marks+-- this shape as infix.+typeFamilyInfixAppView :: Type -> Maybe (Name, TypePromotion, Type, Type)+typeFamilyInfixAppView ty =+  case peelTypeAnn ty of+    TInfix lhs op promoted rhs -> Just (op, promoted, lhs, rhs)+    _ -> Nothing++-- | Pretty-print a type. The AST is assumed to already have TParen nodes+-- in the correct positions (inserted by 'addTypeParens').+--+-- >>> let ty = TApp (TCon "Proxy" Unpromoted) (TParen (TFun ArrowUnrestricted (TCon "A" Unpromoted) (TCon "B" Unpromoted))) in (renderDoc (prettyType ty), show (shorthand ty))+-- ("Proxy (A -> B)","TApp (TCon \"Proxy\") (TParen (TFun (TCon \"A\") (TCon \"B\")))")+--+-- | Check if a type, when pretty-printed, would start with a+-- promotion tick.  This is used to decide whether a promoted list or+-- tuple needs a space after the opening tick to avoid lexer confusion+-- (e.g.  ''[ '[' ... ]'' is invalid, whereas ''[ '[ ... ]'' is valid).+startsWithTick :: Type -> Bool+startsWithTick (TAnn _ sub) = startsWithTick sub+startsWithTick (TList Promoted _) = True+startsWithTick (TCon _ Promoted) = True+startsWithTick (TTuple _ Promoted _) = True+startsWithTick (TTypeLit (TypeLitChar _ _)) = True+startsWithTick (TApp f _) = startsWithTick f+startsWithTick (TInfix lhs _ _ _) = startsWithTick lhs+startsWithTick _ = False++prettyType :: Type -> Doc ann+prettyType ty =+  case ty of+    TAnn _ sub -> prettyType sub+    TVar name -> pretty name+    TCon name promoted ->+      let rendered = renderName name+          base+            | isSymbolicTypeName name = parens (pretty rendered)+            | otherwise = pretty rendered+          promoteTick+            | T.any (== '\'') rendered = "' "+            | otherwise = "'"+       in if promoted == Promoted then promoteTick <> base else base+    TBuiltinCon con -> prettyTypeBuiltinCon con+    TImplicitParam name inner -> pretty name <+> "::" <+> prettyType inner+    TTypeLit lit -> prettyTypeLiteral lit+    TStar spelling -> pretty spelling+    TQuasiQuote quoter body -> prettyQuasiQuote quoter body+    TForall telescope inner ->+      prettyForallTelescope telescope <+> prettyType inner+    -- Before infix detection: required grouping from the parser ('TParen',+    -- @(a :+: b) -> c@, constraints, nested @(c => t)@).+    TParen inner -> parens (prettyType inner)+    TInfix lhs op promoted rhs ->+      prettyType lhs+        <+> (if promoted == Promoted then "'" else mempty)+        <> prettyNameInfixOp op+        <+> prettyType rhs+    TApp f x ->+      prettyType f <+> prettyType x+    TTypeApp f x ->+      prettyType f <+> prettyTypeAppArg x+    TFun arrowKind a b ->+      prettyType a <+> prettyArrowKind arrowKind <+> prettyType b+    TTuple tupleFlavor promoted elems ->+      let elemsDoc = hsep (punctuate comma (map prettyType elems))+          tupleDoc = prettyTupleBody tupleFlavor elemsDoc+       in case (promoted, elems) of+            (Promoted, h : _) | startsWithTick h -> "' " <> tupleDoc+            (Promoted, _) -> "'" <> tupleDoc+            _ -> tupleDoc+    TUnboxedSum elems ->+      hsep ["(#", hsep (punctuate " |" (map prettyType elems)), "#)"]+    TList promoted elems ->+      let elemsDoc = hsep (punctuate comma (map prettyType elems))+          listDoc = brackets elemsDoc+       in case (promoted, elems) of+            (Promoted, h : _) | startsWithTick h -> "' " <> listDoc+            (Promoted, _) -> "'" <> listDoc+            _ -> listDoc+    TKindSig ty' kind ->+      prettyType ty' <+> "::" <+> prettyType kind+    TContext constraints inner ->+      case constraints of+        [] -> prettyType inner+        cs -> prettyContext cs <+> "=>" <+> prettyType inner+    TSplice body -> "$" <> prettySpliceBody body+    TWildcard -> "_"++prettyArrowKind :: ArrowKind -> Doc ann+prettyArrowKind ArrowUnrestricted = "->"+prettyArrowKind ArrowLinear = "%1" <+> "->"+prettyArrowKind (ArrowExplicit ty) = "%" <> prettyType ty <+> "->"++prettyTypeBuiltinCon :: TypeBuiltinCon -> Doc ann+prettyTypeBuiltinCon con =+  case con of+    TBuiltinTuple arity -> parens (pretty (T.replicate (max 0 (arity - 1)) ","))+    TBuiltinArrow -> "(->)"+    TBuiltinList -> "[]"+    TBuiltinCons -> "(:)"++prettyContext :: [Type] -> Doc ann+prettyContext constraints =+  case constraints of+    [] -> mempty+    [single] -> prettyType single+    _ -> parens (hsep (punctuate comma (map prettyType constraints)))++prettyTypeLiteral :: TypeLiteral -> Doc ann+prettyTypeLiteral lit =+  case lit of+    TypeLitInteger _ repr -> pretty repr+    TypeLitSymbol _ repr -> prettyRawText repr+    TypeLitChar _ repr -> pretty repr++-- | Pretty-print a pattern. The AST is assumed to already have PParen nodes+-- in the correct positions (inserted by 'addPatternParens').+--+-- >>> let pat = PAs "xs" (PParen (PNegLit (LitInt 1 TInteger "1"))) in (renderDoc (prettyPattern pat), show (shorthand pat))+-- ("xs@(-1)","PAs UnqualifiedName {\"xs\"} (PParen (PNegLit (LitInt 1 TInteger)))")+prettyPattern :: Pattern -> Doc ann+prettyPattern pat =+  case pat of+    PAnn _ sub -> prettyPattern sub+    PVar name -> prettyBinderUName name+    PTypeBinder binder -> prettyTyVarBinder binder+    PTypeSyntax TypeSyntaxExplicitNamespace ty -> "type" <+> prettyType ty+    PTypeSyntax TypeSyntaxInTerm ty -> prettyType ty+    PWildcard -> "_"+    PLit lit -> prettyLiteral lit+    PQuasiQuote quoter body -> prettyQuasiQuote quoter body+    PTuple Unboxed [] -> "(# #)"+    PTuple tupleFlavor elems -> prettyTupleBody tupleFlavor (hsep (punctuate comma (map prettyPattern elems)))+    PUnboxedSum altIdx arity inner ->+      let slots = [if i == altIdx then prettyPattern inner else mempty | i <- [0 .. arity - 1]]+       in hsep ["(#", prettyBarSeparated slots, "#)"]+    PList elems -> brackets (hsep (punctuate comma (map prettyPattern elems)))+    PCon con typeArgs args -> hsep ([prettyPrefixName con] <> map prettyInvisibleTypeArg typeArgs <> map prettyPattern args)+    PInfix lhs op rhs -> prettyPattern lhs <+> prettyNameInfixOp op <+> prettyPattern rhs+    PView viewExpr inner ->+      prettyExpr viewExpr <> hardline <> indent 1 ("->" <+> prettyPattern inner)+    PAs name inner -> prettyBinderUName name <> "@" <> prettyPattern inner+    PStrict inner -> "!" <> prettyPattern inner+    PIrrefutable inner -> "~" <> prettyPattern inner+    PNegLit lit -> "-" <> prettyLiteral lit+    PParen inner -> parens (prettyPattern inner)+    PRecord con fields hasWildcard ->+      prettyPrefixName con+        <+> braces+          ( hsep+              ( punctuate+                  comma+                  ( [prettyPatternFieldBinding field | field <- fields]+                      ++ [".." | hasWildcard]+                  )+              )+          )+    PTypeSig inner ty -> prettyPattern inner <+> "::" <+> prettyType ty+    PSplice body -> "$" <> prettySpliceBody body++-- | Pretty print a pattern field binding.+prettyPatternFieldBinding :: RecordField Pattern -> Doc ann+prettyPatternFieldBinding field =+  if recordFieldPun field+    then pretty (recordFieldName field)+    else pretty (recordFieldName field) <+> "=" <+> prettyPattern (recordFieldValue field)++prettyLiteral :: Literal -> Doc ann+prettyLiteral lit =+  case peelLiteralAnn lit of+    LitInt _ _ repr -> pretty repr+    LitFloat _ _ repr -> pretty repr+    LitChar _ repr -> pretty repr+    LitCharHash _ repr -> pretty repr+    LitString _ repr -> prettyRawText repr+    LitStringHash _ repr -> prettyRawText repr+    LitAnn {} -> error "unreachable"++prettyDataDecl :: DataDecl -> Doc ann+prettyDataDecl decl =+  case dataDeclConstructors decl of+    ctors+      | any isGadtCon ctors ->+          headDoc <+> prettyGadtConBlock ctors (dataDeclDeriving decl)+    _ ->+      hsep (headParts <> ctorPart <> derivingParts (dataDeclDeriving decl))+  where+    headParts =+      ["data"]+        <> maybe [] (pure . prettyPragma) (dataDeclCTypePragma decl)+        <> prettyDeclBinderHead (dataDeclContext decl) (dataDeclHead decl)+        <> kindPart+    headDoc = hsep headParts+    kindPart = maybe [] (\k -> ["::", prettyType k]) (dataDeclKind decl)+    ctorPart =+      case dataDeclConstructors decl of+        [] -> []+        ctors -> ["=", hsep (punctuate " |" (map prettyDataCon ctors))]++prettyTypeDataDecl :: DataDecl -> Doc ann+prettyTypeDataDecl decl =+  case dataDeclConstructors decl of+    ctors+      | any isGadtCon ctors -> headDoc <+> prettyGadtConBlock ctors []+    _ -> hsep (headParts <> ctorPart)+  where+    headParts =+      ["type data"]+        <> prettyDeclBinderHead (dataDeclContext decl) (dataDeclHead decl)+        <> kindPart+    headDoc = hsep headParts+    kindPart = maybe [] (\k -> ["::", prettyType k]) (dataDeclKind decl)+    ctorPart =+      case dataDeclConstructors decl of+        [] -> []+        ctors -> ["=", hsep (punctuate " |" (map prettyDataCon ctors))]++isGadtCon :: DataConDecl -> Bool+isGadtCon (DataConAnn _ inner) = isGadtCon inner+isGadtCon (GadtCon {}) = True+isGadtCon _ = False++prettyNewtypeDecl :: NewtypeDecl -> Doc ann+prettyNewtypeDecl decl =+  case newtypeDeclConstructor decl of+    Just ctor+      | isGadtCon ctor ->+          headDoc <+> prettyGadtConBlock [ctor] (newtypeDeclDeriving decl)+    _ ->+      hsep (headParts <> ctorPart <> derivingParts (newtypeDeclDeriving decl))+  where+    headParts =+      ["newtype"]+        <> maybe [] (pure . prettyPragma) (newtypeDeclCTypePragma decl)+        <> prettyDeclBinderHead (newtypeDeclContext decl) (newtypeDeclHead decl)+        <> kindPart+    headDoc = hsep headParts+    kindPart = maybe [] (\k -> ["::", prettyType k]) (newtypeDeclKind decl)+    ctorPart =+      case newtypeDeclConstructor decl of+        Nothing -> []+        Just ctor -> ["=", prettyDataCon ctor]++derivingParts :: [DerivingClause] -> [Doc ann]+derivingParts = concatMap derivingPart++prettyGadtConBlock :: [DataConDecl] -> [DerivingClause] -> Doc ann+prettyGadtConBlock ctors derivingClauses =+  "where"+    <> hardline+    <> indent 2 (vsep (map prettyDataCon ctors <> derivingParts derivingClauses))++derivingPart :: DerivingClause -> [Doc ann]+derivingPart (DerivingClause strategy classes) =+  ["deriving"] <> strategyPart strategy <> classesPart classes <> viaPart strategy+  where+    strategyPart Nothing = []+    strategyPart (Just (DerivingVia _)) = []+    strategyPart (Just strategy') = [prettyDerivingStrategy strategy']++    classesPart (Left name) = [prettyName name]+    classesPart (Right []) = ["()"]+    classesPart (Right classTypes) = [parens (hsep (punctuate comma (map prettyType classTypes)))]++    viaPart (Just (DerivingVia ty)) = ["via", prettyType ty]+    viaPart _ = []++prettyDeclBinderHead :: [Type] -> BinderHead UnqualifiedName -> [Doc ann]+prettyDeclBinderHead constraints head' =+  contextPrefix constraints+    <> prettyDeclHeadNameAndParams head'+  where+    prettyDeclHeadNameAndParams binderHead =+      case binderHead of+        PrefixBinderHead name params ->+          [prettyConstructorUName name] <> map prettyTyVarBinder params+        InfixBinderHead lhs name rhs tailPrms ->+          let infixHead = prettyTyVarBinder lhs <+> prettyInfixOp name <+> prettyTyVarBinder rhs+           in case tailPrms of+                [] -> [infixHead]+                _ -> parens infixHead : map prettyTyVarBinder tailPrms++prettyTyVarBinder :: TyVarBinder -> Doc ann+prettyTyVarBinder binder =+  visibleDoc+  where+    coreDoc =+      case (tyVarBinderSpecificity binder, tyVarBinderKind binder) of+        (TyVarBInferred, Nothing) -> braces (pretty (tyVarBinderName binder))+        (TyVarBInferred, Just kind) -> braces (pretty (tyVarBinderName binder) <+> "::" <+> prettyType kind)+        (TyVarBSpecified, Nothing) -> pretty (tyVarBinderName binder)+        (TyVarBSpecified, Just kind) -> parens (pretty (tyVarBinderName binder) <+> "::" <+> prettyType kind)+    visibleDoc =+      case tyVarBinderVisibility binder of+        TyVarBVisible -> coreDoc+        TyVarBInvisible -> "@" <> coreDoc++contextPrefix :: [Type] -> [Doc ann]+contextPrefix constraints =+  case constraints of+    [] -> []+    _ -> [prettyContext constraints, "=>"]++forallTyVarBinderPrefix :: [TyVarBinder] -> [Doc ann]+forallTyVarBinderPrefix [] = []+forallTyVarBinderPrefix binders = ["forall", hsep (map prettyTyVarBinder binders) <> "."]++prettyForallTelescope :: ForallTelescope -> Doc ann+prettyForallTelescope telescope =+  "forall"+    <+> hsep (map prettyTyVarBinder (forallTelescopeBinders telescope))+    <> case forallTelescopeVisibility telescope of+      ForallInvisible -> "."+      ForallVisible -> " ->"++prettyInvisibleTypeArg :: Type -> Doc ann+prettyInvisibleTypeArg = prettyTypeAppArg++prettyTypeAppArg :: Type -> Doc ann+prettyTypeAppArg ty+  | typeStartsWithSplice ty = "@" <> parens (prettyType ty)+  | otherwise = "@" <> prettyType ty++typeStartsWithSplice :: Type -> Bool+typeStartsWithSplice ty =+  case ty of+    TAnn _ sub -> typeStartsWithSplice sub+    TSplice {} -> True+    _ -> False++prettyDataCon :: DataConDecl -> Doc ann+prettyDataCon ctor =+  case ctor of+    DataConAnn _ inner -> prettyDataCon inner+    PrefixCon forallVars constraints name fields ->+      hsep (dataConQualifierPrefix forallVars constraints <> [prettyConstructorUName name] <> map prettyBangType fields)+    InfixCon forallVars constraints lhs op rhs ->+      hsep+        ( dataConQualifierPrefix forallVars constraints+            <> [prettyBangType lhs, prettyInfixOp op, prettyBangType rhs]+        )+    RecordCon forallVars constraints name fields ->+      hsep (dataConQualifierPrefix forallVars constraints <> [prettyConstructorUName name])+        <+> braces (prettyRecordFields fields)+    GadtCon foralls constraints names body ->+      prettyGadtCon foralls constraints names body+    TupleCon forallVars constraints Boxed fields ->+      hsep (dataConQualifierPrefix forallVars constraints)+        <+> parens (hsep (punctuate comma (map prettyBangType fields)))+    TupleCon forallVars constraints Unboxed fields ->+      hsep (dataConQualifierPrefix forallVars constraints)+        <+> "(#"+        <+> hsep (punctuate comma (map prettyBangType fields))+        <+> "#)"+    UnboxedSumCon forallVars constraints pos arity field ->+      hsep (dataConQualifierPrefix forallVars constraints)+        <+> "(#"+        <+> hsep (replicate (pos - 1) "|" <> [prettyBangType field] <> replicate (arity - pos) "|")+        <+> "#)"+    ListCon forallVars constraints ->+      hsep (dataConQualifierPrefix forallVars constraints <> ["[]"])++prettyGadtCon :: [ForallTelescope] -> [Type] -> [UnqualifiedName] -> GadtBody -> Doc ann+prettyGadtCon forallBinders constraints names body =+  hsep+    ( [hsep (punctuate comma (map prettyConstructorUName names)), "::"]+        <> forallPart+        <> contextPart+        <> [prettyGadtBody body]+    )+  where+    forallPart = map prettyForallTelescope forallBinders+    contextPart+      | null constraints = []+      | otherwise = [prettyContext constraints, "=>"]++prettyGadtBody :: GadtBody -> Doc ann+prettyGadtBody body =+  case body of+    GadtPrefixBody args resultTy ->+      case args of+        [] -> prettyType resultTy+        _ ->+          hsep $+            concatMap (\(bt, ak) -> [prettyBangType bt, prettyArrowKind ak]) args+              ++ [prettyType resultTy]+    GadtRecordBody fields resultTy ->+      braces (prettyRecordFields fields) <+> "->" <+> prettyType resultTy++prettyRecordFields :: [FieldDecl] -> Doc ann+prettyRecordFields fields =+  hsep+    ( punctuate+        comma+        [ hsep $+            [hsep (punctuate comma (map prettyFieldName (fieldNames fld)))]+              <> maybe [] (\mult -> ["%" <> prettyType mult]) (fieldMultiplicity fld)+              <> [ "::",+                   prettyRecordFieldBangType (fieldType fld)+                 ]+        | fld <- fields+        ]+    )+  where+    prettyFieldName :: UnqualifiedName -> Doc ann+    prettyFieldName = prettyFunctionBinder++dataConQualifierPrefix :: [TyVarBinder] -> [Type] -> [Doc ann]+dataConQualifierPrefix forallVars constraints = forallTyVarBinderPrefix forallVars <> contextPrefix constraints++-- | Pretty print a BangType. The type already has TParen nodes where needed.+prettyBangType :: BangType -> Doc ann+prettyBangType bt =+  hsep (map prettyPragma (bangPragmas bt) <> [strictOrLazyDoc])+  where+    strictOrLazyDoc+      | bangStrict bt = "!" <> prettyType (bangType bt)+      | bangLazy bt = "~" <> prettyType (bangType bt)+      | otherwise = prettyType (bangType bt)++prettyRecordFieldBangType :: BangType -> Doc ann+prettyRecordFieldBangType bt =+  hsep (map prettyPragma (bangPragmas bt) <> [strictOrLazyDoc])+  where+    strictOrLazyDoc+      | bangStrict bt = "!" <> prettyType (bangType bt)+      | bangLazy bt = "~" <> prettyType (bangType bt)+      | otherwise = prettyType (bangType bt)++prettyClassDecl :: ClassDecl -> Doc ann+prettyClassDecl decl =+  let headDoc =+        hsep+          ( ["class"]+              <> maybeContextPrefix (classDeclContext decl)+              <> prettyNamedBinderHead (classDeclHead decl)+              <> prettyClassFundeps (classDeclFundeps decl)+          )+   in case classDeclItems decl of+        [] -> headDoc+        items ->+          headDoc+            <+> "where"+            <> hardline+            <> indent 2 (vsep (concatMap prettyClassItemLines items))++prettyClassFundeps :: [FunctionalDependency] -> [Doc ann]+prettyClassFundeps deps =+  case deps of+    [] -> []+    _ -> ["|", hsep (punctuate comma (map prettyFunctionalDependency deps))]++prettyFunctionalDependency :: FunctionalDependency -> Doc ann+prettyFunctionalDependency dep =+  hsep+    [ hsep (map pretty (functionalDependencyDeterminers dep)),+      "->",+      hsep (map pretty (functionalDependencyDetermined dep))+    ]++prettyTypeFamilyInjectivity :: TypeFamilyInjectivity -> Doc ann+prettyTypeFamilyInjectivity injectivity =+  hsep+    [ pretty (typeFamilyInjectivityResult injectivity),+      "->",+      hsep (map pretty (typeFamilyInjectivityDetermined injectivity))+    ]++maybeContextPrefix :: Maybe [Type] -> [Doc ann]+maybeContextPrefix maybeConstraints =+  case maybeConstraints of+    Nothing -> []+    Just constraints -> [prettyContext constraints, "=>"]++prettyClassItem :: ClassDeclItem -> Doc ann+prettyClassItem item =+  case item of+    ClassItemAnn _ sub -> prettyClassItem sub+    ClassItemTypeSig names ty -> hsep [hsep (punctuate comma (map prettyBinderName names)), "::", prettyType ty]+    ClassItemDefaultSig name ty -> hsep ["default", prettyBinderName name, "::", prettyType ty]+    ClassItemFixity assoc mNamespace prec ops ->+      hsep+        ( [prettyFixityAssoc assoc]+            <> maybe [] (pure . pretty . show) prec+            <> maybe [] (pure . prettyNamespace) mNamespace+            <> punctuate comma (map prettyInfixOp ops)+        )+    ClassItemDefault valueDecl -> prettyValueDeclSingleLine valueDecl+    ClassItemTypeFamilyDecl tf -> prettyAssocTypeFamilyDecl tf+    ClassItemDataFamilyDecl df -> prettyAssocDataFamilyDecl df+    ClassItemDefaultTypeInst tfi -> prettyDefaultTypeInst tfi+    ClassItemPragma pragma -> prettyPragma pragma++prettyClassItemLines :: ClassDeclItem -> [Doc ann]+prettyClassItemLines item =+  case item of+    ClassItemAnn _ inner -> prettyClassItemLines inner+    ClassItemDefault valueDecl -> prettyValueDeclLines valueDecl+    _ -> [prettyClassItem item]++prettyInstanceDecl :: InstanceDecl -> Doc ann+prettyInstanceDecl decl =+  let headDoc =+        hsep+          ( ["instance"]+              <> map prettyPragma (instanceDeclPragmas decl)+              <> maybe [] (\w -> [prettyPragma w]) (instanceDeclWarning decl)+              <> forallTyVarBinderPrefix (instanceDeclForall decl)+              <> contextPrefix (instanceDeclContext decl)+              <> [prettyType (instanceDeclHead decl)]+          )+   in case instanceDeclItems decl of+        [] -> headDoc+        items ->+          headDoc+            <+> "where"+            <> hardline+            <> indent 2 (vsep (concatMap prettyInstanceItemLines items))++prettyStandaloneDeriving :: StandaloneDerivingDecl -> Doc ann+prettyStandaloneDeriving decl =+  hsep+    ( ["deriving"]+        <> maybe [] (\s -> [prettyDerivingStrategy s]) (standaloneDerivingStrategy decl)+        <> ["instance"]+        <> map prettyPragma (standaloneDerivingPragmas decl)+        <> maybe [] (\w -> [prettyPragma w]) (standaloneDerivingWarning decl)+        <> forallTyVarBinderPrefix (standaloneDerivingForall decl)+        <> contextPrefix (standaloneDerivingContext decl)+        <> [prettyType (standaloneDerivingHead decl)]+    )++prettyPragma :: Pragma -> Doc ann+prettyPragma pragma+  | not (T.null (pragmaRawText pragma)) = pretty (pragmaRawText pragma)+  | otherwise = prettyPragmaType (pragmaType pragma)++prettyPragmaType :: PragmaType -> Doc ann+prettyPragmaType pt =+  case pt of+    PragmaLanguage settings -> "{-# LANGUAGE " <> hsep (punctuate comma (map (pretty . extensionSettingName) settings)) <> " #-}"+    PragmaInstanceOverlap overlapPragma ->+      case overlapPragma of+        Overlapping -> "{-# OVERLAPPING #-}"+        Overlappable -> "{-# OVERLAPPABLE #-}"+        Overlaps -> "{-# OVERLAPS #-}"+        Incoherent -> "{-# INCOHERENT #-}"+    PragmaWarning msg -> "{-# WARNING " <> pretty (show msg) <> " #-}"+    PragmaDeprecated msg -> "{-# DEPRECATED " <> pretty (show msg) <> " #-}"+    PragmaInline kind body -> "{-# " <> pretty kind <> " " <> pretty body <> " #-}"+    PragmaUnpack unpackKind ->+      case unpackKind of+        UnpackPragma -> "{-# UNPACK #-}"+        NoUnpackPragma -> "{-# NOUNPACK #-}"+    PragmaSource sourceText _ -> "{-# SOURCE " <> pretty sourceText <> " #-}"+    PragmaSCC label -> "{-# SCC " <> pretty label <> " #-}"+    PragmaUnknown text -> pretty text++prettyDerivingStrategy :: DerivingStrategy -> Doc ann+prettyDerivingStrategy strategy =+  case strategy of+    DerivingStock -> "stock"+    DerivingNewtype -> "newtype"+    DerivingAnyclass -> "anyclass"+    DerivingVia ty -> "via" <+> prettyType ty++prettyInstanceItem :: InstanceDeclItem -> Doc ann+prettyInstanceItem item =+  case item of+    InstanceItemAnn _ inner -> prettyInstanceItem inner+    InstanceItemBind valueDecl -> prettyValueDeclSingleLine valueDecl+    InstanceItemTypeSig names ty -> hsep [hsep (punctuate comma (map prettyBinderName names)), "::", prettyType ty]+    InstanceItemFixity assoc mNamespace prec ops ->+      hsep+        ( [prettyFixityAssoc assoc]+            <> maybe [] (pure . pretty . show) prec+            <> maybe [] (pure . prettyNamespace) mNamespace+            <> punctuate comma (map prettyInfixOp ops)+        )+    InstanceItemTypeFamilyInst tfi -> prettyInstTypeFamilyInst tfi+    InstanceItemDataFamilyInst dfi -> prettyInstDataFamilyInst dfi+    InstanceItemPragma pragma -> prettyPragma pragma++prettyInstanceItemLines :: InstanceDeclItem -> [Doc ann]+prettyInstanceItemLines item =+  case item of+    InstanceItemAnn _ inner -> prettyInstanceItemLines inner+    InstanceItemBind valueDecl -> prettyValueDeclLines valueDecl+    _ -> [prettyInstanceItem item]++prettyFixityAssoc :: FixityAssoc -> Doc ann+prettyFixityAssoc assoc =+  case assoc of+    Infix -> "infix"+    InfixL -> "infixl"+    InfixR -> "infixr"++prettyForeignDecl :: ForeignDecl -> Doc ann+prettyForeignDecl decl =+  hsep . catMaybes $+    [ Just "foreign",+      Just (prettyDirection (foreignDirection decl)),+      Just (prettyCallConv (foreignCallConv decl)),+      prettySafety <$> foreignSafety decl,+      prettyForeignEntity (foreignEntity decl),+      Just (prettyBinderName (foreignName decl)),+      Just "::",+      Just (prettyType (foreignType decl))+    ]++prettyDirection :: ForeignDirection -> Doc ann+prettyDirection direction =+  case direction of+    ForeignImport -> "import"+    ForeignExport -> "export"++prettyCallConv :: CallConv -> Doc ann+prettyCallConv cc =+  case cc of+    CCall -> "ccall"+    StdCall -> "stdcall"+    CApi -> "capi"+    CPrim -> "prim"+    JavaScript -> "javascript"++prettySafety :: ForeignSafety -> Doc ann+prettySafety safety =+  case safety of+    Safe -> "safe"+    Unsafe -> "unsafe"+    Interruptible -> "interruptible"++prettyForeignEntity :: ForeignEntitySpec -> Maybe (Doc ann)+prettyForeignEntity spec =+  case spec of+    ForeignEntityOmitted -> Nothing+    ForeignEntityDynamic -> Just (quoted "dynamic")+    ForeignEntityWrapper -> Just (quoted "wrapper")+    ForeignEntityStatic Nothing -> Just (quoted "static")+    ForeignEntityStatic (Just name) -> Just (quoted ("static " <> name))+    ForeignEntityAddress Nothing -> Just (quoted "&")+    ForeignEntityAddress (Just name) -> Just (quoted ("&" <> name))+    ForeignEntityNamed name -> Just (quoted name)++prettyInfixOp :: UnqualifiedName -> Doc ann+prettyInfixOp name+  | isSymbolicUName name = pretty (renderUnqualifiedName name)+  | otherwise = "`" <> pretty (renderUnqualifiedName name) <> "`"++prettyNameInfixOp :: Name -> Doc ann+prettyNameInfixOp name+  | isSymbolicName name = pretty (renderName name)+  | otherwise = "`" <> pretty (renderName name) <> "`"++prettyPrefixName :: Name -> Doc ann+prettyPrefixName name+  | isSymbolicName name = parens (pretty rendered)+  | otherwise = pretty rendered+  where+    rendered = renderName name++isSymbolicUName :: UnqualifiedName -> Bool+isSymbolicUName name =+  case unqualifiedNameType name of+    NameVarSym -> True+    NameConSym -> True+    _ -> False++isSymbolicName :: Name -> Bool+isSymbolicName name =+  case nameType name of+    NameVarSym -> True+    NameConSym -> True+    _ -> False++isSymbolicTypeName :: Name -> Bool+isSymbolicTypeName = isSymbolicName++prettyFunctionBinder :: UnqualifiedName -> Doc ann+prettyFunctionBinder name+  | unqualifiedNameType name == NameVarSym || unqualifiedNameType name == NameConSym =+      let rendered = renderUnqualifiedName name+       in if startsWithHash rendered+            then parens (" " <> pretty rendered <> " ")+            else parens (pretty rendered)+  | otherwise = pretty (renderUnqualifiedName name)+  where+    startsWithHash t =+      case T.uncons t of+        Just ('#', _) -> True+        _ -> False++prettyBinderName :: UnqualifiedName -> Doc ann+prettyBinderName = prettyFunctionBinder++prettyBinderUName :: UnqualifiedName -> Doc ann+prettyBinderUName = prettyFunctionBinder++prettyName :: Name -> Doc ann+prettyName name+  | nameType name == NameVarSym || nameType name == NameConSym =+      let rendered = renderName name+       in if startsWithHash rendered+            then parens (" " <> pretty rendered <> " ")+            else parens (pretty rendered)+  | otherwise = pretty (renderName name)+  where+    startsWithHash t =+      case T.uncons t of+        Just ('#', _) -> True+        _ -> False++prettyBundledMemberName :: Name -> Doc ann+prettyBundledMemberName name+  | isHashLeadingSymbolicName name = parens (" " <> pretty (renderName name) <> " ")+  | otherwise = prettyName name++isHashLeadingSymbolicName :: Name -> Bool+isHashLeadingSymbolicName name =+  isSymbolicName name+    && case nameQualifier name of+      Nothing -> case T.uncons (nameText name) of+        Just ('#', _) -> True+        _ -> False+      Just _ -> False++prettyConstructorUName :: UnqualifiedName -> Doc ann+prettyConstructorUName name+  | isSymbolicUName name = parens (pretty (renderUnqualifiedName name))+  | otherwise = pretty (renderUnqualifiedName name)++-- | Pretty-print an expression. The AST is assumed to already have EParen+-- nodes in the correct positions (inserted by 'addExprParens').+--+-- >>> let expr = EApp (EVar "f") (EParen (EInfix (EVar "x") "+" (EVar "y"))) in (renderDoc (prettyExpr expr), show (shorthand expr))+-- ("f\n  (x\n  + y)","EApp (EVar \"f\") (EParen (EInfix (EVar \"x\") \"+\" (EVar \"y\")))")+prettyExpr :: Expr -> Doc ann+prettyExpr expr =+  case expr of+    EApp {} -> prettyApp expr+    ETypeApp fn ty ->+      prettyExpr fn <> hardline <> " " <> prettyTypeAppArg ty+    EVar name -> prettyName name+    ETypeSyntax TypeSyntaxExplicitNamespace ty -> "type" <+> prettyType ty+    ETypeSyntax TypeSyntaxInTerm ty -> prettyType ty+    EInt _ _ repr -> pretty repr+    EFloat _ _ repr -> pretty repr+    EChar _ repr -> pretty repr+    ECharHash _ repr -> pretty repr+    EString _ repr -> prettyRawText repr+    EStringHash _ repr -> prettyRawText repr+    EOverloadedLabel _ raw -> pretty (" " <> raw)+    EQuasiQuote quoter body -> prettyQuasiQuote quoter body+    ETHExpQuote body -> "[|" <+> prettyExpr body <+> "|]"+    ETHTypedQuote body -> "[||" <+> prettyExpr body <+> "||]"+    ETHDeclQuote decls -> prettyTHDeclQuote decls+    ETHTypeQuote ty -> "[t|" <+> prettyType ty <+> "|]"+    ETHPatQuote pat -> "[p|" <+> prettyPattern pat <+> "|]"+    ETHNameQuote body -> "' " <> prettyExpr body+    ETHTypeNameQuote ty -> "'' " <> prettyType ty+    ETHSplice body -> "$" <> prettySpliceBody body+    ETHTypedSplice body -> "$$" <> prettySpliceBody body+    EIf cond yes no ->+      "if" <+> nest 2 (prettyExpr cond <+> "then" <+> prettyExpr yes <+> "else" <+> prettyExpr no)+    EMultiWayIf rhss ->+      "if" <+> hang 3 (prettyMultiWayIfRhss rhss)+    ELambdaPats pats body ->+      "\\" <+> hsep (map prettyPattern pats) <+> "->" <+> nest 2 (prettyExpr body)+    ELambdaCase alts ->+      "\\" <> "case" <> prettyCaseLayout (map prettyCaseAlt alts)+    ELambdaCases alts ->+      "\\" <> "cases" <> prettyCaseLayout (map prettyLambdaCaseAlt alts)+    EInfix lhs op rhs ->+      prettyExpr lhs <> hardline <> prettyNameInfixOp op <+> prettyExpr rhs+    ENegate inner -> "-" <+> prettyExprAtStatementStart inner+    ESectionL lhs op ->+      prettyExpr lhs <> hardline <> " " <> prettyNameInfixOp op+    ESectionR op rhs -> prettyNameInfixOp op <+> prettyExpr rhs+    ELetDecls decls body ->+      case decls of+        [] -> prettyLetDecls decls <+> "in" <+> prettyExpr body+        _ -> align (prettyLetDecls decls <> hardline <> indent 2 ("in" <+> prettyExpr body))+    ECase scrutinee alts ->+      prettyCaseExpr prettyCaseLayout scrutinee alts+    EDo stmts flavor ->+      prettyDoFlavor flavor <> nest 2 (prettyDoLayout prettyDoStmt stmts)+    EListComp body quals ->+      brackets+        ( let qualifiers = prettyCommaSeparated prettyCompStmt quals+           in prettyExpr body <> hardline <> " |" <+> qualifiers+        )+    EListCompParallel body qualifierGroups ->+      brackets+        ( let qualifiers =+                prettyBarSeparated+                  [ prettyCommaSeparated prettyCompStmt group+                  | group <- qualifierGroups+                  ]+           in prettyExpr body <> hardline <> " |" <+> qualifiers+        )+    EArithSeq seqInfo -> prettyArithSeq seqInfo+    ERecordCon name fields hasWildcard ->+      prettyPrefixName name <+> braces (hsep (punctuate comma (map prettyBinding fields ++ [".." | hasWildcard])))+    ERecordUpd base fields ->+      prettyExpr base <+> braces (hsep (punctuate comma (map prettyBinding fields)))+    EGetField base field ->+      prettyExpr base <> "." <> prettyName field+    EGetFieldProjection fields ->+      "." <> mconcat (punctuate "." (map prettyName fields))+    ETypeSig inner ty ->+      align (prettyExpr inner <> hardline <> "::" <+> prettyType ty)+    EParen inner -> case inner of+      ECase scrutinee alts ->+        parens (prettyCaseExpr prettyCaseLayoutAligned scrutinee alts)+      -- ESectionR with a '#'-starting op renders as "(# ...)" which the lexer+      -- reads as TkSpecialUnboxedLParen when UnboxedTuples/UnboxedSums is on.+      -- A leading space produces "( # ...)" which is unambiguous.+      ESectionR op _ | T.isPrefixOf "#" (renderName op) -> parens (" " <> prettyExpr inner)+      -- ESectionL with a '#'-ending op renders as "(x #)" which the lexer+      -- reads as TkSpecialUnboxedRParen when UnboxedTuples/UnboxedSums is on.+      -- A trailing space produces "(x # )" which is unambiguous.+      ESectionL _ op | T.isSuffixOf "#" (renderName op) -> parens (prettyExpr inner <> " ")+      _ -> parens (prettyExpr inner)+    EList values -> brackets (prettyCommaSeparated prettyExpr values)+    ETuple Unboxed [] -> "(# #)"+    ETuple tupleFlavor values ->+      prettyTupleBody tupleFlavor (prettyCommaSeparated (maybe mempty prettyExpr) values)+    EUnboxedSum altIdx arity inner ->+      let slots = [if i == altIdx then prettyExpr inner else mempty | i <- [0 .. arity - 1]]+       in hsep ["(#", prettyBarSeparated slots, "#)"]+    EProc pat body ->+      "proc" <+> prettyPattern pat <+> "->" <+> nest 2 (prettyCmd body)+    EPragma pragma inner ->+      prettyPragma pragma <+> prettyExpr inner+    EAnn _ sub -> prettyExpr sub++prettyApp :: Expr -> Doc ann+prettyApp = prettyAppWith prettyExpr++prettyAppWith :: (Expr -> Doc ann) -> Expr -> Doc ann+prettyAppWith prettyFn expr =+  let (fn, args) = flattenApps expr+   in vsep (prettyFn fn : map (indent 2 . prettyExpr) args)+  where+    flattenApps = go []+    go args (EAnn _ sub) = go args sub+    go args (EApp fn arg) = go (arg : args) fn+    go args root = (root, args)++prettyCommaSeparated :: (a -> Doc ann) -> [a] -> Doc ann+prettyCommaSeparated render items =+  case map render items of+    [] -> mempty+    rendered -> hang 2 (vsep (punctuate comma rendered))++prettyBarSeparated :: [Doc ann] -> Doc ann+prettyBarSeparated items =+  case items of+    [] -> mempty+    firstItem : restItems -> hang 2 (vsep (firstItem : map ("|" <+>) restItems))++prettyTupleBody :: TupleFlavor -> Doc ann -> Doc ann+prettyTupleBody tupleFlavor inner =+  case tupleFlavor of+    Boxed -> parens inner+    Unboxed -> hsep ["(#", inner, "#)"]++prettyBinding :: RecordField Expr -> Doc ann+prettyBinding field =+  if recordFieldPun field+    then prettyName (recordFieldName field)+    else prettyName (recordFieldName field) <+> "=" <+> prettyExpr (recordFieldValue field)++prettyCaseAltWith :: (body -> Doc ann) -> CaseAlt body -> Doc ann+prettyCaseAltWith prettyBody (CaseAlt _ pat rhs) = nest 2 $+  case rhs of+    UnguardedRhs _ body whereDecls ->+      prettyPattern pat+        <+> "->"+        <> hardline+        <> indent 2 (prettyBody body)+        <> prettyIndentedWhereClause whereDecls+    GuardedRhss _ grhss whereDecls ->+      prettyPattern pat+        <> hardline+        <> indent 2 (vsep (map (prettyCaseGuardedRhsBlock prettyBody) grhss))+        <> prettyIndentedWhereClause whereDecls++prettyCaseAlt :: CaseAlt Expr -> Doc ann+prettyCaseAlt = prettyCaseAltWith prettyExpr++prettyGuardedRhsBodyBlock :: Text -> GuardedRhs Expr -> Doc ann+prettyGuardedRhsBodyBlock arrow grhs =+  let guards = guardedRhsGuards grhs+      body = guardedRhsBody grhs+   in "|"+        <+> prettyGuardQualifiersLayout guards+        <> hardline+        <> " "+        <> pretty arrow+        <> hardline+        <> indent 2 (prettyExpr body)++prettyCaseGuardedRhsBlock :: (body -> Doc ann) -> GuardedRhs body -> Doc ann+prettyCaseGuardedRhsBlock prettyBody grhs =+  let guards = guardedRhsGuards grhs+      body = guardedRhsBody grhs+   in "|"+        <+> prettyGuardQualifiersLayout guards+        <> hardline+        <> " "+        <> "->"+        <> hardline+        <> indent 2 (prettyBody body)++prettyMultiWayIfRhss :: [GuardedRhs Expr] -> Doc ann+prettyMultiWayIfRhss rhss = vsep (map (prettyGuardedRhsBodyBlock "->") rhss)++prettyGuardQualifiersLayout :: [GuardQualifier] -> Doc ann+prettyGuardQualifiersLayout qualifiers =+  case map prettyGuardQualifier qualifiers of+    [] -> mempty+    firstQualifier : restQualifiers ->+      vsep (firstQualifier : map (indent 2 . (comma <+>)) restQualifiers)++prettyCaseExpr :: ([Doc ann] -> Doc ann) -> Expr -> [CaseAlt Expr] -> Doc ann+prettyCaseExpr layout scrutinee alts =+  "case"+    <+> nest 2 (prettyExpr scrutinee)+    <+> "of"+    <> layout (map prettyCaseAlt alts)++prettyCaseLayout :: [Doc ann] -> Doc ann+prettyCaseLayout [] = " " <> spacedBraces mempty+prettyCaseLayout alts = nest 2 (hardline <> vsep alts)++prettyCaseLayoutAligned :: [Doc ann] -> Doc ann+prettyCaseLayoutAligned [] = " " <> spacedBraces mempty+prettyCaseLayoutAligned alts = hang 2 (hardline <> vsep alts)++prettyLambdaCaseAlt :: LambdaCaseAlt -> Doc ann+prettyLambdaCaseAlt (LambdaCaseAlt _ pats rhs) = nest 2 $+  case rhs of+    UnguardedRhs _ body whereDecls ->+      hsep (map prettyPattern pats)+        <+> "->"+        <> hardline+        <> indent 2 (prettyExpr body)+        <> prettyIndentedWhereClause whereDecls+    GuardedRhss _ grhss whereDecls ->+      hsep (map prettyPattern pats)+        <> hardline+        <> indent 2 (vsep (map (prettyCaseGuardedRhsBlock prettyExpr) grhss))+        <> prettyIndentedWhereClause whereDecls++prettyGuardQualifier :: GuardQualifier -> Doc ann+prettyGuardQualifier qualifier =+  case qualifier of+    GuardAnn _ inner -> prettyGuardQualifier inner+    GuardExpr expr -> prettyExpr expr+    GuardPat pat expr -> prettyPattern pat <+> "<-" <+> prettyExpr expr+    GuardLet decls -> prettyLetDecls decls++prettyLetDecls :: [Decl] -> Doc ann+prettyLetDecls decls+  | null decls = "let" <+> spacedBraces mempty+  | otherwise =+      "let" <+> hang 0 (vsep (concatMap prettyDeclLines decls))++prettyDoFlavor :: DoFlavor -> Doc ann+prettyDoFlavor DoPlain = "do"+prettyDoFlavor DoMdo = "mdo"+prettyDoFlavor (DoQualified m) = pretty m <> ".do"+prettyDoFlavor (DoQualifiedMdo m) = pretty m <> ".mdo"++prettyDoLayout :: (a -> Doc ann) -> [a] -> Doc ann+prettyDoLayout prettyStmt stmts =+  case stmts of+    [] -> hardline+    _ -> hardline <> prettyLayoutStatements prettyStmt stmts++prettyLayoutStatements :: (a -> Doc ann) -> [a] -> Doc ann+prettyLayoutStatements prettyStmt stmts =+  case map prettyStmt stmts of+    [] -> mempty+    rendered -> vsep rendered++prettyDoStmt :: DoStmt Expr -> Doc ann+prettyDoStmt stmt =+  case stmt of+    DoAnn _ inner -> prettyDoStmt inner+    DoBind pat expr -> prettyPattern pat <+> "<-" <+> nest 2 (prettyExpr expr)+    DoLetDecls decls -> prettyLetDecls decls+    --+    DoExpr expr -> hang 2 (prettyExprAtStatementStart expr)+    DoRecStmt stmts -> "rec" <> nest 2 (prettyDoLayout prettyDoStmt stmts)++-- prettyExprAtStatementStart is a hack to get overloaded labels to align. We always print a space before labels which messes things up.+prettyExprAtStatementStart :: Expr -> Doc ann+prettyExprAtStatementStart expr =+  case expr of+    EAnn _ sub -> prettyExprAtStatementStart sub+    EOverloadedLabel _ raw -> pretty raw+    EApp {} -> prettyAppWith prettyExprAtStatementStart expr+    ETypeApp fn ty -> prettyExprAtStatementStart fn <> hardline <> " " <> prettyTypeAppArg ty+    EInfix lhs op rhs -> prettyExprAtStatementStart lhs <> hardline <> prettyNameInfixOp op <+> prettyExpr rhs+    ESectionL lhs op -> prettyExprAtStatementStart lhs <> hardline <> " " <> prettyNameInfixOp op+    ETypeSig inner ty -> prettyExprAtStatementStart inner <> hardline <> indent 2 ("::" <+> prettyType ty)+    ERecordUpd base fields ->+      prettyExprAtStatementStart base <+> braces (hsep (punctuate comma (map prettyBinding fields)))+    EGetField base field ->+      prettyExprAtStatementStart base <> "." <> prettyName field+    _ -> prettyExpr expr++-- | Pretty-print an arrow command.+prettyCmd :: Cmd -> Doc ann+prettyCmd (CmdAnn _ inner) = prettyCmd inner+prettyCmd cmd = nest 2 $+  case cmd of+    CmdArrApp lhs HsFirstOrderApp rhs ->+      prettyExpr lhs <+> "-<" <+> prettyExpr rhs+    CmdArrApp lhs HsHigherOrderApp rhs ->+      prettyExpr lhs <+> "-<<" <+> prettyExpr rhs+    CmdInfix l op r ->+      prettyCmd l <> hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r+    CmdDo stmts ->+      "do" <> prettyDoLayout prettyCmdStmt stmts+    CmdIf cond yes no ->+      "if" <+> prettyExpr cond <+> "then" <+> prettyCmd yes <+> "else" <+> prettyCmd no+    CmdCase scrut alts ->+      "case" <+> prettyExpr scrut <+> "of" <> prettyCaseLayout (map prettyCmdCaseAlt alts)+    CmdLet decls body ->+      case decls of+        [] -> prettyLetDecls decls <+> "in" <+> prettyCmd body+        _ -> align (prettyLetDecls decls <> hardline <> "in" <+> prettyCmd body)+    CmdLam pats body ->+      "\\" <+> hsep (map prettyPattern pats) <+> "->" <+> prettyCmd body+    CmdApp c e ->+      prettyCmd c <+> prettyExpr e+    CmdPar c ->+      parens (prettyCmd c)++prettyCmdStmt :: DoStmt Cmd -> Doc ann+prettyCmdStmt stmt =+  case stmt of+    DoAnn _ inner -> prettyCmdStmt inner+    DoBind pat cmd' -> prettyPattern pat <+> "<-" <+> prettyCmd cmd'+    DoLetDecls decls -> prettyLetDecls decls+    DoExpr cmd'@CmdLet {} -> parens (prettyCmd cmd')+    DoExpr cmd' -> prettyCmdAtStatementStart cmd'+    DoRecStmt stmts -> "rec" <> nest 2 (prettyDoLayout prettyCmdStmt stmts)++prettyCmdAtStatementStart :: Cmd -> Doc ann+prettyCmdAtStatementStart cmd = nest 2 $+  case cmd of+    CmdAnn _ inner -> prettyCmdAtStatementStart inner+    CmdArrApp lhs HsFirstOrderApp rhs ->+      prettyExprAtStatementStart lhs <+> "-<" <+> prettyExpr rhs+    CmdArrApp lhs HsHigherOrderApp rhs ->+      prettyExprAtStatementStart lhs <+> "-<<" <+> prettyExpr rhs+    CmdInfix l op r ->+      prettyCmdAtStatementStart l <> hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r+    CmdApp c e ->+      prettyCmdAtStatementStart c <+> prettyExpr e+    _ -> prettyCmd cmd++prettyCmdCaseAlt :: CaseAlt Cmd -> Doc ann+prettyCmdCaseAlt = prettyCaseAltWith prettyCmd++prettyCompStmt :: CompStmt -> Doc ann+prettyCompStmt stmt =+  case stmt of+    CompAnn _ inner -> prettyCompStmt inner+    CompGen pat expr -> prettyPattern pat <+> "<-" <+> prettyExpr expr+    CompGuard expr -> prettyExpr expr+    CompLetDecls decls -> prettyLetDecls decls+    CompThen f -> "then" <+> prettyExpr f+    CompThenBy f e -> "then" <+> prettyExpr f <+> "by" <+> prettyExpr e+    CompGroupUsing f -> "then" <+> "group" <+> "using" <+> prettyExpr f+    CompGroupByUsing e f -> "then" <+> "group" <+> "by" <+> prettyExpr e <+> "using" <+> prettyExpr f++prettyGuardedRhssBlock :: [GuardedRhs Expr] -> Maybe [Decl] -> Doc ann+prettyGuardedRhssBlock guards whereDecls =+  vsep (map prettyGuardedRhsBlock guards)+    <> case whereDecls of+      Nothing -> mempty+      Just _ -> hardline <> prettyWhereClauseBare whereDecls++prettyGuardedRhsBlock :: GuardedRhs Expr -> Doc ann+prettyGuardedRhsBlock grhs =+  let guards = guardedRhsGuards grhs+      body = guardedRhsBody grhs+   in "|"+        <+> nest+          2+          ( prettyGuardQualifiersLayout guards+              <> hardline+              <> "="+              <+> nest 2 (prettyExpr body)+          )++prettyArithSeq :: ArithSeq -> Doc ann+prettyArithSeq seqInfo =+  case seqInfo of+    ArithSeqAnn _ inner -> prettyArithSeq inner+    ArithSeqFrom fromExpr -> brackets (prettyExpr fromExpr <> " ..")+    ArithSeqFromThen fromExpr thenExpr -> brackets (prettyExpr fromExpr <> ", " <> prettyExpr thenExpr <> " ..")+    ArithSeqFromTo fromExpr toExpr -> brackets (prettyExpr fromExpr <> " .. " <> prettyExpr toExpr)+    ArithSeqFromThenTo fromExpr thenExpr toExpr ->+      brackets (prettyExpr fromExpr <> ", " <> prettyExpr thenExpr <> " .. " <> prettyExpr toExpr)++quoted :: Text -> Doc ann+quoted txt = pretty (show (T.unpack txt))++prettyQuasiQuote :: Text -> Text -> Doc ann+prettyQuasiQuote quoter body = "[" <> pretty quoter <> "|" <> prettyRawText body <> "|]"++-- ---------------------------------------------------------------------------+-- TypeFamilies pretty-printing helpers++prettyTypeFamilyDecl :: TypeFamilyDecl -> Doc ann+prettyTypeFamilyDecl tf =+  hsep $+    ["type"]+      <> familyKeywordPart (typeFamilyDeclExplicitFamilyKeyword tf)+      <> prettyTypeFamilyHead (typeFamilyDeclHeadForm tf) (typeFamilyDeclHead tf) (typeFamilyDeclParams tf)+      <> resultSigPart (typeFamilyDeclResultSig tf)+      <> eqsPart (typeFamilyDeclEquations tf)+  where+    familyKeywordPart True = ["family"]+    familyKeywordPart False = []+    resultSigPart Nothing = []+    resultSigPart (Just (TypeFamilyKindSig k)) = ["::", prettyType k]+    resultSigPart (Just (TypeFamilyTyVarSig result)) = ["=", prettyTyVarBinder result]+    resultSigPart (Just (TypeFamilyInjectiveSig result injectivity)) =+      ["=", prettyTyVarBinder result, "|", prettyTypeFamilyInjectivity injectivity]+    eqsPart Nothing = []+    eqsPart (Just []) = ["where", spacedBraces mempty]+    eqsPart (Just eqs) = ["where" <> hardline <> indent 2 (vsep (map prettyTypeFamilyEq eqs))]++prettyTypeFamilyEq :: TypeFamilyEq -> Doc ann+prettyTypeFamilyEq eq =+  hsep $+    forallPart (typeFamilyEqForall eq)+      <> prettyTypeFamilyLhs (typeFamilyEqHeadForm eq) (typeFamilyEqLhs eq)+      <> ["=", prettyType (typeFamilyEqRhs eq)]+  where+    forallPart [] = []+    forallPart binders = ["forall", hsep (map prettyTyVarBinder binders) <> "."]++prettyDataFamilyDecl :: DataFamilyDecl -> Doc ann+prettyDataFamilyDecl df =+  hsep $+    ["data", "family"]+      <> prettyNamedBinderHead (dataFamilyDeclHead df)+      <> kindPart (dataFamilyDeclKind df)+  where+    kindPart Nothing = []+    kindPart (Just k) = ["::", prettyType k]++prettyTopTypeFamilyInst :: TypeFamilyInst -> Doc ann+prettyTopTypeFamilyInst tfi =+  hsep $+    ["type", "instance"]+      <> forallPart (typeFamilyInstForall tfi)+      <> prettyTypeFamilyLhs (typeFamilyInstHeadForm tfi) (typeFamilyInstLhs tfi)+      <> ["=", prettyType (typeFamilyInstRhs tfi)]+  where+    forallPart [] = []+    forallPart binders = ["forall", hsep (map prettyTyVarBinder binders) <> "."]++prettyTopDataFamilyInst :: DataFamilyInst -> Doc ann+prettyTopDataFamilyInst dfi =+  case dataFamilyInstConstructors dfi of+    ctors+      | any isGadtCon ctors ->+          headDoc <+> prettyGadtConBlock ctors (dataFamilyInstDeriving dfi)+    _ ->+      hsep $+        headParts+          <> ctorPart (dataFamilyInstConstructors dfi)+          <> derivingParts (dataFamilyInstDeriving dfi)+  where+    keyword = if dataFamilyInstIsNewtype dfi then "newtype" else "data"+    headParts =+      [keyword, "instance"]+        <> forallPart (dataFamilyInstForall dfi)+        <> [prettyType (dataFamilyInstHead dfi)]+        <> kindPart (dataFamilyInstKind dfi)+    headDoc = hsep headParts+    forallPart [] = []+    forallPart binders = ["forall", hsep (map prettyTyVarBinder binders) <> "."]+    kindPart Nothing = []+    kindPart (Just k) = ["::", prettyType k]+    ctorPart [] = []+    ctorPart ctors@(c : _)+      | dataFamilyInstIsNewtype dfi = ["=", prettyDataCon c]+      | otherwise = ["=", hsep (punctuate " |" (map prettyDataCon ctors))]++prettyAssocTypeFamilyDecl :: TypeFamilyDecl -> Doc ann+prettyAssocTypeFamilyDecl tf =+  hsep $+    ["type"]+      <> familyKeywordPart (typeFamilyDeclExplicitFamilyKeyword tf)+      <> prettyTypeFamilyHead (typeFamilyDeclHeadForm tf) (typeFamilyDeclHead tf) (typeFamilyDeclParams tf)+      <> resultSigPart (typeFamilyDeclResultSig tf)+  where+    familyKeywordPart True = ["family"]+    familyKeywordPart False = []+    resultSigPart Nothing = []+    resultSigPart (Just (TypeFamilyKindSig k)) = ["::", prettyType k]+    resultSigPart (Just (TypeFamilyTyVarSig result)) = ["=", prettyTyVarBinder result]+    resultSigPart (Just (TypeFamilyInjectiveSig result injectivity)) =+      ["=", prettyTyVarBinder result, "|", prettyTypeFamilyInjectivity injectivity]++prettyTypeFamilyHead :: TypeHeadForm -> Type -> [TyVarBinder] -> [Doc ann]+prettyTypeFamilyHead headForm headType params =+  case headForm of+    TypeHeadPrefix -> [prettyType headType] <> map prettyTyVarBinder params+    TypeHeadInfix ->+      case (params, typeFamilyInfixAppView headType) of+        ([lhs, rhs], Just (op, promoted, _, _)) ->+          [ prettyTyVarBinder lhs,+            (if promoted == Promoted then "'" else mempty) <> prettyNameInfixOp op,+            prettyTyVarBinder rhs+          ]+        _ -> [prettyTypeFamilyInfix headType]++prettyTypeFamilyLhs :: TypeHeadForm -> Type -> [Doc ann]+prettyTypeFamilyLhs headForm lhs =+  case headForm of+    TypeHeadPrefix -> [prettyType lhs]+    TypeHeadInfix -> [prettyTypeFamilyInfix lhs]++prettyAssocDataFamilyDecl :: DataFamilyDecl -> Doc ann+prettyAssocDataFamilyDecl df =+  hsep $+    ["data"]+      <> prettyNamedBinderHead (dataFamilyDeclHead df)+      <> kindPart (dataFamilyDeclKind df)+  where+    kindPart Nothing = []+    kindPart (Just k) = ["::", prettyType k]++prettyDefaultTypeInst :: TypeFamilyInst -> Doc ann+prettyDefaultTypeInst tfi =+  hsep $+    ["type", "instance"]+      <> forallPart (typeFamilyInstForall tfi)+      <> prettyTypeFamilyLhs (typeFamilyInstHeadForm tfi) (typeFamilyInstLhs tfi)+      <> ["=", prettyType (typeFamilyInstRhs tfi)]+  where+    forallPart [] = []+    forallPart binders = ["forall", hsep (map prettyTyVarBinder binders) <> "."]++prettyInstTypeFamilyInst :: TypeFamilyInst -> Doc ann+prettyInstTypeFamilyInst tfi =+  hsep $+    ["type"]+      <> forallPart (typeFamilyInstForall tfi)+      <> prettyTypeFamilyLhs (typeFamilyInstHeadForm tfi) (typeFamilyInstLhs tfi)+      <> ["=", prettyType (typeFamilyInstRhs tfi)]+  where+    forallPart [] = []+    forallPart binders = ["forall", hsep (map prettyTyVarBinder binders) <> "."]++prettyNamedBinderHead :: BinderHead UnqualifiedName -> [Doc ann]+prettyNamedBinderHead head' =+  case head' of+    PrefixBinderHead name params ->+      [prettyConstructorUName name] <> map prettyTyVarBinder params+    InfixBinderHead lhs name rhs tailPrms ->+      let infixHead = prettyTyVarBinder lhs <+> prettyTypeHeadInfixName name <+> prettyTyVarBinder rhs+       in case tailPrms of+            [] -> [infixHead]+            _ -> parens infixHead : map prettyTyVarBinder tailPrms++prettyTypeHeadInfixName :: UnqualifiedName -> Doc ann+prettyTypeHeadInfixName = prettyInfixOp++prettyTypeFamilyInfix :: Type -> Doc ann+prettyTypeFamilyInfix ty =+  case peelTypeAnn ty of+    TParen inner -> parens (prettyType inner)+    peeled ->+      case typeFamilyInfixAppView peeled of+        Just (op, promoted, lhs, rhs) ->+          prettyType lhs+            <+> (if promoted == Promoted then "'" else mempty)+            <> prettyNameInfixOp op+            <+> prettyType rhs+        _ -> prettyType ty++prettyInstDataFamilyInst :: DataFamilyInst -> Doc ann+prettyInstDataFamilyInst dfi =+  case dataFamilyInstConstructors dfi of+    ctors+      | any isGadtCon ctors ->+          headDoc <+> prettyGadtConBlock ctors (dataFamilyInstDeriving dfi)+    _ ->+      hsep $+        headParts+          <> ctorPart (dataFamilyInstConstructors dfi)+          <> derivingParts (dataFamilyInstDeriving dfi)+  where+    keyword = if dataFamilyInstIsNewtype dfi then "newtype" else "data"+    headParts =+      [keyword, prettyType (dataFamilyInstHead dfi)]+        <> kindPart (dataFamilyInstKind dfi)+    headDoc = hsep headParts+    kindPart Nothing = []+    kindPart (Just k) = ["::", prettyType k]+    ctorPart [] = []+    ctorPart ctors@(c : _)+      | dataFamilyInstIsNewtype dfi = ["=", prettyDataCon c]+      | otherwise = ["=", hsep (punctuate " |" (map prettyDataCon ctors))]
+ src/Aihc/Parser/Shorthand.hs view
@@ -0,0 +1,1247 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+--+-- Module      : Aihc.Parser.Shorthand+-- Description : Compact pretty-printing for debugging/inspection+--+-- This module provides a compact, human-readable representation of parsed+-- AST structures via the 'Shorthand' typeclass. Key features:+--+-- * Source spans are omitted to reduce noise+-- * Empty fields (Nothing, [], False, etc.) and field labels are omitted+-- * Remaining constructor/value tokens are a subsequence of the derived 'Show' output+-- * Output is on a single line by default+-- * Uses the prettyprinter library for consistent formatting+--+-- Example:+--+-- >>> shorthand $ snd $ parseModule defaultConfig "module Demo where x = 1"+-- Module {ModuleHead {"Demo"}, [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]}+module Aihc.Parser.Shorthand+  ( Shorthand (..),+  )+where++import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..))+import Aihc.Parser.Syntax+import Aihc.Parser.Types (ParseResult (..))+import Data.Text (Text)+import Prettyprinter+  ( Doc,+    Pretty (..),+    braces,+    brackets,+    comma,+    hsep,+    parens,+    punctuate,+    (<+>),+  )++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Aihc.Parser++-- | Typeclass for compact, human-readable AST representations.+--+-- The 'shorthand' method produces a 'Doc' that can be rendered to text+-- or shown as a string. This is useful for debugging and golden tests.+--+-- Use 'show' on the result of 'shorthand' to get a 'String':+--+-- @+-- show (shorthand expr) :: String+-- @+class Shorthand a where+  shorthand :: a -> Doc ()++-- ParseResult++instance (Shorthand a) => Shorthand (ParseResult a) where+  shorthand (ParseOk a) = "ParseOk" <+> parens (shorthand a)+  shorthand (ParseErr _) = "ParseErr"++-- Module++instance Shorthand Module where+  shorthand modu =+    "Module" <+> braces (hsep (punctuate comma fields))+    where+      fields =+        optionalField docModuleHead (moduleHead modu)+          <> listField docExtensionSetting (moduleLanguagePragmas modu)+          <> listField docImportDecl (moduleImports modu)+          <> listField docDecl (moduleDecls modu)++instance Shorthand Decl where+  shorthand = docDecl++instance Shorthand Expr where+  shorthand = docExpr++instance Shorthand Pattern where+  shorthand = docPattern++instance Shorthand Type where+  shorthand = docType++instance Shorthand LexToken where+  shorthand = docToken++instance Shorthand LexTokenKind where+  shorthand = docTokenKind++docModuleHead :: ModuleHead -> Doc ann+docModuleHead head' =+  "ModuleHead" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      [docText (moduleHeadName head')]+        <> optionalField docPragma (moduleHeadWarningPragma head')+        <> optionalField (brackets . hsep . punctuate comma . map docExportSpec) (moduleHeadExports head')++docExtensionSetting :: ExtensionSetting -> Doc ann+docExtensionSetting setting =+  case setting of+    EnableExtension ext -> pretty (extensionName ext)+    DisableExtension ext -> "DisableExtension" <+> pretty (extensionName ext)++docExportSpec :: ExportSpec -> Doc ann+docExportSpec spec =+  case spec of+    ExportAnn _ sub -> docExportSpec sub+    ExportModule mWarning name ->+      "ExportModule" <> braces (hsep (punctuate comma (optionalField docPragma mWarning <> [docText name])))+    ExportVar mWarning mNamespace name ->+      "ExportVar" <> braces (hsep (punctuate comma (optionalField docPragma mWarning <> optionalField docIENamespace mNamespace <> [docName name])))+    ExportAbs mWarning mNamespace name ->+      "ExportAbs" <> braces (hsep (punctuate comma (optionalField docPragma mWarning <> optionalField docIENamespace mNamespace <> [docName name])))+    ExportAll mWarning mNamespace name ->+      "ExportAll" <> braces (hsep (punctuate comma (optionalField docPragma mWarning <> optionalField docIENamespace mNamespace <> [docName name])))+    ExportWith mWarning mNamespace name members ->+      "ExportWith" <> braces (hsep (punctuate comma fields))+      where+        fields =+          optionalField docPragma mWarning+            <> optionalField docIENamespace mNamespace+            <> [docName name, brackets (hsep (punctuate comma (map docExportMember members)))]+    ExportWithAll mWarning mNamespace name wildcardIndex members ->+      "ExportWithAll" <> braces (hsep (punctuate comma fields))+      where+        fields =+          optionalField docPragma mWarning+            <> optionalField docIENamespace mNamespace+            <> [docName name, pretty wildcardIndex, brackets (hsep (punctuate comma (map docExportMember members)))]++docImportDecl :: ImportDecl -> Doc ann+docImportDecl decl =+  "ImportDecl" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      [docText (importDeclModule decl)]+        <> optionalField docPragma (importDeclSourcePragma decl)+        <> boolField (importDeclSafe decl)+        <> boolField (importDeclQualified decl)+        <> boolField (importDeclQualifiedPost decl)+        <> optionalField docImportLevel (importDeclLevel decl)+        <> optionalField docText (importDeclPackage decl)+        <> optionalField docText (importDeclAs decl)+        <> optionalField docImportSpec (importDeclSpec decl)++docImportLevel :: ImportLevel -> Doc ann+docImportLevel level =+  case level of+    ImportLevelQuote -> "ImportLevelQuote"+    ImportLevelSplice -> "ImportLevelSplice"++docImportSpec :: ImportSpec -> Doc ann+docImportSpec spec =+  "ImportSpec" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      boolField (importSpecHiding spec)+        <> [brackets (hsep (punctuate comma (map docImportItem (importSpecItems spec))))]++docImportItem :: ImportItem -> Doc ann+docImportItem item =+  case item of+    ImportAnn _ sub -> docImportItem sub+    ImportItemVar mNamespace name ->+      "ImportItemVar" <> braces (hsep (punctuate comma (optionalField docIENamespace mNamespace <> [docUnqualifiedName name])))+    ImportItemAbs mNamespace name ->+      "ImportItemAbs" <> braces (hsep (punctuate comma (optionalField docIENamespace mNamespace <> [docUnqualifiedName name])))+    ImportItemAll mNamespace name ->+      "ImportItemAll" <> braces (hsep (punctuate comma (optionalField docIENamespace mNamespace <> [docUnqualifiedName name])))+    ImportItemWith mNamespace name members ->+      "ImportItemWith" <> braces (hsep (punctuate comma fields))+      where+        fields =+          optionalField docIENamespace mNamespace+            <> [docUnqualifiedName name, brackets (hsep (punctuate comma (map docExportMember members)))]+    ImportItemAllWith mNamespace name wildcardIndex members ->+      "ImportItemAllWith" <> braces (hsep (punctuate comma fields))+      where+        fields =+          optionalField docIENamespace mNamespace+            <> [docUnqualifiedName name, pretty wildcardIndex, brackets (hsep (punctuate comma (map docExportMember members)))]++docIENamespace :: IEEntityNamespace -> Doc ann+docIENamespace namespace =+  case namespace of+    IEEntityNamespaceType -> "IEEntityNamespaceType"+    IEEntityNamespacePattern -> "IEEntityNamespacePattern"+    IEEntityNamespaceData -> "IEEntityNamespaceData"++docIEBundledNamespace :: IEBundledNamespace -> Doc ann+docIEBundledNamespace namespace =+  case namespace of+    IEBundledNamespaceType -> "IEBundledNamespaceType"+    IEBundledNamespaceData -> "IEBundledNamespaceData"++docExportMember :: IEBundledMember -> Doc ann+docExportMember (IEBundledMember mNamespace name) =+  "IEBundledMember" <> braces (hsep (punctuate comma (optionalField docIEBundledNamespace mNamespace <> [docName name])))++-- Declarations++docDecl :: Decl -> Doc ann+docDecl decl =+  case decl of+    DeclAnn _ sub -> docDecl sub+    DeclValue vdecl -> "DeclValue" <+> parens (docValueDecl vdecl)+    DeclTypeSig names ty -> "DeclTypeSig" <+> brackets (hsep (punctuate comma (map docUnqualifiedNameText names))) <+> parens (docType ty)+    DeclPatSyn ps -> "DeclPatSyn" <+> parens (docPatSynDecl ps)+    DeclPatSynSig names ty -> "DeclPatSynSig" <+> brackets (hsep (punctuate comma (map docUnqualifiedName names))) <+> parens (docType ty)+    DeclStandaloneKindSig name kind -> "DeclStandaloneKindSig" <+> parens (docUnqualifiedName name) <+> parens (docType kind)+    DeclFixity assoc mNamespace mPrec ops -> "DeclFixity" <+> docFixityAssoc assoc <+> maybe "Nothing" docIENamespace mNamespace <+> maybe "Nothing" pretty mPrec <+> brackets (hsep (punctuate comma (map docUnqualifiedName ops)))+    DeclRoleAnnotation ann -> "DeclRoleAnnotation" <+> parens (docRoleAnnotation ann)+    DeclTypeSyn syn -> "DeclTypeSyn" <+> parens (docTypeSynDecl syn)+    DeclData dd -> "DeclData" <+> parens (docDataDecl dd)+    DeclTypeData dd -> "DeclTypeData" <+> parens (docDataDecl dd)+    DeclNewtype nd -> "DeclNewtype" <+> parens (docNewtypeDecl nd)+    DeclClass cd -> "DeclClass" <+> parens (docClassDecl cd)+    DeclInstance inst -> "DeclInstance" <+> parens (docInstanceDecl inst)+    DeclStandaloneDeriving sd -> "DeclStandaloneDeriving" <+> parens (docStandaloneDerivingDecl sd)+    DeclDefault tys -> "DeclDefault" <+> brackets (hsep (punctuate comma (map docType tys)))+    DeclForeign fd -> "DeclForeign" <+> parens (docForeignDecl fd)+    DeclSplice body -> "DeclSplice" <+> parens (docExpr body)+    DeclTypeFamilyDecl tf -> "DeclTypeFamilyDecl" <+> parens (docTypeFamilyDecl tf)+    DeclDataFamilyDecl df -> "DeclDataFamilyDecl" <+> parens (docDataFamilyDecl df)+    DeclTypeFamilyInst tfi -> "DeclTypeFamilyInst" <+> parens (docTypeFamilyInst tfi)+    DeclDataFamilyInst dfi -> "DeclDataFamilyInst" <+> parens (docDataFamilyInst dfi)+    DeclPragma pragma -> "DeclPragma" <+> docPragma pragma++docValueDecl :: ValueDecl -> Doc ann+docValueDecl vdecl =+  case vdecl of+    FunctionBind name matches -> "FunctionBind" <+> docUnqualifiedNameText name <+> brackets (hsep (punctuate comma (map docMatch matches)))+    PatternBind multTag pat rhs -> "PatternBind" <+> hsep (docPatternBindFields multTag pat rhs)++docPatternBindFields :: MultiplicityTag -> Pattern -> Rhs Expr -> [Doc ann]+docPatternBindFields multTag pat rhs =+  multiplicityFields <> [parens (docPattern pat), parens (docRhs rhs)]+  where+    multiplicityFields =+      case multTag of+        NoMultiplicityTag -> []+        _ -> [docMultiplicityTag multTag]++docMultiplicityTag :: MultiplicityTag -> Doc ann+docMultiplicityTag NoMultiplicityTag = "NoMultiplicityTag"+docMultiplicityTag LinearMultiplicityTag = "LinearMultiplicityTag"+docMultiplicityTag (ExplicitMultiplicityTag ty) = "ExplicitMultiplicityTag" <+> parens (docType ty)++docArrowKind :: ArrowKind -> Doc ann+docArrowKind ArrowUnrestricted = "ArrowUnrestricted"+docArrowKind ArrowLinear = "ArrowLinear"+docArrowKind (ArrowExplicit ty) = "ArrowExplicit" <+> parens (docType ty)++docPatSynDecl :: PatSynDecl -> Doc ann+docPatSynDecl ps =+  "PatSynDecl" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      [docUnqualifiedName (patSynDeclName ps)]+        <> [docPatSynArgs (patSynDeclArgs ps)]+        <> [docPattern (patSynDeclPat ps)]+        <> [docPatSynDir (patSynDeclDir ps)]++docPatSynDir :: PatSynDir -> Doc ann+docPatSynDir dir =+  case dir of+    PatSynUnidirectional -> "PatSynUnidirectional"+    PatSynBidirectional -> "PatSynBidirectional"+    PatSynExplicitBidirectional matches ->+      "PatSynExplicitBidirectional" <+> brackets (hsep (punctuate comma (map docMatch matches)))++docPatSynArgs :: PatSynArgs -> Doc ann+docPatSynArgs args =+  case args of+    PatSynPrefixArgs vars -> "PatSynPrefixArgs" <+> docTextList vars+    PatSynInfixArgs lhs rhs -> "PatSynInfixArgs" <+> docText lhs <+> docText rhs+    PatSynRecordArgs fields' -> "PatSynRecordArgs" <+> docTextList fields'++docMatch :: Match -> Doc ann+docMatch m =+  "Match" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      [ docMatchHeadForm (matchHeadForm m)+      ]+        <> listField docPattern (matchPats m)+        <> [docRhs (matchRhs m)]++docMatchHeadForm :: MatchHeadForm -> Doc ann+docMatchHeadForm headForm =+  case headForm of+    MatchHeadPrefix -> "MatchHeadPrefix"+    MatchHeadInfix -> "MatchHeadInfix"++docRhsWith :: (body -> Doc ann) -> Rhs body -> Doc ann+docRhsWith docBody rhs =+  case rhs of+    UnguardedRhs _ body Nothing -> docBody body+    UnguardedRhs _ body (Just decls) -> docBody body <+> "Just" <+> brackets (hsep (punctuate comma (map docDecl decls)))+    GuardedRhss _ grhss Nothing -> "GuardedRhss" <+> brackets (hsep (punctuate comma (map (docGuardedRhsWith docBody) grhss)))+    GuardedRhss _ grhss (Just decls) -> "GuardedRhss" <+> brackets (hsep (punctuate comma (map (docGuardedRhsWith docBody) grhss))) <+> "Just" <+> brackets (hsep (punctuate comma (map docDecl decls)))++docRhs :: Rhs Expr -> Doc ann+docRhs = docRhsWith docExpr++docGuardedRhsWith :: (body -> Doc ann) -> GuardedRhs body -> Doc ann+docGuardedRhsWith docBody grhs =+  "GuardedRhs" <+> braces (hsep (punctuate comma [brackets (hsep (punctuate comma (map docGuardQualifier (guardedRhsGuards grhs)))), docBody (guardedRhsBody grhs)]))++docGuardedRhs :: GuardedRhs Expr -> Doc ann+docGuardedRhs = docGuardedRhsWith docExpr++docGuardQualifier :: GuardQualifier -> Doc ann+docGuardQualifier gq =+  case gq of+    GuardAnn _ inner -> docGuardQualifier inner+    GuardExpr expr -> "GuardExpr" <+> parens (docExpr expr)+    GuardPat pat expr -> "GuardPat" <+> parens (docPattern pat) <+> parens (docExpr expr)+    GuardLet decls -> "GuardLet" <+> brackets (hsep (punctuate comma (map docDecl decls)))++docTypeSynDecl :: TypeSynDecl -> Doc ann+docTypeSynDecl syn =+  "TypeSynDecl" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      [docBinderHeadValue (typeSynHead syn)]+        <> [docType (typeSynBody syn)]++docRoleAnnotation :: RoleAnnotation -> Doc ann+docRoleAnnotation ann =+  "RoleAnnotation" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      [docUnqualifiedName (roleAnnotationName ann)]+        <> [brackets (hsep (punctuate comma (map docRole (roleAnnotationRoles ann))))]++docRole :: Role -> Doc ann+docRole role =+  case role of+    RoleNominal -> "RoleNominal"+    RoleRepresentational -> "RoleRepresentational"+    RolePhantom -> "RolePhantom"+    RoleInfer -> "RoleInfer"++docDataDecl :: DataDecl -> Doc ann+docDataDecl dd =+  "DataDecl" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      optionalField docPragma (dataDeclCTypePragma dd)+        <> take 1 binderFields+        <> listField docType (dataDeclContext dd)+        <> drop 1 binderFields+        <> optionalField docType (dataDeclKind dd)+        <> listField docDataConDecl (dataDeclConstructors dd)+        <> listField docDerivingClause (dataDeclDeriving dd)+    binderFields = docBinderHead (dataDeclHead dd)++docNewtypeDecl :: NewtypeDecl -> Doc ann+docNewtypeDecl nd =+  "NewtypeDecl" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      optionalField docPragma (newtypeDeclCTypePragma nd)+        <> take 1 binderFields+        <> listField docType (newtypeDeclContext nd)+        <> drop 1 binderFields+        <> optionalField docType (newtypeDeclKind nd)+        <> optionalField docDataConDecl (newtypeDeclConstructor nd)+        <> listField docDerivingClause (newtypeDeclDeriving nd)+    binderFields = docBinderHead (newtypeDeclHead nd)++docDataConDecl :: DataConDecl -> Doc ann+docDataConDecl dcd =+  case dcd of+    DataConAnn _ inner -> docDataConDecl inner+    PrefixCon forallVars constraints name fields' ->+      "PrefixCon" <+> braces (hsep (punctuate comma ([docUnqualifiedName name] <> listField docTyVarBinder forallVars <> listField docType constraints <> listField docBangType fields')))+    InfixCon forallVars constraints lhs op rhs ->+      "InfixCon" <+> braces (hsep (punctuate comma (listField docTyVarBinder forallVars <> listField docType constraints <> [docBangType lhs, docUnqualifiedName op, docBangType rhs])))+    RecordCon forallVars constraints name fields' ->+      "RecordCon" <+> hsep (docRecordConFields forallVars constraints name fields')+    GadtCon forallBinders constraints names body ->+      "GadtCon" <+> braces (hsep (punctuate comma (listField docForallTelescope forallBinders <> listField docType constraints <> listField docUnqualifiedName names <> [docGadtBody body])))+    TupleCon forallVars constraints flavor fields' ->+      "TupleCon" <+> braces (hsep (punctuate comma (listField docTyVarBinder forallVars <> listField docType constraints <> [pretty (show flavor)] <> listField docBangType fields')))+    UnboxedSumCon forallVars constraints pos arity field' ->+      "UnboxedSumCon" <+> braces (hsep (punctuate comma (listField docTyVarBinder forallVars <> listField docType constraints <> [pretty (show pos), pretty (show arity), docBangType field'])))+    ListCon forallVars constraints ->+      "ListCon" <+> braces (hsep (punctuate comma (listField docTyVarBinder forallVars <> listField docType constraints)))++-- | Document a GADT body+docGadtBody :: GadtBody -> Doc ann+docGadtBody body =+  case body of+    GadtPrefixBody args resultTy ->+      "GadtPrefixBody" <+> braces (hsep (punctuate comma (listField docGadtArg args <> [docType resultTy])))+    GadtRecordBody fields' resultTy ->+      "GadtRecordBody" <+> braces (hsep (punctuate comma (listField docFieldDecl fields' <> [docType resultTy])))++docGadtArg :: (BangType, ArrowKind) -> Doc ann+docGadtArg (bt, ArrowUnrestricted) = parens (docBangType bt)+docGadtArg (bt, ak) = parens (docBangType bt <+> "," <+> docArrowKind ak)++docBangType :: BangType -> Doc ann+docBangType bt =+  "BangType" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      listField docPragma (bangPragmas bt)+        <> boolField (bangStrict bt)+        <> boolField (bangLazy bt)+        <> [docType (bangType bt)]++docFieldDecl :: FieldDecl -> Doc ann+docFieldDecl fd =+  "FieldDecl" <+> brackets (hsep (punctuate comma (map docUnqualifiedNameText (fieldNames fd)))) <+> parens (docFieldDeclType (fieldType fd))++docFieldDeclType :: BangType -> Doc ann+docFieldDeclType bt+  | null (bangPragmas bt),+    not (bangStrict bt),+    not (bangLazy bt) =+      docType (bangType bt)+  | otherwise = docBangType bt++docRecordConFields :: [TyVarBinder] -> [Type] -> UnqualifiedName -> [FieldDecl] -> [Doc ann]+docRecordConFields forallVars constraints name fields' =+  docUnqualifiedNameText name+    : listField docTyVarBinder forallVars+      <> listField docType constraints+      <> [brackets (hsep (punctuate comma (map docFieldDecl fields')))]++docDerivingClause :: DerivingClause -> Doc ann+docDerivingClause dc =+  "DerivingClause" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      optionalField docDerivingStrategy (derivingStrategy dc)+        <> [docDerivingClasses (derivingClasses dc)]++docDerivingClasses :: Either Name [Type] -> Doc ann+docDerivingClasses classes =+  case classes of+    Left name -> docName name+    Right types -> brackets (hsep (punctuate comma (map docType types)))++docDerivingStrategy :: DerivingStrategy -> Doc ann+docDerivingStrategy ds =+  case ds of+    DerivingStock -> "DerivingStock"+    DerivingNewtype -> "DerivingNewtype"+    DerivingAnyclass -> "DerivingAnyclass"+    DerivingVia ty -> "DerivingVia" <+> docType ty++docClassDecl :: ClassDecl -> Doc ann+docClassDecl cd =+  "ClassDecl" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      optionalField (brackets . hsep . punctuate comma . map docType) (classDeclContext cd)+        <> binderFields+        <> listField docFunctionalDependency (classDeclFundeps cd)+        <> listField docClassDeclItem (classDeclItems cd)+    binderFields = docBinderHead (classDeclHead cd)++docFunctionalDependency :: FunctionalDependency -> Doc ann+docFunctionalDependency dep =+  "FunctionalDependency" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      listField docText (functionalDependencyDeterminers dep)+        <> listField docText (functionalDependencyDetermined dep)++docTypeFamilyInjectivity :: TypeFamilyInjectivity -> Doc ann+docTypeFamilyInjectivity injectivity =+  "TypeFamilyInjectivity" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      [ docText (typeFamilyInjectivityResult injectivity)+      ]+        <> listField docText (typeFamilyInjectivityDetermined injectivity)++docTypeFamilyResultSig :: TypeFamilyResultSig -> Doc ann+docTypeFamilyResultSig sig =+  case sig of+    TypeFamilyKindSig kind -> "TypeFamilyKindSig" <+> parens (docType kind)+    TypeFamilyTyVarSig result ->+      "TypeFamilyTyVarSig" <+> braces (hsep (punctuate comma [docTyVarBinder result]))+    TypeFamilyInjectiveSig result injectivity ->+      "TypeFamilyInjectiveSig" <+> braces (hsep (punctuate comma [docTyVarBinder result, docTypeFamilyInjectivity injectivity]))++docClassDeclItem :: ClassDeclItem -> Doc ann+docClassDeclItem item =+  case item of+    ClassItemAnn _ sub -> docClassDeclItem sub+    ClassItemTypeSig names ty -> "ClassItemTypeSig" <+> braces (hsep (punctuate comma [brackets (hsep (punctuate comma (map docUnqualifiedName names))), docType ty]))+    ClassItemDefaultSig name ty -> "ClassItemDefaultSig" <+> braces (hsep (punctuate comma [docUnqualifiedName name, docType ty]))+    ClassItemFixity assoc mNamespace mPrec ops -> "ClassItemFixity" <+> braces (hsep (punctuate comma ([docFixityAssoc assoc] <> optionalField docIENamespace mNamespace <> optionalField pretty mPrec <> [brackets (hsep (punctuate comma (map docUnqualifiedName ops)))])))+    ClassItemDefault vdecl -> "ClassItemDefault" <+> parens (docValueDecl vdecl)+    ClassItemTypeFamilyDecl tf -> "ClassItemTypeFamilyDecl" <+> parens (docTypeFamilyDecl tf)+    ClassItemDataFamilyDecl df -> "ClassItemDataFamilyDecl" <+> parens (docDataFamilyDecl df)+    ClassItemDefaultTypeInst tfi -> "ClassItemDefaultTypeInst" <+> parens (docTypeFamilyInst tfi)+    ClassItemPragma pragma -> "ClassItemPragma" <+> docPragma pragma++docInstanceDecl :: InstanceDecl -> Doc ann+docInstanceDecl inst =+  "InstanceDecl" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      listField docPragma (instanceDeclPragmas inst)+        <> optionalField docPragma (instanceDeclWarning inst)+        <> listField docTyVarBinder (instanceDeclForall inst)+        <> listField docType (instanceDeclContext inst)+        <> [docType (instanceDeclHead inst)]+        <> listField docInstanceDeclItem (instanceDeclItems inst)++docInstanceDeclItem :: InstanceDeclItem -> Doc ann+docInstanceDeclItem item =+  case item of+    InstanceItemAnn _ inner -> docInstanceDeclItem inner+    InstanceItemBind vdecl -> "InstanceItemBind" <+> parens (docValueDecl vdecl)+    InstanceItemTypeSig names ty -> "InstanceItemTypeSig" <+> braces (hsep (punctuate comma [brackets (hsep (punctuate comma (map docUnqualifiedName names))), docType ty]))+    InstanceItemFixity assoc mNamespace mPrec ops -> "InstanceItemFixity" <+> braces (hsep (punctuate comma ([docFixityAssoc assoc] <> optionalField docIENamespace mNamespace <> optionalField pretty mPrec <> [brackets (hsep (punctuate comma (map docUnqualifiedName ops)))])))+    InstanceItemTypeFamilyInst tfi -> "InstanceItemTypeFamilyInst" <+> parens (docTypeFamilyInst tfi)+    InstanceItemDataFamilyInst dfi -> "InstanceItemDataFamilyInst" <+> parens (docDataFamilyInst dfi)+    InstanceItemPragma pragma -> "InstanceItemPragma" <+> docPragma pragma++docStandaloneDerivingDecl :: StandaloneDerivingDecl -> Doc ann+docStandaloneDerivingDecl sd =+  "StandaloneDerivingDecl" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      optionalField docDerivingStrategy (standaloneDerivingStrategy sd)+        <> listField docPragma (standaloneDerivingPragmas sd)+        <> optionalField docPragma (standaloneDerivingWarning sd)+        <> listField docType (standaloneDerivingContext sd)+        <> [docType (standaloneDerivingHead sd)]++docInstanceOverlapPragma :: InstanceOverlapPragma -> Doc ann+docInstanceOverlapPragma pragma' =+  case pragma' of+    Overlapping -> "Overlapping"+    Overlappable -> "Overlappable"+    Overlaps -> "Overlaps"+    Incoherent -> "Incoherent"++docPragmaUnpackKind :: PragmaUnpackKind -> Doc ann+docPragmaUnpackKind kind =+  case kind of+    UnpackPragma -> "UnpackPragma"+    NoUnpackPragma -> "NoUnpackPragma"++docPragmaType :: PragmaType -> Doc ann+docPragmaType pt =+  case pt of+    PragmaLanguage settings -> "PragmaLanguage" <+> brackets (hsep (punctuate comma (map docExtensionSetting settings)))+    PragmaInstanceOverlap overlapPragma -> "PragmaInstanceOverlap" <+> docInstanceOverlapPragma overlapPragma+    PragmaWarning msg -> "PragmaWarning" <+> docText msg+    PragmaDeprecated msg -> "PragmaDeprecated" <+> docText msg+    PragmaInline kind body -> "PragmaInline" <+> docText kind <+> docText body+    PragmaUnpack unpackKind -> "PragmaUnpack" <+> docPragmaUnpackKind unpackKind+    PragmaSource sourceText _ -> "PragmaSource" <+> docText sourceText+    PragmaSCC label -> "PragmaSCC" <+> docText label+    PragmaUnknown text -> "PragmaUnknown" <+> docText text++docPragma :: Pragma -> Doc ann+docPragma pragma = docPragmaType (pragmaType pragma)++docForeignDecl :: ForeignDecl -> Doc ann+docForeignDecl fd =+  "ForeignDecl" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      [docForeignDirection (foreignDirection fd)]+        <> [docCallConv (foreignCallConv fd)]+        <> optionalField docForeignSafety (foreignSafety fd)+        <> [docForeignEntitySpec (foreignEntity fd)]+        <> [docUnqualifiedName (foreignName fd)]+        <> [docType (foreignType fd)]++docForeignDirection :: ForeignDirection -> Doc ann+docForeignDirection fd =+  case fd of+    ForeignImport -> "ForeignImport"+    ForeignExport -> "ForeignExport"++docCallConv :: CallConv -> Doc ann+docCallConv cc =+  case cc of+    CCall -> "CCall"+    StdCall -> "StdCall"+    CApi -> "CApi"+    CPrim -> "CPrim"+    JavaScript -> "JavaScript"++docForeignSafety :: ForeignSafety -> Doc ann+docForeignSafety fs =+  case fs of+    Safe -> "Safe"+    Unsafe -> "Unsafe"+    Interruptible -> "Interruptible"++docForeignEntitySpec :: ForeignEntitySpec -> Doc ann+docForeignEntitySpec spec =+  case spec of+    ForeignEntityDynamic -> "ForeignEntityDynamic"+    ForeignEntityWrapper -> "ForeignEntityWrapper"+    ForeignEntityStatic mName -> "ForeignEntityStatic" <> optionalField' docText mName+    ForeignEntityAddress mName -> "ForeignEntityAddress" <> optionalField' docText mName+    ForeignEntityNamed name -> "ForeignEntityNamed" <+> docText name+    ForeignEntityOmitted -> "ForeignEntityOmitted"++docFixityAssoc :: FixityAssoc -> Doc ann+docFixityAssoc fa =+  case fa of+    Infix -> "Infix"+    InfixL -> "InfixL"+    InfixR -> "InfixR"++-- Types++docType :: Type -> Doc ann+docType ty =+  case ty of+    TVar name -> "TVar" <+> docUnqualifiedNameText name+    TCon name promoted ->+      "TCon"+        <+> docName name+        <> (if promoted == Promoted then " Promoted" else "")+    TBuiltinCon con -> "TBuiltinCon" <+> pretty (show con)+    TImplicitParam name inner -> "TImplicitParam" <+> docText name <+> parens (docType inner)+    TTypeLit lit -> "TTypeLit" <+> docTypeLiteral lit+    TStar {} -> "TStar"+    TQuasiQuote quoter body -> "TQuasiQuote" <+> docText quoter <+> docText body+    TForall telescope inner ->+      case forallTelescopeVisibility telescope of+        ForallInvisible ->+          "TForall"+            <+> brackets (hsep (punctuate comma (map docTyVarBinder (forallTelescopeBinders telescope))))+            <+> parens (docType inner)+        ForallVisible -> "TForall" <+> parens (docForallTelescope telescope) <+> parens (docType inner)+    TApp f x -> "TApp" <+> parens (docType f) <+> parens (docType x)+    TTypeApp f x -> "TTypeApp" <+> parens (docType f) <+> parens (docType x)+    TInfix lhs op promoted rhs ->+      "TInfix"+        <+> parens (docType lhs)+        <+> docName op+        <> (if promoted == Promoted then " Promoted" else "")+        <+> parens (docType rhs)+    TFun arrowKind a b -> "TFun" <+> hsep (docFunctionTypeFields arrowKind a b)+    TTuple tupleFlavor promoted elems ->+      "TTuple" <+> hsep (docTypeTupleFields tupleFlavor promoted elems)+    TUnboxedSum elems ->+      "TUnboxedSum"+        <+> brackets (hsep (punctuate comma (map docType elems)))+    TList promoted elems ->+      "TList" <+> hsep (docTypeListFields promoted elems)+    TParen inner -> "TParen" <+> parens (docType inner)+    TKindSig ty' kind -> "TKindSig" <+> parens (docType ty') <+> parens (docType kind)+    TContext constraints inner -> "TContext" <+> brackets (hsep (punctuate comma (map docType constraints))) <+> parens (docType inner)+    TSplice body -> "TSplice" <+> parens (docExpr body)+    TWildcard -> "TWildcard"+    TAnn _ sub -> docType sub++docTypeLiteral :: TypeLiteral -> Doc ann+docTypeLiteral lit =+  case lit of+    TypeLitInteger n _ -> "TypeLitInteger" <+> pretty n+    TypeLitSymbol s _ -> "TypeLitSymbol" <+> docText s+    TypeLitChar c _ -> "TypeLitChar" <+> pretty (show c)++docFunctionTypeFields :: ArrowKind -> Type -> Type -> [Doc ann]+docFunctionTypeFields arrowKind a b =+  arrowFields <> [parens (docType a), parens (docType b)]+  where+    arrowFields =+      case arrowKind of+        ArrowUnrestricted -> []+        _ -> [docArrowKind arrowKind]++docTypeListFields :: TypePromotion -> [Type] -> [Doc ann]+docTypeListFields promoted elems =+  promotedFields <> [brackets (hsep (punctuate comma (map docType elems)))]+  where+    promotedFields =+      case promoted of+        Unpromoted -> []+        Promoted -> ["Promoted"]++docTypeTupleFields :: TupleFlavor -> TypePromotion -> [Type] -> [Doc ann]+docTypeTupleFields tupleFlavor promoted elems =+  flavorFields <> promotedFields <> [brackets (hsep (punctuate comma (map docType elems)))]+  where+    flavorFields =+      case tupleFlavor of+        Boxed -> []+        _ -> [pretty (show tupleFlavor)]++    promotedFields =+      case promoted of+        Unpromoted -> []+        Promoted -> ["Promoted"]++docTyVarBinder :: TyVarBinder -> Doc ann+docTyVarBinder tvb =+  "TyVarBinder" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      [docText (tyVarBinderName tvb)]+        <> optionalField (\kind -> "Just" <+> parens (docType kind)) (tyVarBinderKind tvb)+        <> optionalField docTyVarBSpecificity (specificityField tvb)+        <> optionalField docTyVarBVisibility (visibilityField tvb)++    specificityField binder =+      case tyVarBinderSpecificity binder of+        TyVarBSpecified -> Nothing+        specificity -> Just specificity++    visibilityField binder =+      case tyVarBinderVisibility binder of+        TyVarBVisible -> Nothing+        visibility -> Just visibility++docTyVarBSpecificity :: TyVarBSpecificity -> Doc ann+docTyVarBSpecificity specificity =+  case specificity of+    TyVarBInferred -> "TyVarBInferred"+    TyVarBSpecified -> "TyVarBSpecified"++docTyVarBVisibility :: TyVarBVisibility -> Doc ann+docTyVarBVisibility visibility =+  case visibility of+    TyVarBVisible -> "TyVarBVisible"+    TyVarBInvisible -> "TyVarBInvisible"++docForallVis :: ForallVis -> Doc ann+docForallVis visibility =+  case visibility of+    ForallInvisible -> "ForallInvisible"+    ForallVisible -> "ForallVisible"++docForallTelescope :: ForallTelescope -> Doc ann+docForallTelescope telescope =+  "ForallTelescope"+    <+> braces+      ( hsep+          ( punctuate+              comma+              ( [docForallVis (forallTelescopeVisibility telescope)]+                  <> listField docTyVarBinder (forallTelescopeBinders telescope)+              )+          )+      )++-- Patterns++docPattern :: Pattern -> Doc ann+docPattern pat =+  case pat of+    PAnn _ sub -> docPattern sub+    PVar name -> "PVar" <+> docUnqualifiedNameText name+    PTypeBinder binder -> "PTypeBinder" <+> parens (docTyVarBinder binder)+    PTypeSyntax form ty -> "PTypeSyntax" <+> docTypeSyntaxForm form <+> parens (docType ty)+    PWildcard -> "PWildcard"+    PLit lit -> "PLit" <+> parens (docLiteral lit)+    PQuasiQuote quoter body -> "PQuasiQuote" <+> docText quoter <+> docText body+    PTuple tupleFlavor elems ->+      "PTuple" <+> hsep (docPatternTupleFields tupleFlavor elems)+    PUnboxedSum altIdx arity inner ->+      "PUnboxedSum" <+> pretty altIdx <+> pretty arity <+> docPattern inner+    PList elems -> "PList" <+> brackets (hsep (punctuate comma (map docPattern elems)))+    PCon name typeArgs args ->+      case typeArgs of+        [] -> "PCon" <+> docName name <+> brackets (hsep (punctuate comma (map docPattern args)))+        _ ->+          "PCon"+            <+> docName name+            <+> braces+              ( hsep+                  ( punctuate+                      comma+                      ( listField docType typeArgs+                          <> listField docPattern args+                      )+                  )+              )+    PInfix lhs op rhs -> "PInfix" <+> parens (docPattern lhs) <+> docName op <+> parens (docPattern rhs)+    PView expr inner -> "PView" <+> parens (docExpr expr) <+> parens (docPattern inner)+    PAs name inner -> "PAs" <+> docUnqualifiedName name <+> parens (docPattern inner)+    PStrict inner -> "PStrict" <+> parens (docPattern inner)+    PIrrefutable inner -> "PIrrefutable" <+> parens (docPattern inner)+    PNegLit lit -> "PNegLit" <+> parens (docLiteral lit)+    PParen inner -> "PParen" <+> parens (docPattern inner)+    PRecord name fields' hasWildcard -> "PRecord" <+> docName name <+> braces (hsep (punctuate comma ([docPatternRecordField recordField | recordField <- fields'] ++ [".." | hasWildcard])))+    PTypeSig inner ty -> "PTypeSig" <+> parens (docPattern inner) <+> parens (docType ty)+    PSplice body -> "PSplice" <+> parens (docExpr body)++docPatternTupleFields :: TupleFlavor -> [Pattern] -> [Doc ann]+docPatternTupleFields tupleFlavor elems =+  flavorFields <> [brackets (hsep (punctuate comma (map docPattern elems)))]+  where+    flavorFields =+      case tupleFlavor of+        Boxed -> []+        _ -> [pretty (show tupleFlavor)]++docLiteral :: Literal -> Doc ann+docLiteral lit =+  case peelLiteralAnn lit of+    LitInt n nt _ -> "LitInt" <+> pretty n <+> docNumericType nt+    LitFloat n ft _ -> "LitFloat" <+> pretty (show n) <+> docFloatType ft+    LitChar c _ -> "LitChar" <+> pretty (show c)+    LitCharHash c repr -> "LitCharHash" <+> pretty (show c) <+> docText repr+    LitString s _ -> "LitString" <+> docText s+    LitStringHash s repr -> "LitStringHash" <+> docText s <+> docText repr+    LitAnn {} -> error "unreachable"++-- Expressions++docExpr :: Expr -> Doc ann+docExpr expr =+  case expr of+    EVar name -> "EVar" <+> docName name+    ETypeSyntax form ty -> "ETypeSyntax" <+> docTypeSyntaxForm form <+> parens (docType ty)+    EInt n nt _ -> "EInt" <+> pretty n <+> docNumericType nt+    EFloat n ft _ -> "EFloat" <+> pretty (show n) <+> docFloatType ft+    EChar c _ -> "EChar" <+> pretty (show c)+    ECharHash c repr -> "ECharHash" <+> pretty (show c) <+> docText repr+    EString s _ -> "EString" <+> docText s+    EStringHash s repr -> "EStringHash" <+> docText s <+> docText repr+    EOverloadedLabel label raw -> "EOverloadedLabel" <+> docText label <+> docText raw+    EQuasiQuote quoter body -> "EQuasiQuote" <+> docText quoter <+> docText body+    ETHExpQuote body -> "ETHExpQuote" <+> parens (docExpr body)+    ETHTypedQuote body -> "ETHTypedQuote" <+> parens (docExpr body)+    ETHDeclQuote decls -> "ETHDeclQuote" <+> brackets (hsep (punctuate comma (map docDecl decls)))+    ETHTypeQuote ty -> "ETHTypeQuote" <+> parens (docType ty)+    ETHPatQuote pat -> "ETHPatQuote" <+> parens (docPattern pat)+    ETHNameQuote body -> "ETHNameQuote" <+> parens (docExpr body)+    ETHTypeNameQuote ty -> "ETHTypeNameQuote" <+> parens (docType ty)+    ETHSplice body -> "ETHSplice" <+> parens (docExpr body)+    ETHTypedSplice body -> "ETHTypedSplice" <+> parens (docExpr body)+    EIf cond yes no -> "EIf" <+> parens (docExpr cond) <+> parens (docExpr yes) <+> parens (docExpr no)+    EMultiWayIf rhss -> "EMultiWayIf" <+> brackets (hsep (punctuate comma (map docGuardedRhs rhss)))+    ELambdaPats pats body -> "ELambdaPats" <+> brackets (hsep (punctuate comma (map docPattern pats))) <+> parens (docExpr body)+    ELambdaCase alts -> "ELambdaCase" <+> brackets (hsep (punctuate comma (map docCaseAlt alts)))+    ELambdaCases alts -> "ELambdaCases" <+> brackets (hsep (punctuate comma (map docLambdaCaseAlt alts)))+    EInfix lhs op rhs -> "EInfix" <+> parens (docExpr lhs) <+> docName op <+> parens (docExpr rhs)+    ENegate inner -> "ENegate" <+> parens (docExpr inner)+    ESectionL lhs op -> "ESectionL" <+> parens (docExpr lhs) <+> docName op+    ESectionR op rhs -> "ESectionR" <+> docName op <+> parens (docExpr rhs)+    ELetDecls decls body -> "ELetDecls" <+> brackets (hsep (punctuate comma (map docDecl decls))) <+> parens (docExpr body)+    ECase scrutinee alts -> "ECase" <+> parens (docExpr scrutinee) <+> brackets (hsep (punctuate comma (map docCaseAlt alts)))+    EDo stmts flavor -> "EDo" <+> hsep (brackets (hsep (punctuate comma (map docDoStmt stmts))) : docDoFlavorFields flavor)+    EListComp body quals -> "EListComp" <+> parens (docExpr body) <+> brackets (hsep (punctuate comma (map docCompStmt quals)))+    EListCompParallel body qualGroups -> "EListCompParallel" <+> parens (docExpr body) <+> brackets (hsep (punctuate "|" [brackets (hsep (punctuate comma (map docCompStmt qs))) | qs <- qualGroups]))+    EArithSeq seqInfo -> "EArithSeq" <+> parens (docArithSeq seqInfo)+    ERecordCon name fields' hasWildcard -> "ERecordCon" <+> docName name <+> braces (hsep (punctuate comma ([docExprRecordField recordField | recordField <- fields'] ++ [".." | hasWildcard])))+    ERecordUpd base fields' -> "ERecordUpd" <+> parens (docExpr base) <+> braces (hsep (punctuate comma [docExprRecordField recordField | recordField <- fields']))+    EGetField base fieldName -> "EGetField" <+> parens (docExpr base) <+> docName fieldName+    EGetFieldProjection fields -> "EGetFieldProjection" <+> brackets (hsep (punctuate comma (map docName fields)))+    ETypeSig inner ty -> "ETypeSig" <+> parens (docExpr inner) <+> parens (docType ty)+    EParen inner -> "EParen" <+> parens (docExpr inner)+    EList elems -> "EList" <+> brackets (hsep (punctuate comma (map docExpr elems)))+    ETuple tupleFlavor elems ->+      "ETuple" <+> hsep (docExprTupleFields tupleFlavor elems)+    EUnboxedSum altIdx arity inner ->+      "EUnboxedSum" <+> pretty altIdx <+> pretty arity <+> docExpr inner+    ETypeApp inner ty -> "ETypeApp" <+> parens (docExpr inner) <+> parens (docType ty)+    EApp f x -> "EApp" <+> parens (docExpr f) <+> parens (docExpr x)+    EProc pat body -> "EProc" <+> parens (docPattern pat) <+> parens (docCmd body)+    EPragma pragma inner -> "EPragma" <+> parens (docPragma pragma) <+> parens (docExpr inner)+    EAnn _ sub -> docExpr sub++docPatternRecordField :: RecordField Pattern -> Doc ann+docPatternRecordField recordField =+  docName (recordFieldName recordField)+    <+> (if recordFieldPun recordField then "~pun" else "=")+    <+> docPattern (recordFieldValue recordField)++docExprRecordField :: RecordField Expr -> Doc ann+docExprRecordField recordField =+  docName (recordFieldName recordField)+    <+> (if recordFieldPun recordField then "~pun" else "=")+    <+> docExpr (recordFieldValue recordField)++docMaybeExpr :: Maybe Expr -> Doc ann+docMaybeExpr Nothing = "Nothing"+docMaybeExpr (Just expr) = docExpr expr++docCaseAltWith :: (body -> Doc ann) -> CaseAlt body -> Doc ann+docCaseAltWith docBody (CaseAlt _ pat rhs) =+  "CaseAlt" <+> parens (docPattern pat) <+> parens (docRhsWith docBody rhs)++docCaseAlt :: CaseAlt Expr -> Doc ann+docCaseAlt = docCaseAltWith docExpr++docLambdaCaseAlt :: LambdaCaseAlt -> Doc ann+docLambdaCaseAlt (LambdaCaseAlt _ pats rhs) =+  "LambdaCaseAlt" <+> brackets (hsep (punctuate comma (map docPattern pats))) <+> parens (docRhs rhs)++docDoFlavorFields :: DoFlavor -> [Doc ann]+docDoFlavorFields flavor =+  case flavor of+    DoPlain -> []+    DoMdo -> flavorField "DoMdo"+    DoQualified m -> flavorField ("DoQualified" <+> docText m)+    DoQualifiedMdo m -> flavorField ("DoQualifiedMdo" <+> docText m)+  where+    flavorField doc = [parens doc]++docExprTupleFields :: TupleFlavor -> [Maybe Expr] -> [Doc ann]+docExprTupleFields tupleFlavor elems =+  flavorFields <> [brackets (hsep (punctuate comma (map docMaybeExpr elems)))]+  where+    flavorFields =+      case tupleFlavor of+        Boxed -> []+        _ -> [pretty (show tupleFlavor)]++docDoStmt :: DoStmt Expr -> Doc ann+docDoStmt stmt =+  case stmt of+    DoAnn _ inner -> docDoStmt inner+    DoBind pat expr -> "DoBind" <+> parens (docPattern pat) <+> parens (docExpr expr)+    DoLetDecls decls -> "DoLetDecls" <+> brackets (hsep (punctuate comma (map docDecl decls)))+    DoExpr expr -> "DoExpr" <+> parens (docExpr expr)+    DoRecStmt stmts -> "DoRecStmt" <+> brackets (hsep (punctuate comma (map docDoStmt stmts)))++docCompStmt :: CompStmt -> Doc ann+docCompStmt stmt =+  case stmt of+    CompAnn _ inner -> docCompStmt inner+    CompGen pat expr -> "CompGen" <+> parens (docPattern pat) <+> parens (docExpr expr)+    CompGuard expr -> "CompGuard" <+> parens (docExpr expr)+    CompLetDecls decls -> "CompLetDecls" <+> brackets (hsep (punctuate comma (map docDecl decls)))+    CompThen f -> "CompThen" <+> parens (docExpr f)+    CompThenBy f e -> "CompThenBy" <+> parens (docExpr f) <+> parens (docExpr e)+    CompGroupUsing f -> "CompGroupUsing" <+> parens (docExpr f)+    CompGroupByUsing e f -> "CompGroupByUsing" <+> parens (docExpr e) <+> parens (docExpr f)++docCmd :: Cmd -> Doc ann+docCmd cmd =+  case cmd of+    CmdAnn _ inner -> docCmd inner+    CmdArrApp lhs HsFirstOrderApp rhs -> "CmdArrApp" <+> parens (docExpr lhs) <+> "HsFirstOrderApp" <+> parens (docExpr rhs)+    CmdArrApp lhs HsHigherOrderApp rhs -> "CmdArrApp" <+> parens (docExpr lhs) <+> "HsHigherOrderApp" <+> parens (docExpr rhs)+    CmdInfix l op r -> "CmdInfix" <+> parens (docCmd l) <+> docName op <+> parens (docCmd r)+    CmdDo stmts -> "CmdDo" <+> brackets (hsep (punctuate comma (map docCmdStmt stmts)))+    CmdIf cond yes no -> "CmdIf" <+> parens (docExpr cond) <+> parens (docCmd yes) <+> parens (docCmd no)+    CmdCase scrut alts -> "CmdCase" <+> parens (docExpr scrut) <+> brackets (hsep (punctuate comma (map docCmdCaseAlt alts)))+    CmdLet decls body -> "CmdLet" <+> brackets (hsep (punctuate comma (map docDecl decls))) <+> parens (docCmd body)+    CmdLam pats body -> "CmdLam" <+> brackets (hsep (punctuate comma (map docPattern pats))) <+> parens (docCmd body)+    CmdApp c e -> "CmdApp" <+> parens (docCmd c) <+> parens (docExpr e)+    CmdPar c -> "CmdPar" <+> parens (docCmd c)++docCmdStmt :: DoStmt Cmd -> Doc ann+docCmdStmt stmt =+  case stmt of+    DoAnn _ inner -> docCmdStmt inner+    DoBind pat cmd' -> "DoBind" <+> parens (docPattern pat) <+> parens (docCmd cmd')+    DoLetDecls decls -> "DoLetDecls" <+> brackets (hsep (punctuate comma (map docDecl decls)))+    DoExpr cmd' -> "DoExpr" <+> parens (docCmd cmd')+    DoRecStmt stmts -> "DoRecStmt" <+> brackets (hsep (punctuate comma (map docCmdStmt stmts)))++docCmdCaseAlt :: CaseAlt Cmd -> Doc ann+docCmdCaseAlt = docCaseAltWith docCmd++docArithSeq :: ArithSeq -> Doc ann+docArithSeq seqInfo =+  case seqInfo of+    ArithSeqAnn _ inner -> docArithSeq inner+    ArithSeqFrom from -> "ArithSeqFrom" <+> parens (docExpr from)+    ArithSeqFromThen from thn -> "ArithSeqFromThen" <+> parens (docExpr from) <+> parens (docExpr thn)+    ArithSeqFromTo from to -> "ArithSeqFromTo" <+> parens (docExpr from) <+> parens (docExpr to)+    ArithSeqFromThenTo from thn to -> "ArithSeqFromThenTo" <+> parens (docExpr from) <+> parens (docExpr thn) <+> parens (docExpr to)++-- Token pretty printing++docToken :: LexToken -> Doc ann+docToken tok = docTokenKind (lexTokenKind tok)++docTokenKind :: LexTokenKind -> Doc ann+docTokenKind kind =+  case kind of+    TkKeywordCase -> "TkKeywordCase"+    TkKeywordClass -> "TkKeywordClass"+    TkKeywordData -> "TkKeywordData"+    TkKeywordDefault -> "TkKeywordDefault"+    TkKeywordDeriving -> "TkKeywordDeriving"+    TkKeywordDo -> "TkKeywordDo"+    TkKeywordElse -> "TkKeywordElse"+    TkKeywordForall -> "TkKeywordForall"+    TkKeywordForeign -> "TkKeywordForeign"+    TkKeywordIf -> "TkKeywordIf"+    TkKeywordImport -> "TkKeywordImport"+    TkKeywordIn -> "TkKeywordIn"+    TkKeywordInfix -> "TkKeywordInfix"+    TkKeywordInfixl -> "TkKeywordInfixl"+    TkKeywordInfixr -> "TkKeywordInfixr"+    TkKeywordInstance -> "TkKeywordInstance"+    TkKeywordLet -> "TkKeywordLet"+    TkKeywordModule -> "TkKeywordModule"+    TkKeywordNewtype -> "TkKeywordNewtype"+    TkKeywordOf -> "TkKeywordOf"+    TkKeywordThen -> "TkKeywordThen"+    TkKeywordType -> "TkKeywordType"+    TkKeywordWhere -> "TkKeywordWhere"+    TkKeywordUnderscore -> "TkKeywordUnderscore"+    TkKeywordProc -> "TkKeywordProc"+    TkKeywordPattern -> "TkKeywordPattern"+    TkKeywordRec -> "TkKeywordRec"+    TkKeywordMdo -> "TkKeywordMdo"+    TkKeywordBy -> "TkKeywordBy"+    TkKeywordUsing -> "TkKeywordUsing"+    TkQualifiedDo modName -> "TkQualifiedDo" <+> docText modName+    TkQualifiedMdo modName -> "TkQualifiedMdo" <+> docText modName+    TkPrefixPercent -> "TkPrefixPercent"+    TkLinearArrow -> "TkLinearArrow"+    TkArrowTail -> "TkArrowTail"+    TkArrowTailReverse -> "TkArrowTailReverse"+    TkDoubleArrowTail -> "TkDoubleArrowTail"+    TkDoubleArrowTailReverse -> "TkDoubleArrowTailReverse"+    TkBananaOpen -> "TkBananaOpen"+    TkBananaClose -> "TkBananaClose"+    TkReservedDotDot -> "TkReservedDotDot"+    TkReservedColon -> "TkReservedColon"+    TkReservedDoubleColon -> "TkReservedDoubleColon"+    TkReservedEquals -> "TkReservedEquals"+    TkReservedBackslash -> "TkReservedBackslash"+    TkReservedPipe -> "TkReservedPipe"+    TkReservedLeftArrow -> "TkReservedLeftArrow"+    TkReservedRightArrow -> "TkReservedRightArrow"+    TkReservedAt -> "TkReservedAt"+    TkReservedDoubleArrow -> "TkReservedDoubleArrow"+    TkTypeApp -> "TkTypeApp"+    TkVarId name -> "TkVarId" <+> docText name+    TkConId name -> "TkConId" <+> docText name+    TkQVarId modName name -> "TkQVarId" <+> docText modName <+> docText name+    TkQConId modName name -> "TkQConId" <+> docText modName <+> docText name+    TkImplicitParam name -> "TkImplicitParam" <+> docText name+    TkVarSym name -> "TkVarSym" <+> docText name+    TkConSym name -> "TkConSym" <+> docText name+    TkQVarSym modName name -> "TkQVarSym" <+> docText modName <+> docText name+    TkQConSym modName name -> "TkQConSym" <+> docText modName <+> docText name+    TkInteger n nt -> "TkInteger" <+> pretty n <+> docNumericType nt+    TkFloat n ft -> "TkFloat" <+> pretty (show n) <+> docFloatType ft+    TkChar c -> "TkChar" <+> pretty (show c)+    TkCharHash c repr -> "TkCharHash" <+> pretty (show c) <+> docText repr+    TkString s -> "TkString" <+> docText s+    TkStringHash s repr -> "TkStringHash" <+> docText s <+> docText repr+    TkOverloadedLabel label raw -> "TkOverloadedLabel" <+> docText label <+> docText raw+    TkSpecialLParen -> "TkSpecialLParen"+    TkSpecialRParen -> "TkSpecialRParen"+    TkSpecialUnboxedLParen -> "TkSpecialUnboxedLParen"+    TkSpecialUnboxedRParen -> "TkSpecialUnboxedRParen"+    TkSpecialComma -> "TkSpecialComma"+    TkSpecialSemicolon -> "TkSpecialSemicolon"+    TkSpecialLBracket -> "TkSpecialLBracket"+    TkSpecialRBracket -> "TkSpecialRBracket"+    TkSpecialBacktick -> "TkSpecialBacktick"+    TkSpecialLBrace -> "TkSpecialLBrace"+    TkSpecialRBrace -> "TkSpecialRBrace"+    TkMinusOperator -> "TkMinusOperator"+    TkPrefixMinus -> "TkPrefixMinus"+    TkPrefixBang -> "TkPrefixBang"+    TkPrefixTilde -> "TkPrefixTilde"+    TkRecordDot -> "TkRecordDot"+    TkPragma pragma' -> "TkPragma" <+> docPragmaType (pragmaType pragma')+    TkQuasiQuote quoter body -> "TkQuasiQuote" <+> docText quoter <+> docText body+    TkLineComment -> "TkLineComment"+    TkBlockComment -> "TkBlockComment"+    TkTHExpQuoteOpen -> "TkTHExpQuoteOpen"+    TkTHExpQuoteClose -> "TkTHExpQuoteClose"+    TkTHTypedQuoteOpen -> "TkTHTypedQuoteOpen"+    TkTHTypedQuoteClose -> "TkTHTypedQuoteClose"+    TkTHDeclQuoteOpen -> "TkTHDeclQuoteOpen"+    TkTHTypeQuoteOpen -> "TkTHTypeQuoteOpen"+    TkTHPatQuoteOpen -> "TkTHPatQuoteOpen"+    TkTHQuoteTick -> "TkTHQuoteTick"+    TkTHTypeQuoteTick -> "TkTHTypeQuoteTick"+    TkTHSplice -> "TkTHSplice"+    TkTHTypedSplice -> "TkTHTypedSplice"+    TkError msg -> "TkError" <+> docText msg+    TkEOF -> "TkEOF"++docTypeSyntaxForm :: TypeSyntaxForm -> Doc ann+docTypeSyntaxForm form =+  case form of+    TypeSyntaxExplicitNamespace -> "TypeSyntaxExplicitNamespace"+    TypeSyntaxInTerm -> "TypeSyntaxInTerm"++docNumericType :: NumericType -> Doc ann+docNumericType nt =+  case nt of+    TInteger -> "TInteger"+    TIntHash -> "TIntHash"+    TWordHash -> "TWordHash"+    TInt8Hash -> "TInt8Hash"+    TInt16Hash -> "TInt16Hash"+    TInt32Hash -> "TInt32Hash"+    TInt64Hash -> "TInt64Hash"+    TWord8Hash -> "TWord8Hash"+    TWord16Hash -> "TWord16Hash"+    TWord32Hash -> "TWord32Hash"+    TWord64Hash -> "TWord64Hash"++docFloatType :: FloatType -> Doc ann+docFloatType ft =+  case ft of+    TFractional -> "TFractional"+    TFloatHash -> "TFloatHash"+    TDoubleHash -> "TDoubleHash"++optionalField :: (a -> Doc ann) -> Maybe a -> [Doc ann]+optionalField f mVal =+  case mVal of+    Just val -> [f val]+    Nothing -> []++optionalField' :: (a -> Doc ann) -> Maybe a -> Doc ann+optionalField' f mVal =+  case mVal of+    Just val -> " " <> f val+    Nothing -> ""++listField :: (a -> Doc ann) -> [a] -> [Doc ann]+listField _ [] = []+listField f xs = [brackets (hsep (punctuate comma (map f xs)))]++boolField :: Bool -> [Doc ann]+boolField False = []+boolField True = ["True"]++docText :: Text -> Doc ann+docText = pretty . show++docName :: Name -> Doc ann+docName name =+  case nameQualifier name of+    Nothing -> docText (nameText name)+    Just qualifier -> docText qualifier <+> docText (nameText name)++docUnqualifiedName :: UnqualifiedName -> Doc ann+docUnqualifiedName name =+  "UnqualifiedName" <+> braces (docText (unqualifiedNameText name))++docUnqualifiedNameText :: UnqualifiedName -> Doc ann+docUnqualifiedNameText = docText . unqualifiedNameText++docTextList :: [Text] -> Doc ann+docTextList ts = brackets (hsep (punctuate comma (map docText ts)))++docTypeFamilyDecl :: TypeFamilyDecl -> Doc ann+docTypeFamilyDecl tf =+  "TypeFamilyDecl" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      [ docTypeHeadForm (typeFamilyDeclHeadForm tf),+        if typeFamilyDeclExplicitFamilyKeyword tf then "True" else "False",+        docType (typeFamilyDeclHead tf)+      ]+        <> listField docTyVarBinder (typeFamilyDeclParams tf)+        <> optionalField docTypeFamilyResultSig (typeFamilyDeclResultSig tf)+        <> case typeFamilyDeclEquations tf of+          Nothing -> []+          Just eqs -> [brackets (hsep (punctuate comma (map docTypeFamilyEq eqs)))]++docTypeFamilyEq :: TypeFamilyEq -> Doc ann+docTypeFamilyEq eq =+  "TypeFamilyEq" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      listField docTyVarBinder (typeFamilyEqForall eq)+        <> [docTypeHeadForm (typeFamilyEqHeadForm eq), docType (typeFamilyEqLhs eq), docType (typeFamilyEqRhs eq)]++docDataFamilyDecl :: DataFamilyDecl -> Doc ann+docDataFamilyDecl df =+  "DataFamilyDecl" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      [docBinderHeadValue (dataFamilyDeclHead df)]+        <> optionalField docType (dataFamilyDeclKind df)++docBinderHead :: BinderHead UnqualifiedName -> [Doc ann]+docBinderHead head' =+  [docBinderHeadValue head']++docBinderHeadValue :: BinderHead UnqualifiedName -> Doc ann+docBinderHeadValue head' =+  case head' of+    PrefixBinderHead name params ->+      "Prefix" <+> hsep (docPrefixBinderHeadFields name params)+    InfixBinderHead lhs name rhs params ->+      "Infix" <+> hsep (docInfixBinderHeadFields lhs name rhs params)++docPrefixBinderHeadFields :: UnqualifiedName -> [TyVarBinder] -> [Doc ann]+docPrefixBinderHeadFields name params =+  docUnqualifiedNameText name : docBinderHeadParams params++docInfixBinderHeadFields :: TyVarBinder -> UnqualifiedName -> TyVarBinder -> [TyVarBinder] -> [Doc ann]+docInfixBinderHeadFields lhs name rhs params =+  [docTyVarBinderShort lhs, docUnqualifiedNameText name, docTyVarBinderShort rhs] <> docBinderHeadParams params++docBinderHeadParams :: [TyVarBinder] -> [Doc ann]+docBinderHeadParams [] = []+docBinderHeadParams params = [brackets (hsep (punctuate comma (map docTyVarBinder params)))]++docTyVarBinderShort :: TyVarBinder -> Doc ann+docTyVarBinderShort tvb+  | Nothing <- tyVarBinderKind tvb,+    TyVarBSpecified <- tyVarBinderSpecificity tvb,+    TyVarBVisible <- tyVarBinderVisibility tvb =+      docText (tyVarBinderName tvb)+  | otherwise = parens (docTyVarBinder tvb)++docTypeFamilyInst :: TypeFamilyInst -> Doc ann+docTypeFamilyInst tfi =+  "TypeFamilyInst" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      listField docTyVarBinder (typeFamilyInstForall tfi)+        <> [docTypeHeadForm (typeFamilyInstHeadForm tfi), docType (typeFamilyInstLhs tfi), docType (typeFamilyInstRhs tfi)]++docTypeHeadForm :: TypeHeadForm -> Doc ann+docTypeHeadForm headForm =+  case headForm of+    TypeHeadPrefix -> "TypeHeadPrefix"+    TypeHeadInfix -> "TypeHeadInfix"++docDataFamilyInst :: DataFamilyInst -> Doc ann+docDataFamilyInst dfi =+  "DataFamilyInst" <+> braces (hsep (punctuate comma fields))+  where+    fields =+      boolField (dataFamilyInstIsNewtype dfi)+        <> listField docTyVarBinder (dataFamilyInstForall dfi)+        <> [docType (dataFamilyInstHead dfi)]+        <> optionalField docType (dataFamilyInstKind dfi)+        <> listField docDataConDecl (dataFamilyInstConstructors dfi)+        <> listField docDerivingClause (dataFamilyInstDeriving dfi)
+ src/Aihc/Parser/Syntax.hs view
@@ -0,0 +1,2288 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+--+-- Module      : Aihc.Parser.Syntax+-- Description : Abstract Syntax Tree+-- License     : Unlicense+--+-- Abstract Syntax Tree (AST) covering Haskell2010 plus all language extensions.+module Aihc.Parser.Syntax+  ( ArithSeq (..),+    ArrowKind (..),+    ArrAppType (..),+    BangType (..),+    BinderName,+    BinderHead (..),+    CallConv (..),+    CaseAlt (..),+    ClassDecl (..),+    ClassDeclItem (..),+    Cmd (..),+    CompStmt (..),+    FunctionalDependency (..),+    TypeFamilyResultSig (..),+    TypeFamilyInjectivity (..),+    TypeHeadForm (..),+    DataConDecl (..),+    DataDecl (..),+    Decl (..),+    DerivingClause (..),+    DerivingStrategy (..),+    DoFlavor (..),+    DoStmt (..),+    Expr (..),+    Extension (..),+    ExtensionSetting (..),+    ExportSpec (..),+    IEEntityNamespace (..),+    IEBundledNamespace (..),+    IEBundledMember (..),+    FieldDecl (..),+    FixityAssoc (..),+    ForeignDecl (..),+    ForeignDirection (..),+    ForeignEntitySpec (..),+    ForeignSafety (..),+    GadtBody (..),+    GuardQualifier (..),+    GuardedRhs (..),+    ImportDecl (..),+    ImportLevel (..),+    ImportItem (..),+    ImportSpec (..),+    InstanceDecl (..),+    InstanceDeclItem (..),+    InstanceOverlapPragma (..),+    LanguageEdition (..),+    LambdaCaseAlt (..),+    Literal (..),+    Match (..),+    MatchHeadForm (..),+    MultiplicityTag (..),+    Module (..),+    ModuleHead (..),+    ModuleHeaderPragmas (..),+    Name (..),+    NameType (..),+    UnqualifiedName (..),+    InstanceHeadType,+    Annotation,+    NewtypeDecl (..),+    OperatorName,+    PatSynArgs (..),+    PatSynDecl (..),+    PatSynDir (..),+    Pattern (..),+    RecordField (..),+    Pragma (..),+    PragmaType (..),+    PragmaUnpackKind (..),+    Role (..),+    RoleAnnotation (..),+    Rhs (..),+    SourceSpan (..),+    StandaloneDerivingDecl (..),+    Type (..),+    TupleFlavor (..),+    TypeSyntaxForm (..),+    FloatType (..),+    NumericType (..),+    TypeLiteral (..),+    TypeBuiltinCon (..),+    TypePromotion (..),+    ForallVis (..),+    ForallTelescope (..),+    TyVarBSpecificity (..),+    TyVarBVisibility (..),+    TyVarBinder (..),+    TypeSynDecl (..),+    TypeFamilyDecl (..),+    TypeFamilyEq (..),+    DataFamilyDecl (..),+    TypeFamilyInst (..),+    DataFamilyInst (..),+    ValueDecl (..),+    allKnownExtensions,+    applyExtensionSetting,+    applyImpliedExtensions,+    binderHeadForm,+    binderHeadName,+    binderHeadParams,+    effectiveExtensions,+    extensionName,+    extensionSettingName,+    gadtBodyResultType,+    languageEditionExtensions,+    editionFromExtensionSettings,+    noSourceSpan,+    mergeSourceSpans,+    mkName,+    mkUnqualifiedName,+    nameFromText,+    parseExtensionName,+    parseExtensionSettingName,+    parseLanguageEdition,+    qualifyName,+    renderName,+    renderUnqualifiedName,+    unqualifiedNameFromText,+    moduleName,+    moduleWarningPragma,+    moduleExports,+    instanceHeadName,+    instanceHeadTypes,+    mkAnnotation,+    fromAnnotation,+    stripAnnotations,+    peelArithSeqAnn,+    peelClassDeclItemAnn,+    peelCmdAnn,+    peelCompStmtAnn,+    peelDataConAnn,+    peelDeclAnn,+    peelDoStmtAnn,+    peelExprAnn,+    peelGuardQualifierAnn,+    peelInstanceDeclItemAnn,+    peelPatternAnn,+    peelTypeAnn,+    peelTypeHead,+    literalAnnSpan,+    peelLiteralAnn,+    typeAnnSpan,+  )+where++import Control.DeepSeq (NFData (..))+import Data.Char (GeneralCategory (..), generalCategory)+import Data.Data (Constr, Data (..), DataType, Fixity (Prefix), mkConstr, mkDataType)+import Data.Dynamic (Dynamic, Typeable, fromDynamic, toDyn)+import Data.List (sort)+import Data.Map qualified as Map+import Data.Maybe (fromMaybe, mapMaybe)+import Data.String (IsString (..))+import Data.Text (Text)+import Data.Text qualified as T+import Data.Typeable (cast)+import GHC.Generics (Generic)++-- | A @LANGUAGE@ pragma name.+-- Examples: @OverloadedStrings@ in @{-# LANGUAGE OverloadedStrings #-}@ and+-- @LambdaCase@ in @{-# LANGUAGE LambdaCase #-}@.+data Extension+  = AllowAmbiguousTypes+  | AlternativeLayoutRule+  | AlternativeLayoutRuleTransitional+  | ApplicativeDo+  | Arrows+  | AutoDeriveTypeable+  | BangPatterns+  | BinaryLiterals+  | BlockArguments+  | CApiFFI+  | ConstrainedClassMethods+  | ConstraintKinds+  | CPP+  | CUSKs+  | DataKinds+  | DatatypeContexts+  | DeepSubsumption+  | DefaultSignatures+  | DeriveAnyClass+  | DeriveDataTypeable+  | DeriveFoldable+  | DeriveFunctor+  | DeriveGeneric+  | DeriveLift+  | DeriveTraversable+  | DerivingStrategies+  | DerivingViaExtension+  | DisambiguateRecordFields+  | DoAndIfThenElse+  | DoRec+  | DuplicateRecordFields+  | EmptyCase+  | EmptyDataDecls+  | EmptyDataDeriving+  | ExistentialQuantification+  | ExplicitForAll+  | ExplicitLevelImports+  | ExplicitNamespaces+  | ExtensibleRecords+  | ExtendedDefaultRules+  | ExtendedLiterals+  | FieldSelectors+  | FlexibleContexts+  | FlexibleInstances+  | ForeignFunctionInterface+  | FunctionalDependencies+  | GADTs+  | GADTSyntax+  | Generics+  | GeneralizedNewtypeDeriving+  | GHC2021+  | GHC2024+  | GHCForeignImportPrim+  | Haskell2010+  | Haskell98+  | HereDocuments+  | HexFloatLiterals+  | ImplicitParams+  | ImplicitPrelude+  | ImplicitStagePersistence+  | ImportQualifiedPost+  | ImpredicativeTypes+  | IncoherentInstances+  | InstanceSigs+  | InterruptibleFFI+  | JavaScriptFFI+  | KindSignatures+  | LambdaCase+  | LexicalNegation+  | LiberalTypeSynonyms+  | LinearTypes+  | ListTuplePuns+  | MagicHash+  | MonadComprehensions+  | MonadFailDesugaring+  | MonoLocalBinds+  | MonoPatBinds+  | MonomorphismRestriction+  | MultilineStrings+  | MultiParamTypeClasses+  | MultiWayIf+  | NamedDefaults+  | NamedFieldPuns+  | NamedWildCards+  | NewQualifiedOperators+  | NegativeLiterals+  | NondecreasingIndentation+  | NPlusKPatterns+  | NullaryTypeClasses+  | NumDecimals+  | NumericUnderscores+  | OrPatterns+  | OverlappingInstances+  | OverloadedLabels+  | OverloadedLists+  | OverloadedRecordDot+  | OverloadedRecordUpdate+  | OverloadedStrings+  | PackageImports+  | ParallelArrays+  | ParallelListComp+  | PartialTypeSignatures+  | PatternSignatures+  | PatternGuards+  | PatternSynonyms+  | PolymorphicComponents+  | PolyKinds+  | PostfixOperators+  | QualifiedDo+  | QualifiedStrings+  | QuantifiedConstraints+  | QuasiQuotes+  | Rank2Types+  | RankNTypes+  | RebindableSyntax+  | RecordPuns+  | RecordWildCards+  | RecursiveDo+  | RegularPatterns+  | RelaxedLayout+  | RelaxedPolyRec+  | RestrictedTypeSynonyms+  | RequiredTypeArguments+  | RoleAnnotations+  | SafeImports+  | SafeHaskell+  | ScopedTypeVariables+  | StandaloneDeriving+  | StandaloneKindSignatures+  | StarIsType+  | StaticPointers+  | Strict+  | StrictData+  | TemplateHaskell+  | TemplateHaskellQuotes+  | TraditionalRecordSyntax+  | TransformListComp+  | Trustworthy+  | TupleSections+  | TypeAbstractions+  | TypeApplications+  | TypeData+  | TypeFamilies+  | TypeFamilyDependencies+  | TypeInType+  | TypeOperators+  | TypeSynonymInstances+  | UnboxedSums+  | UnboxedTuples+  | UndecidableInstances+  | UndecidableSuperClasses+  | UnicodeSyntax+  | UnliftedDatatypes+  | UnliftedFFITypes+  | UnliftedNewtypes+  | UnsafeHaskell+  | ViewPatterns+  | XmlSyntax+  deriving (Data, Eq, Ord, Show, Read, Enum, Bounded, Generic, NFData)++-- | A single @LANGUAGE@ pragma entry.+-- Examples: @EnableExtension LambdaCase@ for @{-# LANGUAGE LambdaCase #-}@ and+-- @DisableExtension ImplicitPrelude@ for @{-# LANGUAGE NoImplicitPrelude #-}@.+data ExtensionSetting+  = -- | @{-# LANGUAGE LambdaCase #-}@+    EnableExtension Extension+  | -- | @{-# LANGUAGE NoImplicitPrelude #-}@+    DisableExtension Extension+  deriving (Data, Eq, Ord, Show, Read, Generic, NFData)++-- | The Haskell language edition/standard.+-- Each edition implies a set of language extensions.+-- Examples: @{-# LANGUAGE Haskell2010 #-}@ and @{-# LANGUAGE GHC2021 #-}@.+data LanguageEdition+  = Haskell98Edition+  | Haskell2010Edition+  | GHC2021Edition+  | GHC2024Edition+  deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, NFData)++-- | Pragmas extracted from a module header.+-- Contains the last language edition pragma (if any) and all extension settings.+-- Example: @{-# LANGUAGE Haskell2010, LambdaCase, NoImplicitPrelude #-}@.+data ModuleHeaderPragmas = ModuleHeaderPragmas+  { headerLanguageEdition :: Maybe LanguageEdition,+    headerExtensionSettings :: [ExtensionSetting]+  }+  deriving (Eq, Show, Generic, NFData)++allKnownExtensions :: [Extension]+allKnownExtensions = [minBound .. maxBound]++extensionName :: Extension -> Text+extensionName ext =+  case ext of+    DerivingViaExtension -> T.pack "DerivingVia"+    SafeHaskell -> T.pack "Safe"+    UnsafeHaskell -> T.pack "Unsafe"+    _ -> T.pack (show ext)++extensionSettingName :: ExtensionSetting -> Text+extensionSettingName setting =+  case setting of+    EnableExtension ext -> extensionName ext+    DisableExtension ext -> T.pack "No" <> extensionName ext++parseExtensionName :: Text -> Maybe Extension+parseExtensionName raw =+  Map.lookup trimmed extensionMap+  where+    extensionMap :: Map.Map Text Extension+    extensionMap = Map.fromList $ aliases ++ [(T.pack (show ext), ext) | ext <- [minBound .. maxBound]]+    trimmed = T.strip raw+    aliases =+      [ ("Cpp", CPP),+        ("DerivingVia", DerivingViaExtension),+        ("GeneralisedNewtypeDeriving", GeneralizedNewtypeDeriving),+        ("Safe", SafeHaskell),+        ("Unsafe", UnsafeHaskell)+      ]++parseExtensionSettingName :: Text -> Maybe ExtensionSetting+parseExtensionSettingName raw =+  case T.stripPrefix (T.pack "No") trimmed of+    Just rest+      | not (T.null rest) ->+          case parseExtensionName rest of+            Just ext -> Just (DisableExtension ext)+            Nothing -> EnableExtension <$> parseExtensionName trimmed+    _ -> EnableExtension <$> parseExtensionName trimmed+  where+    trimmed = T.strip raw++-- | Parse a language edition name (e.g., "Haskell2010", "GHC2021").+parseLanguageEdition :: Text -> Maybe LanguageEdition+parseLanguageEdition raw+  | trimmed == T.pack "Haskell98" = Just Haskell98Edition+  | trimmed == T.pack "Haskell2010" = Just Haskell2010Edition+  | trimmed == T.pack "GHC2021" = Just GHC2021Edition+  | trimmed == T.pack "GHC2024" = Just GHC2024Edition+  | otherwise = Nothing+  where+    trimmed = T.strip raw++editionFromExtensionSettings :: [ExtensionSetting] -> Maybe LanguageEdition+editionFromExtensionSettings = worker Nothing+  where+    worker acc [] = acc+    worker _ (EnableExtension Haskell98 : rest) = worker (Just Haskell98Edition) rest+    worker _ (EnableExtension Haskell2010 : rest) = worker (Just Haskell2010Edition) rest+    worker _ (EnableExtension GHC2021 : rest) = worker (Just GHC2021Edition) rest+    worker _ (EnableExtension GHC2024 : rest) = worker (Just GHC2024Edition) rest+    worker acc (_ : rest) = worker acc rest++-- | Get the set of extensions enabled by a language edition.+-- These lists are derived from GHC's DynFlags.languageExtensions.+-- IMPORTANT: Keep these in sync with GHC. The test suite validates this.+languageEditionExtensions :: LanguageEdition -> [Extension]+languageEditionExtensions edition =+  case edition of+    Haskell98Edition ->+      -- Haskell98 has minimal extensions, mostly implicitly enabled features+      [ CUSKs,+        DeepSubsumption,+        DatatypeContexts,+        FieldSelectors,+        ImplicitPrelude,+        ImplicitStagePersistence,+        ListTuplePuns,+        MonomorphismRestriction,+        NondecreasingIndentation,+        NPlusKPatterns,+        StarIsType,+        TraditionalRecordSyntax+      ]+    Haskell2010Edition ->+      -- Haskell2010 adds a few more extensions over Haskell98+      [ CUSKs,+        DeepSubsumption,+        DatatypeContexts,+        DoAndIfThenElse,+        EmptyDataDecls,+        FieldSelectors,+        ForeignFunctionInterface,+        ImplicitPrelude,+        ImplicitStagePersistence,+        ListTuplePuns,+        MonomorphismRestriction,+        PatternGuards,+        RelaxedPolyRec,+        StarIsType,+        TraditionalRecordSyntax+      ]+    GHC2021Edition ->+      -- GHC2021 enables many modern convenience extensions+      [ BangPatterns,+        BinaryLiterals,+        ConstrainedClassMethods,+        ConstraintKinds,+        DeriveDataTypeable,+        DeriveFoldable,+        DeriveFunctor,+        DeriveGeneric,+        DeriveLift,+        DeriveTraversable,+        DoAndIfThenElse,+        EmptyCase,+        EmptyDataDecls,+        EmptyDataDeriving,+        ExistentialQuantification,+        ExplicitForAll,+        FieldSelectors,+        FlexibleContexts,+        FlexibleInstances,+        ForeignFunctionInterface,+        GADTSyntax,+        GeneralizedNewtypeDeriving,+        HexFloatLiterals,+        ImplicitPrelude,+        ImplicitStagePersistence,+        ImportQualifiedPost,+        InstanceSigs,+        KindSignatures,+        ListTuplePuns,+        MonomorphismRestriction,+        MultiParamTypeClasses,+        NamedFieldPuns,+        NamedWildCards,+        NumericUnderscores,+        PatternGuards,+        PolyKinds,+        PostfixOperators,+        RankNTypes,+        RelaxedPolyRec,+        ScopedTypeVariables,+        StandaloneDeriving,+        StandaloneKindSignatures,+        StarIsType,+        TraditionalRecordSyntax,+        TupleSections,+        TypeApplications,+        TypeOperators,+        TypeSynonymInstances+      ]+    GHC2024Edition ->+      -- GHC2024 adds more extensions on top of GHC2021+      [ BangPatterns,+        BinaryLiterals,+        ConstrainedClassMethods,+        ConstraintKinds,+        DataKinds,+        DeriveDataTypeable,+        DeriveFoldable,+        DeriveFunctor,+        DeriveGeneric,+        DeriveLift,+        DeriveTraversable,+        DerivingStrategies,+        DisambiguateRecordFields,+        DoAndIfThenElse,+        EmptyCase,+        EmptyDataDecls,+        EmptyDataDeriving,+        ExistentialQuantification,+        ExplicitForAll,+        ExplicitNamespaces,+        FieldSelectors,+        FlexibleContexts,+        FlexibleInstances,+        ForeignFunctionInterface,+        GADTs,+        GADTSyntax,+        GeneralizedNewtypeDeriving,+        HexFloatLiterals,+        ImplicitPrelude,+        ImplicitStagePersistence,+        ImportQualifiedPost,+        InstanceSigs,+        KindSignatures,+        LambdaCase,+        ListTuplePuns,+        MonoLocalBinds,+        MonomorphismRestriction,+        MultiParamTypeClasses,+        NamedFieldPuns,+        NamedWildCards,+        NumericUnderscores,+        PatternGuards,+        PolyKinds,+        PostfixOperators,+        RankNTypes,+        RelaxedPolyRec,+        RoleAnnotations,+        ScopedTypeVariables,+        StandaloneDeriving,+        StandaloneKindSignatures,+        StarIsType,+        TraditionalRecordSyntax,+        TupleSections,+        TypeApplications,+        TypeOperators,+        TypeSynonymInstances+      ]++-- FIXME: Verify against GHC's impliedXFlags+impliedExtensions :: [(Extension, [ExtensionSetting])]+impliedExtensions =+  [ (DeriveTraversable, [EnableExtension DeriveFunctor, EnableExtension DeriveFoldable]),+    (DerivingViaExtension, [EnableExtension DerivingStrategies]),+    (DuplicateRecordFields, [EnableExtension DisambiguateRecordFields]),+    (ExistentialQuantification, [EnableExtension ExplicitForAll]),+    (ExplicitLevelImports, [DisableExtension ImplicitStagePersistence]),+    (FlexibleInstances, [EnableExtension TypeSynonymInstances]),+    (FunctionalDependencies, [EnableExtension MultiParamTypeClasses]),+    (GADTs, [EnableExtension GADTSyntax, EnableExtension MonoLocalBinds]),+    (ImpredicativeTypes, [EnableExtension RankNTypes]),+    (IncoherentInstances, [EnableExtension OverlappingInstances]),+    (LiberalTypeSynonyms, [EnableExtension ExplicitForAll]),+    (LinearTypes, [EnableExtension MonoLocalBinds]),+    (MonadComprehensions, [EnableExtension ParallelListComp]),+    (MultiParamTypeClasses, [EnableExtension ConstrainedClassMethods]),+    (PolymorphicComponents, [EnableExtension RankNTypes]),+    (PolyKinds, [EnableExtension KindSignatures]),+    (QuantifiedConstraints, [EnableExtension ExplicitForAll]),+    (Rank2Types, [EnableExtension RankNTypes]),+    (RankNTypes, [EnableExtension ExplicitForAll]),+    (RebindableSyntax, [DisableExtension ImplicitPrelude]),+    (RecordWildCards, [EnableExtension DisambiguateRecordFields]),+    (ScopedTypeVariables, [EnableExtension ExplicitForAll]),+    (StandaloneKindSignatures, [DisableExtension CUSKs]),+    (Strict, [EnableExtension StrictData]),+    (TemplateHaskell, [EnableExtension TemplateHaskellQuotes]),+    (TypeFamilies, [EnableExtension ExplicitNamespaces, EnableExtension KindSignatures, EnableExtension MonoLocalBinds]),+    (TypeAbstractions, [EnableExtension TypeApplications]),+    (TypeFamilyDependencies, [EnableExtension TypeFamilies]),+    (TypeInType, [EnableExtension PolyKinds, EnableExtension DataKinds, EnableExtension KindSignatures]),+    (TypeOperators, [EnableExtension ExplicitNamespaces]),+    (RequiredTypeArguments, [EnableExtension TypeApplications]),+    (UnboxedTuples, [EnableExtension UnboxedSums]),+    (UnliftedDatatypes, [EnableExtension DataKinds, EnableExtension StandaloneKindSignatures])+  ]++applyExtensionSetting :: ExtensionSetting -> [Extension] -> [Extension]+applyExtensionSetting setting extensions =+  case setting of+    EnableExtension ext -> ext : filter (/= ext) extensions+    DisableExtension ext -> filter (/= ext) extensions++applyImpliedExtensions :: [Extension] -> [Extension]+applyImpliedExtensions extensions =+  let settings = concat $ mapMaybe (`lookup` impliedExtensions) extensions+      newExtensions = foldr applyExtensionSetting extensions settings+   in if sort newExtensions == sort extensions then extensions else applyImpliedExtensions newExtensions++effectiveExtensions :: LanguageEdition -> [ExtensionSetting] -> [Extension]+effectiveExtensions edition extensionSettings =+  applyImpliedExtensions $+    foldr applyExtensionSetting (languageEditionExtensions edition) extensionSettings++-- | Source location metadata for parsed syntax.+-- Example: the span covering @map@ in @map f xs@.+data SourceSpan+  = -- | No location information is available.+    NoSourceSpan+  | -- | A concrete span such as the token range for @map@ in @map f xs@.+    SourceSpan+      { sourceSpanSourceName :: !FilePath,+        sourceSpanStartLine :: !Int,+        sourceSpanStartCol :: !Int,+        sourceSpanEndLine :: !Int,+        sourceSpanEndCol :: !Int,+        sourceSpanStartOffset :: !Int,+        sourceSpanEndOffset :: !Int+      }+  deriving (Data, Eq, Ord, Generic, NFData)++instance Show SourceSpan where+  show NoSourceSpan = "NoSourceSpan"+  show SourceSpan {sourceSpanStartLine, sourceSpanStartCol, sourceSpanEndLine, sourceSpanEndCol} =+    "SourceSpan "+      ++ show sourceSpanStartLine+      ++ " "+      ++ show sourceSpanStartCol+      ++ " "+      ++ show sourceSpanEndLine+      ++ " "+      ++ show sourceSpanEndCol++noSourceSpan :: SourceSpan+noSourceSpan = NoSourceSpan++mergeSourceSpans :: SourceSpan -> SourceSpan -> SourceSpan+mergeSourceSpans left right =+  case (left, right) of+    ( SourceSpan name l1 c1 _ _ startOffset _,+      SourceSpan _ _ _ l2 c2 _ endOffset+      ) ->+        SourceSpan name l1 c1 l2 c2 startOffset endOffset+    (NoSourceSpan, span') -> span'+    (span', NoSourceSpan) -> span'++-- | A qualified or unqualified name with type information.+--+-- The 'nameQualifier' is the module path (e.g., \"Data.List\"), and+-- 'nameText' is the local name (e.g., \"map\"). For unqualified names,+-- 'nameQualifier' is 'Nothing'. Example: @Data.List.map@.+data Name = Name+  { -- | Module qualifier (e.g., @\"Data.List\"@ for @Data.List.map@)+    nameQualifier :: Maybe Text,+    -- | Whether this is a variable, constructor, or operator+    nameType :: NameType,+    -- | The local name (e.g., @\"map\"@, @\".+.\"@)+    nameText :: Text,+    -- | Metadata attached to this name occurrence.+    nameAnns :: [Annotation]+  }+  deriving (Eq, Show, Generic, NFData, Data)++-- | An unqualified identifier or operator.+-- Examples: @map@, @Just@, @:+:@.+data UnqualifiedName = UnqualifiedName+  { unqualifiedNameType :: NameType,+    unqualifiedNameText :: Text,+    unqualifiedNameAnns :: [Annotation]+  }+  deriving (Eq, Show, Generic, NFData, Data)++-- | The syntactic category of a name.+data NameType+  = -- | Variable identifier (e.g., @x@, @map@, @id@)+    NameVarId+  | -- | Constructor identifier (e.g., @Just@, @Maybe@)+    NameConId+  | -- | Variable operator (e.g., @+@, @.&.@)+    NameVarSym+  | -- | Constructor operator (e.g., @:@, @:++@)+    NameConSym+  deriving (Eq, Show, Generic, NFData, Enum, Bounded, Data)++mkName :: Maybe Text -> NameType -> Text -> Name+mkName qualifier ty txt = Name qualifier ty txt []++qualifyName :: Maybe Text -> UnqualifiedName -> Name+qualifyName qualifier name =+  Name qualifier (unqualifiedNameType name) (unqualifiedNameText name) (unqualifiedNameAnns name)++mkUnqualifiedName :: NameType -> Text -> UnqualifiedName+mkUnqualifiedName ty txt = UnqualifiedName ty txt []++renderName :: Name -> Text+renderName name =+  case nameQualifier name of+    Just qualifier -> qualifier <> "." <> nameText name+    Nothing -> nameText name++renderUnqualifiedName :: UnqualifiedName -> Text+renderUnqualifiedName = unqualifiedNameText++instance IsString Name where+  fromString = nameFromText . T.pack++instance IsString UnqualifiedName where+  fromString = unqualifiedNameFromText . T.pack++nameFromText :: Text -> Name+nameFromText txt =+  let (qualifier, localName) = splitQualifiedIdentifierText txt+   in Name qualifier (inferNameType localName) localName []+  where+    splitQualifiedIdentifierText fullName =+      case T.splitOn "." fullName of+        [] -> (Nothing, fullName)+        [_] -> (Nothing, fullName)+        parts+          | all isModuleSegment (init parts) && isIdentifierSegment (last parts) ->+              (Just (T.intercalate "." (init parts)), last parts)+          | otherwise ->+              (Nothing, fullName)++    isModuleSegment segment =+      case T.uncons segment of+        Just (c, rest) -> isConIdentifierStartChar c && T.all isIdentChar rest+        Nothing -> False++    isIdentifierSegment segment =+      let magicHashes = T.takeWhileEnd (== '#') segment+          baseSegment = T.dropEnd (T.length magicHashes) segment+       in case T.uncons baseSegment of+            Just (c, rest) -> isIdentifierStartChar c && T.all isIdentChar rest+            Nothing -> False++unqualifiedNameFromText :: Text -> UnqualifiedName+unqualifiedNameFromText txt = UnqualifiedName (inferNameType txt) txt []++inferNameType :: Text -> NameType+inferNameType localName+  | isOperatorLikeText localName =+      if T.isPrefixOf ":" localName+        then NameConSym+        else NameVarSym+  | otherwise =+      case T.uncons localName of+        Just (c, _) | isConIdentifierStartChar c -> NameConId+        Just (c, _) | isIdentifierStartChar c -> NameVarId+        _ -> NameConId++isIdentChar :: Char -> Bool+isIdentChar c = isIdentifierStartChar c || isIdentifierContinueChar c || c == '\''++isIdentifierStartChar :: Char -> Bool+isIdentifierStartChar c = c == '_' || generalCategory c == LowercaseLetter || isConIdentifierStartChar c++isConIdentifierStartChar :: Char -> Bool+isConIdentifierStartChar c = generalCategory c `elem` [UppercaseLetter, TitlecaseLetter]++isIdentifierNumberChar :: Char -> Bool+isIdentifierNumberChar c =+  case generalCategory c of+    DecimalNumber -> True+    OtherNumber -> True+    _ -> False++isIdentifierContinueChar :: Char -> Bool+isIdentifierContinueChar c =+  case generalCategory c of+    LetterNumber -> True+    ModifierLetter -> True+    NonSpacingMark -> True+    _ -> isIdentifierNumberChar c++isOperatorLikeText :: Text -> Bool+isOperatorLikeText op =+  not (T.null op) && T.all isOperatorChar op++isOperatorChar :: Char -> Bool+isOperatorChar c = c `elem` (":!#$%&*+./<=>?@\\^|-~" :: String) || isUnicodeOperatorChar c++isUnicodeOperatorChar :: Char -> Bool+isUnicodeOperatorChar c =+  case generalCategory c of+    MathSymbol -> True+    CurrencySymbol -> True+    ModifierSymbol -> True+    OtherSymbol -> True+    ConnectorPunctuation -> c > '\x7f'+    DashPunctuation -> c > '\x7f'+    OtherPunctuation -> c > '\x7f'+    _ -> False++type BinderName = UnqualifiedName++type OperatorName = UnqualifiedName++-- | Strictness field pragmas.+-- Examples: @{-# UNPACK #-}@ and @{-# NOUNPACK #-}@.+data PragmaUnpackKind+  = -- | @{-# UNPACK #-}@+    UnpackPragma+  | -- | @{-# NOUNPACK #-}@+    NoUnpackPragma+  deriving (Data, Eq, Ord, Show, Read, Generic, NFData)++-- | Parsed pragma payload.+-- Examples include @{-# LANGUAGE LambdaCase #-}@, @{-# WARNING "use g" #-}@,+-- @{-# INLINE [1] f #-}@, and @{-# SCC loop #-}@.+data PragmaType+  = -- | @{-# LANGUAGE LambdaCase, NoImplicitPrelude #-}@+    PragmaLanguage [ExtensionSetting]+  | -- | @{-# OVERLAPPING #-}@ on an instance declaration.+    PragmaInstanceOverlap InstanceOverlapPragma+  | -- | @{-# WARNING "use g" #-}@+    PragmaWarning Text+  | -- | @{-# DEPRECATED "use g" #-}@+    PragmaDeprecated Text+  | -- | @{-# INLINE [1] f #-}@ or @{-# NOINLINE f #-}@.+    PragmaInline Text Text+  | -- | @{-# UNPACK #-}@ or @{-# NOUNPACK #-}@.+    PragmaUnpack PragmaUnpackKind+  | -- | @{-# SOURCE #-}@ or @{-# SOURCE "phase" #-}@.+    PragmaSource Text Text+  | -- | @{-# SCC loop #-}@+    PragmaSCC Text+  | -- | Any pragma preserved as raw text but not otherwise classified.+    PragmaUnknown Text+  deriving (Data, Eq, Ord, Show, Read, Generic, NFData)++-- | A full pragma, including its original source text.+-- Example: @{-# INLINE map #-}@.+data Pragma = Pragma+  { pragmaType :: PragmaType,+    pragmaRawText :: Text+  }+  deriving (Data, Eq, Ord, Show, Read, Generic, NFData)++-- | A whole Haskell module.+-- Example: @module M (x) where import Data.List; x = 1@.+data Module = Module+  { moduleAnns :: [Annotation],+    moduleHead :: Maybe ModuleHead,+    moduleLanguagePragmas :: [ExtensionSetting],+    moduleImports :: [ImportDecl],+    moduleDecls :: [Decl]+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | The optional @module ... where@ header.+-- Example: @module M (x, type T) where@.+data ModuleHead = ModuleHead+  { moduleHeadAnns :: [Annotation],+    moduleHeadName :: Text,+    moduleHeadWarningPragma :: Maybe Pragma,+    moduleHeadExports :: Maybe [ExportSpec]+  }+  deriving (Data, Eq, Show, Generic, NFData)++moduleName :: Module -> Maybe Text+moduleName modu = moduleHeadName <$> moduleHead modu++moduleWarningPragma :: Module -> Maybe Pragma+moduleWarningPragma modu = moduleHeadWarningPragma =<< moduleHead modu++moduleExports :: Module -> Maybe [ExportSpec]+moduleExports modu = moduleHeadExports =<< moduleHead modu++-- | Optional namespace qualifiers on import or export items.+-- Examples: @type T@, @pattern P@, @data T@.+data IEEntityNamespace+  = -- | @type T@+    IEEntityNamespaceType+  | -- | @pattern P@+    IEEntityNamespacePattern+  | -- | @data T@+    IEEntityNamespaceData+  deriving (Data, Eq, Show, Generic, NFData)++-- | Namespace qualifiers for bundled members in import and export lists.+-- Examples: @T(type (+))@ and @T(data MkT)@.+data IEBundledNamespace+  = -- | @T(type (+))@+    IEBundledNamespaceType+  | -- | @T(data MkT)@+    IEBundledNamespaceData+  deriving (Data, Eq, Show, Generic, NFData)++-- | A member bundled with a parent import or export.+-- Example: @Just@ in @Maybe(Just, Nothing)@.+data IEBundledMember = IEBundledMember+  { ieBundledMemberNamespace :: Maybe IEBundledNamespace,+    ieBundledMemberName :: Name+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | One item in a module export list.+data ExportSpec+  = -- | @module Data.List@+    ExportModule (Maybe Pragma) Text+  | -- | @map@ or @type T@+    ExportVar (Maybe Pragma) (Maybe IEEntityNamespace) Name+  | -- | @Maybe@+    ExportAbs (Maybe Pragma) (Maybe IEEntityNamespace) Name+  | -- | @Maybe(..)@+    ExportAll (Maybe Pragma) (Maybe IEEntityNamespace) Name+  | -- | @Maybe(Just, Nothing)@+    ExportWith (Maybe Pragma) (Maybe IEEntityNamespace) Name [IEBundledMember]+  | -- | @Maybe(Just, .., Nothing)@+    ExportWithAll (Maybe Pragma) (Maybe IEEntityNamespace) Name Int [IEBundledMember]+  | -- | Metadata for the whole export item.+    ExportAnn Annotation ExportSpec+  deriving (Data, Eq, Show, Generic, NFData)++-- | A module import declaration.+-- Example: @import qualified Data.Map as Map hiding (lookup)@.+data ImportDecl = ImportDecl+  { importDeclAnns :: [Annotation],+    importDeclLevel :: Maybe ImportLevel,+    importDeclPackage :: Maybe Text,+    importDeclSourcePragma :: Maybe Pragma,+    importDeclSafe :: Bool,+    importDeclQualified :: Bool,+    importDeclQualifiedPost :: Bool,+    importDeclModule :: Text,+    importDeclAs :: Maybe Text,+    importDeclSpec :: Maybe ImportSpec+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | Explicit level imports.+-- Examples: @import quote M@ and @import splice M@.+data ImportLevel+  = -- | @import quote M@+    ImportLevelQuote+  | -- | @import splice M@+    ImportLevelSplice+  deriving (Data, Eq, Show, Generic, NFData)++-- | An optional import list or hiding list.+-- Examples: @(map, foldr)@ and @hiding (map)@.+data ImportSpec = ImportSpec+  { importSpecAnns :: [Annotation],+    importSpecHiding :: Bool,+    importSpecItems :: [ImportItem]+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | One item in an import list.+data ImportItem+  = -- | @map@ or @type T@+    ImportItemVar (Maybe IEEntityNamespace) UnqualifiedName+  | -- | @Maybe@+    ImportItemAbs (Maybe IEEntityNamespace) UnqualifiedName+  | -- | @Maybe(..)@+    ImportItemAll (Maybe IEEntityNamespace) UnqualifiedName+  | -- | @Maybe(Just, Nothing)@+    ImportItemWith (Maybe IEEntityNamespace) UnqualifiedName [IEBundledMember]+  | -- | @Maybe(Just, .., Nothing)@+    ImportItemAllWith (Maybe IEEntityNamespace) UnqualifiedName Int [IEBundledMember]+  | -- | Metadata for the whole import item.+    ImportAnn Annotation ImportItem+  deriving (Data, Eq, Show, Generic, NFData)++-- | A top-level declaration.+data Decl+  = -- | Metadata for the whole declaration.+    DeclAnn Annotation Decl+  | -- | @f x = x@ or @x = 1@+    DeclValue ValueDecl+  | -- | @f, g :: Int -> Int@+    DeclTypeSig [BinderName] Type+  | -- | @pattern P x = Just x@+    DeclPatSyn PatSynDecl+  | -- | @pattern P :: a -> Maybe a@+    DeclPatSynSig [BinderName] Type+  | -- | @type T :: Type -> Type@+    DeclStandaloneKindSig BinderName Type+  | -- | @infixr 5 :+:@+    DeclFixity FixityAssoc (Maybe IEEntityNamespace) (Maybe Int) [OperatorName]+  | -- | @type role T nominal representational@+    DeclRoleAnnotation RoleAnnotation+  | -- | @type Pair a = (a, a)@+    DeclTypeSyn TypeSynDecl+  | -- | @type data Nat = Z | S Nat@+    DeclTypeData DataDecl+  | -- | @data Maybe a = Nothing | Just a@+    DeclData DataDecl+  | -- | @newtype Identity a = Identity a@+    DeclNewtype NewtypeDecl+  | -- | @class Functor f where fmap :: (a -> b) -> f a -> f b@+    DeclClass ClassDecl+  | -- | @instance Show a => Show [a] where ...@+    DeclInstance InstanceDecl+  | -- | @deriving stock instance Show a => Show (T a)@+    DeclStandaloneDeriving StandaloneDerivingDecl+  | -- | @default (Integer, Double)@+    DeclDefault [Type]+  | -- | @$decl@ or @$(decl)@+    DeclSplice Expr+  | -- | @foreign import ccall "puts" puts :: CString -> IO CInt@+    DeclForeign ForeignDecl+  | -- | @type family F a :: Type@+    DeclTypeFamilyDecl TypeFamilyDecl+  | -- | @data family DF a@+    DeclDataFamilyDecl DataFamilyDecl+  | -- | @type instance F Int = Bool@+    DeclTypeFamilyInst TypeFamilyInst+  | -- | @data instance DF Int = DFInt@+    DeclDataFamilyInst DataFamilyInst+  | -- | A standalone pragma declaration such as @{-# INLINE f #-}@.+    DeclPragma Pragma+  deriving (Data, Eq, Show, Generic, NFData)++-- | Peel nested 'DeclAnn' wrappers.+peelDeclAnn :: Decl -> Decl+peelDeclAnn (DeclAnn _ inner) = peelDeclAnn inner+peelDeclAnn d = d++-- | Multiplicity tag on a let/where pattern binding.+-- Corresponds to @x = e@ (no tag), @%1 x = e@ (linear), @%m x = e@ (explicit).+data MultiplicityTag+  = -- | @x = e@+    NoMultiplicityTag+  | -- | @%1 x = e@+    LinearMultiplicityTag+  | -- | @%m x = e@+    ExplicitMultiplicityTag Type+  deriving (Data, Eq, Show, Generic, NFData)++-- | A value binding.+data ValueDecl+  = -- | @f x y = body@+    FunctionBind BinderName [Match]+  | -- | @pat = body@ or @%1 pat = body@+    PatternBind MultiplicityTag Pattern (Rhs Expr)+  deriving (Data, Eq, Show, Generic, NFData)++-- | One equation of a function or pattern synonym.+-- Examples: @f x = x@ and @x :+: y = z@.+data Match = Match+  { matchAnns :: [Annotation],+    matchHeadForm :: MatchHeadForm,+    matchPats :: [Pattern],+    matchRhs :: Rhs Expr+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | Whether a binding head is prefix or infix.+-- Examples: @f x@ and @x :+: y@.+data MatchHeadForm+  = -- | @f x@+    MatchHeadPrefix+  | -- | @x :+: y@+    MatchHeadInfix+  deriving (Data, Eq, Show, Generic, NFData)++-- | Pattern synonym declaration direction.+data PatSynDir+  = -- | @pattern P x <- pat@+    PatSynUnidirectional+  | -- | @pattern P x = pat@+    PatSynBidirectional+  | -- | @pattern P x <- pat where P x = expr@+    PatSynExplicitBidirectional [Match]+  deriving (Data, Eq, Show, Generic, NFData)++-- | Pattern synonym argument form.+data PatSynArgs+  = -- | @pattern Name arg1 arg2 ...@+    PatSynPrefixArgs [Text]+  | -- | @pattern arg1 \`Name\` arg2@ or @pattern arg1 :+: arg2@+    PatSynInfixArgs Text Text+  | -- | @pattern Name {field1, field2}@+    PatSynRecordArgs [Text]+  deriving (Data, Eq, Show, Generic, NFData)++-- | Pattern synonym declaration.+-- Example: @pattern JustOne x = Just [x]@.+data PatSynDecl = PatSynDecl+  { patSynDeclName :: UnqualifiedName,+    patSynDeclArgs :: PatSynArgs,+    patSynDeclPat :: Pattern,+    patSynDeclDir :: PatSynDir+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | The right-hand side of a binding, case alternative, or lambda case.+data Rhs body+  = -- | @= body@ with an optional @where@ clause.+    UnguardedRhs [Annotation] body (Maybe [Decl])+  | -- | Guarded equations such as @| x > 0 = body@.+    GuardedRhss [Annotation] [GuardedRhs body] (Maybe [Decl])+  deriving (Data, Eq, Show, Generic, NFData)++-- | One guarded branch.+-- Example: @| x > 0 = x@.+data GuardedRhs body = GuardedRhs+  { guardedRhsAnns :: [Annotation],+    guardedRhsGuards :: [GuardQualifier],+    guardedRhsBody :: body+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | A single qualifier inside a guarded right-hand side.+data GuardQualifier+  = -- | Metadata for the whole guard qualifier (typically a 'SourceSpan' via 'mkAnnotation').+    GuardAnn Annotation GuardQualifier+  | -- | @x > 0@+    GuardExpr Expr+  | -- | @Just y <- mx@+    GuardPat Pattern Expr+  | -- | @let y = f x@+    GuardLet [Decl]+  deriving (Data, Eq, Show, Generic, NFData)++peelGuardQualifierAnn :: GuardQualifier -> GuardQualifier+peelGuardQualifierAnn (GuardAnn _ inner) = peelGuardQualifierAnn inner+peelGuardQualifierAnn q = q++-- | A literal token.+data Literal+  = -- | Metadata for the whole literal.+    LitAnn Annotation Literal+  | -- | @1@, @1#@, @1#Word8@+    LitInt Integer NumericType Text+  | -- | @1.0@, @1.0#@, @1.0##@+    LitFloat Rational FloatType Text+  | -- | @'x'@+    LitChar Char Text+  | -- | @'x'#@+    LitCharHash Char Text+  | -- | @"hello"@+    LitString Text Text+  | -- | @"hello"#@+    LitStringHash Text Text+  deriving (Data, Eq, Show, Generic, NFData)++literalAnnSpan :: SourceSpan -> Literal -> Literal+literalAnnSpan sp = LitAnn (mkAnnotation sp)++peelLiteralAnn :: Literal -> Literal+peelLiteralAnn (LitAnn _ inner) = peelLiteralAnn inner+peelLiteralAnn lit = lit++-- | Whether tuple syntax is boxed or unboxed.+-- Examples: @(a, b)@ and @(# a, b #)@.+data TupleFlavor+  = -- | @(a, b)@+    Boxed+  | -- | @(# a, b #)@+    Unboxed+  deriving (Data, Eq, Show, Generic, NFData)++-- | One record field occurrence.+-- Examples: @x = 1@ in @T { x = 1 }@ and @x@ in @T { x }@.+data RecordField a = RecordField+  { recordFieldName :: Name,+    recordFieldValue :: a,+    recordFieldPun :: Bool+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | A pattern.+data Pattern+  = -- | Metadata for the whole pattern.+    PAnn Annotation Pattern+  | -- | @x@+    PVar UnqualifiedName+  | -- | @\@a@ in a required type argument pattern.+    PTypeBinder TyVarBinder+  | -- | @type T@ in a term-level pattern position.+    PTypeSyntax TypeSyntaxForm Type+  | -- | @_@+    PWildcard+  | -- | @1@ or @'x'@+    PLit Literal+  | -- | @[p| body |]@+    PQuasiQuote Text Text+  | -- | @(p1, p2)@ or @(# p1, p2 #)@+    PTuple TupleFlavor [Pattern]+  | -- | @(# | p | #)@+    PUnboxedSum Int Int Pattern+  | -- | @[p1, p2]@+    PList [Pattern]+  | -- | @Just x@ or @Proxy \@Type@+    PCon Name [Type] [Pattern]+  | -- | @x :+: y@+    PInfix Pattern Name Pattern+  | -- | @(view -> pat)@+    PView Expr Pattern+  | -- | @name\@pat@+    PAs UnqualifiedName Pattern+  | -- | @!pat@+    PStrict Pattern+  | -- | @~pat@+    PIrrefutable Pattern+  | -- | @-1@+    PNegLit Literal+  | -- | @(pat)@+    PParen Pattern+  | -- | @T { x = p, y, .. }@+    PRecord Name [RecordField Pattern] Bool -- Bool: wildcard present+  | -- | @(pat :: ty)@+    PTypeSig Pattern Type+  | -- | @$pat@ or @$(pat)@+    PSplice Expr+  -- \$pat or $(pat) (TH pattern splice)+  deriving (Data, Eq, Show, Generic, NFData)++-- | Peel nested 'PAnn' wrappers.+peelPatternAnn :: Pattern -> Pattern+peelPatternAnn (PAnn _ inner) = peelPatternAnn inner+peelPatternAnn p = p++-- | How type syntax appears in a term or pattern position.+-- Examples: @type T@ and @f (type T)@.+data TypeSyntaxForm+  = -- | The explicit @type@ namespace, as in @type T@.+    TypeSyntaxExplicitNamespace+  | -- | Type syntax embedded in term syntax, as in @f (type T)@.+    TypeSyntaxInTerm+  deriving (Data, Eq, Show, Generic, NFData)++-- | Whether a @forall@ telescope is invisible or visible.+-- Examples: @forall a. ...@ and @forall a -> ...@.+data ForallVis+  = -- | @forall a. ...@+    ForallInvisible+  | -- | @forall a -> ...@+    ForallVisible+  deriving (Data, Eq, Show, Generic, NFData)++-- | The binders introduced by a @forall@.+-- Example: @forall a b. a -> b -> a@.+data ForallTelescope = ForallTelescope+  { forallTelescopeVisibility :: ForallVis,+    forallTelescopeBinders :: [TyVarBinder]+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | The kind of a function arrow.+-- @ArrowUnrestricted@ is the ordinary @->@.+-- @ArrowLinear@ is @%1 ->@ (or its Unicode equivalent @⊸@).+-- @ArrowExplicit ty@ is @%m ->@ for an arbitrary multiplicity type @m@.+data ArrowKind+  = ArrowUnrestricted+  | ArrowLinear+  | ArrowExplicit Type+  deriving (Data, Eq, Show, Generic, NFData)++-- | A type.+data Type+  = -- | Metadata for the whole type.+    TAnn Annotation Type+  | -- | @a@+    TVar UnqualifiedName+  | -- | @Maybe@ or @'Just@+    TCon Name TypePromotion+  | -- | @(,)@, @(->)@, @[]@, or @(:)@+    TBuiltinCon TypeBuiltinCon+  | -- | @(?x :: Int) => Int@+    TImplicitParam Text Type+  | -- | @1@, @"x"@, or @'c'@ at the type level.+    TTypeLit TypeLiteral+  | -- | @*@ as written source syntax.+    TStar Text+  | -- | @[t| body |]@+    TQuasiQuote Text Text+  | -- | @forall a. ty@+    TForall ForallTelescope Type+  | -- | @Maybe a@+    TApp Type Type+  | -- | @Proxy \@Type@+    TTypeApp Type Type+  | -- | @a :+: b@+    TInfix Type Name TypePromotion Type+  | -- | @a -> b@, @a %1 -> b@, or @a %m -> b@+    TFun ArrowKind Type Type+  | -- | @(a, b)@, @'(a, b)@, or @(# a, b #)@+    TTuple TupleFlavor TypePromotion [Type]+  | -- | @(# a | b #)@+    TUnboxedSum [Type]+  | -- | @[a]@ or @'[a, b]@+    TList TypePromotion [Type]+  | -- | @(ty)@+    TParen Type+  | -- | @(a :: Type)@+    TKindSig Type Type+  | -- | @(Show a, Eq a) => a -> String@+    TContext [Type] Type+  | -- | @$typ@ or @$(typ)@+    TSplice Expr+  | -- \$typ or $(typ) (TH type splice)+    -- \_ (wildcard type, used in type family instance patterns)+    TWildcard+  deriving (Data, Eq, Show, Generic, NFData)++-- | Built-in type constructors that have dedicated surface syntax.+-- Examples: @(,)@, @(->)@, @[]@, and @(:)@.+data TypeBuiltinCon+  = -- | An @n@-tuple constructor like @(,)@ or @(,,)@.+    TBuiltinTuple Int+  | -- | @(->)@+    TBuiltinArrow+  | -- | @[]@+    TBuiltinList+  | -- | @(:)@+    TBuiltinCons+  deriving (Data, Eq, Show, Generic, NFData)++typeAnnSpan :: SourceSpan -> Type -> Type+typeAnnSpan sp = TAnn (mkAnnotation sp)++-- | Peel nested 'TAnn' wrappers (e.g. span-only dynamic annotations).+peelTypeAnn :: Type -> Type+peelTypeAnn (TAnn _ inner) = peelTypeAnn inner+peelTypeAnn t = t++-- | Peel 'TAnn' then 'TParen' (used when matching on type shape under annotations+-- and explicit parentheses).+peelTypeHead :: Type -> Type+peelTypeHead (TAnn _ inner) = peelTypeHead inner+peelTypeHead (TParen inner) = peelTypeHead inner+peelTypeHead ty = ty++-- | A type-level literal.+-- Examples: @1@, @"name"@, and @'x'@ in types.+data TypeLiteral+  = -- | @1@+    TypeLitInteger Integer Text+  | -- | @"name"@+    TypeLitSymbol Text Text+  | -- | @'x'@+    TypeLitChar Char Text+  deriving (Data, Eq, Show, Generic, NFData)++-- | Numeric type suffix for integer literals.+-- Corresponds to the ExtendedLiterals extension (GHC 9.8+).+-- Examples: @1@ -> TInteger, @1#@ -> TIntHash, @1#Word8@ -> TWord8Hash+data NumericType+  = TInteger+  | TIntHash+  | TWordHash+  | TInt8Hash+  | TInt16Hash+  | TInt32Hash+  | TInt64Hash+  | TWord8Hash+  | TWord16Hash+  | TWord32Hash+  | TWord64Hash+  deriving (Data, Eq, Ord, Show, Read, Generic, NFData)++-- | Float type suffix for fractional literals.+-- Examples: @1.0@, @1.0#@, @1.0##@.+data FloatType+  = TFractional+  | TFloatHash+  | TDoubleHash+  deriving (Data, Eq, Ord, Show, Read, Generic, NFData)++-- | Whether list, tuple, and constructor syntax is promoted with a leading quote.+-- Examples: @Maybe@ versus @'Just@, @[a]@ versus @'[a]@.+data TypePromotion+  = -- | Ordinary type syntax such as @Maybe@ or @[a]@.+    Unpromoted+  | -- | Promoted syntax such as @'Just@ or @'[a]@.+    Promoted+  deriving (Data, Eq, Show, Generic, NFData)++-- | Whether a type-variable binder was written as inferred or specified.+-- Examples: @{a}@ versus @a@.+data TyVarBSpecificity+  = -- | @{a}@ or @{a :: k}@+    TyVarBInferred+  | -- | @a@ or @(a :: k)@+    TyVarBSpecified+  deriving (Data, Eq, Show, Generic, NFData)++-- | Whether a type-variable binder is visible or invisible.+-- Examples: @a@ versus @@a@.+data TyVarBVisibility+  = -- | @a@+    TyVarBVisible+  | -- | @@a@+    TyVarBInvisible+  deriving (Data, Eq, Show, Generic, NFData)++-- | One type-variable binder.+-- Examples: @a@, @(a :: Type)@, @{a}@, and @@k@.+data TyVarBinder = TyVarBinder+  { tyVarBinderAnns :: [Annotation],+    tyVarBinderName :: Text,+    -- | Optional kind annotation. Examples: @(a :: Type)@ and @{a :: Type}@.+    tyVarBinderKind :: Maybe Type,+    -- | Whether the binder was written as specified (@a@, @(a :: k)@)+    -- or inferred (@{a}@, @{a :: k}@).+    tyVarBinderSpecificity :: TyVarBSpecificity,+    -- | Whether the binder was written visibly (@a@) or invisibly (@@a@).+    tyVarBinderVisibility :: TyVarBVisibility+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | Whether a type or binder head is prefix or infix.+-- Examples: @T a@ versus @a :+: b@.+data TypeHeadForm+  = -- | @T a@+    TypeHeadPrefix+  | -- | @a :+: b@+    TypeHeadInfix+  deriving (Data, Eq, Show, Generic, NFData)++-- | The head of a declaration that binds a type constructor or class.+data BinderHead name+  = -- | @T a b@+    PrefixBinderHead name [TyVarBinder]+  | -- | @a :+: b@+    InfixBinderHead TyVarBinder name TyVarBinder [TyVarBinder]+  deriving (Data, Eq, Show, Generic, NFData)++binderHeadForm :: BinderHead name -> TypeHeadForm+binderHeadForm head' =+  case head' of+    PrefixBinderHead {} -> TypeHeadPrefix+    InfixBinderHead {} -> TypeHeadInfix++binderHeadName :: BinderHead name -> name+binderHeadName head' =+  case head' of+    PrefixBinderHead name _ -> name+    InfixBinderHead _ name _ _ -> name++binderHeadParams :: BinderHead name -> [TyVarBinder]+binderHeadParams head' =+  case head' of+    PrefixBinderHead _ params -> params+    InfixBinderHead lhs _ rhs tailParams -> lhs : rhs : tailParams++-- | Instance heads are stored as ordinary types.  Parenthesisation is+-- captured naturally via 'TParen' nodes, so a separate 'Bool' flag is+-- unnecessary.  The class name and type arguments can be extracted from+-- the spine when needed (see 'instanceHeadName', 'instanceHeadTypes').+type InstanceHeadType = Type++-- | Extract the class name from an instance head type by walking the+-- application spine down to the leftmost atom, peeling through 'TParen'+-- and 'TAnn' nodes.+--+-- >>> fmap renderName $ instanceHeadName (TApp (TCon "C" Unpromoted) (TVar "a"))+-- Just "C"+-- >>> fmap renderName $ instanceHeadName (TInfix (TVar "a") ":=>" Unpromoted (TVar "b"))+-- Just ":=>"+instanceHeadName :: Type -> Maybe Name+instanceHeadName = go+  where+    go (TAnn _ t) = go t+    go (TApp f _) = go f+    go (TTypeApp f _) = go f+    go (TParen t) = go t+    go (TCon name _) = Just name+    go (TInfix _ name _ _) = Just name+    go _ = Nothing++-- | Extract the type arguments from an instance head type.+--+-- For prefix application spines like @TApp (TApp (TCon C) a) b@, returns+-- @[a, b]@.  For infix heads like @TInfix a op b@, returns @[a, b]@.+instanceHeadTypes :: Type -> [Type]+instanceHeadTypes = go []+  where+    go acc (TAnn _ t) = go acc t+    go acc (TApp f arg) = go (arg : acc) f+    go acc (TTypeApp f _) = go acc f+    go acc (TParen t) = go acc t+    go _ (TInfix lhs _ _ rhs) = [lhs, rhs]+    go acc _ = acc++-- | Roles used in @type role@ annotations.+-- Examples: @nominal@, @representational@, @phantom@, and @_@.+data Role+  = -- | @nominal@+    RoleNominal+  | -- | @representational@+    RoleRepresentational+  | -- | @phantom@+    RolePhantom+  | -- | @_@+    RoleInfer+  deriving (Data, Eq, Show, Generic, NFData)++-- | A @type role@ declaration.+-- Example: @type role T nominal representational@.+data RoleAnnotation = RoleAnnotation+  { roleAnnotationName :: UnqualifiedName,+    roleAnnotationRoles :: [Role]+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | A @type@ synonym declaration.+-- Example: @type Pair a = (a, a)@.+data TypeSynDecl = TypeSynDecl+  { typeSynHead :: BinderHead UnqualifiedName,+    typeSynBody :: Type+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | Open or closed type synonym family declaration.+-- Used for top-level @type family F a@ and associated @type F a :: Kind@ in class bodies.+-- Examples: @type family F a :: Type@ and+-- @type family F a where F Int = Bool@.+data TypeFamilyDecl = TypeFamilyDecl+  { typeFamilyDeclHeadForm :: TypeHeadForm,+    typeFamilyDeclExplicitFamilyKeyword :: Bool,+    -- | Family head type. For simple families like @type family F a@, this is @TCon "F"@.+    -- For infix families like @type family l `And` r@, this is the full infix type.+    typeFamilyDeclHead :: Type,+    typeFamilyDeclParams :: [TyVarBinder],+    -- | Optional result signature, either an unnamed kind annotation (@:: Kind@)+    -- or a named result variable with injectivity annotation (@= r | r -> a@).+    typeFamilyDeclResultSig :: Maybe TypeFamilyResultSig,+    -- | @Nothing@ = open family; @Just eqs@ = closed family with equations+    typeFamilyDeclEquations :: Maybe [TypeFamilyEq]+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | The result signature on a type family head.+data TypeFamilyResultSig+  = -- | @type family F a :: Type@+    TypeFamilyKindSig Type+  | -- | @type family F a = r@+    TypeFamilyTyVarSig TyVarBinder+  | -- | @type family F a = r | r -> a@+    TypeFamilyInjectiveSig TyVarBinder TypeFamilyInjectivity+  deriving (Data, Eq, Show, Generic, NFData)++-- | The injectivity annotation in a type family result signature.+-- Example: @r -> a b@ in @type family F a b = r | r -> a b@.+data TypeFamilyInjectivity = TypeFamilyInjectivity+  { typeFamilyInjectivityAnns :: [Annotation],+    typeFamilyInjectivityResult :: Text,+    typeFamilyInjectivityDetermined :: [Text]+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | One equation in a closed type family: @[forall binders.] LhsType = RhsType@+-- Example: @forall a. F [a] = Maybe a@.+data TypeFamilyEq = TypeFamilyEq+  { typeFamilyEqAnns :: [Annotation],+    typeFamilyEqForall :: [TyVarBinder],+    typeFamilyEqHeadForm :: TypeHeadForm,+    typeFamilyEqLhs :: Type,+    typeFamilyEqRhs :: Type+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | Data family declaration (standalone or associated in a class body).+-- Example: @data family DF a :: Type@.+data DataFamilyDecl = DataFamilyDecl+  { dataFamilyDeclHead :: BinderHead UnqualifiedName,+    -- | Optional result kind annotation (@:: Kind@)+    dataFamilyDeclKind :: Maybe Type+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | Type family instance: @type [instance] [forall binders.] LhsType = RhsType@+-- Example: @type instance F Int = Bool@.+data TypeFamilyInst = TypeFamilyInst+  { typeFamilyInstForall :: [TyVarBinder],+    typeFamilyInstHeadForm :: TypeHeadForm,+    typeFamilyInstLhs :: Type,+    typeFamilyInstRhs :: Type+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | Data or newtype family instance (standalone or in an instance body).+-- Examples: @data instance DF Int = DFInt@ and+-- @newtype instance DF Bool = DFBool Bool@.+data DataFamilyInst = DataFamilyInst+  { -- | @True@ when declared with @newtype instance@+    dataFamilyInstIsNewtype :: Bool,+    dataFamilyInstForall :: [TyVarBinder],+    -- | The LHS type-application pattern (e.g. @GMap (Either a b) v@)+    dataFamilyInstHead :: Type,+    -- | Optional inline result kind annotation (@:: Kind@) before @=@ or @where@+    dataFamilyInstKind :: Maybe Type,+    dataFamilyInstConstructors :: [DataConDecl],+    dataFamilyInstDeriving :: [DerivingClause]+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | A @data@ or @type data@ declaration body.+-- Examples: @data Maybe a = Nothing | Just a@ and @type data Nat = Z | S Nat@.+data DataDecl = DataDecl+  { dataDeclCTypePragma :: Maybe Pragma,+    dataDeclHead :: BinderHead UnqualifiedName,+    dataDeclContext :: [Type],+    -- | Optional inline kind annotation (@:: Kind@) before @=@ or @where@+    dataDeclKind :: Maybe Type,+    dataDeclConstructors :: [DataConDecl],+    dataDeclDeriving :: [DerivingClause]+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | A @newtype@ declaration.+-- Example: @newtype Identity a = Identity a@.+data NewtypeDecl = NewtypeDecl+  { newtypeDeclCTypePragma :: Maybe Pragma,+    newtypeDeclHead :: BinderHead UnqualifiedName,+    newtypeDeclContext :: [Type],+    -- | Optional inline kind annotation (@:: Kind@) before @=@ or @where@+    newtypeDeclKind :: Maybe Type,+    newtypeDeclConstructor :: Maybe DataConDecl,+    newtypeDeclDeriving :: [DerivingClause]+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | A data constructor declaration.+data DataConDecl+  = -- | Metadata for the whole constructor declaration (typically a 'SourceSpan' via 'mkAnnotation').+    DataConAnn Annotation DataConDecl+  | -- | @Just a@+    PrefixCon [TyVarBinder] [Type] UnqualifiedName [BangType]+  | -- | @a :+: b@+    InfixCon [TyVarBinder] [Type] BangType UnqualifiedName BangType+  | -- | @MkT { x :: Int, y :: Bool }@+    RecordCon [TyVarBinder] [Type] UnqualifiedName [FieldDecl]+  | -- | GADT-style constructor: @Con :: forall a. Ctx => Type@+    -- The list of names supports multiple constructors: @T1, T2 :: Type@+    GadtCon [ForallTelescope] [Type] [UnqualifiedName] GadtBody+  | -- | Tuple-style constructor: @()@, @(a,b)@, @(# #)@, @(# a,b #)@+    TupleCon [TyVarBinder] [Type] TupleFlavor [BangType]+  | -- | Unboxed sum constructor: @(# a | #)@, @(# | b #)@+    -- Fields: forall vars, context, position (1-based), total arity, field type+    UnboxedSumCon [TyVarBinder] [Type] Int Int BangType+  | -- | List constructor: @[]@+    ListCon [TyVarBinder] [Type]+  deriving (Data, Eq, Show, Generic, NFData)++-- | Strip nested 'DataConAnn' wrappers.+peelDataConAnn :: DataConDecl -> DataConDecl+peelDataConAnn (DataConAnn _ inner) = peelDataConAnn inner+peelDataConAnn d = d++-- | Body of a GADT constructor after the @::@ and optional forall/context+-- Examples: @MkT :: a -> T a@ and @MkT :: { field :: a } -> T a@.+data GadtBody+  = -- | Prefix body: each argument is paired with its outgoing arrow kind.+    -- E.g. @a -> b %1 -> T a@ gives @[(a, ArrowUnrestricted), (b, ArrowLinear)]@ with result @T a@.+    GadtPrefixBody [(BangType, ArrowKind)] Type+  | -- | Record body: @{ field :: Type } -> T a@+    GadtRecordBody [FieldDecl] Type+  deriving (Data, Eq, Show, Generic, NFData)++-- | Get the result type from a GADT body+gadtBodyResultType :: GadtBody -> Type+gadtBodyResultType body =+  case body of+    GadtPrefixBody _ ty -> ty+    GadtRecordBody _ ty -> ty++-- | A field or constructor argument type with strictness/laziness markers.+-- Examples: @a@, @!a@, @~a@, and @{-# UNPACK #-} !Int@.+data BangType = BangType+  { bangAnns :: [Annotation],+    bangPragmas :: [Pragma],+    bangStrict :: Bool,+    bangLazy :: Bool,+    bangType :: Type+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | A record field declaration.+-- Example: @x, y :: Int@ in @data T = MkT { x, y :: Int }@.+data FieldDecl = FieldDecl+  { fieldAnns :: [Annotation],+    fieldNames :: [UnqualifiedName],+    -- | Optional multiplicity annotation, e.g. @x %'Many :: a@.+    fieldMultiplicity :: Maybe Type,+    fieldType :: BangType+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | One @deriving@ clause.+-- Examples: @deriving Show@ and @deriving stock (Eq, Ord)@.+data DerivingClause = DerivingClause+  { derivingStrategy :: Maybe DerivingStrategy,+    derivingClasses :: Either Name [Type]+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | An explicit deriving strategy.+data DerivingStrategy+  = -- | @deriving stock Show@+    DerivingStock+  | -- | @deriving newtype Num@+    DerivingNewtype+  | -- | @deriving anyclass C@+    DerivingAnyclass+  | -- | @deriving via Wrapper T@+    DerivingVia Type+  deriving (Data, Eq, Show, Generic, NFData)++-- | A standalone deriving declaration.+-- Example: @deriving stock instance Show a => Show (T a)@.+data StandaloneDerivingDecl = StandaloneDerivingDecl+  { standaloneDerivingStrategy :: Maybe DerivingStrategy,+    standaloneDerivingPragmas :: [Pragma],+    standaloneDerivingWarning :: Maybe Pragma,+    standaloneDerivingForall :: [TyVarBinder],+    standaloneDerivingContext :: [Type],+    standaloneDerivingHead :: InstanceHeadType+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | A class declaration.+-- Example: @class (Eq a) => C a where f :: a -> Bool@.+data ClassDecl = ClassDecl+  { classDeclContext :: Maybe [Type],+    classDeclHead :: BinderHead UnqualifiedName,+    classDeclFundeps :: [FunctionalDependency],+    classDeclItems :: [ClassDeclItem]+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | A functional dependency.+-- Example: @a -> b@ in @class C a b | a -> b@.+data FunctionalDependency = FunctionalDependency+  { functionalDependencyAnns :: [Annotation],+    functionalDependencyDeterminers :: [Text],+    functionalDependencyDetermined :: [Text]+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | An item inside a class body.+data ClassDeclItem+  = -- | Metadata for the whole class item.+    ClassItemAnn Annotation ClassDeclItem+  | -- | @f :: a -> Bool@+    ClassItemTypeSig [BinderName] Type+  | -- | @default f :: Show a => a -> String@+    ClassItemDefaultSig BinderName Type+  | -- | @infixr 5 :+:@+    ClassItemFixity FixityAssoc (Maybe IEEntityNamespace) (Maybe Int) [OperatorName]+  | -- | A default method body such as @f x = True@.+    ClassItemDefault ValueDecl+  | -- | @type family F a@+    ClassItemTypeFamilyDecl TypeFamilyDecl+  | -- | @data family DF a@+    ClassItemDataFamilyDecl DataFamilyDecl+  | -- | @type F Int = Bool@+    ClassItemDefaultTypeInst TypeFamilyInst+  | -- | A pragma inside the class body, such as @{-# MINIMAL f #-}@.+    ClassItemPragma Pragma+  deriving (Data, Eq, Show, Generic, NFData)++peelClassDeclItemAnn :: ClassDeclItem -> ClassDeclItem+peelClassDeclItemAnn (ClassItemAnn _ inner) = peelClassDeclItemAnn inner+peelClassDeclItemAnn item = item++-- | An instance declaration.+-- Example: @instance Show a => Show [a] where show = ...@.+data InstanceDecl = InstanceDecl+  { instanceDeclPragmas :: [Pragma],+    instanceDeclWarning :: Maybe Pragma,+    instanceDeclForall :: [TyVarBinder],+    instanceDeclContext :: [Type],+    instanceDeclHead :: InstanceHeadType,+    instanceDeclItems :: [InstanceDeclItem]+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | The pragma controlling instance overlap.+-- Examples: @{-# OVERLAPPING #-}@ and @{-# INCOHERENT #-}@.+data InstanceOverlapPragma+  = -- | @{-# OVERLAPPING #-}@+    Overlapping+  | -- | @{-# OVERLAPPABLE #-}@+    Overlappable+  | -- | @{-# OVERLAPS #-}@+    Overlaps+  | -- | @{-# INCOHERENT #-}@+    Incoherent+  deriving (Data, Eq, Ord, Show, Read, Generic, NFData)++-- | An item inside an instance body.+data InstanceDeclItem+  = -- | Metadata for the whole instance item (typically a 'SourceSpan' via 'mkAnnotation').+    InstanceItemAnn Annotation InstanceDeclItem+  | -- | A method body such as @show x = ...@+    InstanceItemBind ValueDecl+  | -- | @show :: T -> String@+    InstanceItemTypeSig [BinderName] Type+  | -- | @infixr 5 :+:@+    InstanceItemFixity FixityAssoc (Maybe IEEntityNamespace) (Maybe Int) [OperatorName]+  | -- | @type F Int = Bool@+    InstanceItemTypeFamilyInst TypeFamilyInst+  | -- | @data instance DF Int = DFInt@+    InstanceItemDataFamilyInst DataFamilyInst+  | -- pragma inside instance body (e.g. {-# SPECIALIZE instance ... #-})+    InstanceItemPragma Pragma+  deriving (Data, Eq, Show, Generic, NFData)++peelInstanceDeclItemAnn :: InstanceDeclItem -> InstanceDeclItem+peelInstanceDeclItemAnn (InstanceItemAnn _ inner) = peelInstanceDeclItemAnn inner+peelInstanceDeclItemAnn item = item++-- | Fixity associativity declarations.+-- Examples: @infix@, @infixl@, and @infixr@.+data FixityAssoc+  = -- | @infix@+    Infix+  | -- | @infixl@+    InfixL+  | -- | @infixr@+    InfixR+  deriving (Data, Eq, Show, Generic, NFData)++-- | A foreign import or export declaration.+-- Example: @foreign import ccall "puts" puts :: CString -> IO CInt@.+data ForeignDecl = ForeignDecl+  { foreignDirection :: ForeignDirection,+    foreignCallConv :: CallConv,+    foreignSafety :: Maybe ForeignSafety,+    foreignEntity :: ForeignEntitySpec,+    foreignName :: UnqualifiedName,+    foreignType :: Type+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | The entity part of a foreign declaration.+data ForeignEntitySpec+  = -- | @foreign import ccall "dynamic" ...@+    ForeignEntityDynamic+  | -- | @foreign import ccall "wrapper" ...@+    ForeignEntityWrapper+  | -- | @foreign import ccall "static foo" ...@+    ForeignEntityStatic (Maybe Text)+  | -- | @foreign import ccall "&foo" ...@+    ForeignEntityAddress (Maybe Text)+  | -- | @foreign import ccall "foo" ...@+    ForeignEntityNamed Text+  | -- | No explicit entity string, as in @foreign import ccall foo :: ...@.+    ForeignEntityOmitted+  deriving (Data, Eq, Show, Generic, NFData)++-- | Whether a foreign declaration imports or exports a symbol.+-- Examples: @foreign import@ and @foreign export@.+data ForeignDirection+  = -- | @foreign import ...@+    ForeignImport+  | -- | @foreign export ...@+    ForeignExport+  deriving (Data, Eq, Show, Generic, NFData)++-- | The calling convention used by a foreign declaration.+-- Examples: @ccall@, @stdcall@, @capi@, @prim@, and @javascript@.+data CallConv+  = -- | @ccall@+    CCall+  | -- | @stdcall@+    StdCall+  | -- | @capi@+    CApi+  | -- | @prim@+    CPrim+  | -- | @javascript@+    JavaScript+  deriving (Data, Eq, Show, Generic, NFData)++-- | Optional foreign-call safety annotations.+-- Examples: @safe@, @unsafe@, and @interruptible@.+data ForeignSafety+  = -- | @safe@+    Safe+  | -- | @unsafe@+    Unsafe+  | -- | @interruptible@+    Interruptible+  deriving (Data, Eq, Show, Generic, NFData)++-- | Opaque metadata attached to syntax nodes.+-- Example: a stored 'SourceSpan' created with 'mkAnnotation'.+newtype Annotation = Annotation Dynamic+  deriving (Show, Generic)++mkAnnotation :: (Typeable a) => a -> Annotation+mkAnnotation = Annotation . toDyn++fromAnnotation :: (Typeable a) => Annotation -> Maybe a+fromAnnotation (Annotation value) = fromDynamic value++instance Data Annotation where+  gfoldl _ z = z+  gunfold _ z _ = z (Annotation (toDyn ()))+  toConstr _ = annotationConstr+  dataTypeOf _ = annotationDataType++annotationConstr :: Constr+annotationConstr = mkConstr annotationDataType "Annotation" [] Prefix++annotationDataType :: DataType+annotationDataType = mkDataType "Aihc.Parser.Syntax.Annotation" [annotationConstr]++instance Eq Annotation where+  _ == _ = True++instance NFData Annotation where+  rnf (Annotation _) = ()++-- | An expression.+data Expr+  = -- | Metadata for the whole expression.+    EAnn Annotation Expr+  | -- | @x@ or @Data.List.map@+    EVar Name+  | -- | @type T@ in a term position.+    ETypeSyntax TypeSyntaxForm Type+  | -- | @1@, @1#@, @1#Word8@+    EInt Integer NumericType Text+  | -- | @1.0@, @1.0#@, @1.0##@+    EFloat Rational FloatType Text+  | -- | @'x'@+    EChar Char Text+  | -- | @'x'#@+    ECharHash Char Text+  | -- | @"hello"@+    EString Text Text+  | -- | @"hello"#@+    EStringHash Text Text+  | -- | @#name@+    EOverloadedLabel Text Text+  | -- | @[qq| body |]@+    EQuasiQuote Text Text+  | -- | @if c then t else e@+    EIf Expr Expr Expr+  | -- | @if | g1 -> e1 | g2 -> e2@+    EMultiWayIf [GuardedRhs Expr]+  | -- | @\x y -> body@+    ELambdaPats [Pattern] Expr+  | -- | @\case { p -> e }@+    ELambdaCase [CaseAlt Expr]+  | -- | @\cases { p q -> e }@+    ELambdaCases [LambdaCaseAlt]+  | -- | @a + b@+    EInfix Expr Name Expr+  | -- | @-x@+    ENegate Expr+  | -- | @(x +)@+    ESectionL Expr Name+  | -- | @(+ x)@+    ESectionR Name Expr+  | -- | @let x = 1 in x@+    ELetDecls [Decl] Expr+  | -- | @case x of { Just y -> y }@+    ECase Expr [CaseAlt Expr]+  | -- | @do { x <- mx; pure x }@, @mdo { ... }@, or @M.do { ... }@+    EDo [DoStmt Expr] DoFlavor+  | -- | @[x | x <- xs, x > 0]@+    EListComp Expr [CompStmt]+  | -- | @[x + y | x <- xs | y <- ys]@+    EListCompParallel Expr [[CompStmt]]+  | -- | @[1,3 .. 9]@+    EArithSeq ArithSeq+  | -- | @T { x = 1, y, .. }@+    ERecordCon Name [RecordField Expr] Bool -- Bool: wildcard present+  | -- | @r { x = 1 }@+    ERecordUpd Expr [RecordField Expr]+  | -- | @a.b@+    EGetField Expr Name -- a.b (OverloadedRecordDot)+  | -- | @(.b)@ or @(.b.c)@+    EGetFieldProjection [Name] -- (.b) or (.b.c) projection section (OverloadedRecordDot)+  | -- | @(expr :: ty)@+    ETypeSig Expr Type+  | -- | @(expr)@+    EParen Expr+  | -- | @[x, y]@+    EList [Expr]+  | -- | @(x, y)@, @(, y)@, or @(# x | #)@+    ETuple TupleFlavor [Maybe Expr]+  | -- | @(# | x | #)@+    EUnboxedSum Int Int Expr+  | -- | @f \@Type@+    ETypeApp Expr Type+  | -- | @f x@+    EApp Expr Expr+  | -- Template Haskell quotes++    -- | @[| expr |]@ or @[e| expr |]@+    ETHExpQuote Expr+  | -- | @[|| expr ||]@ or @[e|| expr ||]@+    ETHTypedQuote Expr+  | -- | @[d| decls |]@+    ETHDeclQuote [Decl]+  | -- | @[t| type |]@+    ETHTypeQuote Type+  | -- | @[p| pat |]@+    ETHPatQuote Pattern+  | -- | @'expr@ in the term namespace.+    ETHNameQuote Expr+  | -- | @''Type@ in the type namespace.+    ETHTypeNameQuote Type+  | -- Template Haskell splices++    -- | @$expr@ or @$(expr)@+    ETHSplice Expr+  | -- | @$$expr@ or @$$(expr)@+    ETHTypedSplice Expr+  | -- Arrow notation (Arrows extension)++    -- | @proc pat -> cmd@+    EProc Pattern Cmd+  | -- | @{-# SCC foo #-} expr@+    EPragma Pragma Expr+  deriving (Data, Eq, Show, Generic, NFData)++-- | Peel nested 'EAnn' layers (e.g. span-only dynamic annotations).+peelExprAnn :: Expr -> Expr+peelExprAnn (EAnn _ x) = peelExprAnn x+peelExprAnn x = x++-- | One @case@ or @\case@ alternative.+-- Example: @Just x -> x@.+data CaseAlt body = CaseAlt+  { caseAltAnns :: [Annotation],+    caseAltPattern :: Pattern,+    caseAltRhs :: Rhs body+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | One multi-argument @\cases@ alternative.+-- Example: @Just x y -> x + y@.+data LambdaCaseAlt = LambdaCaseAlt+  { lambdaCaseAltAnns :: [Annotation],+    lambdaCaseAltPats :: [Pattern],+    lambdaCaseAltRhs :: Rhs Expr+  }+  deriving (Data, Eq, Show, Generic, NFData)++-- | The keyword that introduces a @do@-like block.+-- Examples: @do@, @mdo@, @M.do@, and @M.mdo@.+data DoFlavor+  = -- | @do { stmts }@+    DoPlain+  | -- | @mdo { stmts }@+    DoMdo+  | -- | @M.do { stmts }@ (QualifiedDo)+    DoQualified Text+  | -- | @M.mdo { stmts }@ (QualifiedDo + RecursiveDo)+    DoQualifiedMdo Text+  deriving (Data, Eq, Show, Generic, NFData)++-- | A statement inside a @do@ block.+data DoStmt body+  = -- | Metadata for the whole do-statement (typically a 'SourceSpan' via 'mkAnnotation').+    DoAnn Annotation (DoStmt body)+  | -- | @pat <- expr@+    DoBind Pattern body+  | -- | @let decls@+    DoLetDecls [Decl]+  | -- | A bare expression statement such as @print x@.+    DoExpr body+  | -- | @rec { stmts }@+    DoRecStmt [DoStmt body] -- rec { stmts }+  deriving (Data, Eq, Show, Generic, NFData)++peelDoStmtAnn :: DoStmt body -> DoStmt body+peelDoStmtAnn (DoAnn _ inner) = peelDoStmtAnn inner+peelDoStmtAnn s = s++-- | Arrow command type (used inside 'proc' expressions).+-- Commands mirror expressions but live in a separate namespace so the+-- pretty-printer knows not to parenthesise @do { … }@ as an infix LHS.+data Cmd+  = -- | Metadata for the whole command (typically a 'SourceSpan' via 'mkAnnotation').+    CmdAnn Annotation Cmd+  | -- | @exp -\< exp@ or @exp -\<\< exp@+    CmdArrApp Expr ArrAppType Expr+  | -- | Command-level infix: @cmd1 op cmd2@+    CmdInfix Cmd Name Cmd+  | -- | @do { cstmts }@+    CmdDo [DoStmt Cmd]+  | -- | @if exp then cmd else cmd@+    CmdIf Expr Cmd Cmd+  | -- | @case exp of { calts }@+    CmdCase Expr [CaseAlt Cmd]+  | -- | @let decls in cmd@+    CmdLet [Decl] Cmd+  | -- | @\\pats -> cmd@+    CmdLam [Pattern] Cmd+  | -- | Command application: @cmd exp@+    CmdApp Cmd Expr+  | -- | Parenthesised command: @(cmd)@+    CmdPar Cmd+  deriving (Data, Eq, Show, Generic, NFData)++peelCmdAnn :: Cmd -> Cmd+peelCmdAnn (CmdAnn _ inner) = peelCmdAnn inner+peelCmdAnn c = c++-- | Arrow application type: first-order (@-\<@) or higher-order (@-\<\<@).+data ArrAppType+  = -- | @f -< x@+    HsFirstOrderApp+  | -- | @f -<< x@+    HsHigherOrderApp+  deriving (Data, Eq, Show, Generic, NFData)++-- | A statement inside a list comprehension.+data CompStmt+  = -- | Metadata for the whole comprehension statement (typically a 'SourceSpan' via 'mkAnnotation').+    CompAnn Annotation CompStmt+  | -- | @x <- xs@+    CompGen Pattern Expr+  | -- | @x > 0@+    CompGuard Expr+  | -- | @let y = f x@+    CompLetDecls [Decl]+  | -- | @then f@ (TransformListComp)+    CompThen Expr+  | -- | @then f by e@ (TransformListComp)+    CompThenBy Expr Expr+  | -- | @then group using f@ (TransformListComp)+    CompGroupUsing Expr+  | -- | @then group by e using f@ (TransformListComp)+    CompGroupByUsing Expr Expr+  deriving (Data, Eq, Show, Generic, NFData)++peelCompStmtAnn :: CompStmt -> CompStmt+peelCompStmtAnn (CompAnn _ inner) = peelCompStmtAnn inner+peelCompStmtAnn s = s++-- | An arithmetic sequence expression.+data ArithSeq+  = -- | Metadata for the whole arithmetic sequence (typically a 'SourceSpan' via 'mkAnnotation').+    ArithSeqAnn Annotation ArithSeq+  | -- | @[expr ..]@+    ArithSeqFrom Expr+  | -- | @[start, thenExpr ..]@+    ArithSeqFromThen Expr Expr+  | -- | @[start .. end]@+    ArithSeqFromTo Expr Expr+  | -- | @[start, thenExpr .. end]@+    ArithSeqFromThenTo Expr Expr Expr+  deriving (Data, Eq, Show, Generic, NFData)++peelArithSeqAnn :: ArithSeq -> ArithSeq+peelArithSeqAnn (ArithSeqAnn _ inner) = peelArithSeqAnn inner+peelArithSeqAnn s = s++-- | Recursively strip all annotations from an AST value.+--+-- Removes annotation wrapper constructors (e.g. 'EAnn', 'TAnn', 'PAnn',+-- 'DeclAnn') and replaces annotation lists with @[]@.  The traversal is+-- bottom-up: children are stripped before their parent, so nested annotation+-- wrappers are fully removed.+stripAnnotations :: (Data a) => a -> a+stripAnnotations x = applyStrip (gmapT stripAnnotations x)+  where+    applyStrip :: (Data c) => c -> c+    applyStrip =+      id+        `extT` sExpr+        `extT` sType+        `extT` sPattern+        `extT` sDecl+        `extT` sDataConDecl+        `extT` sLiteral+        `extT` sGuardQualifier+        `extT` (sDoStmt :: DoStmt Expr -> DoStmt Expr)+        `extT` (sDoStmt :: DoStmt Cmd -> DoStmt Cmd)+        `extT` sCompStmt+        `extT` sArithSeq+        `extT` sClassDeclItem+        `extT` sInstanceDeclItem+        `extT` sCmd+        `extT` sName+        `extT` sUnqualifiedName+        `extT` sExportSpec+        `extT` sImportItem+        `extT` sAnnotations+        `extT` sPragma++    -- \| Extend a generic transformation with a type-specific case.+    extT :: (Typeable c, Typeable d) => (c -> c) -> (d -> d) -> c -> c+    extT f g y = fromMaybe (f y) (cast . g =<< cast y)++    sExpr :: Expr -> Expr+    sExpr (EAnn _ e) = e+    sExpr e = e++    sType :: Type -> Type+    sType (TAnn _ t) = t+    sType t = t++    sPattern :: Pattern -> Pattern+    sPattern (PAnn _ p) = p+    sPattern p = p++    sDecl :: Decl -> Decl+    sDecl (DeclAnn _ d) = d+    sDecl d = d++    sDataConDecl :: DataConDecl -> DataConDecl+    sDataConDecl (DataConAnn _ d) = d+    sDataConDecl d = d++    sLiteral :: Literal -> Literal+    sLiteral (LitAnn _ l) = l+    sLiteral l = l++    sGuardQualifier :: GuardQualifier -> GuardQualifier+    sGuardQualifier (GuardAnn _ q) = q+    sGuardQualifier q = q++    sDoStmt :: DoStmt body -> DoStmt body+    sDoStmt (DoAnn _ s) = s+    sDoStmt s = s++    sCompStmt :: CompStmt -> CompStmt+    sCompStmt (CompAnn _ s) = s+    sCompStmt s = s++    sArithSeq :: ArithSeq -> ArithSeq+    sArithSeq (ArithSeqAnn _ s) = s+    sArithSeq s = s++    sClassDeclItem :: ClassDeclItem -> ClassDeclItem+    sClassDeclItem (ClassItemAnn _ i) = i+    sClassDeclItem i = i++    sInstanceDeclItem :: InstanceDeclItem -> InstanceDeclItem+    sInstanceDeclItem (InstanceItemAnn _ i) = i+    sInstanceDeclItem i = i++    sCmd :: Cmd -> Cmd+    sCmd (CmdAnn _ c) = c+    sCmd c = c++    sName :: Name -> Name+    sName name = name {nameAnns = []}++    sUnqualifiedName :: UnqualifiedName -> UnqualifiedName+    sUnqualifiedName name = name {unqualifiedNameAnns = []}++    sExportSpec :: ExportSpec -> ExportSpec+    sExportSpec (ExportAnn _ e) = e+    sExportSpec e = e++    sImportItem :: ImportItem -> ImportItem+    sImportItem (ImportAnn _ i) = i+    sImportItem i = i++    sAnnotations :: [Annotation] -> [Annotation]+    sAnnotations _ = []++    sPragma :: Pragma -> Pragma+    sPragma p = p {pragmaRawText = ""}
+ src/Aihc/Parser/Token.hs view
@@ -0,0 +1,39 @@+-- |+-- Module      : Aihc.Parser.Token+-- Description : Public token API for inspecting lexer output+--+-- This module exposes the stable token-facing surface of the parser without+-- making callers depend on the internal lexer implementation. It is intended+-- for diagnostics, tooling, generators, and tests that need to inspect the+-- token stream directly instead of parsing it into the AST.+--+-- A 'LexToken' records the token 'LexTokenKind', original source text, source+-- span, whether it started at the beginning of a logical line, and its+-- 'TokenOrigin'. Tokens with 'FromSource' come from the input text; tokens with+-- 'InsertedLayout' are virtual braces or semicolons inserted by the layout+-- pass.+--+-- The @lexTokens*@ functions scan arbitrary source fragments. The+-- @lexModuleTokens*@ variants additionally read the module header first, apply+-- any @LANGUAGE@ pragmas (including implied extensions), and then run layout in+-- module mode so top-level declarations receive the same virtual layout tokens+-- as the parser. Use the @WithSourceName@ variants when diagnostics should+-- carry a caller-provided source name instead of @"<input>"@.+--+-- 'readModuleHeaderExtensions' returns the raw extension settings discovered in+-- the leading module pragmas, while 'readModuleHeaderPragmas' separates a+-- language edition from explicit extension toggles.+module Aihc.Parser.Token+  ( TokenOrigin (..),+    LexToken (..),+    LexTokenKind (..),+    readModuleHeaderExtensions,+    readModuleHeaderPragmas,+    lexTokensWithExtensions,+    lexModuleTokensWithExtensions,+    lexTokensWithSourceNameAndExtensions,+    lexModuleTokensWithSourceNameAndExtensions,+  )+where++import Aihc.Parser.Lex
+ src/Aihc/Parser/Types.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Aihc.Parser.Types+  ( TokStream (..),+    mkTokStream,+    mkTokStreamModule,+    mkTokStreamFromTokens,+    ParserErrorComponent (..),+    FoundToken (..),+    mkFoundToken,+    ParseErrorBundle,+    ParseResult (..),+    ParserConfig (..),+  )+where++import Aihc.Parser.Lex+  ( LayoutState (..),+    LexToken (..),+    LexTokenKind (..),+    Pragma,+    TokenOrigin (..),+    layoutTransition,+    mkInitialLayoutState,+    mkInitialLexerState,+    readModuleHeaderExtensions,+    scanAllTokens,+  )+import Aihc.Parser.Syntax (Extension, SourceSpan, applyExtensionSetting, applyImpliedExtensions)+import Control.DeepSeq (NFData (..))+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import Text.Megaparsec qualified as MP+import Text.Megaparsec.Error qualified as MPE+import Text.Megaparsec.Stream (Stream (..))++-- | Raw Megaparsec parse error bundle for low-level parser entry points.+type ParseErrorBundle = MPE.ParseErrorBundle TokStream ParserErrorComponent++data FoundToken = FoundToken+  { foundTokenText :: !Text,+    foundTokenKind :: !(Maybe LexTokenKind),+    foundTokenSpan :: !SourceSpan,+    foundTokenOrigin :: !TokenOrigin+  }+  deriving (Eq, Ord, Show, Generic, NFData)++data ParserErrorComponent+  = UnexpectedTokenExpecting+  { unexpectedFound :: Maybe FoundToken,+    unexpectedExpecting :: Text,+    unexpectedContext :: [Text]+  }+  deriving (Eq, Ord, Show, Generic)++instance MPE.ShowErrorComponent ParserErrorComponent where+  showErrorComponent (UnexpectedTokenExpecting _ expecting _) = "expecting " <> T.unpack expecting++mkFoundToken :: LexToken -> FoundToken+mkFoundToken tok =+  FoundToken+    { foundTokenText = lexTokenText tok,+      foundTokenKind = Just (lexTokenKind tok),+      foundTokenSpan = lexTokenSpan tok,+      foundTokenOrigin = lexTokenOrigin tok+    }++-- | Token stream backed by a shared lazy raw token list and a layout overlay.+--+-- The raw token list (@tokStreamRawTokens@) is produced lazily by scanning the+-- input once. Backtracking never causes characters to be re-scanned — it only+-- restores a pointer into this shared list. The layout overlay+-- (@tokStreamLayoutState@) runs 'layoutTransition' on each raw token to produce+-- virtual @{@, @;@, @}@ tokens. This allows the parser to influence layout+-- decisions (e.g., by closing implicit layout contexts via+-- 'closeImplicitLayoutContext').+data TokStream = TokStream+  { -- | Shared lazy list of raw tokens (never re-scanned on backtrack).+    tokStreamRawTokens :: [LexToken],+    -- | Layout engine state (context stack, pending layout, buffer).+    tokStreamLayoutState :: LayoutState,+    -- | Hidden pragmas that appeared before the next source token.+    -- Parsers may inspect these explicitly, but they never participate in the+    -- ordinary token stream.+    tokStreamPendingPragmas :: [Pragma],+    tokStreamPrevToken :: Maybe LexToken,+    tokStreamExtensions :: [Extension],+    -- | Whether this stream has already emitted TkEOF.+    -- After EOF is emitted, 'take1_' returns Nothing.+    tokStreamEOFEmitted :: !Bool+  }++-- -- Manual Eq instance — we skip tokStreamRawTokens since list position is not+-- -- efficiently comparable and Megaparsec tracks offset separately.+-- instance Eq TokStream where+--   a == b =+--     tokStreamLayoutState a == tokStreamLayoutState b+--       && tokStreamPendingPragmas a == tokStreamPendingPragmas b+--       && tokStreamPrevToken a == tokStreamPrevToken b+--       && tokStreamExtensions a == tokStreamExtensions b+--       && tokStreamEOFEmitted a == tokStreamEOFEmitted b++-- -- Manual Ord instance+-- instance Ord TokStream where+--   compare a b =+--     compare (tokStreamEOFEmitted a) (tokStreamEOFEmitted b)++-- Manual Show instance+instance Show TokStream where+  show ts =+    "TokStream { eofEmitted = "+      <> show (tokStreamEOFEmitted ts)+      <> ", pendingPragmas = "+      <> show (length (tokStreamPendingPragmas ts))+      <> ", prevToken = "+      <> show (tokStreamPrevToken ts)+      <> ", extensions = "+      <> show (tokStreamExtensions ts)+      <> " }"++-- Manual NFData instance — don't force the lazy raw token list.+instance NFData TokStream where+  rnf ts =+    rnf (tokStreamPendingPragmas ts) `seq`+      rnf (tokStreamPrevToken ts) `seq`+        rnf (tokStreamExtensions ts) `seq`+          rnf (tokStreamEOFEmitted ts)++-- | Create a TokStream for parsing expressions/declarations (no module layout).+mkTokStream :: FilePath -> [Extension] -> Text -> TokStream+mkTokStream sourceName exts input =+  let (env, lexSt) = mkInitialLexerState sourceName exts input+   in normalizeTokStream+        TokStream+          { tokStreamRawTokens = scanAllTokens env lexSt,+            tokStreamLayoutState = mkInitialLayoutState False exts,+            tokStreamPendingPragmas = [],+            tokStreamPrevToken = Nothing,+            tokStreamExtensions = exts,+            tokStreamEOFEmitted = False+          }++-- | Create a TokStream for parsing full modules (with module-body layout).+-- Also bootstraps LANGUAGE pragma extensions from the module header.+mkTokStreamModule :: FilePath -> [Extension] -> Text -> TokStream+mkTokStreamModule sourceName baseExts input =+  let (env, lexSt) = mkInitialLexerState sourceName effectiveExts input+   in normalizeTokStream+        TokStream+          { tokStreamRawTokens = scanAllTokens env lexSt,+            tokStreamLayoutState = mkInitialLayoutState True effectiveExts,+            tokStreamPendingPragmas = [],+            tokStreamPrevToken = Nothing,+            tokStreamExtensions = effectiveExts,+            tokStreamEOFEmitted = False+          }+  where+    headerSettings = readModuleHeaderExtensions input+    effectiveExts = applyImpliedExtensions (foldr applyExtensionSetting baseExts headerSettings)++-- | Create a TokStream from pre-lexed tokens (for testing/compatibility).+-- Layout tokens must already be inserted in the token list.+mkTokStreamFromTokens :: [LexToken] -> TokStream+mkTokStreamFromTokens toks =+  let (env, lexSt) = mkInitialLexerState "<tokens>" [] ""+   in normalizeTokStream+        TokStream+          { tokStreamRawTokens = scanAllTokens env lexSt,+            tokStreamLayoutState =+              (mkInitialLayoutState False [])+                { layoutBuffer = toks+                },+            tokStreamPendingPragmas = [],+            tokStreamPrevToken = Nothing,+            tokStreamExtensions = [],+            tokStreamEOFEmitted = False+          }++pragmaFromToken :: LexToken -> Maybe Pragma+pragmaFromToken tok =+  case lexTokenKind tok of+    TkPragma pragma' -> Just pragma'+    _ -> Nothing++isHiddenToken :: LexToken -> Bool+isHiddenToken tok =+  case lexTokenKind tok of+    TkPragma _ -> True+    TkLineComment -> True+    TkBlockComment -> True+    _ -> False++normalizeTokStream :: TokStream -> TokStream+normalizeTokStream ts0+  | tokStreamEOFEmitted ts0 = ts0+  | otherwise = go ts0+  where+    go ts =+      case layoutBuffer (tokStreamLayoutState ts) of+        tok : rest+          | Just pragma' <- pragmaFromToken tok ->+              go+                ts+                  { tokStreamLayoutState = (tokStreamLayoutState ts) {layoutBuffer = rest},+                    tokStreamPendingPragmas = tokStreamPendingPragmas ts <> [pragma']+                  }+          | isHiddenToken tok ->+              go+                ts+                  { tokStreamLayoutState = (tokStreamLayoutState ts) {layoutBuffer = rest}+                  }+          | otherwise -> ts+        [] ->+          case tokStreamRawTokens ts of+            [] -> ts+            rawTok : rawRest ->+              let (allToks, laySt') = layoutTransition (tokStreamLayoutState ts) rawTok+                  laySt'' = laySt' {layoutBuffer = allToks}+               in go ts {tokStreamRawTokens = rawRest, tokStreamLayoutState = laySt''}++-- | Step one token from the stream. This is the core primitive used by all+-- Stream methods.+--+-- Tokens are produced in two phases:+--+-- 1. Drain any buffered tokens from the layout state (virtual braces/semicolons+--    from 'layoutTransition' or 'closeImplicitLayoutContext').+-- 2. Fetch the next raw token from the shared lazy list and run+--    'layoutTransition' to produce virtual layout tokens and the raw token+--    itself. The first token is returned; the rest are buffered.+--+-- Because the raw token list is a shared lazy list, backtracking to an earlier+-- stream position is O(1) and never re-scans characters.+stepOne :: TokStream -> Maybe (LexToken, TokStream)+stepOne ts+  | tokStreamEOFEmitted ts = Nothing+  | otherwise =+      let ts0 = normalizeTokStream ts+          laySt = tokStreamLayoutState ts0+       in case layoutBuffer laySt of+            -- Drain buffered tokens first (virtual braces/semicolons)+            tok : rest ->+              let isEOF = lexTokenKind tok == TkEOF+                  pendingPragmas =+                    case lexTokenOrigin tok of+                      InsertedLayout -> tokStreamPendingPragmas ts0+                      FromSource+                        | lexTokenKind tok == TkSpecialSemicolon -> tokStreamPendingPragmas ts0+                        | otherwise -> []+                  ts' =+                    ts0+                      { tokStreamLayoutState = laySt {layoutBuffer = rest},+                        tokStreamPendingPragmas = pendingPragmas,+                        tokStreamPrevToken = Just tok,+                        tokStreamEOFEmitted = isEOF+                      }+               in Just+                    (tok, normalizeTokStream ts')+            [] ->+              Nothing++instance Stream TokStream where+  type Token TokStream = LexToken+  type Tokens TokStream = [LexToken]++  tokenToChunk _ tok = [tok]+  tokensToChunk _ = id+  chunkToTokens _ = id+  chunkLength _ = length+  chunkEmpty _ = null++  take1_ = stepOne++  takeN_ n ts+    | n <= 0 = Just ([], ts)+    | otherwise =+        case stepOne ts of+          Nothing -> Nothing+          Just (tok, ts') ->+            let go 1 acc s = Just (reverse (tok : acc), s)+                go k acc s =+                  case stepOne s of+                    Nothing -> Just (reverse (tok : acc), s)+                    Just (t, s') -> go (k - 1) (t : acc) s'+             in go n [] ts'++  takeWhile_ f =+    go []+    where+      go acc s =+        case stepOne s of+          Nothing -> (reverse acc, s)+          Just (tok, s')+            | f tok -> go (tok : acc) s'+            | otherwise ->+                -- Put the non-matching token back by using the pre-step state+                (reverse acc, s)++data ParserConfig = ParserConfig+  { parserSourceName :: FilePath,+    parserExtensions :: [Extension]+  }+  deriving (Eq, Show, Generic, NFData)++data ParseResult a+  = ParseOk a+  | ParseErr [(SourceSpan, Text)]++instance (NFData a) => NFData (ParseResult a) where+  rnf parseResult =+    case parseResult of+      ParseOk parsed -> rnf parsed+      ParseErr errs -> rnf errs
+ test/Spec.hs view
@@ -0,0 +1,2191 @@+{-# LANGUAGE MultilineStrings #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Aihc.Cpp (resultOutput)+import Aihc.Parser+import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..), lexTokens, lexTokensWithExtensions)+import Aihc.Parser.Parens (addDeclParens, addExprParens, addTypeParens)+import Aihc.Parser.Pretty ()+import Aihc.Parser.Shorthand (Shorthand (shorthand))+import Aihc.Parser.Syntax+import Control.DeepSeq (rnf)+import CppSupport (preprocessForParserWithoutIncludesIfEnabled)+import Data.Char (ord)+import Data.Data (Data, dataTypeConstrs, dataTypeOf, gmapQl, isAlgType, showConstr, toConstr)+import Data.Maybe (isNothing)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Numeric (showHex, showOct)+import ParserValidation (formatDiff, stripParens, validateParser)+import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.Text (renderStrict)+import Test.ErrorMessages.Suite (errorMessageTests)+import Test.ExtensionMapping.Suite (extensionMappingTests)+import Test.HackageTester.Suite (hackageTesterTests)+import Test.Lexer.Suite (lexerTests)+import Test.Oracle.Suite (oracleTests)+import Test.Parser.Suite (parserGoldenTests)+import Test.Performance.Suite (parserPerformanceTests)+import Test.Properties.Arb.Decl (genDeclClass, genDeclDataFamilyInst, shrinkDecl)+import Test.Properties.Arb.Expr (shrinkExpr)+import Test.Properties.Arb.Identifiers+  ( genConSym,+    genVarSym,+    isValidConIdent,+    isValidGeneratedConSym,+    isValidGeneratedIdent,+    isValidGeneratedVarSym,+    shrinkIdent,+  )+import Test.Properties.Arb.Module (genTypeName)+import Test.Properties.Arb.Pattern (shrinkPattern)+import Test.Properties.Arb.Utils (requiredExtensions)+import Test.Properties.DeclRoundTrip (prop_declPrettyRoundTrip)+import Test.Properties.ExprRoundTrip (prop_exprPrettyRoundTrip)+import Test.Properties.MinimalParentheses (prop_minimalParenthesesExpr, prop_minimalParenthesesPattern, prop_minimalParenthesesSignatureType, prop_minimalParenthesesType)+import Test.Properties.ModuleRoundTrip (prop_modulePrettyRoundTrip, prop_moduleValidator)+import Test.Properties.NoExceptions+  ( prop_declParserArbitraryTokensNoExceptions,+    prop_exprParserArbitraryTokensNoExceptions,+    prop_genLexTokenKindConstructorCoverage,+    prop_importDeclParserArbitraryTokensNoExceptions,+    prop_lexerArbitraryTextNoExceptions,+    prop_moduleHeaderParserArbitraryTokensNoExceptions,+    prop_moduleParserArbitraryTokensNoExceptions,+    prop_patternParserArbitraryTokensNoExceptions,+    prop_preprocessorArbitraryTextNoExceptions,+    prop_typeParserArbitraryTokensNoExceptions,+  )+import Test.Properties.ParensIdempotency+  ( prop_declParensIdempotent,+    prop_exprParensIdempotent,+    prop_moduleParensIdempotent,+    prop_patternParensIdempotent,+    prop_typeParensIdempotent,+  )+import Test.Properties.PatternRoundTrip (prop_patternPrettyRoundTrip)+import Test.Properties.ShorthandSubset+  ( prop_shorthandDeclSubsetOfShow,+    prop_shorthandExprSubsetOfShow,+    prop_shorthandLexTokenSubsetOfShow,+    prop_shorthandModuleSubsetOfShow,+    prop_shorthandTypeSubsetOfShow,+  )+import Test.Properties.TypeRoundTrip (prop_typePrettyRoundTrip)+import Test.QuickCheck (Arbitrary (arbitrary), Gen, Property, counterexample, shrink)+import Test.QuickCheck.Gen qualified as QGen+import Test.QuickCheck.Random qualified as QRandom+import Test.StackageProgress.Summary (stackageProgressSummaryTests)+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck qualified as QC+import Text.Read (readMaybe)++tenMinutes :: Timeout+tenMinutes = Timeout (10 * 60 * 1000000) "10m"++sampleGen :: Int -> Gen a -> [a]+sampleGen count gen = QGen.unGen (QC.vectorOf count gen) (QRandom.mkQCGen 20260415) 5++renderPretty :: (Pretty a) => a -> Text+renderPretty = renderStrict . layoutPretty defaultLayoutOptions . pretty++assertEqualShorthand :: (Shorthand a, Eq a) => String -> a -> a -> Assertion+assertEqualShorthand context expected actual+  | expected == actual = return ()+  | otherwise = assertFailure ("context: " <> context <> "\nexpected:\n" <> show (shorthand expected) <> "\nactual:\n" <> show (shorthand actual))++assertParsedStrippedExprShapeRoundTrip :: ParserConfig -> Text -> Assertion+assertParsedStrippedExprShapeRoundTrip config source =+  case parseExpr config source of+    ParseOk expr ->+      let stripped = stripParens (stripAnnotations expr)+          rendered = renderPretty stripped+       in case parseExpr config rendered of+            ParseOk reparsed -> do+              assertEqualShorthand (T.unpack rendered) (stripAnnotations stripped) (stripAnnotations (stripParens reparsed))+            ParseErr bundle ->+              assertFailure ("expected pretty-printed expression to reparse, got:\n" <> formatParseErrors "<test>" Nothing bundle)+    ParseErr bundle ->+      assertFailure ("expected parse success for:\n" <> T.unpack source <> "\n" <> formatParseErrors "<test>" Nothing bundle)++assertParsedStrippedPatternShapeRoundTrip :: ParserConfig -> Text -> Assertion+assertParsedStrippedPatternShapeRoundTrip config source =+  case parsePattern config source of+    ParseOk pat ->+      let stripped = stripParens pat+          rendered = renderPretty stripped+       in case parsePattern config rendered of+            ParseOk reparsed ->+              assertEqual "reparsed pattern" (stripAnnotations stripped) (stripAnnotations (stripParens reparsed))+            ParseErr bundle ->+              assertFailure ("expected pretty-printed pattern to reparse:\n" <> T.unpack rendered <> "\ngot:\n" <> formatParseErrors "<test>" Nothing bundle)+    ParseErr bundle ->+      assertFailure ("expected parse success for " <> T.unpack source <> "\n" <> formatParseErrors "<test>" Nothing bundle)++assertParsedStrippedDeclShapeRoundTrip :: ParserConfig -> Text -> Assertion+assertParsedStrippedDeclShapeRoundTrip config source =+  case parseDecl config source of+    ParseOk decl ->+      let stripped = stripParens decl+          rendered = renderPretty stripped+       in case parseDecl config rendered of+            ParseOk reparsed ->+              assertEqual "reparsed declaration" (stripAnnotations stripped) (stripAnnotations (stripParens reparsed))+            ParseErr bundle ->+              assertFailure ("expected pretty-printed declaration to reparse, got:\n" <> formatParseErrors "<test>" Nothing bundle)+    ParseErr bundle ->+      assertFailure ("expected parse success for " <> T.unpack source <> "\n" <> formatParseErrors "<test>" Nothing bundle)++assertParsedModulePrettyContains :: Text -> Text -> Assertion+assertParsedModulePrettyContains source expected =+  case parseModule defaultConfig source of+    ([], modu) ->+      let rendered = renderPretty modu+       in assertBool ("expected rendered module to contain " <> T.unpack expected) (expected `T.isInfixOf` rendered)+    (errs, _) ->+      assertFailure ("expected parse success, got: " <> show errs)++assertExprRenderingRoundTrip :: ParserConfig -> Expr -> Text -> Assertion+assertExprRenderingRoundTrip config expr rendered =+  case parseExpr config rendered of+    ParseOk reparsed ->+      assertEqual "reparsed expression" (stripAnnotations (addExprParens expr)) (stripAnnotations reparsed)+    ParseErr bundle ->+      assertFailure ("expected pretty-printed expression to reparse, got:\n" <> formatParseErrors "<test>" Nothing bundle)++main :: IO ()+main = buildTests >>= defaultMain++buildTests :: IO TestTree+buildTests = do+  parserGolden <- parserGoldenTests+  performance <- parserPerformanceTests+  errorMessages <- errorMessageTests+  oracle <- oracleTests+  lexer <- lexerTests+  let hackageTester = hackageTesterTests+  pure $+    testGroup+      "aihc-parser"+      [ parserGolden,+        performance,+        errorMessages,+        lexer,+        testGroup+          "parser"+          [ testCase "emits lexer error token for unterminated strings" test_unterminatedStringProducesErrorToken,+            testCase "emits lexer error token for unterminated block comments" test_unterminatedBlockCommentProducesErrorToken,+            testCase "applies hash line directives to subsequent tokens" test_hashLineDirectiveUpdatesSpan,+            testCase "applies gcc-style hash line directives to subsequent tokens" test_gccHashLineDirectiveUpdatesSpan,+            testCase "skips leading shebang lines as trivia" test_leadingShebangIsSkipped,+            testCase "skips space-prefixed shebang lines as trivia" test_spacedLeadingShebangIsSkipped,+            testCase "skips mid-stream shebang lines as trivia" test_midStreamShebangIsSkipped,+            testCase "does not misclassify line-start #) as a directive" test_lineStartHashTokenIsNotDirective,+            testCase "lexes overloaded labels as single tokens" test_overloadedLabelLexesAsSingleToken,+            testCase "preserves bundled export wildcard position" test_bundledExportWildcardPosition,+            testCase "parses associated data family operator names" test_associatedDataFamilyOperatorName,+            testCase "parses infix associated data family operator names" test_associatedDataFamilyInfixOperatorName,+            testCase "lexes quoted overloaded labels" test_quotedOverloadedLabelLexes,+            testCase "does not lex symbolic unicode as overloaded labels" test_unicodeSymbolIsNotOverloadedLabel,+            testCase "lexes string gaps before a closing quote" test_stringGapBeforeClosingQuoteLexes,+            testCase "pretty-prints overloaded labels with delimiter spacing" test_overloadedLabelPrettyPrintsWithDelimiterSpacing,+            testCase "applies LINE pragmas to subsequent tokens" test_linePragmaUpdatesSpan,+            testCase "applies COLUMN pragmas to subsequent tokens" test_columnPragmaUpdatesSpan,+            testCase "applies COLUMN pragmas in the middle of a line" test_inlineColumnPragmaUpdatesSpan,+            testCase "sets lexTokenAtLineStart correctly" test_tokenAtLineStartWithoutDirective,+            testCase "hash line directive sets lexTokenAtLineStart" test_hashLineDirectiveSetsAtLineStart,+            testCase "hash line directive preserves layout" test_hashLineDirectivePreservesLayout,+            testCase "inserts empty case layout at EOF" test_emptyCaseLayoutAtEof,+            testCase "comments are ignored in module headers" test_commentsIgnoredInModuleHeaders,+            testCase "comments are ignored by layout" test_commentsIgnoredByLayout,+            testCase "comments preserve trivia for negative literals" test_commentsPreserveTriviaForNegativeLiterals,+            testCase "indented hash-line is operator, not directive" test_indentedHashLineIsOperator,+            testCase "TransformListComp reserves by and using" test_transformListCompReservesByAndUsing,+            testCase "lexes alternate valid character literal spellings" test_alternateCharLiteralSpellingsLexLikeGhc,+            testCase "lexes control-backslash character literal" test_controlBackslashCharLiteralLexes,+            testCase "parses character literals after escaped backslash cons patterns" test_escapedBackslashConsPatternCharLiteralParses,+            testCase "generated identifiers reject lexer keywords" test_generatedIdentifiersRejectLexerKeywords,+            testCase "generated identifiers reject standalone underscore" test_generatedIdentifiersRejectStandaloneUnderscore,+            testCase "shrunk identifiers reject standalone underscore" test_shrunkIdentifiersRejectStandaloneUnderscore,+            testCase "shrunk pattern type signatures shrink their types" test_shrunkPatternTypeSignaturesShrinkTypes,+            testCase "shrunk standalone kind signatures shrink binder kinds" test_shrunkStandaloneKindSignaturesShrinkBinderKinds,+            testCase "shrunk module headers without warnings make progress" test_shrunkModuleHeaderWithoutWarningMakesProgress,+            testCase "syntax utility functions cover public edge cases" test_syntaxUtilityFunctions,+            testCase "shrunk class default pattern binds make progress" test_shrunkClassDefaultPatternBindMakesProgress,+            testCase "shrunk arrow command infix lhs modules make progress" test_shrunkArrowCommandInfixLhsModuleMakesProgress,+            testCase "shrunk wildcard pattern binds do not cycle" test_shrunkWildcardPatternBindsDoNotCycle,+            testCase "shrunk infix expression left operands do not cycle" test_shrunkInfixExprLeftOperandsDoNotCycle,+            testCase "shrunk right sections do not keep prefix minus" test_shrunkRightSectionsDoNotKeepPrefixMinus,+            testCase "shrunk let expressions do not cycle through simple lets" test_shrunkLetExpressionsDoNotCycleThroughSimpleLets,+            testCase "shrunk wildcard let expressions do not cycle through simple lets" test_shrunkWildcardLetExpressionsDoNotCycleThroughSimpleLets,+            testCase "generated identifiers accept unicode variable characters" test_generatedIdentifiersAcceptUnicodeVariableCharacters,+            testCase "lexes unicode identifier continuation characters" test_unicodeIdentifierContinuationCharactersLex,+            testCase "generated identifiers accept MagicHash suffixes" test_generatedIdentifiersAcceptMagicHashSuffixes,+            testCase "generated constructor identifiers accept unicode uppercase and number tails" test_generatedConstructorIdentifiersAcceptUnicodeCharacters,+            testCase "data CTYPE pragmas round-trip" test_dataDeclCTypePragmaRoundTrips,+            testCase "newtype CTYPE pragmas round-trip" test_newtypeCTypePragmaRoundTrips,+            testCase "generated constructor identifiers accept MagicHash suffixes" test_generatedConstructorIdentifiersAcceptMagicHashSuffixes,+            testCase "lexes identifiers with repeated MagicHash suffixes" test_magicHashIdentifierLexes,+            testCase "parses repeated MagicHash suffixes in exports" test_magicHashExportParses,+            testCase "quasiquotes do not enable Template Haskell name quotes" test_quasiQuotesDoNotEnableTHNameQuotes,+            testCase "generated constructor symbols reject reserved spellings" test_generatedConstructorSymbolsRejectReservedSpellings,+            testCase "generated variable symbols reject reserved spellings" test_generatedVariableSymbolsRejectReservedSpellings,+            testCase "generated operators reject arrow tail spellings" test_generatedOperatorsRejectArrowTailSpellings,+            testCase "generated expressions can include mdo" test_generatedExpressionsCanIncludeMdo,+            testCase "generated expressions can include SCC pragmas" test_generatedExpressionsCanIncludeSccPragmas,+            testCase "generated expressions can include explicit type syntax" test_generatedExpressionsCanIncludeExplicitTypeSyntax,+            testCase "pretty-prints negated layout-ending list-comprehension bodies" test_prettyNegatedLayoutEndingListCompBody,+            testCase "pretty-prints layout let guards in multi-way if" test_prettyLayoutLetGuardInMultiWayIf,+            testCase "pretty-prints multi-way if left operands using layout" test_prettyMultiWayIfInfixLhs,+            testCase "pretty-prints multi-way if left operands inside do using layout" test_prettyMultiWayIfInfixLhsInsideDo,+            testCase "pretty-prints multi-way if left operands inside unboxed tuples with parentheses" test_prettyMultiWayIfInfixLhsInsideUnboxedTuple,+            testCase "pretty-prints multi-way if left operands inside unboxed sums with parentheses" test_prettyMultiWayIfInfixLhsInsideUnboxedSum,+            testCase "pretty-prints lambda-case applicative chains without extra parens" test_prettyLambdaCaseApplicativeChain,+            testCase "pretty-prints TH splices before record dots with parentheses" test_prettySpliceRecordDotBase,+            testCase "rejects compact explicit type namespace TH splices" test_compactExplicitTypeNamespaceTHSplicesReject,+            testCase "pretty-prints infix RHS open-ended expressions inside sections" test_prettyInfixRhsOpenEndedInsideSection,+            testCase "pretty-prints nested infix RHS expressions inside sections" test_prettyNestedInfixRhsInsideSection,+            testCase "pretty-prints right sections with bare infix operands" test_prettyRightSectionInfixOperand,+            testCase "pretty-prints infix RHS open-ended expressions before following infix operators" test_prettyInfixRhsOpenEndedBeforeFollowingInfix,+            testCase "parenthesizes transform-list-comp group-by infix RHS before using" test_transformListCompGroupByInfixRhsParens,+            testCase "preserves transform-list-comp then-by lambda-case RHS" test_transformListCompThenByLambdaCaseRhs,+            testCase "parenthesizes lambda RHS before following infix operators" test_lambdaInfixRhsBeforeFollowingInfixParens,+            testCase "parenthesizes if RHS before following infix operators" test_ifInfixRhsBeforeFollowingInfixParens,+            testCase "parenthesizes infix RHS operands inside left sections" test_infixRhsInsideLeftSectionParens,+            testCase "pretty-prints reserved at right sections" test_prettyReservedAtRightSection,+            testCase "pretty-prints type applications after layout-ending functions" test_prettyTypeAppAfterLayoutEndingFunction,+            testCase "pretty-prints type signatures after layout-ending functions" test_prettyTypeSigAfterLayoutEndingFunction,+            testCase "pretty-prints operators after layout-rendered do blocks" test_prettyOperatorAfterLayoutDoBlock,+            testCase "pretty-prints negated open-ended expressions inside left sections" test_prettyNegatedOpenEndedSectionLhs,+            testCase "pretty-prints negated open-ended type signature bodies" test_prettyNegatedOpenEndedTypeSigBody,+            testCase "parenthesizes command lambda RHS before following infix operators" test_commandLambdaRhsBeforeFollowingInfixParens,+            testCase "pretty-prints record-dot TH splice bases" test_prettyRecordDotTHSpliceBase,+            testCase "inserts required parentheses" test_parenthesesInsertion,+            testCase "parses TH type quotes before constrained expression signatures" test_thTypeQuoteBeforeConstraintExprSig,+            testCase "parenthesizes view expressions ending with applied type signatures" test_viewExprAppliedTypeSigParens,+            testCase "parenthesizes multi-way if view expressions ending with type signatures in decls" test_viewExprMultiWayIfTypeSigParens,+            testCase "parenthesizes infix view expressions in lambda-cases" test_viewExprInfixLambdaCasesParens,+            testCase "leaves block infix lhs view expressions bare" test_viewExprBlockInfixLhsNoParens,+            testCase "leaves view expression block arguments bare" test_viewExprBlockArgumentNoParens,+            testCase "leaves multi-way-if app infix lhs view expressions bare" test_viewExprMultiWayIfAppInfixLhsNoParens,+            testCase "parenthesizes non-final let block arguments in view expressions" test_viewExprNonfinalLetBlockArgumentParens,+            testCase "parenthesizes non-final proc block arguments in view expressions" test_viewExprNonfinalProcBlockArgumentParens,+            testCase "parenthesizes arrow-command lhs applications ending in lambda-case" test_arrowCommandLhsLambdaCaseParens,+            testCase "parenthesizes arrow-command lhs applications ending in mdo" test_arrowCommandLhsMdoParens,+            testCase "parenthesizes arrow-command lhs applications ending in lambda-cases" test_arrowCommandLhsLambdaCasesParens,+            testCase "parenthesizes typed arrow-command RHS inside view expressions" test_viewExprArrowCommandTypeSigRhsParens,+            testCase "parenthesizes negated typed view expressions" test_viewExprNegatedTypeSigParens,+            testCase "pretty-prints typed view expressions without invalid layout" test_typedViewExprPrettyLayout,+            testCase "parenthesizes typed classic-if tuple view expressions" test_tupleClassicIfViewExprTypeSigParens,+            testCase "parenthesizes typed record-field view expressions with layout blocks" test_recordFieldViewExprTypeSigParens,+            testCase "rejects bare kind signatures as signature types" test_signatureTypeParserRejectsBareKindSignature,+            testCase "parses parenthesized kind signatures as signature types" test_signatureTypeParserParsesParenthesizedKindSignature,+            testCase "parses delimited kind signatures as signature types" test_signatureTypeParserParsesDelimitedKindSignature,+            testCase "rejects nested bare delimited kind signatures" test_typeParserRejectsNestedBareDelimitedKindSignature,+            testCase "rejects bare kind signatures in signature type applications" test_signatureTypeParserRejectsAppArgBareKindSignature,+            testCase "parses parenthesized kind signatures in signature type applications" test_signatureTypeParserParsesAppArgParenthesizedKindSignature,+            testCase "rejects bare kind signatures in signature implicit parameter bodies" test_signatureTypeParserRejectsImplicitParamBareKindSignature,+            testCase "rejects bare implicit parameter type arguments in contexts" test_typeParserRejectsBareImplicitParamContextAppArg,+            testCase "rejects bare context result kind signatures before outer kind signatures" test_typeParserRejectsBareContextResultKindSignatureBeforeOuterKindSignature,+            testCase "parses parenthesized context result kind signatures before outer kind signatures" test_typeParserParsesParenthesizedContextResultKindSignatureBeforeOuterKindSignature,+            testCase "rejects bare kind signatures in value signatures" test_declParserRejectsBareKindSignature,+            testCase "parses bare kind signatures as types" test_typeParserParsesBareKindSignature,+            testCase "parenthesizes forall body kind signatures in standalone kind signatures" test_standaloneKindSignatureForallBodyKindSigParens,+            testCase "preserves nested context kind signatures" test_typeParensNestedContextKindSignatureIsPreserved,+            testCase "shrunk do expressions keep a final expression statement" test_shrunkDoExpressionsKeepFinalExpression,+            testCase "formats roundtrip diffs minimally" test_roundtripDiffIsMinimal,+            testCase "bird-track unliteration preserves tab-sensitive layout columns" test_birdTrackUnlitPreservesTabColumns,+            localOption (QC.QuickCheckTests 2000) $+              QC.testProperty "generated valid char literal spellings lex like GHC" prop_validGeneratedCharLiteralSpellingsLexLikeGhc,+            QC.testProperty "generated operators reject dash-only comment starters" prop_generatedOperatorsRejectDashOnlyCommentStarters,+            localOption (QC.QuickCheckTests 25) $+              QC.testProperty "generated operators can produce unicode asterism" prop_generatedOperatorsCanProduceUnicodeAsterism,+            QC.testProperty "generated constructor symbols are valid" prop_generatedConstructorSymbolsAreValid,+            QC.testProperty "generated variable symbols are valid" prop_generatedVariableSymbolsAreValid+          ],+        testGroup+          "checkPattern (do-bind)"+          [ testCase "rejects if-then-else in pattern context" test_doBindRejectsIfExpr+          ],+        adjustOption (const tenMinutes) $+          testGroup+            "properties"+            [ QC.testProperty "expr paren insertion is minimal" prop_minimalParenthesesExpr,+              QC.testProperty "pattern paren insertion is minimal" prop_minimalParenthesesPattern,+              QC.testProperty "signature type paren insertion is minimal" prop_minimalParenthesesSignatureType,+              QC.testProperty "type paren insertion is minimal" prop_minimalParenthesesType,+              QC.testProperty "generated expr AST pretty-printer round-trip" prop_exprPrettyRoundTrip,+              QC.testProperty "generated decl AST pretty-printer round-trip" prop_declPrettyRoundTrip,+              QC.testProperty "generated data family instances can include inline result kinds" prop_generatedDataFamilyInstancesCanIncludeInlineResultKinds,+              QC.testProperty "generated class declarations can include associated data family operators" prop_generatedClassDeclsCanIncludeAssociatedDataFamilyOperators,+              QC.testProperty "generated class items include explicit associated type family syntax" prop_generatedAssociatedTypeFamiliesCanUseExplicitFamilyKeyword,+              QC.testProperty "generated class declarations cover all class item constructors" prop_generatedClassDeclsCoverAllClassItemConstructors,+              QC.testProperty "generated modules can include empty bundled imports" prop_generatedModulesCanIncludeEmptyBundledImports,+              QC.testProperty "generated type names can appear in empty bundled import syntax" prop_generatedTypeNamesSupportEmptyBundledImports,+              QC.testProperty "generated module AST pretty-printer round-trip" prop_modulePrettyRoundTrip,+              QC.testProperty "generated module AST validator" prop_moduleValidator,+              QC.testProperty "generated pattern AST pretty-printer round-trip" prop_patternPrettyRoundTrip,+              QC.testProperty "generated type AST pretty-printer round-trip" prop_typePrettyRoundTrip,+              QC.testProperty "module paren insertion is idempotent" prop_moduleParensIdempotent,+              QC.testProperty "decl paren insertion is idempotent" prop_declParensIdempotent,+              QC.testProperty "expr paren insertion is idempotent" prop_exprParensIdempotent,+              QC.testProperty "pattern paren insertion is idempotent" prop_patternParensIdempotent,+              QC.testProperty "type paren insertion is idempotent" prop_typeParensIdempotent,+              QC.testProperty "module shorthand is a subset of Show" prop_shorthandModuleSubsetOfShow,+              QC.testProperty "decl shorthand is a subset of Show" prop_shorthandDeclSubsetOfShow,+              QC.testProperty "expr shorthand is a subset of Show" prop_shorthandExprSubsetOfShow,+              QC.testProperty "type shorthand is a subset of Show" prop_shorthandTypeSubsetOfShow,+              QC.testProperty "lex token shorthand is a subset of Show" prop_shorthandLexTokenSubsetOfShow,+              QC.testProperty "lex token kind generator covers constructors" prop_genLexTokenKindConstructorCoverage,+              testGroup+                "no exceptions"+                [ QC.testProperty "preprocessor accepts arbitrary text" prop_preprocessorArbitraryTextNoExceptions,+                  QC.testProperty "lexer accepts arbitrary text" prop_lexerArbitraryTextNoExceptions,+                  QC.testProperty "module parser accepts arbitrary tokens" prop_moduleParserArbitraryTokensNoExceptions,+                  QC.testProperty "expr parser accepts arbitrary tokens" prop_exprParserArbitraryTokensNoExceptions,+                  QC.testProperty "type parser accepts arbitrary tokens" prop_typeParserArbitraryTokensNoExceptions,+                  QC.testProperty "pattern parser accepts arbitrary tokens" prop_patternParserArbitraryTokensNoExceptions,+                  QC.testProperty "decl parser accepts arbitrary tokens" prop_declParserArbitraryTokensNoExceptions,+                  QC.testProperty "import decl parser accepts arbitrary tokens" prop_importDeclParserArbitraryTokensNoExceptions,+                  QC.testProperty "module header parser accepts arbitrary tokens" prop_moduleHeaderParserArbitraryTokensNoExceptions+                ]+            ],+        oracle,+        extensionMappingTests,+        hackageTester,+        stackageProgressSummaryTests+      ]++test_unterminatedStringProducesErrorToken :: Assertion+test_unterminatedStringProducesErrorToken =+  case lexTokens "\"unterminated" of+    [LexToken {lexTokenKind = TkError _}, LexToken {lexTokenKind = TkEOF}] -> pure ()+    other -> assertFailure ("expected TkError followed by TkEOF, got: " <> show other)++test_unterminatedBlockCommentProducesErrorToken :: Assertion+test_unterminatedBlockCommentProducesErrorToken =+  case lexTokens "{-" of+    [LexToken {lexTokenKind = TkError _}, LexToken {lexTokenKind = TkEOF}] -> pure ()+    other -> assertFailure ("expected TkError followed by TkEOF, got: " <> show other)++test_hashLineDirectiveUpdatesSpan :: Assertion+test_hashLineDirectiveUpdatesSpan =+  case lexTokens "#line 42\nx" of+    [LexToken {lexTokenKind = TkVarId "x", lexTokenSpan = span'}, LexToken {lexTokenKind = TkEOF}] ->+      assertSourceSpan "<input>" 42 1 42 2 9 10 span'+    other -> assertFailure ("expected identifier at line 42, got: " <> show other)++test_gccHashLineDirectiveUpdatesSpan :: Assertion+test_gccHashLineDirectiveUpdatesSpan =+  case lexTokens "# 42 \"generated.h\"\nx" of+    [LexToken {lexTokenKind = TkVarId "x", lexTokenSpan = span'}, LexToken {lexTokenKind = TkEOF}] ->+      assertSourceSpan "generated.h" 42 1 42 2 19 20 span'+    other -> assertFailure ("expected identifier at line 42 from gcc-style directive, got: " <> show other)++test_leadingShebangIsSkipped :: Assertion+test_leadingShebangIsSkipped =+  case lexTokens "#!/usr/bin/env runghc\nmain\n" of+    [LexToken {lexTokenKind = TkVarId "main", lexTokenSpan = span'}, LexToken {lexTokenKind = TkEOF}] ->+      assertSourceSpan "<input>" 2 1 2 5 22 26 span'+    other -> assertFailure ("expected leading shebang to be skipped, got: " <> show other)++test_spacedLeadingShebangIsSkipped :: Assertion+test_spacedLeadingShebangIsSkipped =+  case lexTokens " #!/usr/bin/env runghc\nmain\n" of+    [LexToken {lexTokenKind = TkVarId "main", lexTokenSpan = span'}, LexToken {lexTokenKind = TkEOF}] ->+      assertSourceSpan "<input>" 2 1 2 5 23 27 span'+    other -> assertFailure ("expected spaced leading shebang to be skipped, got: " <> show other)++test_midStreamShebangIsSkipped :: Assertion+test_midStreamShebangIsSkipped =+  case lexTokens "x\n#!/usr/bin/env runghc\ny" of+    [ LexToken {lexTokenKind = TkVarId "x", lexTokenSpan = xSpan},+      LexToken {lexTokenKind = TkVarId "y", lexTokenSpan = ySpan},+      LexToken {lexTokenKind = TkEOF}+      ] -> do+        assertSourceSpan "<input>" 1 1 1 2 0 1 xSpan+        assertSourceSpan "<input>" 3 1 3 2 24 25 ySpan+    other -> assertFailure ("expected mid-stream shebang to be skipped, got: " <> show other)++test_lineStartHashTokenIsNotDirective :: Assertion+test_lineStartHashTokenIsNotDirective =+  case lexTokensWithExtensions [UnboxedTuples] "(#\n  x\n  #)" of+    [ LexToken {lexTokenKind = TkSpecialUnboxedLParen},+      LexToken {lexTokenKind = TkVarId "x"},+      LexToken {lexTokenKind = TkSpecialUnboxedRParen},+      LexToken {lexTokenKind = TkEOF}+      ] -> pure ()+    other -> assertFailure ("expected line-start #) to lex as an unboxed tuple token, got: " <> show other)++test_overloadedLabelLexesAsSingleToken :: Assertion+test_overloadedLabelLexesAsSingleToken =+  case lexTokensWithExtensions [OverloadedLabels] "#typeUrl" of+    [LexToken {lexTokenKind = TkOverloadedLabel "typeUrl" "#typeUrl"}, LexToken {lexTokenKind = TkEOF}] -> pure ()+    other -> assertFailure ("expected overloaded label token, got: " <> show other)++test_quotedOverloadedLabelLexes :: Assertion+test_quotedOverloadedLabelLexes =+  case lexTokensWithExtensions [OverloadedLabels] "#\"The quick brown fox\"" of+    [LexToken {lexTokenKind = TkOverloadedLabel "The quick brown fox" "#\"The quick brown fox\""}, LexToken {lexTokenKind = TkEOF}] -> pure ()+    other -> assertFailure ("expected quoted overloaded label token, got: " <> show other)++test_unicodeSymbolIsNotOverloadedLabel :: Assertion+test_unicodeSymbolIsNotOverloadedLabel = do+  case lexTokensWithExtensions [OverloadedLabels] "#﹏" of+    [LexToken {lexTokenKind = TkVarSym "#﹏"}, LexToken {lexTokenKind = TkEOF}] -> pure ()+    other -> assertFailure ("expected symbolic operator tokens, got: " <> show other)+  let config = defaultConfig {parserExtensions = [Arrows, MagicHash, OverloadedLabels]}+      source = "0.0 = proc 0.0 -> 0 -<< 'w'# where { ( #﹏ ) = proc C -> [] -< [] }"+  case parseDecl config source of+    ParseOk _ -> pure ()+    ParseErr bundle ->+      assertFailure ("expected parse success for " <> T.unpack source <> "\n" <> formatParseErrors "<test>" Nothing bundle)++test_stringGapBeforeClosingQuoteLexes :: Assertion+test_stringGapBeforeClosingQuoteLexes = do+  case lexTokens (T.pack "\"\\\n\\\"") of+    [LexToken {lexTokenKind = TkString ""}, LexToken {lexTokenKind = TkEOF}] -> pure ()+    other -> assertFailure ("expected empty string token after string gap, got: " <> show other)+  case lexTokens (T.pack "\"\\\n\\c\"") of+    [LexToken {lexTokenKind = TkString "c"}, LexToken {lexTokenKind = TkEOF}] -> pure ()+    other -> assertFailure ("expected string token with literal c after string gap, got: " <> show other)++test_overloadedLabelPrettyPrintsWithDelimiterSpacing :: Assertion+test_overloadedLabelPrettyPrintsWithDelimiterSpacing = do+  let config = defaultConfig {parserExtensions = [OverloadedLabels, UnboxedTuples]}+      exprs =+        [ ETuple Boxed [Just (EOverloadedLabel "a" "#a"), Nothing],+          EList [EOverloadedLabel "a" "#a"],+          EParen (EOverloadedLabel "a" "#a")+        ]+      rendered = map (renderStrict . layoutPretty defaultLayoutOptions . pretty) exprs+      expected = ["( #a,\n   )", "[ #a]", "( #a)"]+  assertEqual "pretty-printed forms" expected rendered+  mapM_+    ( \source ->+        case parseExpr config source of+          ParseErr err -> assertFailure ("expected parse success for " <> T.unpack source <> "\n" <> formatParseErrors "<test>" Nothing err)+          ParseOk _ -> pure ()+    )+    rendered++test_linePragmaUpdatesSpan :: Assertion+test_linePragmaUpdatesSpan =+  case lexTokens "{-# LINE 17 #-}\nx" of+    [LexToken {lexTokenKind = TkVarId "x", lexTokenSpan = span'}, LexToken {lexTokenKind = TkEOF}] ->+      assertSourceSpan "<input>" 17 1 17 2 16 17 span'+    other -> assertFailure ("expected identifier at line 17, got: " <> show other)++test_columnPragmaUpdatesSpan :: Assertion+test_columnPragmaUpdatesSpan =+  case lexTokens "x\n{-# COLUMN 7 #-}y" of+    [ LexToken {lexTokenKind = TkVarId "x"},+      LexToken {lexTokenKind = TkVarId "y", lexTokenSpan = span'},+      LexToken {lexTokenKind = TkEOF}+      ] -> assertSourceSpan "<input>" 2 7 2 8 18 19 span'+    other -> assertFailure ("expected second identifier at column 7, got: " <> show other)++test_inlineColumnPragmaUpdatesSpan :: Assertion+test_inlineColumnPragmaUpdatesSpan =+  case lexTokens "x{-# COLUMN 7 #-}y" of+    [ LexToken {lexTokenKind = TkVarId "x", lexTokenSpan = xSpan},+      LexToken {lexTokenKind = TkVarId "y", lexTokenSpan = ySpan},+      LexToken {lexTokenKind = TkEOF}+      ] -> do+        assertSourceSpan "<input>" 1 1 1 2 0 1 xSpan+        assertSourceSpan "<input>" 1 7 1 8 17 18 ySpan+    other -> assertFailure ("expected inline COLUMN pragma to update same-line column, got: " <> show other)++test_tokenAtLineStartWithoutDirective :: Assertion+test_tokenAtLineStartWithoutDirective =+  case lexTokens "x y" of+    [LexToken {lexTokenKind = TkVarId "x", lexTokenAtLineStart = True}, LexToken {lexTokenKind = TkVarId "y", lexTokenAtLineStart = False}, LexToken {lexTokenKind = TkEOF}] ->+      pure ()+    other -> assertFailure ("expected x at line start and y not at line start, got: " <> show other)++test_hashLineDirectiveSetsAtLineStart :: Assertion+test_hashLineDirectiveSetsAtLineStart =+  case lexTokens "x\n#line 1 \"foo.hs\"\ny" of+    [LexToken {lexTokenKind = TkVarId "x", lexTokenAtLineStart = True}, LexToken {lexTokenKind = TkVarId "y", lexTokenAtLineStart = True}, LexToken {lexTokenKind = TkEOF}] ->+      pure ()+    other -> assertFailure ("expected x and y both at line start, got: " <> show other)++test_hashLineDirectivePreservesLayout :: Assertion+test_hashLineDirectivePreservesLayout =+  let source = T.unlines ["module Test where", "x = 1", "#line 1 \"foo.hs\"", "y = 2"]+      (errs, modu) = parseModule defaultConfig source+   in do+        assertBool ("expected no parse errors, got: " <> show errs) (null errs)+        assertEqual "expected two declarations" 2 (length (moduleDecls modu))++test_emptyCaseLayoutAtEof :: Assertion+test_emptyCaseLayoutAtEof =+  let source = "x = case () of"+      kinds = map lexTokenKind (lexTokens source)+   in assertEqual+        "token kinds"+        [ TkVarId "x",+          TkReservedEquals,+          TkKeywordCase,+          TkSpecialLParen,+          TkSpecialRParen,+          TkKeywordOf,+          TkSpecialLBrace,+          TkSpecialRBrace,+          TkEOF+        ]+        kinds++test_commentsIgnoredInModuleHeaders :: Assertion+test_commentsIgnoredInModuleHeaders =+  let source =+        T.unlines+          [ "{-# LANGUAGE OverloadedLabels #-}",+            "-- comment between pragma and module header",+            "module Test where",+            "x = #foo"+          ]+      (errs, modu) = parseModule defaultConfig source+   in do+        assertBool ("expected no parse errors, got: " <> show errs) (null errs)+        assertEqual "expected one declaration" 1 (length (moduleDecls modu))++test_commentsIgnoredByLayout :: Assertion+test_commentsIgnoredByLayout =+  let source =+        T.unlines+          [ "module Test where",+            "main = do",+            "  -- comment inside layout block",+            "  pure ()",+            "  pure ()"+          ]+      (errs, modu) = parseModule defaultConfig source+   in do+        assertBool ("expected no parse errors, got: " <> show errs) (null errs)+        assertEqual "expected one declaration" 1 (length (moduleDecls modu))++test_commentsPreserveTriviaForNegativeLiterals :: Assertion+test_commentsPreserveTriviaForNegativeLiterals =+  case lexTokensWithExtensions [NegativeLiterals] "x -- comment\n-1" of+    [ LexToken {lexTokenKind = TkVarId "x"},+      LexToken {lexTokenKind = TkLineComment},+      LexToken {lexTokenKind = TkInteger (-1) TInteger},+      LexToken {lexTokenKind = TkEOF}+      ] -> pure ()+    other -> assertFailure ("expected comment trivia before negative literal, got: " <> show other)++test_indentedHashLineIsOperator :: Assertion+test_indentedHashLineIsOperator =+  -- '# line' on an indented continuation line must lex as operator '#'+  -- plus identifier 'line', not as a CPP #line directive.+  case lexTokens "x\n  # line" of+    [ LexToken {lexTokenKind = TkVarId "x"},+      LexToken {lexTokenKind = TkVarSym "#"},+      LexToken {lexTokenKind = TkVarId "line"},+      LexToken {lexTokenKind = TkEOF}+      ] -> pure ()+    other -> assertFailure ("expected indented '# line' to lex as operator + identifier, got: " <> show other)++assertSourceSpan :: FilePath -> Int -> Int -> Int -> Int -> Int -> Int -> SourceSpan -> Assertion+assertSourceSpan expectedName expectedStartLine expectedStartCol expectedEndLine expectedEndCol expectedStartOffset expectedEndOffset span' =+  case span' of+    SourceSpan {sourceSpanSourceName, sourceSpanStartLine, sourceSpanStartCol, sourceSpanEndLine, sourceSpanEndCol, sourceSpanStartOffset, sourceSpanEndOffset} -> do+      assertEqual "source name" expectedName sourceSpanSourceName+      assertEqual "start line" expectedStartLine sourceSpanStartLine+      assertEqual "start col" expectedStartCol sourceSpanStartCol+      assertEqual "end line" expectedEndLine sourceSpanEndLine+      assertEqual "end col" expectedEndCol sourceSpanEndCol+      assertEqual "start offset" expectedStartOffset sourceSpanStartOffset+      assertEqual "end offset" expectedEndOffset sourceSpanEndOffset+    NoSourceSpan -> assertFailure "expected SourceSpan, got NoSourceSpan"++assertReadRoundTrip :: (Eq a, Read a, Show a) => String -> [a] -> Assertion+assertReadRoundTrip label =+  mapM_ $ \value ->+    assertEqual (label <> ": " <> show value) (Just value) (readMaybe (show value))++test_syntaxUtilityFunctions :: Assertion+test_syntaxUtilityFunctions = do+  assertEqual "known extensions" ([minBound .. maxBound] :: [Extension]) allKnownExtensions+  mapM_+    (\ext -> assertEqual ("extension enum round trip: " <> show ext) ext (toEnum (fromEnum ext)))+    allKnownExtensions+  assertBool "extension ordering is stable" (AllowAmbiguousTypes < XmlSyntax)+  assertReadRoundTrip "extension read/show" allKnownExtensions+  assertReadRoundTrip+    "extension setting read/show"+    [ EnableExtension LambdaCase,+      DisableExtension ImplicitPrelude+    ]+  assertEqual "extension alias Cpp" (Just CPP) (parseExtensionName " Cpp ")+  assertEqual "extension alias DerivingVia" (Just DerivingViaExtension) (parseExtensionName "DerivingVia")+  assertEqual "extension alias GeneralisedNewtypeDeriving" (Just GeneralizedNewtypeDeriving) (parseExtensionName "GeneralisedNewtypeDeriving")+  assertEqual "extension alias Safe" (Just SafeHaskell) (parseExtensionName "Safe")+  assertEqual "extension alias Unsafe" (Just UnsafeHaskell) (parseExtensionName "Unsafe")+  assertEqual "extension setting disable" (Just (DisableExtension ImplicitPrelude)) (parseExtensionSettingName "NoImplicitPrelude")+  assertEqual "extension setting fallback" (Just (EnableExtension NondecreasingIndentation)) (parseExtensionSettingName "NondecreasingIndentation")+  assertEqual "extension setting unknown disable" Nothing (parseExtensionSettingName "NoDefinitelyNotAnExtension")++  assertReadRoundTrip "language edition read/show" ([minBound .. maxBound] :: [LanguageEdition])+  assertEqual "language edition Haskell98" (Just Haskell98Edition) (parseLanguageEdition " Haskell98 ")+  assertEqual "language edition Haskell2010" (Just Haskell2010Edition) (parseLanguageEdition "Haskell2010")+  assertEqual "language edition GHC2021" (Just GHC2021Edition) (parseLanguageEdition "GHC2021")+  assertEqual "language edition GHC2024" (Just GHC2024Edition) (parseLanguageEdition "GHC2024")+  assertEqual "language edition unknown" Nothing (parseLanguageEdition "GHC2099")+  assertEqual+    "last language edition wins"+    (Just GHC2024Edition)+    (editionFromExtensionSettings [EnableExtension Haskell98, DisableExtension LambdaCase, EnableExtension GHC2024])+  assertEqual "no language edition" Nothing (editionFromExtensionSettings [EnableExtension LambdaCase])++  let spanA = SourceSpan "A.hs" 1 2 1 4 0 2+      spanB = SourceSpan "A.hs" 2 1 2 5 3 7+      merged = SourceSpan "A.hs" 1 2 2 5 0 7+  assertEqual "show no source span" "NoSourceSpan" (show noSourceSpan)+  assertEqual "show source span" "SourceSpan 1 2 2 5" (show merged)+  assertEqual "merge source spans" merged (mergeSourceSpans spanA spanB)+  assertEqual "merge left missing source span" spanB (mergeSourceSpans NoSourceSpan spanB)+  assertEqual "merge right missing source span" spanA (mergeSourceSpans spanA NoSourceSpan)+  assertBool "source span ordering" (spanA < spanB)+  assertBool "source span nfdata" (rnf merged `seq` True)++  assertReadRoundTrip "pragma unpack kind read/show" [UnpackPragma, NoUnpackPragma]+  assertReadRoundTrip+    "pragma type read/show"+    [ PragmaLanguage [EnableExtension LambdaCase, DisableExtension ImplicitPrelude],+      PragmaInstanceOverlap Overlapping,+      PragmaWarning "warn",+      PragmaDeprecated "old",+      PragmaInline "[1]" "INLINE",+      PragmaUnpack UnpackPragma,+      PragmaSource "SOURCE" "",+      PragmaSCC "loop",+      PragmaUnknown "CUSTOM"+    ]+  assertReadRoundTrip+    "pragma read/show"+    [Pragma (PragmaWarning "warn") "{-# WARNING x \"warn\" #-}"]+  assertReadRoundTrip "numeric type read/show" [TInteger, TIntHash, TWordHash, TInt8Hash, TInt16Hash, TInt32Hash, TInt64Hash, TWord8Hash, TWord16Hash, TWord32Hash, TWord64Hash]+  assertReadRoundTrip "float type read/show" [TFractional, TFloatHash, TDoubleHash]+  assertReadRoundTrip "instance overlap pragma read/show" [Overlapping, Overlappable, Overlaps, Incoherent]+  assertBool "numeric type ordering" (TInteger < TWord64Hash)+  assertBool "pragma nfdata" (rnf (Pragma (PragmaInline "[1]" "INLINE") "") `seq` True)++test_generatedIdentifiersRejectLexerKeywords :: Assertion+test_generatedIdentifiersRejectLexerKeywords =+  assertBool "lexer keywords must not be treated as valid generated identifiers" $+    not (any isValidGeneratedIdent ["case", "module", "rec", "mdo", "pattern", "proc", "by", "using", "_"])++test_transformListCompReservesByAndUsing :: Assertion+test_transformListCompReservesByAndUsing = do+  case lexTokensWithExtensions [TransformListComp] "by using" of+    [ LexToken {lexTokenKind = TkKeywordBy},+      LexToken {lexTokenKind = TkKeywordUsing},+      LexToken {lexTokenKind = TkEOF}+      ] ->+        pure ()+    other -> assertFailure ("expected TransformListComp keyword tokens, got: " <> show other)+  let source = "module M where\nby = (); using = ()\n"+      cfg = defaultConfig {parserExtensions = [TransformListComp]}+      (errs, _modu) = parseModule cfg source+  assertBool "TransformListComp should reject by/using as top-level binders" (not (null errs))++test_generatedIdentifiersRejectStandaloneUnderscore :: Assertion+test_generatedIdentifiersRejectStandaloneUnderscore =+  assertBool "standalone underscore must not be treated as a valid generated identifier" $+    not (isValidGeneratedIdent "_")++test_shrunkIdentifiersRejectStandaloneUnderscore :: Assertion+test_shrunkIdentifiersRejectStandaloneUnderscore =+  assertBool "standalone underscore must not be produced by shrinking" $+    "_" `notElem` shrinkIdent "__"++test_shrunkPatternTypeSignaturesShrinkTypes :: Assertion+test_shrunkPatternTypeSignaturesShrinkTypes =+  assertBool "pattern type signatures should shrink names in their types" $+    any shrinksTypeName (shrinkPattern pat)+  where+    pat = PTypeSig PWildcard (TCon originalName Unpromoted)+    originalName = mkName (Just "\120613\120044\42565") NameConSym ":\118928\8690\10289"+    shrinksTypeName (PTypeSig PWildcard (TCon name Unpromoted)) =+      isNothing (nameQualifier name) || nameText name == ":+"+    shrinksTypeName _ = False++test_shrunkStandaloneKindSignaturesShrinkBinderKinds :: Assertion+test_shrunkStandaloneKindSignaturesShrinkBinderKinds =+  assertBool "standalone kind signatures should shrink names in forall binder kinds" $+    any shrinksBinderKind (shrinkDecl decl)+  where+    decl =+      DeclStandaloneKindSig+        (mkUnqualifiedName NameConSym ":+")+        ( TForall+            ForallTelescope+              { forallTelescopeVisibility = ForallInvisible,+                forallTelescopeBinders =+                  [ TyVarBinder+                      []+                      "a"+                      (Just (TVar (mkUnqualifiedName NameVarId "\985\5115####")))+                      TyVarBSpecified+                      TyVarBVisible+                  ]+              }+            (TKindSig TWildcard TWildcard)+        )+    shrinksBinderKind+      ( DeclStandaloneKindSig+          _+          ( TForall+              ForallTelescope {forallTelescopeBinders = [TyVarBinder {tyVarBinderKind = Just (TVar name)}]}+              (TKindSig TWildcard TWildcard)+            )+        ) = renderUnqualifiedName name == "a"+    shrinksBinderKind _ = False++test_shrunkModuleHeaderWithoutWarningMakesProgress :: Assertion+test_shrunkModuleHeaderWithoutWarningMakesProgress =+  assertBool "module shrinker must not return the original module" $+    modu `notElem` shrink modu+  where+    modu =+      Module+        { moduleAnns = [],+          moduleHead =+            Just+              ModuleHead+                { moduleHeadAnns = [],+                  moduleHeadName = "A",+                  moduleHeadWarningPragma = Nothing,+                  moduleHeadExports = Nothing+                },+          moduleLanguagePragmas = [],+          moduleImports = [],+          moduleDecls = []+        }++test_shrunkClassDefaultPatternBindMakesProgress :: Assertion+test_shrunkClassDefaultPatternBindMakesProgress =+  assertBool "class default pattern bind shrinker must not return the original declaration" $+    decl `notElem` shrinkDecl decl+  where+    decl =+      DeclClass+        ClassDecl+          { classDeclContext = Nothing,+            classDeclHead = PrefixBinderHead (mkUnqualifiedName NameConId "C") [],+            classDeclFundeps = [],+            classDeclItems =+              [ ClassItemDefault+                  ( PatternBind+                      NoMultiplicityTag+                      (PVar (mkUnqualifiedName NameVarId "x"))+                      (UnguardedRhs [] (EList []) Nothing)+                  )+              ]+          }++test_shrunkArrowCommandInfixLhsModuleMakesProgress :: Assertion+test_shrunkArrowCommandInfixLhsModuleMakesProgress =+  assertBool "module shrinker must not return the original arrow command module" $+    modu `notElem` shrink modu+  where+    modu =+      Module+        { moduleAnns = [],+          moduleHead = Nothing,+          moduleLanguagePragmas = [],+          moduleImports = [],+          moduleDecls =+            [ DeclValue+                ( PatternBind+                    NoMultiplicityTag+                    (PVar (mkUnqualifiedName NameVarId "a"))+                    (UnguardedRhs [] (EProc PWildcard command) Nothing)+                )+            ]+        }+    command =+      CmdArrApp+        (EInfix (EList []) (qualifyName Nothing (mkUnqualifiedName NameVarId "a")) (EList []))+        HsFirstOrderApp+        ( ELetDecls+            [ DeclValue+                ( PatternBind+                    NoMultiplicityTag+                    (PVar (mkUnqualifiedName NameVarId "x"))+                    (UnguardedRhs [] (ETuple Unboxed []) Nothing)+                )+            ]+            (EInt 846 TIntHash "846#")+        )++test_shrunkWildcardPatternBindsDoNotCycle :: Assertion+test_shrunkWildcardPatternBindsDoNotCycle =+  assertBool "pattern bind shrinker must not cycle between wildcard and simple variable patterns" $+    all (\shrunk -> decl `notElem` shrinkDecl shrunk) (shrinkDecl decl)+  where+    decl =+      DeclValue+        ( PatternBind+            NoMultiplicityTag+            PWildcard+            (UnguardedRhs [] (EList []) Nothing)+        )++test_shrunkInfixExprLeftOperandsDoNotCycle :: Assertion+test_shrunkInfixExprLeftOperandsDoNotCycle =+  assertBool "infix expression shrinker must not cycle between simple variables and empty lists on the lhs" $+    all (\shrunk -> expr `notElem` shrink shrunk) (shrink expr)+  where+    expr =+      EInfix+        (EVar (qualifyName Nothing (mkUnqualifiedName NameVarId "a")))+        (qualifyName Nothing (mkUnqualifiedName NameVarId "a"))+        (EList [])++test_shrunkRightSectionsDoNotKeepPrefixMinus :: Assertion+test_shrunkRightSectionsDoNotKeepPrefixMinus =+  assertBool "right section shrinker must not keep the unqualified minus operator" $+    not (any isUnqualifiedMinusRightSection (shrink expr))+  where+    expr =+      ESectionR+        (qualifyName Nothing (mkUnqualifiedName NameVarSym "-"))+        (EInt 1 TInteger "1")+    isUnqualifiedMinusRightSection (ESectionR name _) =+      isNothing (nameQualifier name)+        && nameType name == NameVarSym+        && nameText name == "-"+    isUnqualifiedMinusRightSection _ = False++test_shrunkLetExpressionsDoNotCycleThroughSimpleLets :: Assertion+test_shrunkLetExpressionsDoNotCycleThroughSimpleLets =+  assertBool "let expression shrinker must not cycle through its simple let target" $+    all (\shrunk -> expr `notElem` shrink shrunk) (shrink expr)+  where+    expr =+      ELetDecls+        [ DeclValue+            ( PatternBind+                NoMultiplicityTag+                (PVar (mkUnqualifiedName NameVarId "a"))+                (UnguardedRhs [] (ETuple Boxed []) Nothing)+            )+        ]+        (EList [])++test_shrunkWildcardLetExpressionsDoNotCycleThroughSimpleLets :: Assertion+test_shrunkWildcardLetExpressionsDoNotCycleThroughSimpleLets =+  assertBool "let expression shrinker must not cycle between wildcard and simple variable let targets" $+    all (\shrunk -> expr `notElem` shrink shrunk) (shrink expr)+  where+    expr =+      ELetDecls+        [ DeclValue+            ( PatternBind+                NoMultiplicityTag+                PWildcard+                (UnguardedRhs [] (EList []) Nothing)+            )+        ]+        (EList [])++test_generatedIdentifiersAcceptUnicodeVariableCharacters :: Assertion+test_generatedIdentifiersAcceptUnicodeVariableCharacters = do+  assertBool "unicode lowercase letters and unicode numbers should be accepted in generated identifiers" $+    isValidGeneratedIdent "a\x03b1\x00b2"+  assertBool "unicode lowercase letters should be accepted at the start of generated identifiers" $+    isValidGeneratedIdent "\x03bbx"++test_unicodeIdentifierContinuationCharactersLex :: Assertion+test_unicodeIdentifierContinuationCharactersLex =+  mapM_+    assertVarId+    [ "\x03b1\x209b", -- modifier letter: alpha + subscript s+      "a\x0301", -- non-spacing mark: a + combining acute+      "a\x2160" -- letter number: a + roman numeral one+    ]+  where+    assertVarId ident =+      case lexTokens ident of+        [LexToken {lexTokenKind = TkVarId actual}, LexToken {lexTokenKind = TkEOF}]+          | actual == ident -> pure ()+        other -> assertFailure ("expected variable identifier " <> T.unpack ident <> ", got: " <> show other)++test_generatedIdentifiersAcceptMagicHashSuffixes :: Assertion+test_generatedIdentifiersAcceptMagicHashSuffixes = do+  assertBool "MagicHash should allow a single trailing hash on variable identifiers" $+    isValidGeneratedIdent "x#"+  assertBool "MagicHash should allow repeated trailing hashes on variable identifiers" $+    isValidGeneratedIdent "x####"++test_generatedConstructorIdentifiersAcceptUnicodeCharacters :: Assertion+test_generatedConstructorIdentifiersAcceptUnicodeCharacters = do+  assertBool "unicode titlecase letters should be accepted at the start of constructor identifiers" $+    isValidConIdent "\x01c5tail"+  assertBool "unicode uppercase letters and unicode numbers should be accepted in constructor identifiers" $+    isValidConIdent "\x0394\x0660"++test_dataDeclCTypePragmaRoundTrips :: Assertion+test_dataDeclCTypePragmaRoundTrips = do+  let source = T.unlines ["{-# LANGUAGE GHC2021 #-}", "{-# LANGUAGE CApiFFI #-}", "module M where", "data {-# CTYPE \"termbox.h\" \"struct tb_cell\" #-} Tb_cell = Tb_cell"]+  assertParsedModulePrettyContains source "CTYPE \"termbox.h\" \"struct tb_cell\""++test_newtypeCTypePragmaRoundTrips :: Assertion+test_newtypeCTypePragmaRoundTrips = do+  let source = T.unlines ["{-# LANGUAGE GHC2021 #-}", "{-# LANGUAGE CApiFFI #-}", "module M where", "import Foreign.C.Types (CInt (..))", "newtype {-# CTYPE \"signed int\" #-} Fixed = Fixed CInt"]+  assertParsedModulePrettyContains source "CTYPE \"signed int\""++test_generatedConstructorIdentifiersAcceptMagicHashSuffixes :: Assertion+test_generatedConstructorIdentifiersAcceptMagicHashSuffixes = do+  assertBool "MagicHash should allow a single trailing hash on constructor identifiers" $+    isValidConIdent "T#"+  assertBool "MagicHash should allow repeated trailing hashes on constructor identifiers" $+    isValidConIdent "T####"++test_magicHashIdentifierLexes :: Assertion+test_magicHashIdentifierLexes = do+  let varTokens = lexTokensWithExtensions [MagicHash] "x####"+      conTokens = lexTokensWithExtensions [MagicHash] "T####"+  case varTokens of+    [LexToken {lexTokenKind = TkVarId "x####"}, LexToken {lexTokenKind = TkEOF}] -> pure ()+    other -> assertFailure ("expected MagicHash var identifier token, got: " <> show other)+  case conTokens of+    [LexToken {lexTokenKind = TkConId "T####"}, LexToken {lexTokenKind = TkEOF}] -> pure ()+    other -> assertFailure ("expected MagicHash constructor identifier token, got: " <> show other)++test_magicHashExportParses :: Assertion+test_magicHashExportParses =+  let source = T.unlines ["{-# LANGUAGE MagicHash #-}", "module M (f##) where", "", "f## = undefined"]+      (errs, modu) = parseModule defaultConfig source+   in case errs of+        [] ->+          case moduleHead modu of+            Just ModuleHead {moduleHeadExports = Just [ExportAnn _ (ExportVar _ _ name)]} | name == qualifyName Nothing (mkUnqualifiedName NameVarId "f##") -> pure ()+            other -> assertFailure ("expected export of f##, got: " <> show other)+        _ -> assertFailure ("expected parse success for MagicHash export, got: " <> formatParseErrors "<quickcheck>" (Just source) errs)++test_generatedConstructorSymbolsRejectReservedSpellings :: Assertion+test_generatedConstructorSymbolsRejectReservedSpellings =+  assertBool "reserved constructor symbol spellings must be rejected" $+    not (any isValidGeneratedConSym [":", "::"])++test_generatedVariableSymbolsRejectReservedSpellings :: Assertion+test_generatedVariableSymbolsRejectReservedSpellings =+  assertBool "reserved variable symbol spellings and dash runs must be rejected" $+    not (any isValidGeneratedVarSym ["..", "=", "\\", "|", "|+", "<-", "->", "~", "=>", "--", "---"])++test_generatedOperatorsRejectArrowTailSpellings :: Assertion+test_generatedOperatorsRejectArrowTailSpellings =+  assertBool "arrow-tail operators must not be treated as valid generated operators" $+    not (any isValidGeneratedVarSym ["-<", ">-", "-<<", ">>-"])++test_generatedExpressionsCanIncludeMdo :: Assertion+test_generatedExpressionsCanIncludeMdo =+  let samples = QGen.unGen (QC.vectorOf 4000 (QC.resize 5 (QC.arbitrary :: QC.Gen Expr))) (QRandom.mkQCGen 737) 5+   in assertBool "expected expression generator to include at least one mdo expression" $+        any isMdo samples+  where+    isMdo (EDo _ DoMdo) = True+    isMdo _ = False++test_generatedExpressionsCanIncludeSccPragmas :: Assertion+test_generatedExpressionsCanIncludeSccPragmas =+  let samples = QGen.unGen (QC.vectorOf 4000 (QC.resize 5 (QC.arbitrary :: QC.Gen Expr))) (QRandom.mkQCGen 738) 5+   in assertBool "expected expression generator to include at least one SCC pragma expression" $+        any (Set.member "EPragma" . usedCtors) samples++test_generatedExpressionsCanIncludeExplicitTypeSyntax :: Assertion+test_generatedExpressionsCanIncludeExplicitTypeSyntax =+  let samples = QGen.unGen (QC.vectorOf 4000 (QC.resize 5 (QC.arbitrary :: QC.Gen Expr))) (QRandom.mkQCGen 739) 5+   in assertBool "expected expression generator to include at least one explicit type syntax expression" $+        any (Set.member "ETypeSyntax" . usedCtors) samples++usedCtors :: (Data a) => a -> Set.Set String+usedCtors x =+  let here+        | isAlgType (dataTypeOf x) = Set.singleton (showConstr (toConstr x))+        | otherwise = Set.empty+   in here <> gmapQl (<>) Set.empty usedCtors x++test_alternateCharLiteralSpellingsLexLikeGhc :: Assertion+test_alternateCharLiteralSpellingsLexLikeGhc =+  mapM_ assertCharLiteralLexesLikeGhc finiteAlternateCharLiteralSpellings++test_controlBackslashCharLiteralLexes :: Assertion+test_controlBackslashCharLiteralLexes =+  assertCharLiteralLexesLikeGhc "'\\^\\'"++test_escapedBackslashConsPatternCharLiteralParses :: Assertion+test_escapedBackslashConsPatternCharLiteralParses =+  let source =+        T.unlines+          [ "module X where",+            "",+            "go xs = case xs of",+            "  '^' : '\\\\' : xs -> '\\^\\' : go xs",+            "  ys -> ys"+          ]+      (errs, _) = parseModule defaultConfig source+   in assertBool ("expected no parse errors, got: " <> show errs) (null errs)++prop_validGeneratedCharLiteralSpellingsLexLikeGhc :: QC.Property+prop_validGeneratedCharLiteralSpellingsLexLikeGhc =+  QC.forAll genValidCharLiteral $ \raw ->+    QC.counterexample ("literal: " <> T.unpack raw) $+      case ghcReadCharLiteral raw of+        Nothing -> QC.counterexample "generator produced an invalid literal" False+        Just expected ->+          case lexTokens raw of+            [LexToken {lexTokenKind = TkChar actual}, LexToken {lexTokenKind = TkEOF}] -> actual QC.=== expected+            other -> QC.counterexample ("unexpected tokens: " <> show other) False++prop_generatedOperatorsRejectDashOnlyCommentStarters :: QC.Property+prop_generatedOperatorsRejectDashOnlyCommentStarters =+  QC.forAll genVarSym $ \op ->+    QC.counterexample ("invalid generated operator: " <> show op) (isValidGeneratedVarSym op)++prop_generatedOperatorsCanProduceUnicodeAsterism :: QC.Property+prop_generatedOperatorsCanProduceUnicodeAsterism =+  QC.counterexample "expected ⁂ to be a valid generated operator" $+    isValidGeneratedVarSym "⁂"++prop_generatedConstructorSymbolsAreValid :: QC.Property+prop_generatedConstructorSymbolsAreValid =+  QC.forAll genConSym $ \op ->+    QC.counterexample ("invalid generated constructor symbol: " <> show op) (isValidGeneratedConSym op)++prop_generatedVariableSymbolsAreValid :: QC.Property+prop_generatedVariableSymbolsAreValid =+  QC.forAll genVarSym $ \op ->+    QC.counterexample ("invalid generated variable symbol: " <> show op) (isValidGeneratedVarSym op)++assertCharLiteralLexesLikeGhc :: T.Text -> Assertion+assertCharLiteralLexesLikeGhc raw =+  case ghcReadCharLiteral raw of+    Nothing -> assertFailure ("expected GHC to accept valid char literal: " <> show raw)+    Just expected ->+      case lexTokens raw of+        [LexToken {lexTokenKind = TkChar actual}, LexToken {lexTokenKind = TkEOF}] ->+          assertEqual ("character mismatch for literal " <> T.unpack raw) expected actual+        other ->+          assertFailure ("expected char token for literal " <> T.unpack raw <> ", got: " <> show other)++ghcReadCharLiteral :: T.Text -> Maybe Char+ghcReadCharLiteral raw =+  case reads (T.unpack raw) of+    [(c, "")] -> Just c+    _ -> Nothing++genValidCharLiteral :: QC.Gen T.Text+genValidCharLiteral =+  QC.oneof+    [ T.pack . show <$> (QC.arbitrary :: QC.Gen Char),+      QC.elements finiteAlternateCharLiteralSpellings,+      genNumericCharLiteral,+      genHexCharLiteral,+      genOctalCharLiteral+    ]++genNumericCharLiteral :: QC.Gen T.Text+genNumericCharLiteral = do+  c <- QC.arbitrary :: QC.Gen Char+  leadingZeros <- QC.chooseInt (0, 4)+  pure (mkCharLiteral ("\\" <> T.replicate leadingZeros "0" <> T.pack (show (ord c))))++genHexCharLiteral :: QC.Gen T.Text+genHexCharLiteral = do+  c <- QC.arbitrary :: QC.Gen Char+  leadingZeros <- QC.chooseInt (0, 4)+  uppercase <- QC.arbitrary+  let digits = showHex (ord c) ""+      rendered = if uppercase then map toUpperAscii digits else digits+  pure (mkCharLiteral ("\\x" <> T.replicate leadingZeros "0" <> T.pack rendered))++genOctalCharLiteral :: QC.Gen T.Text+genOctalCharLiteral = do+  c <- QC.arbitrary :: QC.Gen Char+  leadingZeros <- QC.chooseInt (0, 4)+  pure (mkCharLiteral ("\\o" <> T.replicate leadingZeros "0" <> T.pack (showOct (ord c) "")))++mkCharLiteral :: T.Text -> T.Text+mkCharLiteral body = "'" <> body <> "'"++finiteAlternateCharLiteralSpellings :: [T.Text]+finiteAlternateCharLiteralSpellings = map mkCharLiteral (simpleEscapeBodies <> controlEscapeBodies <> namedEscapeBodies)++simpleEscapeBodies :: [T.Text]+simpleEscapeBodies = ["\\a", "\\b", "\\f", "\\n", "\\r", "\\t", "\\v", "\\\\", "\\\"", "\\'"]++controlEscapeBodies :: [T.Text]+controlEscapeBodies = [T.pack ['\\', '^', c] | c <- ['@' .. '_']]++namedEscapeBodies :: [T.Text]+namedEscapeBodies =+  map+    ("\\" <>)+    [ "NUL",+      "SOH",+      "STX",+      "ETX",+      "EOT",+      "ENQ",+      "ACK",+      "BEL",+      "BS",+      "HT",+      "LF",+      "VT",+      "FF",+      "CR",+      "SO",+      "SI",+      "DLE",+      "DC1",+      "DC2",+      "DC3",+      "DC4",+      "NAK",+      "SYN",+      "ETB",+      "CAN",+      "EM",+      "SUB",+      "ESC",+      "FS",+      "GS",+      "RS",+      "US",+      "SP",+      "DEL"+    ]++toUpperAscii :: Char -> Char+toUpperAscii c+  | 'a' <= c && c <= 'f' = toEnum (fromEnum c - 32)+  | otherwise = c++test_doBindRejectsIfExpr :: Assertion+test_doBindRejectsIfExpr =+  let src = "x = do { if True then 1 else 2 <- return 3 }"+      (errs, _) = parseModule defaultConfig src+   in assertBool "expected parse error for if-then-else in bind pattern" (not (null errs))++test_bundledExportWildcardPosition :: Assertion+test_bundledExportWildcardPosition = do+  let source =+        T.unlines+          [ "{-# LANGUAGE PatternSynonyms #-}",+            "{-# LANGUAGE ExplicitNamespaces #-}",+            "module M (T (.., P, data Q)) where",+            "data T = A | B",+            "pattern P :: T",+            "pattern P = A",+            "pattern Q :: T",+            "pattern Q = B"+          ]+      (errs, modu) = parseModule defaultConfig source+      rendered = renderStrict (layoutPretty defaultLayoutOptions (pretty modu))+      (reparseErrs, reparsed) = parseModule defaultConfig rendered+   in do+        assertBool ("expected no parse errors, got: " <> show errs) (null errs)+        assertBool ("expected reparsed pretty output to succeed, got: " <> show reparseErrs) (null reparseErrs)+        case moduleExports modu of+          Just [ExportAnn _ (ExportWithAll _ Nothing "T" 0 [IEBundledMember Nothing "P", IEBundledMember (Just IEBundledNamespaceData) "Q"])] ->+            case moduleExports reparsed of+              Just [ExportAnn _ (ExportWithAll _ Nothing "T" 0 [IEBundledMember Nothing "P", IEBundledMember (Just IEBundledNamespaceData) "Q"])] ->+                pure ()+              other ->+                assertFailure ("unexpected reparsed export AST: " <> show other)+          other ->+            assertFailure ("unexpected export AST: " <> show other)++test_quasiQuotesDoNotEnableTHNameQuotes :: Assertion+test_quasiQuotesDoNotEnableTHNameQuotes = do+  let config = defaultConfig {parserExtensions = [QuasiQuotes]}+      source = T.unlines ["module M where", "x = 'id", "y = ''T"]+      (errs, _modu) = parseModule config source+  assertBool "expected TH name quotes to require TemplateHaskellQuotes or TemplateHaskell" (not (null errs))++test_prettyNegatedLayoutEndingListCompBody :: Assertion+test_prettyNegatedLayoutEndingListCompBody = do+  let config = defaultConfig {parserExtensions = [BlockArguments]}+      source =+        """+        [-0.0+          case 0.0 of+            0+              | let {  }+               ->+                ""+         | let {  }]+        """+  assertParsedStrippedExprShapeRoundTrip config source++test_prettyLayoutLetGuardInMultiWayIf :: Assertion+test_prettyLayoutLetGuardInMultiWayIf = do+  let config = defaultConfig {parserExtensions = [BlockArguments, MultiWayIf]}+      source =+        """+        if | let+             x =+               ()+                :: a+            ->+             case '5' of+               (+) ->+                 0+        """+  assertParsedStrippedExprShapeRoundTrip config source++test_prettyMultiWayIfInfixLhs :: Assertion+test_prettyMultiWayIfInfixLhs = do+  let config = defaultConfig {parserExtensions = [MultiWayIf]}+      source =+        """+        (if | True+            ->+             ())+         `a` 'x'+        """+  assertParsedStrippedExprShapeRoundTrip config source++test_prettyMultiWayIfInfixLhsInsideDo :: Assertion+test_prettyMultiWayIfInfixLhsInsideDo = do+  let config = defaultConfig {parserExtensions = [MultiWayIf]}+      source =+        """+        do+          (if | True+              ->+               ())+            `a` 'x'+        """+  assertParsedStrippedExprShapeRoundTrip config source++test_prettyMultiWayIfInfixLhsInsideUnboxedTuple :: Assertion+test_prettyMultiWayIfInfixLhsInsideUnboxedTuple = do+  let config = defaultConfig {parserExtensions = [UnboxedTuples, MultiWayIf, OverloadedLabels]}+      source =+        """+        (# ((if | let {  }+                 ->+                  #foo)+            `a` [880+                 | 48.7]) #)+        """+  assertParsedStrippedExprShapeRoundTrip config source++test_prettyMultiWayIfInfixLhsInsideUnboxedSum :: Assertion+test_prettyMultiWayIfInfixLhsInsideUnboxedSum = do+  let config = defaultConfig {parserExtensions = [UnboxedSums, MultiWayIf]}+      source =+        """+        (# ((if | let {  }+                 ->+                  0)+             `a` ()) | #)+        """+  assertParsedStrippedExprShapeRoundTrip config source++test_prettyLambdaCaseApplicativeChain :: Assertion+test_prettyLambdaCaseApplicativeChain = do+  let config = defaultConfig {parserExtensions = [LambdaCase]}+      source =+        T.unlines+          [ "f originalParsedOptions =",+            "  (Options <$> __command",+            "   <*> \\case",+            "         f | __withFlake f -> Flake",+            "         _ | otherwise -> Traditional",+            "   <*> __prioritiseLocalPinnedSystem)",+            "    originalParsedOptions"+          ]+  assertParsedStrippedDeclShapeRoundTrip config source++test_prettyInfixRhsOpenEndedInsideSection :: Assertion+test_prettyInfixRhsOpenEndedInsideSection = do+  let config = defaultConfig {parserExtensions = [LambdaCase]}+      source =+        """+        ((\\case {  })+         `a` (\\ 0 -> ' ')+         `a`)+        """+  assertParsedStrippedExprShapeRoundTrip config source++test_prettyNestedInfixRhsInsideSection :: Assertion+test_prettyNestedInfixRhsInsideSection = do+  let source =+        """+        ([]+         + (""+            `a` ())+         +)+        """+  assertParsedStrippedExprShapeRoundTrip defaultConfig source++test_prettyRightSectionInfixOperand :: Assertion+test_prettyRightSectionInfixOperand = do+  let sources =+        [ "(/ 10 ^ (3 :: Int))",+          "(<> msg <> \"\\n\")",+          "(++ \" seconds\" ++ dir f)",+          "(< sizeOf x * 8)",+          "(<= m + 1 / 2)",+          "(.+^ p ^. vel)",+          "(<?> prettyIndentation ref ++ \" (started at line \" ++ prettyLine ref ++ \")\")"+        ]+  mapM_ (assertParsedStrippedExprShapeRoundTrip defaultConfig) sources++test_prettyInfixRhsOpenEndedBeforeFollowingInfix :: Assertion+test_prettyInfixRhsOpenEndedBeforeFollowingInfix = do+  let config = defaultConfig {parserExtensions = [TemplateHaskell, QuasiQuotes]}+      source =+        """+        [t| () |]+         + (if [t| _ |] then [] else [])+         `a` 0+        """+  assertParsedStrippedExprShapeRoundTrip config source++test_lambdaInfixRhsBeforeFollowingInfixParens :: Assertion+test_lambdaInfixRhsBeforeFollowingInfixParens = do+  let config = defaultConfig {parserExtensions = [QuasiQuotes]}+      source =+        """+        (+) =+          []+           `a` (\\ [a||] -> 0)+           `a` ()+        """+  assertParsedStrippedDeclShapeRoundTrip config source++test_ifInfixRhsBeforeFollowingInfixParens :: Assertion+test_ifInfixRhsBeforeFollowingInfixParens = do+  let config = defaultConfig {parserExtensions = [OverloadedLabels, OverloadedRecordDot]}+      source =+        """+        (+) =+          []+           `a` (if () then #a else ())+           `a` (.a)+        """+  assertParsedStrippedDeclShapeRoundTrip config source++test_infixRhsInsideLeftSectionParens :: Assertion+test_infixRhsInsideLeftSectionParens = do+  let config = defaultConfig {parserExtensions = [TemplateHaskell]}+      source =+        """+        a =+          ('' ()+           + (0 `a` 0)+           `a`)+        """+  assertParsedStrippedDeclShapeRoundTrip config source++test_prettyReservedAtRightSection :: Assertion+test_prettyReservedAtRightSection = do+  let expr = ESectionR (qualifyName Nothing (mkUnqualifiedName NameVarSym "@")) (ETuple Boxed [])+      rendered = renderStrict (layoutPretty defaultLayoutOptions (pretty expr))+  assertEqual "pretty-printed expression" "(@ ())" rendered+  assertExprRenderingRoundTrip defaultConfig expr rendered++test_prettyTypeAppAfterLayoutEndingFunction :: Assertion+test_prettyTypeAppAfterLayoutEndingFunction = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+      source =+        """+        (+) =+          0+            \\case+              0.0 ->+                ""#+           @(# _ | * #)+        """+  assertParsedStrippedDeclShapeRoundTrip config source++test_prettyTypeSigAfterLayoutEndingFunction :: Assertion+test_prettyTypeSigAfterLayoutEndingFunction = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+      source =+        """+        (:+) =+          [d|+            |]+            \\case+              _ ->+                '1'+           :: [a||]+        """+  assertParsedStrippedDeclShapeRoundTrip config source++test_prettyOperatorAfterLayoutDoBlock :: Assertion+test_prettyOperatorAfterLayoutDoBlock = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+      source =+        """+        (do+           let f x = \\case+                 -134 | (# #) <- 'n' -> 85.3)+        + (# | | | 0 #)+        """+  assertParsedStrippedExprShapeRoundTrip config source++test_prettySpliceRecordDotBase :: Assertion+test_prettySpliceRecordDotBase = do+  let config = defaultConfig {parserExtensions = [TemplateHaskell, OverloadedRecordDot, MagicHash]}+  assertParsedStrippedExprShapeRoundTrip config "($x#).adpE"++test_prettyNegatedOpenEndedSectionLhs :: Assertion+test_prettyNegatedOpenEndedSectionLhs = do+  let config = defaultConfig {parserExtensions = [BlockArguments]}+      source =+        """+        ((-(""+          (if 'N' then () else ())))+         `a`)+        """+  assertParsedStrippedExprShapeRoundTrip config source++test_prettyNegatedOpenEndedTypeSigBody :: Assertion+test_prettyNegatedOpenEndedTypeSigBody = do+  let config = defaultConfig {parserExtensions = [BlockArguments, MagicHash, UnboxedTuples]}+      source =+        """+        -((# #)+          (if ""# then [] else (+)))+         :: C+        """+  assertParsedStrippedExprShapeRoundTrip config source++test_commandLambdaRhsBeforeFollowingInfixParens :: Assertion+test_commandLambdaRhsBeforeFollowingInfixParens = do+  let plusName = qualifyName Nothing (mkUnqualifiedName NameVarSym "+")+      aName = qualifyName Nothing (mkUnqualifiedName NameVarId "a")+      arrApp op = CmdArrApp (EList []) op (EList [])+      command =+        CmdInfix+          ( CmdInfix+              (arrApp HsHigherOrderApp)+              plusName+              (CmdLam [PWildcard] (arrApp HsFirstOrderApp))+          )+          aName+          (arrApp HsFirstOrderApp)+      decl =+        DeclValue+          ( PatternBind+              NoMultiplicityTag+              PWildcard+              (UnguardedRhs [] (EProc PWildcard command) Nothing)+          )+      rendered = renderPretty decl+  case validateParser "<test>" GHC2024Edition (map EnableExtension requiredExtensions) rendered of+    Nothing -> pure ()+    Just err ->+      assertFailure ("expected pretty-printed command to validate, got:\n" <> show err <> "\nRendered:\n" <> T.unpack rendered)++test_prettyRecordDotTHSpliceBase :: Assertion+test_prettyRecordDotTHSpliceBase = do+  let config = defaultConfig {parserExtensions = [TemplateHaskell, MagicHash, OverloadedRecordDot]}+  assertParsedStrippedExprShapeRoundTrip config "($q#).j7Msfc"+  assertParsedStrippedExprShapeRoundTrip config "($$q#).j7Msfc"++test_compactExplicitTypeNamespaceTHSplicesReject :: Assertion+test_compactExplicitTypeNamespaceTHSplicesReject = do+  let config = defaultConfig {parserExtensions = [ExplicitNamespaces, TemplateHaskell, UnboxedSums, ViewPatterns]}+  case parseExpr config "$type _" of+    ParseErr {} -> pure ()+    ParseOk expr -> assertFailure ("expected compact type splice expression to fail, got: " <> show (shorthand (stripAnnotations expr)))+  case parsePattern config "$type _" of+    ParseErr {} -> pure ()+    ParseOk pat -> assertFailure ("expected compact type splice pattern to fail, got: " <> show (shorthand (stripAnnotations pat)))+  case parsePattern config "(# | $type _ {} -> _ #)" of+    ParseErr {} -> pure ()+    ParseOk pat -> assertFailure ("expected compact type splice view pattern to fail, got: " <> show (shorthand (stripAnnotations pat)))+  assertParsedStrippedExprShapeRoundTrip config "$(type _)"+  assertParsedStrippedPatternShapeRoundTrip config "(# | $(type _) {} -> _ #)"++test_parenthesesInsertion :: Assertion+test_parenthesesInsertion = do+  let config =+        defaultConfig+          { parserExtensions =+              [ TemplateHaskell,+                MagicHash,+                OverloadedRecordDot,+                Arrows,+                BlockArguments,+                QuasiQuotes,+                ViewPatterns,+                UnboxedSums,+                MultiWayIf,+                QualifiedDo,+                ParallelListComp,+                TransformListComp+              ]+          }+  assertParsedStrippedExprShapeRoundTrip config "- (- 10)"+  assertParsedStrippedExprShapeRoundTrip config "a + (b + c)"+  assertParsedStrippedExprShapeRoundTrip config "(' (+)).a"+  assertParsedStrippedExprShapeRoundTrip config "(A.+).a"+  assertParsedStrippedExprShapeRoundTrip config "[t| (_ :: _) |]"+  assertParsedStrippedExprShapeRoundTrip config "[p| _ |] (proc _ -> () -<< a)"+  assertParsedStrippedPatternShapeRoundTrip config "(# | proc _ -> [] -< [] -> _ #)"+  assertParsedStrippedPatternShapeRoundTrip config "(:+) {a = [let a = () in [] ..] -> _}"+  assertParsedStrippedPatternShapeRoundTrip config "C {a = proc _ -> do ([] -<< []) + case [] of _ -> [] -<< [] -> _}"+  assertParsedStrippedPatternShapeRoundTrip config "(proc _ -> (if [] then [] -<< [] else [] -<< []) + case [] of _ -> [] -< [] -> _)"+  assertParsedStrippedDeclShapeRoundTrip config "a = ((if | [] -> []) :: _,)"+  assertParsedStrippedPatternShapeRoundTrip config "((A.do (if | [] -> []) :: _) -> _)"+  assertParsedStrippedDeclShapeRoundTrip config "_ = ([] + - let _ = [] in []) :: _"+  assertParsedStrippedPatternShapeRoundTrip config "C {a = [[] | then [] by [] | then [] + [] by []] -> _}"+  assertParsedStrippedExprShapeRoundTrip config "let ((:+) :: _) = [] in []"++test_thTypeQuoteBeforeConstraintExprSig :: Assertion+test_thTypeQuoteBeforeConstraintExprSig = do+  let config = defaultConfig {parserExtensions = [TemplateHaskell, QuasiQuotes]}+      source :: Text+      source = "x = [t| C |] :: (:+) => ()"+  case parseDecl config source of+    ParseOk _ -> pure ()+    ParseErr bundle ->+      assertFailure ("expected parse success for " <> T.unpack source <> "\n" <> formatParseErrors "<test>" Nothing bundle)++test_viewExprAppliedTypeSigParens :: Assertion+test_viewExprAppliedTypeSigParens = do+  let config = defaultConfig {parserExtensions = [BlockArguments, DataKinds, ViewPatterns]}+      source =+        """+        (([]+          (if a then a else []+           :: 'C -> C))+         -> C)+        """+  assertParsedStrippedPatternShapeRoundTrip config source++test_viewExprMultiWayIfTypeSigParens :: Assertion+test_viewExprMultiWayIfTypeSigParens = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+      source =+        """+        (# (if | let {  }+                ->+                 'G'+                  :: *)+              -> 0+             | +             |  #) =+          [(\\cases {  }) ..]+        """+  assertParsedStrippedDeclShapeRoundTrip config source++test_viewExprInfixLambdaCasesParens :: Assertion+test_viewExprInfixLambdaCasesParens = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+      source =+        """+        _ = \\cases+              (([] `a` []) -> _) ->+                []+        """+  assertParsedStrippedDeclShapeRoundTrip config source+  assertParsedStrippedDeclShapeRoundTrip config "_ = [] where _ `a` (((\\case _ -> []) + []) -> _) = []"+  assertParsedStrippedDeclShapeRoundTrip config "_ = [] where ((do [] `a` []) -> _) = []"+  assertParsedStrippedPatternShapeRoundTrip config "(((if | [] -> []) `a` []) -> _)"++test_viewExprBlockInfixLhsNoParens :: Assertion+test_viewExprBlockInfixLhsNoParens = do+  let source =+        """+        {-# LANGUAGE ViewPatterns #-}+        module M where+        f [case [] of {  }+          + []+           -> _] = []+        """+      expected =+        """+        f [case [] of {  }+          + []+           -> _] = []+        """+  assertParsedModulePrettyContains source expected++test_viewExprBlockArgumentNoParens :: Assertion+test_viewExprBlockArgumentNoParens = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+      source =+        """+        (# []+               if | let {  }+                      ->+                       []+               []+              -> _+             |  #)+        """+  assertParsedStrippedPatternShapeRoundTrip config source++test_viewExprMultiWayIfAppInfixLhsNoParens :: Assertion+test_viewExprMultiWayIfAppInfixLhsNoParens = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+      source =+        """+        (# []+               if | []+                      ->+                       []+             + []+              -> _+             |  #)+        """+  assertParsedStrippedPatternShapeRoundTrip config source++test_viewExprNonfinalLetBlockArgumentParens :: Assertion+test_viewExprNonfinalLetBlockArgumentParens = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  assertParsedStrippedExprShapeRoundTrip+    config+    """+    do+      ([]+          let _ = []+            in []+          []+         -> _) <- []+      []+    """++test_viewExprNonfinalProcBlockArgumentParens :: Assertion+test_viewExprNonfinalProcBlockArgumentParens = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+      source = "([] (proc _ -> [] -<< []) [] -> _)"+  assertParsedStrippedPatternShapeRoundTrip config source++test_viewExprArrowCommandTypeSigRhsParens :: Assertion+test_viewExprArrowCommandTypeSigRhsParens = do+  let config = defaultConfig {parserExtensions = [Arrows, MagicHash, QuasiQuotes, ViewPatterns]}+      source =+        """+        ((proc a -> () -<< ('7'#+         :: [a||]))+         -> C {})+        """+  assertParsedStrippedPatternShapeRoundTrip config source++test_viewExprNegatedTypeSigParens :: Assertion+test_viewExprNegatedTypeSigParens = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+      source =+        """+        _ = []+            where+              ((- \\ _ -> []+                    :: _+                 -> _)+               -> _) + _ = []+        """+  assertParsedStrippedDeclShapeRoundTrip config source++test_typedViewExprPrettyLayout :: Assertion+test_typedViewExprPrettyLayout = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  assertParsedStrippedExprShapeRoundTrip+    config+    """+    do+      (([]+        :: _)+       -> _) <- []+      []+    """+  assertParsedStrippedPatternShapeRoundTrip+    config+    """+     ((if | let _ = []+             ->+              []+      :: _)+    -> _)+    """++test_tupleClassicIfViewExprTypeSigParens :: Assertion+test_tupleClassicIfViewExprTypeSigParens = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  assertParsedStrippedPatternShapeRoundTrip+    config+    """+    (_, ((if [] then [] else []+          :: _)+         -> _))+    """++test_recordFieldViewExprTypeSigParens :: Assertion+test_recordFieldViewExprTypeSigParens = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+      source =+        """+        _ = []+            where+              _ `a` (:+) {a = ((if [] then [] else []+                               :: _)+                              -> _)} = []+        """+  assertParsedStrippedDeclShapeRoundTrip config source+  assertParsedStrippedPatternShapeRoundTrip+    config+    """+    C {a = (,+              if | []+                     ->+                      []+              :: _)+     -> _}+    """++test_signatureTypeParserRejectsBareKindSignature :: Assertion+test_signatureTypeParserRejectsBareKindSignature = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  case parseSignatureType config "_ :: _" of+    ParseErr {} -> pure ()+    ParseOk ty ->+      assertFailure ("expected parse failure, got: " <> show (shorthand (stripAnnotations ty)))++test_signatureTypeParserParsesParenthesizedKindSignature :: Assertion+test_signatureTypeParserParsesParenthesizedKindSignature = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  case parseSignatureType config "(_ :: _)" of+    ParseOk ty ->+      assertEqual "parenthesized kind signature" (TParen (TKindSig TWildcard TWildcard)) (stripAnnotations ty)+    ParseErr bundle ->+      assertFailure ("expected parse success for parenthesized kind signature\n" <> formatParseErrors "<test>" Nothing bundle)++test_signatureTypeParserParsesDelimitedKindSignature :: Assertion+test_signatureTypeParserParsesDelimitedKindSignature = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  case parseSignatureType config "[_ :: _]" of+    ParseOk ty ->+      assertEqual "delimited kind signature" (TList Unpromoted [TKindSig TWildcard TWildcard]) (stripAnnotations ty)+    ParseErr bundle ->+      assertFailure ("expected parse success for delimited kind signature\n" <> formatParseErrors "<test>" Nothing bundle)++test_typeParserRejectsNestedBareDelimitedKindSignature :: Assertion+test_typeParserRejectsNestedBareDelimitedKindSignature = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  case parseType config "[_ :: _ :: _]" of+    ParseErr {} -> pure ()+    ParseOk ty ->+      assertFailure ("expected parse failure, got: " <> show (shorthand (stripAnnotations ty)))++test_signatureTypeParserRejectsAppArgBareKindSignature :: Assertion+test_signatureTypeParserRejectsAppArgBareKindSignature = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  case parseSignatureType config "_ _ :: _" of+    ParseErr {} -> pure ()+    ParseOk ty ->+      assertFailure ("expected parse failure, got: " <> show (shorthand (stripAnnotations ty)))++test_signatureTypeParserParsesAppArgParenthesizedKindSignature :: Assertion+test_signatureTypeParserParsesAppArgParenthesizedKindSignature = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  case parseSignatureType config "_ (_ :: _)" of+    ParseOk ty ->+      assertEqual "parenthesized app argument kind signature" (TApp TWildcard (TParen (TKindSig TWildcard TWildcard))) (stripAnnotations ty)+    ParseErr bundle ->+      assertFailure ("expected parse success for parenthesized app argument kind signature\n" <> formatParseErrors "<test>" Nothing bundle)++test_signatureTypeParserRejectsImplicitParamBareKindSignature :: Assertion+test_signatureTypeParserRejectsImplicitParamBareKindSignature = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  case parseSignatureType config "?a :: _ :: _" of+    ParseErr {} -> pure ()+    ParseOk ty ->+      assertFailure ("expected parse failure, got: " <> show (shorthand (stripAnnotations ty)))++test_typeParserRejectsBareImplicitParamContextAppArg :: Assertion+test_typeParserRejectsBareImplicitParamContextAppArg = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  case parseType config "_ => (_, (:+) ?a :: _) => _" of+    ParseErr {} -> pure ()+    ParseOk ty ->+      assertFailure ("expected parse failure, got: " <> show (shorthand (stripAnnotations ty)))++test_typeParserRejectsBareContextResultKindSignatureBeforeOuterKindSignature :: Assertion+test_typeParserRejectsBareContextResultKindSignatureBeforeOuterKindSignature = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  case parseType config "_ => _ :: _ :: _" of+    ParseErr {} -> pure ()+    ParseOk ty ->+      assertFailure ("expected parse failure, got: " <> show (shorthand (stripAnnotations ty)))+  case parseDecl config "type X = _ => _ :: _ :: _" of+    ParseErr {} -> pure ()+    ParseOk decl ->+      assertFailure ("expected parse failure, got: " <> show (shorthand (stripAnnotations decl)))++test_typeParserParsesParenthesizedContextResultKindSignatureBeforeOuterKindSignature :: Assertion+test_typeParserParsesParenthesizedContextResultKindSignatureBeforeOuterKindSignature = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  case parseType config "_ => (_ :: _) :: _" of+    ParseOk {} -> pure ()+    ParseErr bundle ->+      assertFailure ("expected parse success for parenthesized context result kind signature\n" <> formatParseErrors "<test>" Nothing bundle)+  case parseDecl config "type X = _ => (_ :: _) :: _" of+    ParseOk {} -> pure ()+    ParseErr bundle ->+      assertFailure ("expected parse success for parenthesized context result kind signature declaration\n" <> formatParseErrors "<test>" Nothing bundle)++test_declParserRejectsBareKindSignature :: Assertion+test_declParserRejectsBareKindSignature = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  case parseDecl config "x :: _ :: _" of+    ParseErr {} -> pure ()+    ParseOk decl ->+      assertFailure ("expected parse failure, got: " <> show (shorthand (stripAnnotations decl)))++test_typeParserParsesBareKindSignature :: Assertion+test_typeParserParsesBareKindSignature = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+  case parseType config "_ :: _" of+    ParseOk ty ->+      assertEqual "type kind signature" (TKindSig TWildcard TWildcard) (stripAnnotations ty)+    ParseErr bundle ->+      assertFailure ("expected parse success for type kind signature\n" <> formatParseErrors "<test>" Nothing bundle)++test_standaloneKindSignatureForallBodyKindSigParens :: Assertion+test_standaloneKindSignatureForallBodyKindSigParens = do+  let decl =+        DeclStandaloneKindSig+          (mkUnqualifiedName NameConSym ":+")+          ( TForall+              ForallTelescope+                { forallTelescopeVisibility = ForallInvisible,+                  forallTelescopeBinders =+                    [ TyVarBinder+                        []+                        "a"+                        (Just TWildcard)+                        TyVarBSpecified+                        TyVarBVisible+                    ]+                }+              (TKindSig TWildcard TWildcard)+          )+      source = renderStrict (layoutPretty defaultLayoutOptions (pretty (addDeclParens decl)))+  assertEqual "standalone kind signature source" "type (:+) :: forall (a :: _). (_ :: _)" source++test_typeParensNestedContextKindSignatureIsPreserved :: Assertion+test_typeParensNestedContextKindSignatureIsPreserved = do+  let ty = TContext [TWildcard] (TContext [TWildcard] (TKindSig TWildcard TWildcard))+      expected = TContext [TWildcard] (TContext [TWildcard] (TParen (TKindSig TWildcard TWildcard)))+  assertEqual "nested context body" expected (addTypeParens ty)++test_shrunkDoExpressionsKeepFinalExpression :: Assertion+test_shrunkDoExpressionsKeepFinalExpression = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+      source =+        """+        do+          (([] :: _) -> _) <- []+          []+        """+  case parseExpr config source of+    ParseOk expr ->+      let invalidShrinks = [stmts | EDo stmts _ <- shrinkExpr expr, not (testDoStmtsEndInExpr stmts)]+       in assertEqual "invalid do-statement shrinks" [] invalidShrinks+    ParseErr bundle ->+      assertFailure ("expected parse success for " <> T.unpack source <> "\n" <> formatParseErrors "<test>" Nothing bundle)++test_transformListCompGroupByInfixRhsParens :: Assertion+test_transformListCompGroupByInfixRhsParens = do+  let config = defaultConfig {parserExtensions = [TransformListComp]}+  assertParsedStrippedDeclShapeRoundTrip config "_ = [[] | then group by ([] `a` - []) using []]"++test_transformListCompThenByLambdaCaseRhs :: Assertion+test_transformListCompThenByLambdaCaseRhs = do+  let config = defaultConfig {parserExtensions = [LambdaCase, TransformListComp]}+      source =+        """+        _ = [[] | let _ = [],+                  then [] `a` \\case+                    _ -> [] by []]+        """+  assertParsedStrippedDeclShapeRoundTrip config source++testDoStmtsEndInExpr :: [DoStmt Expr] -> Bool+testDoStmtsEndInExpr stmts =+  case reverse stmts of+    stmt : _ -> testIsDoExprStmt stmt+    [] -> False++testIsDoExprStmt :: DoStmt Expr -> Bool+testIsDoExprStmt stmt =+  case peelDoStmtAnn stmt of+    DoExpr {} -> True+    _ -> False++test_arrowCommandLhsLambdaCaseParens :: Assertion+test_arrowCommandLhsLambdaCaseParens = do+  let config = defaultConfig {parserExtensions = [Arrows, BlockArguments, LambdaCase]}+      source =+        """+        0 =+          proc a -> ([]+            \\case+              C ->+                []) -< ()+        """+  assertParsedStrippedDeclShapeRoundTrip config source++test_arrowCommandLhsMdoParens :: Assertion+test_arrowCommandLhsMdoParens = do+  let config = defaultConfig {parserExtensions = requiredExtensions}+      source =+        """+        (:+) =+          proc a -> (()+            + mdo+                "nerEAot"#) -< ()+        """+  assertParsedStrippedDeclShapeRoundTrip config source++test_arrowCommandLhsLambdaCasesParens :: Assertion+test_arrowCommandLhsLambdaCasesParens = do+  let config = defaultConfig {parserExtensions = [Arrows, BlockArguments, LambdaCase]}+      source =+        """+        0 =+          proc a -> ([]+            \\cases+              C ->+                []) -< ()+        """+  assertParsedStrippedDeclShapeRoundTrip config source++test_roundtripDiffIsMinimal :: Assertion+test_roundtripDiffIsMinimal =+  let before =+        T.unlines+          [ "data CtOrigin",+            "  = forall (p :: Pass). (OutputableBndrId p) =>",+            "    ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p)) |",+            "    ExpectedFunTyViewPat !(HsExpr GhcRn) |",+            "    forall (p :: Pass). Outputable (HsExpr (GhcPass p)) =>",+            "    Thing"+          ]+      rendered =+        T.unlines+          [ "data CtOrigin",+            "  = forall p. (OutputableBndrId p) =>",+            "    ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p)) |",+            "    ExpectedFunTyViewPat !(HsExpr GhcRn) |",+            "    forall p. Outputable (HsExpr (GhcPass p)) =>",+            "    Thing"+          ]+      expected =+        Just+          ( T.unlines+              [ "@@ line 2 @@",+                "-   = forall (p :: Pass). (OutputableBndrId p) =>",+                "+   = forall p. (OutputableBndrId p) =>",+                "-     forall (p :: Pass). Outputable (HsExpr (GhcPass p)) =>",+                "+     forall p. Outputable (HsExpr (GhcPass p)) =>"+              ]+          )+   in assertEqual "minimal diff" expected (formatDiff before rendered)++-- | Regression test: bird-track unliteration must preserve column positions so+-- that tab-aligned case alternatives remain in the same layout context.+-- Before the fix, stripping "> " shifted columns by 2, causing tab-expanded+-- and space-only lines to land at different indentation columns.+test_birdTrackUnlitPreservesTabColumns :: Assertion+test_birdTrackUnlitPreservesTabColumns = do+  -- Literate Haskell with tab-indented case alternatives.+  -- The tab on the "Just" line and the spaces on the "Nothing" line+  -- are carefully chosen so they align at the same column in the original+  -- (with "> " prefix) but diverge after naively stripping "> ".+  let lhsSource =+        T.unlines+          [ "> module LitTest where",+            "> f x = case x of",+            ">          \t        Just y  -> y",+            ">                       Nothing -> 0"+          ]+      preprocessed = resultOutput (preprocessForParserWithoutIncludesIfEnabled [] [] "LitTest.lhs" [] lhsSource)+      (errs, _modu) = parseModule defaultConfig preprocessed+  assertBool+    ("expected no parse errors for bird-track .lhs with tabs, got:\n" <> formatParseErrors "LitTest.lhs" (Just preprocessed) errs)+    (null errs)++test_associatedDataFamilyOperatorName :: Assertion+test_associatedDataFamilyOperatorName = do+  let source = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "{-# LANGUAGE TypeOperators #-}", "class C a where", "  data (:*:) a"]+      expectedName = mkUnqualifiedName NameConSym ":*:"+  case parseModule defaultConfig source of+    ([], modu) ->+      case map peelDeclAnn (moduleDecls modu) of+        [ DeclClass ClassDecl {classDeclItems = [ClassItemAnn _ (ClassItemDataFamilyDecl dataFamilyDecl)]}+          ]+            | binderHeadName (dataFamilyDeclHead dataFamilyDecl) == expectedName,+              map tyVarBinderName (binderHeadParams (dataFamilyDeclHead dataFamilyDecl)) == ["a"],+              isNothing (dataFamilyDeclKind dataFamilyDecl) ->+                pure ()+        other ->+          assertFailure ("expected associated data family operator declaration, got: " <> show other)+    (errs, _) ->+      assertFailure ("expected associated data family operator declaration to parse, got: " <> show errs)++test_associatedDataFamilyInfixOperatorName :: Assertion+test_associatedDataFamilyInfixOperatorName = do+  let source = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "{-# LANGUAGE TypeOperators #-}", "class C a where", "  data a :*: b"]+      expectedName = mkUnqualifiedName NameConSym ":*:"+  case parseModule defaultConfig source of+    ([], modu) ->+      case map peelDeclAnn (moduleDecls modu) of+        [ DeclClass ClassDecl {classDeclItems = [ClassItemAnn _ (ClassItemDataFamilyDecl dataFamilyDecl)]}+          ]+            | binderHeadForm (dataFamilyDeclHead dataFamilyDecl) == TypeHeadInfix,+              binderHeadName (dataFamilyDeclHead dataFamilyDecl) == expectedName,+              map tyVarBinderName (binderHeadParams (dataFamilyDeclHead dataFamilyDecl)) == ["a", "b"],+              isNothing (dataFamilyDeclKind dataFamilyDecl) ->+                pure ()+        other ->+          assertFailure ("expected infix associated data family operator declaration, got: " <> show other)+    (errs, _) ->+      assertFailure ("expected infix associated data family operator declaration to parse, got: " <> show errs)++prop_generatedDataFamilyInstancesCanIncludeInlineResultKinds :: Property+prop_generatedDataFamilyInstancesCanIncludeInlineResultKinds =+  let samples = sampleGen 6000 genDeclDataFamilyInst+      matching =+        [ decl+        | decl@(DeclDataFamilyInst DataFamilyInst {dataFamilyInstKind = Just _}) <- samples+        ]+   in counterexample ("expected at least one generated data family instance with inline result kind; sampled " <> show (length samples)) (not (null matching))++prop_generatedClassDeclsCanIncludeAssociatedDataFamilyOperators :: Property+prop_generatedClassDeclsCanIncludeAssociatedDataFamilyOperators =+  let samples = sampleGen 6000 genDeclClass+      prefixMatches =+        [ decl+        | decl@(DeclClass ClassDecl {classDeclItems}) <- samples,+          ClassItemDataFamilyDecl dataFamilyDecl <- map peelClassDeclItemAnn classDeclItems,+          binderHeadForm (dataFamilyDeclHead dataFamilyDecl) == TypeHeadPrefix,+          let name = binderHeadName (dataFamilyDeclHead dataFamilyDecl),+          unqualifiedNameType name == NameConSym+        ]+      infixMatches =+        [ decl+        | decl@(DeclClass ClassDecl {classDeclItems}) <- samples,+          ClassItemDataFamilyDecl dataFamilyDecl <- map peelClassDeclItemAnn classDeclItems,+          binderHeadForm (dataFamilyDeclHead dataFamilyDecl) == TypeHeadInfix,+          let name = binderHeadName (dataFamilyDeclHead dataFamilyDecl),+          let params = binderHeadParams (dataFamilyDeclHead dataFamilyDecl),+          unqualifiedNameType name == NameConSym+            && length params == 2+        ]+   in counterexample+        ( "expected generated class declarations to include prefix and infix associated data family operators; sampled "+            <> show (length samples)+            <> ", prefix matches="+            <> show (length prefixMatches)+            <> ", infix matches="+            <> show (length infixMatches)+        )+        (not (null prefixMatches) && not (null infixMatches))++prop_generatedAssociatedTypeFamiliesCanUseExplicitFamilyKeyword :: Property+prop_generatedAssociatedTypeFamiliesCanUseExplicitFamilyKeyword =+  let samples = sampleGen 6000 (arbitrary :: Gen Module)+      matching =+        [ tf+        | modu <- samples,+          DeclClass ClassDecl {classDeclItems} <- moduleDecls modu,+          ClassItemTypeFamilyDecl tf <- map peelClassDeclItemAnn classDeclItems,+          typeFamilyDeclExplicitFamilyKeyword tf+        ]+   in counterexample+        ( "expected generated modules to include explicit associated type family syntax; sampled "+            <> show (length samples)+            <> ", matches="+            <> show (length matching)+        )+        (not (null matching))++prop_generatedClassDeclsCoverAllClassItemConstructors :: Property+prop_generatedClassDeclsCoverAllClassItemConstructors =+  let samples = sampleGen 6000 genDeclClass+      seen =+        Set.fromList+          [ showConstr (toConstr item)+          | DeclClass ClassDecl {classDeclItems} <- samples,+            item <- map peelClassDeclItemAnn classDeclItems+          ]+      expected =+        Set.fromList+          [ ctor+          | ctor <- map showConstr (dataTypeConstrs (dataTypeOf (undefined :: ClassDeclItem))),+            ctor /= "ClassItemAnn"+          ]+      missing = Set.toList (expected Set.\\ seen)+   in counterexample+        ( "expected generated class declarations to cover all class item constructors; missing "+            <> show missing+            <> ", sampled "+            <> show (length samples)+            <> " declarations"+        )+        (Set.null (expected Set.\\ seen))++prop_generatedModulesCanIncludeEmptyBundledImports :: Property+prop_generatedModulesCanIncludeEmptyBundledImports =+  let samples = sampleGen 6000 (arbitrary :: Gen Module)+      matching =+        [ modu+        | modu <- samples,+          any hasEmptyBundledImport (moduleImports modu)+        ]+   in counterexample+        ( "expected generated modules to include empty bundled imports; sampled "+            <> show (length samples)+            <> ", matches="+            <> show (length matching)+        )+        (not (null matching))+  where+    hasEmptyBundledImport decl =+      case importDeclSpec decl of+        Just spec -> any isEmptyBundledImportItem (importSpecItems spec)+        Nothing -> False+    isEmptyBundledImportItem item =+      case item of+        ImportAnn _ sub -> isEmptyBundledImportItem sub+        ImportItemWith _ _ [] -> True+        _ -> False++prop_generatedTypeNamesSupportEmptyBundledImports :: Property+prop_generatedTypeNamesSupportEmptyBundledImports =+  let samples = sampleGen 512 genTypeName+      renderImport name = T.unlines ["module M where", "import A (" <> renderUnqualifiedName name <> "())"]+      failures =+        [ (name, err)+        | name <- samples,+          Just err <- [validateParser "GeneratedEmptyBundledImport.hs" Haskell2010Edition [] (renderImport name)]+        ]+   in counterexample+        ( unlines+            [ "expected generated type names to support empty bundled import syntax",+              "sample count: " <> show (length samples),+              "failure count: " <> show (length failures),+              unlines [T.unpack (renderUnqualifiedName name) <> ": " <> show err | (name, err) <- take 10 failures]+            ]+        )+        (null failures)
+ test/Test/ErrorMessages/Suite.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.ErrorMessages.Suite+  ( errorMessageTests,+  )+where++import Control.Monad (unless, when)+import Data.Text qualified as T+import ParserErrorGolden qualified as PEG+import System.FilePath (takeExtension)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertFailure, testCase)++errorMessageTests :: IO TestTree+errorMessageTests = do+  cases <- PEG.loadErrorMessageCases+  checks <- mapM mkCaseTest cases+  summary <- mkSummaryTest cases+  pure (testGroup "error-messages" ([fixtureValidationTests] <> checks <> [summary]))++mkCaseTest :: PEG.ErrorMessageCase -> IO TestTree+mkCaseTest meta = pure $ testCase (PEG.caseId meta) (assertCase meta)++mkSummaryTest :: [PEG.ErrorMessageCase] -> IO TestTree+mkSummaryTest cases = do+  let outcomes = map evaluate cases+  pure $ testCase "summary" (assertNoRegressions outcomes)++assertCase :: PEG.ErrorMessageCase -> Assertion+assertCase meta =+  case PEG.evaluateErrorMessageCase meta of+    (PEG.OutcomeFail, details) ->+      assertFailure+        ( "Regression in parser error case "+            <> PEG.caseId meta+            <> " ("+            <> PEG.caseCategory meta+            <> ")"+            <> " details="+            <> details+        )+    _ -> pure ()++assertNoRegressions :: [(PEG.ErrorMessageCase, PEG.Outcome, String)] -> Assertion+assertNoRegressions outcomes = do+  let (passN, failN) = PEG.progressSummary outcomes+      totalN = passN + failN+      completion = pct passN totalN+  when (failN > 0) $+    assertFailure+      ( "parser error regressions found. "+          <> "pass="+          <> show passN+          <> " fail="+          <> show failN+          <> " completion="+          <> show completion+          <> "%"+      )++evaluate :: PEG.ErrorMessageCase -> (PEG.ErrorMessageCase, PEG.Outcome, String)+evaluate meta =+  let (outcome, details) = PEG.evaluateErrorMessageCase meta+   in (meta, outcome, details)++pct :: Int -> Int -> Double+pct done totalN+  | totalN <= 0 = 0.0+  | otherwise = fromIntegral (done * 10000 `div` totalN) / 100.0++fixtureValidationTests :: TestTree+fixtureValidationTests =+  testGroup+    "fixture-parse"+    [ testCase "rejects missing required keys" $+        case PEG.parseErrorMessageCaseText "missing.yaml" "ghc: bad\n" of+          Left _ -> pure ()+          Right _ -> assertFailure "expected parse failure for missing required YAML keys",+      testCase "rejects unexpected status field" $+        case PEG.parseErrorMessageCaseText "status.yaml" invalidStatusFixture of+          Left _ -> pure ()+          Right _ -> assertFailure "expected parse failure when status field is present",+      testCase "accepts basic fixtures" $+        case PEG.parseErrorMessageCaseText "pass.yaml" validPassFixture of+          Left err -> assertFailure ("expected parse success, got: " <> err)+          Right _ -> pure (),+      testCase "only YAML fixtures are loaded" $ do+        cases <- PEG.loadErrorMessageCases+        mapM_+          ( \meta ->+              unless (takeExtension (PEG.casePath meta) `elem` [".yaml", ".yml"]) $+                assertFailure ("unexpected non-error-message fixture loaded: " <> PEG.casePath meta)+          )+          cases+    ]++invalidStatusFixture :: T.Text+invalidStatusFixture =+  T.unlines+    [ "src: bad",+      "ghc: bad",+      "aihc: bad",+      "status: pass"+    ]++validPassFixture :: T.Text+validPassFixture =+  T.unlines+    [ "src: bad",+      "ghc: bad",+      "aihc: bad"+    ]
+ test/Test/ExtensionMapping/Suite.hs view
@@ -0,0 +1,110 @@+module Test.ExtensionMapping.Suite+  ( extensionMappingTests,+  )+where++import Aihc.Parser.Syntax qualified as Syntax+import Data.List (intercalate, sort)+import Data.Maybe (isNothing)+import Data.Set qualified as Set+import Data.Text qualified as T+import GHC.Driver.DynFlags qualified as DynFlags+import GHC.LanguageExtensions.Type qualified as GHC+import Language.Haskell.Extension qualified as Cabal+import Language.Haskell.TH.Syntax qualified as TH+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase)++extensionMappingTests :: TestTree+extensionMappingTests =+  testGroup+    "extension-mapping"+    [ testCase "maps all Cabal KnownExtension constructors" test_cabalKnownExtensionCoverage,+      testCase "maps all TemplateHaskell Extension constructors" test_templateHaskellExtensionCoverage,+      testGroup+        "language-edition-extensions"+        [ testCase "Haskell98 extensions match GHC" test_haskell98Extensions,+          testCase "Haskell2010 extensions match GHC" test_haskell2010Extensions,+          testCase "GHC2021 extensions match GHC" test_ghc2021Extensions,+          testCase "GHC2024 extensions match GHC" test_ghc2024Extensions+        ]+    ]++test_cabalKnownExtensionCoverage :: IO ()+test_cabalKnownExtensionCoverage = do+  let missing =+        [ show ext+        | ext <- [minBound .. maxBound] :: [Cabal.KnownExtension],+          isNothing (toParserExtension ext)+        ]+  assertNoMissing "Cabal.KnownExtension" missing++test_templateHaskellExtensionCoverage :: IO ()+test_templateHaskellExtensionCoverage = do+  let missing =+        [ show ext+        | ext <- [minBound .. maxBound] :: [TH.Extension],+          isNothing (toParserExtension ext)+        ]+  assertNoMissing "Language.Haskell.TH.Syntax.Extension" missing++toParserExtension :: (Show a) => a -> Maybe Syntax.Extension+toParserExtension = Syntax.parseExtensionName . T.pack . show++assertNoMissing :: String -> [String] -> IO ()+assertNoMissing _ [] = pure ()+assertNoMissing source missing =+  assertFailure+    ( source+        <> " constructors missing Parser.Syntax mapping: "+        <> intercalate ", " missing+    )++-- | Test that our Haskell98 extension list matches GHC's.+test_haskell98Extensions :: IO ()+test_haskell98Extensions =+  compareEditionExtensions Syntax.Haskell98Edition DynFlags.Haskell98++-- | Test that our Haskell2010 extension list matches GHC's.+test_haskell2010Extensions :: IO ()+test_haskell2010Extensions =+  compareEditionExtensions Syntax.Haskell2010Edition DynFlags.Haskell2010++-- | Test that our GHC2021 extension list matches GHC's.+test_ghc2021Extensions :: IO ()+test_ghc2021Extensions =+  compareEditionExtensions Syntax.GHC2021Edition DynFlags.GHC2021++-- | Test that our GHC2024 extension list matches GHC's.+test_ghc2024Extensions :: IO ()+test_ghc2024Extensions =+  compareEditionExtensions Syntax.GHC2024Edition DynFlags.GHC2024++-- | Compare our edition extensions against GHC's.+-- The test extracts the canonical extension names from both sources and compares them.+compareEditionExtensions :: Syntax.LanguageEdition -> DynFlags.Language -> IO ()+compareEditionExtensions ourEdition ghcLang = do+  let ourExts = Set.fromList (map (T.unpack . Syntax.extensionName) (Syntax.languageEditionExtensions ourEdition))+      ghcExts = Set.fromList (map ghcExtToName (DynFlags.languageExtensions (Just ghcLang)))+      -- Extensions in GHC but not in our list+      missingInOurs = Set.difference ghcExts ourExts+      -- Extensions in our list but not in GHC+      extraInOurs = Set.difference ourExts ghcExts++  case (Set.null missingInOurs, Set.null extraInOurs) of+    (True, True) -> pure ()+    _ ->+      assertFailure $+        "Extension mismatch for "+          <> show ghcLang+          <> ":\n"+          <> (if Set.null missingInOurs then "" else "  Missing (in GHC but not ours): " <> intercalate ", " (sort (Set.toList missingInOurs)) <> "\n")+          <> (if Set.null extraInOurs then "" else "  Extra (in ours but not GHC): " <> intercalate ", " (sort (Set.toList extraInOurs)) <> "\n")++-- | Convert a GHC extension to its canonical name for comparison.+-- Handles the spelling difference for Cpp (GHC) vs CPP (ours).+ghcExtToName :: GHC.Extension -> String+ghcExtToName ext =+  case ext of+    GHC.Cpp -> "CPP"+    _ -> show ext
+ test/Test/Fixtures/ViewPatterns/do-tuple-view-pattern.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{- Test nested view pattern in tuple inside do-block -}+module DoTupleViewPattern where++f mx = do+  (a, b -> c) <- mx+  return undefined
+ test/Test/Fixtures/corpus/regressions/regression-001.hs view
@@ -0,0 +1,2 @@+module R where+apply = f (g h)
+ test/Test/Fixtures/equivalent/decl/context-kindsig-rhs.yaml view
@@ -0,0 +1,6 @@+extensions: [TemplateHaskell, PartialTypeSignatures, FlexibleContexts]+equivalent:+  - "type X = _ => $a :: _"+  - "type X = (_ => $a) :: _"+status: pass+reason: GHC parses the unparenthesized kind signature as applying to the whole constrained type.
+ test/Test/Fixtures/equivalent/decl/delimited-context-kindsig-rhs.yaml view
@@ -0,0 +1,6 @@+extensions: [PartialTypeSignatures, FlexibleContexts]+equivalent:+  - "type T a = (_, _ => _ :: _)"+  - "type T a = (_, (_ => _) :: _)"+status: pass+reason: GHC parses a bare kind signature after a tuple-element context as applying to the whole constrained type.
+ test/Test/Fixtures/equivalent/decl/paren-rhs.yaml view
@@ -0,0 +1,5 @@+extensions: []+equivalent:+  - x = 10+  - x = (10)+status: pass
+ test/Test/Fixtures/equivalent/expr/infix-left-assoc.yaml view
@@ -0,0 +1,6 @@+extensions: []+equivalent:+  - a + b + c+  - (a + b) + c+status: pass+reason: parser matches GHC's left-associated parsed infix tree
+ test/Test/Fixtures/equivalent/expr/multi-way-if-branch-infix.yaml view
@@ -0,0 +1,6 @@+extensions: []+equivalent:+  - if | True -> a + b+  - if | True -> (a + b)+status: pass+reason: A same-line infix expression after a multi-way-if guard arrow belongs to the guard body.
+ test/Test/Fixtures/equivalent/expr/multi-way-if-indented.yaml view
@@ -0,0 +1,13 @@+extensions: []+equivalent:+  - |+    if | True+        ->+        1+       + 2+  - |+    if | True+        ->+        1 + 2+status: pass+reason: With indentation the same as the bar, the infix operator is part of the guard body.
+ test/Test/Fixtures/equivalent/expr/multi-way-if-infix.yaml view
@@ -0,0 +1,14 @@+extensions: []+equivalent:+  - |+    if | True+        ->+        1+      + 2+  - |+    (if | True+        ->+        1)+      + 2+status: pass+reason: With indentation of less than the bar, the infix operator is not part of the guard body.
+ test/Test/Fixtures/equivalent/expr/multi-way-if-outside-infix.yaml view
@@ -0,0 +1,8 @@+extensions: []+equivalent:+  - |+    if | True -> a+     + b+  - (if | True -> a) + b+status: pass+reason: An infix operator indented less than the multi-way-if bar is outside the guard body.
+ test/Test/Fixtures/equivalent/module/braced-decls.yaml view
@@ -0,0 +1,8 @@+extensions: []+equivalent:+  - |+    module X where+    x = 10+  - |+    module X where { x = 10 }+status: pass
+ test/Test/Fixtures/equivalent/module/th-name-quote-record-dot.yaml view
@@ -0,0 +1,10 @@+extensions: [TemplateHaskell, OverloadedRecordDot]+equivalent:+  - |+    module M where+    x = ' ().a+  - |+    module M where+    x = (' ()).a+status: pass+reason: TH value quote record-dot syntax is equivalent to explicit grouping
+ test/Test/Fixtures/equivalent/module/th-type-name-quote-record-dot.yaml view
@@ -0,0 +1,10 @@+extensions: [TemplateHaskell, OverloadedRecordDot]+equivalent:+  - |+    module M where+    x = '' ().a+  - |+    module M where+    x = ('' ()).a+status: pass+reason: TH type name quote record-dot syntax is equivalent to explicit grouping
+ test/Test/Fixtures/equivalent/pattern/paren-con-arg.yaml view
@@ -0,0 +1,5 @@+extensions: []+equivalent:+  - Just x+  - Just (x)+status: pass
+ test/Test/Fixtures/equivalent/pattern/view-block-app-arg.yaml view
@@ -0,0 +1,20 @@+extensions: [BlockArguments, UnboxedSums, ViewPatterns, MultiWayIf]+equivalent:+  - |+    (# []+           if | let {  }+                  ->+                   []+           []+          -> _+         |  #)+  - |+    (# []+           (if | let {  }+                   ->+                    [])+           []+          -> _+         |  #)+status: pass+reason: A view-pattern arrow bounds the view expression, so block arguments without type signatures can stay bare.
+ test/Test/Fixtures/equivalent/pattern/view-nonfinal-let-block-app-arg.yaml view
@@ -0,0 +1,16 @@+extensions: [BlockArguments, ViewPatterns]+equivalent:+  - |+    ([]+        let _ = []+          in []+        []+       -> _)+  - |+    ([]+        (let _ = []+           in [])+        []+       -> _)+status: fail+reason: A non-final let block argument in a view expression absorbs the following application argument unless parenthesized.
+ test/Test/Fixtures/error-messages/module/arrow-pattern.yaml view
@@ -0,0 +1,11 @@+src: |+  {-# LANGUAGE Arrows #-}+  f (y -< x) = 5+ghc: |+  test.hs:2:4: error: [GHC-98980] Command syntax in pattern: y -< x+aihc: |+  test.hs:2:6:+  2 | f (y -< x) = 5+    |      ^^+  unexpected '-<'+  expecting pattern atom
+ test/Test/Fixtures/error-messages/module/case-missing-of.yaml view
@@ -0,0 +1,21 @@+src: |+  x = case+  y = 20 ++ghc: |+  test.hs:2:1: error: [GHC-58481]+      parse error (possibly incorrect indentation or mismatched brackets)+aihc: |+  test.hs:1:5:+  1 | x = case+    |     ^^^^+  unexpected end of input+  expecting expression+  context: while parsing case expression+  context: while parsing equation right-hand side++  test.hs:2:8:+  2 | y = 20 ++    |        ^+  unexpected end of input+  expecting expression+  context: while parsing equation right-hand side
+ test/Test/Fixtures/error-messages/module/cpp-bad-macro.yaml view
@@ -0,0 +1,12 @@+src: |+  {-# LANGUAGE CPP #-}+  #define BadCPPMacro module+  fn :: BadCPPMacro -> IO ()+ghc: |+  test.hs:5:7: error: [GHC-58481] parse error on input `module'+aihc: |+  test.hs:5:7:+  5 | fn :: module -> IO ()+    |       ^^^^^^+  unexpected 'module'+  expecting type
+ test/Test/Fixtures/error-messages/module/cpp-directive-missing-rhs.yaml view
@@ -0,0 +1,12 @@+src: |+  {-# LANGUAGE CPP #-}+  #define Short MuchLongerType+  fn :: Short -> module+ghc: |+  test.hs:5:25: error: [GHC-58481] parse error on input `module'+aihc: |+  test.hs:5:25:+  5 | fn :: MuchLongerType -> module+    |                         ^^^^^^+  unexpected 'module'+  expecting type
+ test/Test/Fixtures/error-messages/module/do-bind-missing-rhs.yaml view
@@ -0,0 +1,18 @@+src: |+  x = do { _ <- }+ghc: |+  test.hs:1:15: error: [GHC-58481] parse error on input `}'+aihc: |+  test.hs:1:15:+  1 | x = do { _ <- }+    |               ^+  unexpected '}'+  expecting expression+  context: while parsing '<-' binding+  context: while parsing equation right-hand side++  test.hs:1:15:+  1 | x = do { _ <- }+    |               ^+  unexpected }+  expecting end of input
+ test/Test/Fixtures/error-messages/module/hash-line-missing-rhs.yaml view
@@ -0,0 +1,13 @@+src: |+  # 20 "source"+  x =+ghc: |+  source:21:1: error: [GHC-58481]+      parse error (possibly incorrect indentation or mismatched brackets)+aihc: |+  source:20:3:+  20 | x =+     |   ^+  unexpected end of input+  expecting expression+  context: while parsing equation right-hand side
+ test/Test/Fixtures/error-messages/module/if-missing-condition-keyword.yaml view
@@ -0,0 +1,11 @@+src: |+  x = if then 1 else 2+ghc: |+  test.hs:1:8: error: [GHC-58481] parse error on input `then'+aihc: |+  test.hs:1:8:+  1 | x = if then 1 else 2+    |        ^^^^+  unexpected 'then'+  expecting expression+  context: while parsing equation right-hand side
+ test/Test/Fixtures/error-messages/module/import-prelude-lowercase.yaml view
@@ -0,0 +1,10 @@+src: |+  import prelude+ghc: |+  test.hs:1:8: error: [GHC-58481] parse error on input `prelude'+aihc: |+  test.hs:1:8:+  1 | import prelude+    |        ^^^^^^^+  unexpected 'prelude'+  expecting module name
+ test/Test/Fixtures/error-messages/module/import-qualified-qualified.yaml view
@@ -0,0 +1,12 @@+src: |+  {-# LANGUAGE ImportQualifiedPost #-}+  import qualified Prelude qualified+ghc: |+  test.hs:2:26: error: [GHC-05661]+      Multiple occurrences of 'qualified'+aihc: |+  test.hs:2:26:+  2 | import qualified Prelude qualified+    |                          ^^^^^^^^^+  unexpected 'qualified'+  expecting import declaration without duplicate 'qualified'
+ test/Test/Fixtures/error-messages/module/import-then-let-missing-rhs.yaml view
@@ -0,0 +1,19 @@+src: |+  import+  x = let+ghc: |+  test.hs:2:1: error: [GHC-58481]+      parse error (possibly incorrect indentation or mismatched brackets)+aihc: |+  test.hs:1:1:+  1 | import+    | ^^^^^^+  unexpected end of input+  expecting module name++  test.hs:2:5:+  2 | x = let+    |     ^^^+  unexpected end of input+  expecting expression+  context: while parsing equation right-hand side
+ test/Test/Fixtures/error-messages/module/import-where.yaml view
@@ -0,0 +1,10 @@+src: |+  import where+ghc: |+  test.hs:1:8: error: [GHC-58481] parse error on input `where'+aihc: |+  test.hs:1:8:+  1 | import where+    |        ^^^^^+  unexpected 'where'+  expecting module name
+ test/Test/Fixtures/error-messages/module/lambda-in-case-branch.yaml view
@@ -0,0 +1,12 @@+src: |+  f x =+    case x of+      \a -> a+ghc: |+  test.hs:3:5: error: [GHC-00482] Illegal lambda-syntax in pattern+aihc: |+  test.hs:3:5:+  3 |     \a -> a+    |     ^+  unexpected \+  expecting end of input
+ test/Test/Fixtures/error-messages/module/lambda-missing-body.yaml view
@@ -0,0 +1,13 @@+src: |+  x = \y ->+ghc: |+  test.hs:2:1: error: [GHC-58481]+      parse error (possibly incorrect indentation or mismatched brackets)+aihc: |+  test.hs:1:8:+  1 | x = \y ->+    |        ^^+  unexpected end of input+  expecting expression+  context: while parsing lambda body+  context: while parsing equation right-hand side
+ test/Test/Fixtures/error-messages/module/let-expression-in-pattern.yaml view
@@ -0,0 +1,16 @@+src: |+  f n (let exp = x^2 in exp n) = True+ghc: |+  test.hs:1:6: error: [GHC-78892] (let ... in ...)-syntax in pattern+aihc: |+  test.hs:1:6:+  1 | f n (let exp = x^2 in exp n) = True+    |      ^^^+  unexpected 'let'+  expecting pattern atom++  test.hs:1:28:+  1 | f n (let exp = x^2 in exp n) = True+    |                            ^+  unexpected )+  expecting end of input
+ test/Test/Fixtures/error-messages/module/list-pattern-in-equation.yaml view
@@ -0,0 +1,12 @@+src: |+  f [1..10] = 0+  f _ = 1+ghc: |+  test.hs:1:3: error: [GHC-04584]+      Expression syntax in pattern: [1 .. 10]+aihc: |+  test.hs:1:5:+  1 | f [1..10] = 0+    |     ^^+  unexpected '..'+  expecting pattern atom
+ test/Test/Fixtures/error-messages/module/missing-class-item-separator.yaml view
@@ -0,0 +1,18 @@+src: |+  {-# LANGUAGE TypeFamilies #-}+  module M where+  class C a where { type F a type G a }+ghc: |+  test.hs:3:28: error: [GHC-58481] parse error on input `type'+aihc: |+  test.hs:3:28:+  3 | class C a where { type F a type G a }+    |                            ^^^^+  unexpected type+  expecting operator '::', operator '=', symbol '(', symbol ';', symbol '}', type application '@', or type parameter binder+  +  test.hs:3:37:+  3 | class C a where { type F a type G a }+    |                                     ^+  unexpected }+  expecting end of input
+ test/Test/Fixtures/error-messages/module/missing-import-name.yaml view
@@ -0,0 +1,11 @@+src: |+  import+ghc: |+  test.hs:2:1: error: [GHC-58481]+      parse error (possibly incorrect indentation or mismatched brackets)+aihc: |+  test.hs:1:1:+  1 | import+    | ^^^^^^+  unexpected end of input+  expecting module name
+ test/Test/Fixtures/error-messages/module/missing-module-name.yaml view
@@ -0,0 +1,10 @@+src: |+  module where+ghc: |+  test.hs:1:8: error: [GHC-58481] parse error on input `where'+aihc: |+  test.hs:1:8:+  1 | module where+    |        ^^^^^+  unexpected 'where'+  expecting module name
+ test/Test/Fixtures/error-messages/module/missing-rhs.yaml view
@@ -0,0 +1,12 @@+src: |+  x =+ghc: |+  test.hs:2:1: error: [GHC-58481]+      parse error (possibly incorrect indentation or mismatched brackets)+aihc: |+  test.hs:1:3:+  1 | x =+    |   ^+  unexpected end of input+  expecting expression+  context: while parsing equation right-hand side
+ test/Test/Fixtures/error-messages/module/multiple-decl-errors.yaml view
@@ -0,0 +1,21 @@+src: |+  x =+  y =+  z = 1+ghc: |+  test.hs:2:1: error: [GHC-58481]+      parse error (possibly incorrect indentation or mismatched brackets)+aihc: |+  test.hs:1:3:+  1 | x =+    |   ^+  unexpected end of input+  expecting expression+  context: while parsing equation right-hand side++  test.hs:2:3:+  2 | y =+    |   ^+  unexpected end of input+  expecting expression+  context: while parsing equation right-hand side
+ test/Test/Fixtures/error-messages/module/multiple-import-errors-braced.yaml view
@@ -0,0 +1,16 @@+src: |+  { import qualified; import qualified; x = 1 }+ghc: |+  test.hs:1:19: error: [GHC-58481] parse error on input `;'+aihc: |+  test.hs:1:19:+  1 | { import qualified; import qualified; x = 1 }+    |                   ^+  unexpected ';'+  expecting module name++  test.hs:1:37:+  1 | { import qualified; import qualified; x = 1 }+    |                                     ^+  unexpected ';'+  expecting module name
+ test/Test/Fixtures/error-messages/module/multiple-import-errors.yaml view
@@ -0,0 +1,16 @@+src: |+  import qualified; import qualified; x = 1+ghc: |+  test.hs:1:17: error: [GHC-58481] parse error on input `;'+aihc: |+  test.hs:1:17:+  1 | import qualified; import qualified; x = 1+    |                 ^+  unexpected ';'+  expecting module name++  test.hs:1:35:+  1 | import qualified; import qualified; x = 1+    |                                   ^+  unexpected ';'+  expecting module name
+ test/Test/Fixtures/error-messages/module/nested-case-in-equation.yaml view
@@ -0,0 +1,12 @@+src: |+  f x y = case x of+    case y of+      _ -> 1+ghc: |+  test.hs:2:3: error: [GHC-53786] (case ... of ...)-syntax in pattern+aihc: |+  test.hs:2:3:+  2 |   case y of+    |   ^^^^+  unexpected case+  expecting end of input
+ test/Test/Fixtures/error-messages/module/pattern-as-non-constructor.yaml view
@@ -0,0 +1,10 @@+src: |+  f x@(just a) = ()+ghc: |+  test.hs:1:6: error: [GHC-07626] Parse error in pattern: just+aihc: |+  test.hs:1:11:+  1 | f x@(just a) = ()+    |           ^+  unexpected 'a'+  expecting pattern atom
+ test/Test/Fixtures/error-messages/module/pattern-list-vs-recursive-function.yaml view
@@ -0,0 +1,10 @@+src: |+  f n (sq n) = True+ghc: |+  test.hs:1:6: error: [GHC-07626] Parse error in pattern: sq+aihc: |+  test.hs:1:9:+  1 | f n (sq n) = True+    |         ^+  unexpected 'n'+  expecting pattern atom
+ test/Test/Fixtures/error-messages/module/pattern-reserved-with-patternsynonyms.yaml view
@@ -0,0 +1,12 @@+src: |+  {-# LANGUAGE PatternSynonyms #-}+  id :: pattern -> pattern+  id x = x+ghc: |+  test.hs:2:7: error: [GHC-58481] parse error on input `pattern'+aihc: |+  test.hs:2:7:+  2 | id :: pattern -> pattern+    |       ^^^^^^^+  unexpected 'pattern'+  expecting type
+ test/Test/Fixtures/error-messages/module/record-update-with-wildcard.yaml view
@@ -0,0 +1,18 @@+src: |+  y = x {field=8, ..}+ghc: |+  test.hs:1:17: error: [GHC-70712]+      You cannot use `..' in a record update+aihc: |+  test.hs:1:17:+  1 | y = x {field=8, ..}+    |                 ^^+  unexpected '..'+  expecting expression+  context: while parsing equation right-hand side++  test.hs:1:19:+  1 | y = x {field=8, ..}+    |                   ^+  unexpected }+  expecting end of input
+ test/Test/Fixtures/error-messages/module/transform-list-comp-by-binder.yaml view
@@ -0,0 +1,12 @@+src: |+  {-# LANGUAGE TransformListComp #-}+  module TransformListCompByBinder where+  by = ()+ghc: |+  test.hs:3:1: error: [GHC-58481] parse error on input `by'+aihc: |+  test.hs:3:1:+  3 | by = ()+    | ^^+  unexpected by+  expecting end of input
+ test/Test/Fixtures/error-messages/module/transform-list-comp-using-binder.yaml view
@@ -0,0 +1,12 @@+src: |+  {-# LANGUAGE TransformListComp #-}+  module TransformListCompUsingBinder where+  using = ()+ghc: |+  test.hs:3:1: error: [GHC-58481] parse error on input `using'+aihc: |+  test.hs:3:1:+  3 | using = ()+    | ^^^^^+  unexpected using+  expecting end of input
+ test/Test/Fixtures/error-messages/module/tuple-or-pattern-merge.yaml view
@@ -0,0 +1,14 @@+src: |+  merge [] bs rest = bs ++ rest+  merge as [] rest = as ++ rest+  merge a:as (b:bs) rest+      | a > b     = merge as (b:bs) (a:rest)+      | otherwise = merge (a:as) bs (b:rest)+ghc: |+  test.hs:3:1: error: [GHC-07626] Parse error in pattern: merge+aihc: |+  test.hs:3:8:+  3 | merge a:as (b:bs) rest+    |        ^+  unexpected ':'+  expecting = or guarded right-hand side
+ test/Test/Fixtures/golden/expr/block-args-case-simple.yaml view
@@ -0,0 +1,7 @@+extensions: [BlockArguments]+input: |+  id case x of+    _ -> ()+ast: |-+  EApp (EVar "id") (ECase (EVar "x") [CaseAlt (PWildcard) (ETuple [])])+status: pass
+ test/Test/Fixtures/golden/expr/block-args-case-trailing-arg.yaml view
@@ -0,0 +1,7 @@+extensions: [BlockArguments]+input: |+  f (case x of+       _ -> ()) arg2+ast: |-+  EApp (EApp (EVar "f") (EParen (ECase (EVar "x") [CaseAlt (PWildcard) (ETuple [])]))) (EVar "arg2")+status: pass
+ test/Test/Fixtures/golden/expr/block-args-do-bind.yaml view
@@ -0,0 +1,8 @@+extensions: [BlockArguments]+input: |+  mapM f do+    x <- get+    return x+ast: |-+  EApp (EApp (EVar "mapM") (EVar "f")) (EDo [DoBind (PVar "x") (EVar "get"), DoExpr (EApp (EVar "return") (EVar "x"))])+status: pass
+ test/Test/Fixtures/golden/expr/block-args-do-disabled.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  id do+    pure ()+ast: |-+status: fail+reason: BlockArguments extension not enabled
+ test/Test/Fixtures/golden/expr/block-args-do-multiple.yaml view
@@ -0,0 +1,8 @@+extensions: [BlockArguments]+input: |+  f x do+    y+    z+ast: |-+  EApp (EApp (EVar "f") (EVar "x")) (EDo [DoExpr (EVar "y"), DoExpr (EVar "z")])+status: pass
+ test/Test/Fixtures/golden/expr/block-args-do-simple.yaml view
@@ -0,0 +1,7 @@+extensions: [BlockArguments]+input: |+  id do+    pure ()+ast: |-+  EApp (EVar "id") (EDo [DoExpr (EApp (EVar "pure") (ETuple []))])+status: pass
+ test/Test/Fixtures/golden/expr/block-args-if-explicit-paren.yaml view
@@ -0,0 +1,6 @@+extensions: [BlockArguments]+input: |+  f (if x then y else z)+ast: |-+  EApp (EVar "f") (EParen (EIf (EVar "x") (EVar "y") (EVar "z")))+status: pass
+ test/Test/Fixtures/golden/expr/block-args-if-nested.yaml view
@@ -0,0 +1,6 @@+extensions: [BlockArguments]+input: |+  f if x then g if y then a else b else c+ast: |-+  EApp (EVar "f") (EIf (EVar "x") (EApp (EVar "g") (EIf (EVar "y") (EVar "a") (EVar "b"))) (EVar "c"))+status: pass
+ test/Test/Fixtures/golden/expr/block-args-if-simple.yaml view
@@ -0,0 +1,6 @@+extensions: [BlockArguments]+input: |+  id if x then y else z+ast: |-+  EApp (EVar "id") (EIf (EVar "x") (EVar "y") (EVar "z"))+status: pass
+ test/Test/Fixtures/golden/expr/block-args-if-trailing-arg.yaml view
@@ -0,0 +1,6 @@+extensions: [BlockArguments]+input: |+  f (if x then y else z) arg2+ast: |-+  EApp (EApp (EVar "f") (EParen (EIf (EVar "x") (EVar "y") (EVar "z")))) (EVar "arg2")+status: pass
+ test/Test/Fixtures/golden/expr/block-args-lambda-simple.yaml view
@@ -0,0 +1,6 @@+extensions: [BlockArguments]+input: |+  id \x -> x+ast: |-+  EApp (EVar "id") (ELambdaPats [PVar "x"] (EVar "x"))+status: pass
+ test/Test/Fixtures/golden/expr/block-args-lambda-trailing-arg.yaml view
@@ -0,0 +1,6 @@+extensions: [BlockArguments]+input: |+  f (\x -> x) arg2+ast: |-+  EApp (EApp (EVar "f") (EParen (ELambdaPats [PVar "x"] (EVar "x")))) (EVar "arg2")+status: pass
+ test/Test/Fixtures/golden/expr/case-record-pattern.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  case x of Foo { bar = baz } -> baz+ast: |-+  ECase (EVar "x") [CaseAlt (PRecord "Foo" {"bar" = PVar "baz"}) (EVar "baz")]+status: pass
+ test/Test/Fixtures/golden/expr/cases-no-extension.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  \cases -> ()+ast: |-+  ELambdaPats [PVar "cases"] (ETuple [])+status: pass
+ test/Test/Fixtures/golden/expr/cases-with-extension.yaml view
@@ -0,0 +1,6 @@+extensions: [LambdaCase]+input: |+  \cases -> ()+ast: |-+  ELambdaCases [LambdaCaseAlt [] (ETuple [])]+status: pass
+ test/Test/Fixtures/golden/expr/do-explicit-braces-empty.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  do {}+ast: |-+status: fail+reason: empty do blocks are invalid
+ test/Test/Fixtures/golden/expr/do-explicit-braces.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  do { x; y }+ast: |-+  EDo [DoExpr (EVar "x"), DoExpr (EVar "y")]+status: pass
+ test/Test/Fixtures/golden/expr/do-layout-bad-dedent.yaml view
@@ -0,0 +1,8 @@+extensions: []+input: |+  do+    x+   y+ast: |-+status: fail+reason: invalid do-notation dedent
+ test/Test/Fixtures/golden/expr/do-layout-basic.yaml view
@@ -0,0 +1,8 @@+extensions: []+input: |+  do+    x+    y+ast: |-+  EDo [DoExpr (EVar "x"), DoExpr (EVar "y")]+status: pass
+ test/Test/Fixtures/golden/expr/do-layout-bind.yaml view
@@ -0,0 +1,8 @@+extensions: []+input: |+  do+    x <- y+    x+ast: |-+  EDo [DoBind (PVar "x") (EVar "y"), DoExpr (EVar "x")]+status: pass
+ test/Test/Fixtures/golden/expr/do-layout-continuation.yaml view
@@ -0,0 +1,8 @@+extensions: []+input: |+  do+    x+      y+ast: |-+  EDo [DoExpr (EApp (EVar "x") (EVar "y"))]+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-binary-int8.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals]+input: |+  0b1010#Int8+ast: |-+  EInt 10 TInt8Hash+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-double-hash.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals, MagicHash]+input: |+  10.3##+ast: |-+  EFloat 103 % 10 TDoubleHash+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-float-hash.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals, MagicHash]+input: |+  10.3#+ast: |-+  EFloat 103 % 10 TFloatHash+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-fractional.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals, MagicHash]+input: |+  10.3+ast: |-+  EFloat 103 % 10 TFractional+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-hex-word8.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals]+input: |+  0xFF#Word8+ast: |-+  EInt 255 TWord8Hash+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-int-hash.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals, MagicHash]+input: |+  1#+ast: |-+  EInt 1 TIntHash+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-int16.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals, MagicHash]+input: |+  123#Int16+ast: |-+  EInt 123 TInt16Hash+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-int32.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals, MagicHash]+input: |+  123#Int32+ast: |-+  EInt 123 TInt32Hash+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-int64.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals, MagicHash]+input: |+  123#Int64+ast: |-+  EInt 123 TInt64Hash+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-int8.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals, MagicHash]+input: |+  123#Int8+ast: |-+  EInt 123 TInt8Hash+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-word-hash.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals, MagicHash]+input: |+  1##+ast: |-+  EInt 1 TWordHash+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-word16.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals, MagicHash]+input: |+  123#Word16+ast: |-+  EInt 123 TWord16Hash+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-word32.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals, MagicHash]+input: |+  123#Word32+ast: |-+  EInt 123 TWord32Hash+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-word64.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals, MagicHash]+input: |+  123#Word64+ast: |-+  EInt 123 TWord64Hash+status: pass
+ test/Test/Fixtures/golden/expr/extended-literals-word8.yaml view
@@ -0,0 +1,6 @@+extensions: [ExtendedLiterals, MagicHash]+input: |+  123#Word8+ast: |-+  EInt 123 TWord8Hash+status: pass
+ test/Test/Fixtures/golden/expr/foo-hash-bar-magic-hash.yaml view
@@ -0,0 +1,6 @@+extensions: [MagicHash]+input: |+  foo#bar+ast: |-+  EApp (EVar "foo#") (EVar "bar")+status: pass
+ test/Test/Fixtures/golden/expr/foo-hash-bar-no-magic-hash.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  foo#bar+ast: |-+  EInfix (EVar "foo") "#" (EVar "bar")+status: pass
+ test/Test/Fixtures/golden/expr/hex-fractional-no-exponent.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  0x5e.a+ast: |-+  EFloat 757 % 8 TFractional+status: pass
+ test/Test/Fixtures/golden/expr/if-both-branches-type-sig.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  if x then y :: T else z :: U+ast: |-+  EIf (EVar "x") (ETypeSig (EVar "y") (TCon "T")) (ETypeSig (EVar "z") (TCon "U"))+status: pass
+ test/Test/Fixtures/golden/expr/if-else-type-sig.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  if x then y else z :: T+ast: |-+  EIf (EVar "x") (EVar "y") (ETypeSig (EVar "z") (TCon "T"))+status: pass
+ test/Test/Fixtures/golden/expr/if-then-type-sig-arrow.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  if x then y :: T -> U else z+ast: |-+  EIf (EVar "x") (ETypeSig (EVar "y") (TFun (TCon "T") (TCon "U"))) (EVar "z")+status: pass
+ test/Test/Fixtures/golden/expr/if-then-type-sig.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  if x then y :: T else z+ast: |-+  EIf (EVar "x") (ETypeSig (EVar "y") (TCon "T")) (EVar "z")+status: pass
+ test/Test/Fixtures/golden/expr/invalid-token.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  f @+ast: |-+status: fail+reason: invalid token
+ test/Test/Fixtures/golden/expr/lambda-case-empty.yaml view
@@ -0,0 +1,7 @@+extensions:+  - LambdaCase+input: |+  \case {}+ast: |-+  ELambdaCase []+status: pass
+ test/Test/Fixtures/golden/expr/lambda-case-multiline-application.yaml view
@@ -0,0 +1,11 @@+extensions:+  - LambdaCase+input: |+  map+    (\case+        Just n -> n+        Nothing -> 0+    )+ast: |-+  EApp (EVar "map") (EParen (ELambdaCase [CaseAlt (PCon "Just" [PVar "n"]) (EVar "n"), CaseAlt (PCon "Nothing" []) (EInt 0 TInteger)]))+status: pass
+ test/Test/Fixtures/golden/expr/lexneg-after-infix-dollar.yaml view
@@ -0,0 +1,6 @@+extensions: [LexicalNegation]+input: |+  f $ -x+ast: |-+  EInfix (EVar "f") "$" (ENegate (EVar "x"))+status: pass
+ test/Test/Fixtures/golden/expr/lexneg-app-space-var.yaml view
@@ -0,0 +1,6 @@+extensions: [LexicalNegation]+input: |+  f -x+ast: |-+  EApp (EVar "f") (ENegate (EVar "x"))+status: pass
+ test/Test/Fixtures/golden/expr/lexneg-paren-minus-spaced.yaml view
@@ -0,0 +1,6 @@+extensions: [LexicalNegation]+input: |+  (- x)+ast: |-+  EParen (ESectionR "-" (EVar "x"))+status: pass
+ test/Test/Fixtures/golden/expr/lexneg-precedence-infix.yaml view
@@ -0,0 +1,6 @@+extensions: [LexicalNegation]+input: |+  -a % b+ast: |-+  EInfix (ENegate (EVar "a")) "%" (EVar "b")+status: pass
+ test/Test/Fixtures/golden/expr/magic-hash-ident.yaml view
@@ -0,0 +1,6 @@+extensions: [MagicHash]+input: |+  x#+ast: |-+  EVar "x#"+status: pass
+ test/Test/Fixtures/golden/expr/magic-hash-int-literal.yaml view
@@ -0,0 +1,6 @@+extensions: [MagicHash]+input: |+  42#+ast: |-+  EInt 42 TIntHash+status: pass
+ test/Test/Fixtures/golden/expr/magic-hash-word-float-literal.yaml view
@@ -0,0 +1,6 @@+extensions: [MagicHash]+input: |+  0.0##+ast: |-+  EFloat 0 % 1 TDoubleHash+status: pass
+ test/Test/Fixtures/golden/expr/magic-hash-word-literal.yaml view
@@ -0,0 +1,6 @@+extensions: [MagicHash]+input: |+  0##+ast: |-+  EInt 0 TWordHash+status: pass
+ test/Test/Fixtures/golden/expr/mdo-explicit-braces.yaml view
@@ -0,0 +1,6 @@+extensions: [RecursiveDo]+input: |+  mdo { pure x }+ast: |-+  EDo [DoExpr (EApp (EVar "pure") (EVar "x"))] (DoMdo)+status: pass
+ test/Test/Fixtures/golden/expr/missing-rparen.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (f x+ast: |-+status: fail+reason: missing right parenthesis
+ test/Test/Fixtures/golden/expr/multiline-application.yaml view
@@ -0,0 +1,8 @@+extensions: []+input: |+  f+    x+    y+ast: |-+  EApp (EApp (EVar "f") (EVar "x")) (EVar "y")+status: pass
+ test/Test/Fixtures/golden/expr/multiline-basic.yaml view
@@ -0,0 +1,7 @@+extensions: [MultilineStrings]+input: |+  """Hello, World!"""+ast: |-+  EString "Hello, World!"+status: pass+comment: Single line without leading/trailing newlines
+ test/Test/Fixtures/golden/expr/multiline-blank-line.yaml view
@@ -0,0 +1,13 @@+extensions: [MultilineStrings]+input: |+  """+      Line 1+      +      Line 2+      """+ast: |-+  EString "Line 1\n\nLine 2"+status: pass+comment: |+  Common indentation stripped. Whitespace-only lines become empty.+  Leading/trailing newlines removed.
+ test/Test/Fixtures/golden/expr/multiline-embedded-tab.yaml view
@@ -0,0 +1,10 @@+extensions: [MultilineStrings]+input: |+  """+      Line with tab character:	here+      """+ast: |-+  EString "Line with tab character:\there"+status: pass+comment: |+  Common indentation stripped. Non-leading tab character preserved in content.
+ test/Test/Fixtures/golden/expr/multiline-empty.yaml view
@@ -0,0 +1,7 @@+extensions: [MultilineStrings]+input: |+  """"""+ast: |-+  EString ""+status: pass+comment: Empty multiline string
+ test/Test/Fixtures/golden/expr/multiline-escape.yaml view
@@ -0,0 +1,7 @@+extensions: [MultilineStrings]+input: |+  """Line 1\nLine 2"""+ast: |-+  EString "Line 1\nLine 2"+status: pass+comment: Backslash-n is resolved to newline after multiline post-processing.
+ test/Test/Fixtures/golden/expr/multiline-indent.yaml view
@@ -0,0 +1,10 @@+extensions: [MultilineStrings]+input: |+  """+      indented+      text+      """+ast: |-+  EString "indented\ntext"+status: pass+comment: Common indentation (4 spaces) is stripped, leading/trailing newlines removed.
+ test/Test/Fixtures/golden/expr/multiline-leading-trailing-newlines.yaml view
@@ -0,0 +1,10 @@+extensions: [MultilineStrings]+input: |+  """+  first line+  second line+  """+ast: |-+  EString "first line\nsecond line"+status: pass+comment: Leading and trailing newlines are removed per GHC MultilineStrings spec.
+ test/Test/Fixtures/golden/expr/multiline-newlines.yaml view
@@ -0,0 +1,9 @@+extensions: [MultilineStrings]+input: |+  """Line 1+  Line 2+  Line 3"""+ast: |-+  EString "Line 1\nLine 2\nLine 3"+status: pass+comment: Multiple lines with no common indentation. Text starts on same line as opening delimiter.
+ test/Test/Fixtures/golden/expr/multiline-single-line.yaml view
@@ -0,0 +1,7 @@+extensions: [MultilineStrings]+input: |+  """single line"""+ast: |-+  EString "single line"+status: pass+comment: Triple-quoted string on single line (no newlines)
+ test/Test/Fixtures/golden/expr/multiline-string-gap.yaml view
@@ -0,0 +1,12 @@+extensions: [MultilineStrings]+input: |+  """+      Line 1\+      \continues here+      """+ast: |-+  EString "Line 1continues here"+status: pass+comment: |+  String gap (\<whitespace>\) is collapsed before multiline processing.+  The backslash-whitespace-backslash sequence is removed entirely.
+ test/Test/Fixtures/golden/expr/multiline-tabs.yaml view
@@ -0,0 +1,12 @@+extensions: [MultilineStrings]+input: |+  """+  	Line 1+  	Line 2+  	"""+ast: |-+  EString "Line 1\nLine 2"+status: pass+comment: |+  Leading tabs expanded to spaces (8-space tab stops), then common+  indentation stripped. Leading/trailing newlines removed.
+ test/Test/Fixtures/golden/expr/multiline-trailing-gap-before-close.yaml view
@@ -0,0 +1,13 @@+extensions: [MultilineStrings]+input: |+  """+  Line 1+  Line 2+  Line 3\+  \"""+ast: |-+  EString "Line 1\nLine 2\nLine 3"+status: pass+comment: |+  A string gap can appear immediately before the closing multiline delimiter.+  The gap is collapsed before delimiter detection, so the trailing newline is omitted.
+ test/Test/Fixtures/golden/expr/multiline-unescaped-quotes.yaml view
@@ -0,0 +1,11 @@+extensions: [MultilineStrings]+input: |+  """+      "Hello"+      """+ast: |-+  EString "\"Hello\""+status: pass+comment: |+  Double quotes don't need escaping inside multiline strings unless+  they form a triple-quote sequence.
+ test/Test/Fixtures/golden/expr/multiline-varying-indent.yaml view
@@ -0,0 +1,11 @@+extensions: [MultilineStrings]+input: |+  """Line 1+      Line 2 with extra indent+  Line 3"""+ast: |-+  EString "Line 1\n    Line 2 with extra indent\nLine 3"+status: pass+comment: |+  Text starts on same line as opening delimiter. No common indentation+  among non-first lines (Line 3 has zero indent).
+ test/Test/Fixtures/golden/expr/multiway-if-infix-branch-body.yaml view
@@ -0,0 +1,6 @@+extensions: [MultiWayIf]+input: |+  if | guard -> body `op` rhs+ast: |-+  EMultiWayIf [GuardedRhs {[GuardExpr (EVar "guard")], EInfix (EVar "body") "op" (EVar "rhs")}]+status: pass
+ test/Test/Fixtures/golden/expr/multiway-if-offside-infix-lhs.yaml view
@@ -0,0 +1,9 @@+extensions: [MultiWayIf, Arrows]+input: |+  if | 0+       ->+        ()+   `a` proc p -> () -<< 0.0+ast: |-+  EInfix (EMultiWayIf [GuardedRhs {[GuardExpr (EInt 0 TInteger)], ETuple []}]) "a" (EProc (PVar "p") (CmdArrApp (ETuple []) HsHigherOrderApp (EFloat 0 % 1 TFractional)))+status: pass
+ test/Test/Fixtures/golden/expr/negate-after-infix-plus.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  a + - 1+ast: |-+  EInfix (EVar "a") "+" (ENegate (EInt 1 TInteger))+status: pass
+ test/Test/Fixtures/golden/expr/negate-after-infix-var.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  f $ - x+ast: |-+  EInfix (EVar "f") "$" (ENegate (EVar "x"))+status: pass
+ test/Test/Fixtures/golden/expr/negate-application.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  -f x+ast: |-+  ENegate (EApp (EVar "f") (EVar "x"))+status: pass
+ test/Test/Fixtures/golden/expr/negate-infix-chain.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  -1 + 2+ast: |-+  EInfix (ENegate (EInt 1 TInteger)) "+" (EInt 2 TInteger)+status: pass
+ test/Test/Fixtures/golden/expr/negate-int-default.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  -1+ast: |-+  ENegate (EInt 1 TInteger)+status: pass
+ test/Test/Fixtures/golden/expr/negate-int-lexical-negation.yaml view
@@ -0,0 +1,6 @@+extensions: [NegativeLiterals]+input: |+  -1+ast: |-+  EInt -1 TInteger+status: pass
+ test/Test/Fixtures/golden/expr/negate-paren-int-hash.yaml view
@@ -0,0 +1,6 @@+extensions: [MagicHash]+input: |+  -(95#)+ast: |-+  ENegate (EParen (EInt 95 TIntHash))+status: pass
+ test/Test/Fixtures/golden/expr/negative-literal-extension.yaml view
@@ -0,0 +1,7 @@+extensions:+  - NegativeLiterals+input: |+  -1+ast: |-+  EInt -1 TInteger+status: pass
+ test/Test/Fixtures/golden/expr/neglit-app-space-int.yaml view
@@ -0,0 +1,6 @@+extensions: [NegativeLiterals]+input: |+  f -5+ast: |-+  EApp (EVar "f") (EInt -5 TInteger)+status: pass
+ test/Test/Fixtures/golden/expr/neglit-infix-minus-paren.yaml view
@@ -0,0 +1,6 @@+extensions: [NegativeLiterals]+input: |+  f -(x*2)+ast: |-+  EInfix (EVar "f") "-" (EParen (EInfix (EVar "x") "*" (EInt 2 TInteger)))+status: pass
+ test/Test/Fixtures/golden/expr/neglit-infix-minus-var.yaml view
@@ -0,0 +1,6 @@+extensions: [NegativeLiterals]+input: |+  f -x+ast: |-+  EInfix (EVar "f") "-" (EVar "x")+status: pass
+ test/Test/Fixtures/golden/expr/neglit-infix-tight-int.yaml view
@@ -0,0 +1,6 @@+extensions: [NegativeLiterals]+input: |+  f-5+ast: |-+  EInfix (EVar "f") "-" (EInt 5 TInteger)+status: pass
+ test/Test/Fixtures/golden/expr/neglit-unary-int.yaml view
@@ -0,0 +1,6 @@+extensions: [NegativeLiterals]+input: |+  -10+ast: |-+  EInt -10 TInteger+status: pass
+ test/Test/Fixtures/golden/expr/nested-app.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  f (g 1)+ast: |-+  EApp (EVar "f") (EParen (EApp (EVar "g") (EInt 1 TInteger)))+status: pass
+ test/Test/Fixtures/golden/expr/noext-infix-minus-int.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  f -5+ast: |-+  EInfix (EVar "f") "-" (EInt 5 TInteger)+status: pass
+ test/Test/Fixtures/golden/expr/noext-infix-minus-var.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  f -x+ast: |-+  EInfix (EVar "f") "-" (EVar "x")+status: pass
+ test/Test/Fixtures/golden/expr/operator-section-trailing-minus.yaml view
@@ -0,0 +1,6 @@+extensions: [GHC2021]+input: |+  (n-1-)+ast: |-+  EParen (ESectionL (EInfix (EVar "n") "-" (EInt 1 TInteger)) "-")+status: pass
+ test/Test/Fixtures/golden/expr/overloaded-label-basic.yaml view
@@ -0,0 +1,6 @@+extensions: [OverloadedLabels]+input: |+  #typeUrl+ast: |-+  EOverloadedLabel "typeUrl" "#typeUrl"+status: pass
+ test/Test/Fixtures/golden/expr/overloaded-label-quoted.yaml view
@@ -0,0 +1,6 @@+extensions: [OverloadedLabels]+input: |+  #"The quick brown fox"+ast: |-+  EOverloadedLabel "The quick brown fox" "#\"The quick brown fox\""+status: pass
+ test/Test/Fixtures/golden/expr/paren-negate-spaced.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (- x)+ast: |-+  EParen (ENegate (EVar "x"))+status: pass
+ test/Test/Fixtures/golden/expr/paren-negate-tight.yaml view
@@ -0,0 +1,6 @@+extensions: [LexicalNegation]+input: |+  (-x)+ast: |-+  ENegate (EVar "x")+status: pass
+ test/Test/Fixtures/golden/expr/paren-section-infix-fmap.yaml view
@@ -0,0 +1,6 @@+extensions: [GHC2021]+input: |+  (a . b <$>)+ast: |-+  EParen (ESectionL (EInfix (EVar "a") "." (EVar "b")) "<$>")+status: pass
+ test/Test/Fixtures/golden/expr/paren-section-left-plus.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (x+)+ast: |-+  EParen (ESectionL (EVar "x") "+")+status: pass
+ test/Test/Fixtures/golden/expr/paren-section-right-plus.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (+x)+ast: |-+  EParen (ESectionR "+" (EVar "x"))+status: pass
+ test/Test/Fixtures/golden/expr/proc-notation.yaml view
@@ -0,0 +1,6 @@+extensions: [Arrows]+input: |+  proc x -> returnA -< x+ast: |-+  EProc (PVar "x") (CmdArrApp (EVar "returnA") HsFirstOrderApp (EVar "x"))+status: pass
+ test/Test/Fixtures/golden/expr/qualified-conop-infix.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  x Data.List.:++ y+ast: |-+  EInfix (EVar "x") "Data.List" ":++" (EVar "y")+status: pass
+ test/Test/Fixtures/golden/expr/qualified-dot-section-right.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (Foo.. x)+ast: |-+  EParen (ESectionR "Foo" "." (EVar "x"))+status: pass
+ test/Test/Fixtures/golden/expr/qualified-op-deep.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (A.B.C.+)+ast: |-+  EVar "A.B.C" "+"+status: pass
+ test/Test/Fixtures/golden/expr/qualified-op-infix.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  x Prelude.+ y+ast: |-+  EInfix (EVar "x") "Prelude" "+" (EVar "y")+status: pass
+ test/Test/Fixtures/golden/expr/qualified-op-paren.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (Prelude.+)+ast: |-+  EVar "Prelude" "+"+status: pass
+ test/Test/Fixtures/golden/expr/qualified-op-section-left.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (x Prelude.+)+ast: |-+  EParen (ESectionL (EVar "x") "Prelude" "+")+status: pass
+ test/Test/Fixtures/golden/expr/qualified-op-section-right.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (Prelude.+ x)+ast: |-+  EParen (ESectionR "Prelude" "+" (EVar "x"))+status: pass
+ test/Test/Fixtures/golden/expr/record-dot-chained.yaml view
@@ -0,0 +1,6 @@+extensions: [OverloadedRecordDot]+input: |+  a.b.c+ast: |-+  EGetField (EGetField (EVar "a") "b") "c"+status: pass
+ test/Test/Fixtures/golden/expr/record-dot-composition-unaffected.yaml view
@@ -0,0 +1,6 @@+extensions: [OverloadedRecordDot]+input: |+  f . g+ast: |-+  EInfix (EVar "f") "." (EVar "g")+status: pass
+ test/Test/Fixtures/golden/expr/record-dot-disabled.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  record.field+ast: |-+  EInfix (EVar "record") "." (EVar "field")+status: pass
+ test/Test/Fixtures/golden/expr/record-dot-in-app.yaml view
@@ -0,0 +1,6 @@+extensions: [OverloadedRecordDot]+input: |+  f record.field+ast: |-+  EApp (EVar "f") (EGetField (EVar "record") "field")+status: pass
+ test/Test/Fixtures/golden/expr/record-dot-paren-base.yaml view
@@ -0,0 +1,6 @@+extensions: [OverloadedRecordDot]+input: |+  (f x).field+ast: |-+  EGetField (EParen (EApp (EVar "f") (EVar "x"))) "field"+status: pass
+ test/Test/Fixtures/golden/expr/record-dot-projection-chained.yaml view
@@ -0,0 +1,6 @@+extensions: [OverloadedRecordDot]+input: |+  (.f.g)+ast: |-+  EParen (EGetFieldProjection ["f", "g"])+status: pass
+ test/Test/Fixtures/golden/expr/record-dot-projection-simple.yaml view
@@ -0,0 +1,6 @@+extensions: [OverloadedRecordDot]+input: |+  (.field)+ast: |-+  EParen (EGetFieldProjection ["field"])+status: pass
+ test/Test/Fixtures/golden/expr/record-dot-simple.yaml view
@@ -0,0 +1,6 @@+extensions: [OverloadedRecordDot]+input: |+  record.field+ast: |-+  EGetField (EVar "record") "field"+status: pass
+ test/Test/Fixtures/golden/expr/record-dot-then-update.yaml view
@@ -0,0 +1,6 @@+extensions: [OverloadedRecordDot]+input: |+  r.field { x = 1 }+ast: |-+  ERecordUpd (EGetField (EVar "r") "field") {"x" = EInt 1 TInteger}+status: pass
+ test/Test/Fixtures/golden/expr/simple-app.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  f x+ast: |-+  EApp (EVar "f") (EVar "x")+status: pass
+ test/Test/Fixtures/golden/expr/simple-int.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  42+ast: |-+  EInt 42 TInteger+status: pass
+ test/Test/Fixtures/golden/expr/th-qualified-name-quotes.yaml view
@@ -0,0 +1,7 @@+extensions:+  - TemplateHaskell+input: |+  ('M.v, '(M.+))+ast: |-+  ETuple [ETHNameQuote (EVar "M" "v"), ETHNameQuote (EVar "M" "+")]+status: pass
+ test/Test/Fixtures/golden/expr/tuple-constructor-3.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (,,)+ast: |-+  ETuple [Nothing, Nothing, Nothing]+status: pass
+ test/Test/Fixtures/golden/expr/tuple-pair.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (a,b)+ast: |-+  ETuple [EVar "a", EVar "b"]+status: pass
+ test/Test/Fixtures/golden/expr/tuple-section-left.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (a,)+ast: |-+  ETuple [EVar "a", Nothing]+status: pass
+ test/Test/Fixtures/golden/expr/tuple-section-middle.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (a,,b)+ast: |-+  ETuple [EVar "a", Nothing, EVar "b"]+status: pass
+ test/Test/Fixtures/golden/expr/tuple-section-nested-left.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  ((,a),)+ast: |-+  ETuple [ETuple [Nothing, EVar "a"], Nothing]+status: pass
+ test/Test/Fixtures/golden/expr/tuple-section-nested-unit.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  ((),,)+ast: |-+  ETuple [ETuple [], Nothing, Nothing]+status: pass
+ test/Test/Fixtures/golden/expr/tuple-section-right.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (,a)+ast: |-+  ETuple [Nothing, EVar "a"]+status: pass
+ test/Test/Fixtures/golden/expr/tuple-unit.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  ()+ast: |-+  ETuple []+status: pass
+ test/Test/Fixtures/golden/expr/type-app-loose.yaml view
@@ -0,0 +1,6 @@+extensions: [TypeApplications]+input: |+  f @ a+ast: |-+  EInfix (EVar "f") "@" (EVar "a")+status: pass
+ test/Test/Fixtures/golden/expr/type-app-no-space.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  read@Int 5+ast: |-+status: fail+reason: type application requires space before @
+ test/Test/Fixtures/golden/expr/type-app-tight-no-space-chain.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  f @Int@Bool+ast: |-+status: fail+reason: type application chain requires spaces before @
+ test/Test/Fixtures/golden/expr/type-app-tight.yaml view
@@ -0,0 +1,6 @@+extensions: [TypeApplications]+input: |+  f @a+ast: |-+  ETypeApp (EVar "f") (TVar "a")+status: pass
+ test/Test/Fixtures/golden/expr/unboxed-tuple-basic.yaml view
@@ -0,0 +1,6 @@+extensions: [UnboxedTuples]+input: |+  (# 1, 2 #)+ast: |-+  ETuple Unboxed [EInt 1 TInteger, EInt 2 TInteger]+status: pass
+ test/Test/Fixtures/golden/expr/unboxed-tuple-constructor-3.yaml view
@@ -0,0 +1,6 @@+extensions: [UnboxedTuples]+input: |+  (#,,#)+ast: |-+  ETuple Unboxed [Nothing, Nothing, Nothing]+status: pass
+ test/Test/Fixtures/golden/expr/unboxed-tuple-section.yaml view
@@ -0,0 +1,6 @@+extensions: [UnboxedTuples]+input: |+  (# 1, #)+ast: |-+  ETuple Unboxed [EInt 1 TInteger, Nothing]+status: pass
+ test/Test/Fixtures/golden/import/operator-import.yaml view
@@ -0,0 +1,7 @@+extensions:+  - TypeOperators+input: |+  import Data.Type.Equality ((:~~:)(..))+ast: |-+  Module {[ImportDecl {"Data.Type.Equality", ImportSpec {[ImportItemAll{UnqualifiedName {":~~:"}}]}}]}+status: pass
+ test/Test/Fixtures/golden/module/FlexibleInstances/instance-unit.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  class Unit x+  instance Unit a+status: pass+ast: |-+  Module {[DeclClass (ClassDecl {Prefix "Unit" [TyVarBinder {"x"}]}), DeclInstance (InstanceDecl {TApp (TCon "Unit") (TVar "a")})]}
+ test/Test/Fixtures/golden/module/app.yaml view
@@ -0,0 +1,8 @@+extensions: []+input: |+  module Demo where+  id1 = f x+  id2 = f (g 3)+ast: |-+  Module {ModuleHead {"Demo"}, [DeclValue (PatternBind (PVar "id1") (EApp (EVar "f") (EVar "x"))), DeclValue (PatternBind (PVar "id2") (EApp (EVar "f") (EParen (EApp (EVar "g") (EInt 3 TInteger)))))]}+status: pass
+ test/Test/Fixtures/golden/module/arrow-command-infix-bare-case-arrapp.yaml view
@@ -0,0 +1,8 @@+extensions: [Arrows, ViewPatterns]+input: |+  x C {a = proc _ -> case [] of+        _ -> [] -<< []+     `a` [] -< []+   -> _} = ()+status: fail+reason: GHC rejects bare case and arrow application operands in command infix syntax
+ test/Test/Fixtures/golden/module/arrow-proc-lhs-needs-parens.yaml view
@@ -0,0 +1,6 @@+extensions: [Arrows, ViewPatterns, BlockArguments]+input: |+  module M where+  f [proc _ -> proc _ -> [] -< [] -<< [] -> _] = ()+status: fail+reason: bare proc command lhs must be parenthesized before -<<
+ test/Test/Fixtures/golden/module/associated-type-default-shorthand.yaml view
@@ -0,0 +1,10 @@+extensions: [TypeFamilies]+input: |+  {-# LANGUAGE TypeFamilies #-}+  module M where+  class Foo n where+    type O n+    type O n = Int+ast: |-+  Module {ModuleHead {"M"}, [TypeFamilies], [DeclClass (ClassDecl {Prefix "Foo" [TyVarBinder {"n"}], [ClassItemTypeFamilyDecl (TypeFamilyDecl {TypeHeadPrefix, False, TCon "O", [TyVarBinder {"n"}]}), ClassItemDefaultTypeInst (TypeFamilyInst {TypeHeadPrefix, TApp (TCon "O") (TVar "n"), TCon "Int"})]})]}+status: pass
+ test/Test/Fixtures/golden/module/bad-head.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  module where+  x = 1+ast: |-+status: fail+reason: invalid module header
+ test/Test/Fixtures/golden/module/block-args-lambda-as-pattern.yaml view
@@ -0,0 +1,6 @@+extensions: [GHC2021, BlockArguments]+input: |+  f = g \x@(Y a) -> z+ast: |-+  Module {[DeclValue (PatternBind (PVar "f") (EApp (EVar "g") (ELambdaPats [PAs UnqualifiedName {"x"} (PParen (PCon "Y" [PVar "a"]))] (EVar "z"))))]}+status: pass
+ test/Test/Fixtures/golden/module/case-guarded-in-record-field.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  module CaseGuardedInRecordField where+  x = R { f = case y of A | p -> 1 | q -> 2, g = 3 }+ast: |-+  Module {ModuleHead {"CaseGuardedInRecordField"}, [DeclValue (PatternBind (PVar "x") (ERecordCon "R" {"f" = ECase (EVar "y") [CaseAlt (PCon "A" []) (GuardedRhss [GuardedRhs {[GuardExpr (EVar "p")], EInt 1 TInteger}, GuardedRhs {[GuardExpr (EVar "q")], EInt 2 TInteger}])], "g" = EInt 3 TInteger}))]}+status: pass
+ test/Test/Fixtures/golden/module/case-in-record-field.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  module CaseInRecordField where+  x = R { f = case y of A -> 1, g = 3 }+ast: |-+  Module {ModuleHead {"CaseInRecordField"}, [DeclValue (PatternBind (PVar "x") (ERecordCon "R" {"f" = ECase (EVar "y") [CaseAlt (PCon "A" []) (EInt 1 TInteger)], "g" = EInt 3 TInteger}))]}+status: pass
+ test/Test/Fixtures/golden/module/class-infix-identifier-head.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  module M where+  class xs `Infix` ys+ast: |-+  Module {ModuleHead {"M"}, [DeclClass (ClassDecl {Infix "xs" "Infix" "ys"})]}+status: pass
+ test/Test/Fixtures/golden/module/class-infix-kinded-head.yaml view
@@ -0,0 +1,7 @@+extensions: [KindSignatures]+input: |+  {-# LANGUAGE KindSignatures #-}+  class (xs :: [k]) `Infix` (ys :: [k])+ast: |-+  Module {[KindSignatures], [DeclClass (ClassDecl {Infix (TyVarBinder {"xs", Just (TList [TVar "k"])}) "Infix" (TyVarBinder {"ys", Just (TList [TVar "k"])})})]}+status: pass
+ test/Test/Fixtures/golden/module/data-bool-core-lib.yaml view
@@ -0,0 +1,34 @@+extensions: []+input: |+  module Data.Bool+    ( Bool (False, True),+      (&&),+      not,+      otherwise,+      (||),+    )+  where++  data Bool = False | True++  infixr 3 &&++  (&&) :: Bool -> Bool -> Bool+  False && _ = False+  True && x = x++  not :: Bool -> Bool+  not False = True+  not True = False++  otherwise :: Bool+  otherwise = True++  infixr 2 ||++  (||) :: Bool -> Bool -> Bool+  False || x = x+  True || _ = True+ast: |-+  Module {ModuleHead {"Data.Bool", [ExportWith{"Bool", [IEBundledMember{"False"}, IEBundledMember{"True"}]}, ExportVar{"&&"}, ExportVar{"not"}, ExportVar{"otherwise"}, ExportVar{"||"}]}, [DeclData (DataDecl {Prefix "Bool", [PrefixCon {UnqualifiedName {"False"}}, PrefixCon {UnqualifiedName {"True"}}]}), DeclFixity InfixR Nothing 3 [UnqualifiedName {"&&"}], DeclTypeSig ["&&"] (TFun (TCon "Bool") (TFun (TCon "Bool") (TCon "Bool"))), DeclValue (FunctionBind "&&" [Match {MatchHeadInfix, [PCon "False" [], PWildcard], EVar "False"}]), DeclValue (FunctionBind "&&" [Match {MatchHeadInfix, [PCon "True" [], PVar "x"], EVar "x"}]), DeclTypeSig ["not"] (TFun (TCon "Bool") (TCon "Bool")), DeclValue (FunctionBind "not" [Match {MatchHeadPrefix, [PCon "False" []], EVar "True"}]), DeclValue (FunctionBind "not" [Match {MatchHeadPrefix, [PCon "True" []], EVar "False"}]), DeclTypeSig ["otherwise"] (TCon "Bool"), DeclValue (PatternBind (PVar "otherwise") (EVar "True")), DeclFixity InfixR Nothing 2 [UnqualifiedName {"||"}], DeclTypeSig ["||"] (TFun (TCon "Bool") (TFun (TCon "Bool") (TCon "Bool"))), DeclValue (FunctionBind "||" [Match {MatchHeadInfix, [PCon "False" [], PVar "x"], EVar "x"}]), DeclValue (FunctionBind "||" [Match {MatchHeadInfix, [PCon "True" [], PWildcard], EVar "True"}])]}+status: pass
+ test/Test/Fixtures/golden/module/data-con-infix-parenthesized-function-type.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  data A b = (Int -> Int) `Infix` b+ast: |-+  Module {[DeclData (DataDecl {Prefix "A" [TyVarBinder {"b"}], [InfixCon {BangType {TParen (TFun (TCon "Int") (TCon "Int"))}, UnqualifiedName {"Infix"}, BangType {TVar "b"}}]})]}+status: pass
+ test/Test/Fixtures/golden/module/data-con-infix-parenthesized-infix-type.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  data a :+: b+  data A b = (Int :+: Int) `Infix` b+ast: |-+  Module {[DeclData (DataDecl {Infix "a" ":+:" "b"}), DeclData (DataDecl {Prefix "A" [TyVarBinder {"b"}], [InfixCon {BangType {TParen (TInfix (TCon "Int") ":+:" (TCon "Int"))}, UnqualifiedName {"Infix"}, BangType {TVar "b"}}]})]}+status: pass
+ test/Test/Fixtures/golden/module/data-con-infix-simple-type.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  data A b = Int `Infix` b+ast: |-+  Module {[DeclData (DataDecl {Prefix "A" [TyVarBinder {"b"}], [InfixCon {BangType {TCon "Int"}, UnqualifiedName {"Infix"}, BangType {TVar "b"}}]})]}+status: pass
+ test/Test/Fixtures/golden/module/data-con-infix-tuple-constructor-application.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  data A b = (,) Int Int `Infix` b+ast: |-+  Module {[DeclData (DataDecl {Prefix "A" [TyVarBinder {"b"}], [InfixCon {BangType {TApp (TApp (TBuiltinCon TBuiltinTuple 2) (TCon "Int")) (TCon "Int")}, UnqualifiedName {"Infix"}, BangType {TVar "b"}}]})]}+status: pass
+ test/Test/Fixtures/golden/module/data-con-infix-type-app-rhs.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  data A a b = b `Infix` a b+ast: |-+  Module {[DeclData (DataDecl {Prefix "A" [TyVarBinder {"a"}, TyVarBinder {"b"}], [InfixCon {BangType {TVar "b"}, UnqualifiedName {"Infix"}, BangType {TApp (TVar "a") (TVar "b")}}]})]}+status: pass
+ test/Test/Fixtures/golden/module/data-deriving-complex-types.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  data X = X deriving (Class a b c, forall n. OtherClass n a)+ast: |-+  Module {[DeclData (DataDecl {Prefix "X", [PrefixCon {UnqualifiedName {"X"}}], [DerivingClause {[TApp (TApp (TApp (TCon "Class") (TVar "a")) (TVar "b")) (TVar "c"), TForall [TyVarBinder {"n"}] (TApp (TApp (TCon "OtherClass") (TVar "n")) (TVar "a"))]}]})]}+status: pass
+ test/Test/Fixtures/golden/module/data-deriving-qualified-bare.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  data X = X deriving Mod.ClassName+ast: |-+  Module {[DeclData (DataDecl {Prefix "X", [PrefixCon {UnqualifiedName {"X"}}], [DerivingClause {"Mod" "ClassName"}]})]}+status: pass
+ test/Test/Fixtures/golden/module/data-mixed-operator-and-normal-fields.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  data T = MkT { ($$) :: Int, (>>=) :: String, normalField :: Bool }+ast: |-+  Module {[DeclData (DataDecl {Prefix "T", [RecordCon "MkT" [FieldDecl ["$$"] (TCon "Int"), FieldDecl [">>="] (TCon "String"), FieldDecl ["normalField"] (TCon "Bool")]]})]}+status: pass
+ test/Test/Fixtures/golden/module/data-record-bang-star.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  data C = MkC {x :: ~(*), y :: !(*)}+ast: |-+  Module {[DeclData (DataDecl {Prefix "C", [RecordCon "MkC" [FieldDecl ["x"] (BangType {True, TParen (TStar)}), FieldDecl ["y"] (BangType {True, TParen (TStar)})]]})]}+status: pass
+ test/Test/Fixtures/golden/module/dataset-prefix.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  module DatasetPrefix where+  dataset = 5+ast: |-+  Module {ModuleHead {"DatasetPrefix"}, [DeclValue (PatternBind (PVar "dataset") (EInt 5 TInteger))]}+status: pass
+ test/Test/Fixtures/golden/module/default-decl-empty.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  default ()+ast: |-+  Module {[DeclDefault []]}+status: pass
+ test/Test/Fixtures/golden/module/default-decl.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  module D10 where+  default (Integer, Double)+ast: |-+  Module {ModuleHead {"D10"}, [DeclDefault [TCon "Integer", TCon "Double"]]}+status: pass
+ test/Test/Fixtures/golden/module/do-if-then-else-case-layout.yaml view
@@ -0,0 +1,15 @@+extensions: [DoAndIfThenElse]+input: |+  {-# LANGUAGE DoAndIfThenElse #-}+  module DoAndIfThenElseCaseLayout where+  toCaseLayout = do+    if True+      then do+      case undefined of+        Left err -> error err+        Right obj -> return obj+      else do+      return ()+ast: |-+  Module {ModuleHead {"DoAndIfThenElseCaseLayout"}, [DoAndIfThenElse], [DeclValue (PatternBind (PVar "toCaseLayout") (EDo [DoExpr (EIf (EVar "True") (EDo [DoExpr (ECase (EVar "undefined") [CaseAlt (PCon "Left" [PVar "err"]) (EApp (EVar "error") (EVar "err")), CaseAlt (PCon "Right" [PVar "obj"]) (EApp (EVar "return") (EVar "obj"))])]) (EDo [DoExpr (EApp (EVar "return") (ETuple []))]))]))]}+status: pass
+ test/Test/Fixtures/golden/module/do-if-then-else-let-layout.yaml view
@@ -0,0 +1,16 @@+extensions: [DoAndIfThenElse]+input: |+  {-# LANGUAGE DoAndIfThenElse #-}+  module DoAndIfThenElseLetLayout where+  withLet :: IO ()+  withLet = do+    if True+      then do+      let x = 1+          y = 2+      return (x + y)+      else do+      return 0+ast: |-+  Module {ModuleHead {"DoAndIfThenElseLetLayout"}, [DoAndIfThenElse], [DeclTypeSig ["withLet"] (TApp (TCon "IO") (TTuple [])), DeclValue (PatternBind (PVar "withLet") (EDo [DoExpr (EIf (EVar "True") (EDo [DoLetDecls [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger)), DeclValue (PatternBind (PVar "y") (EInt 2 TInteger))], DoExpr (EApp (EVar "return") (EParen (EInfix (EVar "x") "+" (EVar "y"))))]) (EDo [DoExpr (EApp (EVar "return") (EInt 0 TInteger))]))]))]}+status: pass
+ test/Test/Fixtures/golden/module/do-where-layout-multi.yaml view
@@ -0,0 +1,12 @@+extensions: []+input: |+  module DoWhereLayoutMulti where+  testMulti a b = do+    x+    y+    where+      x = a+      y = b+ast: |-+  Module {ModuleHead {"DoWhereLayoutMulti"}, [DeclValue (FunctionBind "testMulti" [Match {MatchHeadPrefix, [PVar "a", PVar "b"], EDo [DoExpr (EVar "x"), DoExpr (EVar "y")] Just [DeclValue (PatternBind (PVar "x") (EVar "a")), DeclValue (PatternBind (PVar "y") (EVar "b"))]}])]}+status: pass
+ test/Test/Fixtures/golden/module/do-where-layout.yaml view
@@ -0,0 +1,9 @@+extensions: []+input: |+  module DoWhereLayout where+  testDoWhereLayout a = do+    action+    where action = a+ast: |-+  Module {ModuleHead {"DoWhereLayout"}, [DeclValue (FunctionBind "testDoWhereLayout" [Match {MatchHeadPrefix, [PVar "a"], EDo [DoExpr (EVar "action")] Just [DeclValue (PatternBind (PVar "action") (EVar "a"))]}])]}+status: pass
+ test/Test/Fixtures/golden/module/explicit-namespace-app-arg-bare.yaml view
@@ -0,0 +1,5 @@+extensions: [ExplicitNamespaces, RequiredTypeArguments, PartialTypeSignatures]+input: |+  x = a type _+status: fail+reason: GHC rejects bare explicit namespace syntax as a function argument
+ test/Test/Fixtures/golden/module/explicit-namespace-record-dot-bare.yaml view
@@ -0,0 +1,5 @@+extensions: [ExplicitNamespaces, OverloadedRecordDot, TemplateHaskell]+input: |+  x = type (:+).a+status: fail+reason: GHC rejects record-dot access directly after an explicit namespace expression
+ test/Test/Fixtures/golden/module/explicit-namespace-record-update-bare.yaml view
@@ -0,0 +1,5 @@+extensions: [ExplicitNamespaces]+input: |+  x = type (:+) {}+status: fail+reason: GHC rejects record construction/update directly after an explicit namespace expression
+ test/Test/Fixtures/golden/module/export-spec-bundled-data-members.yaml view
@@ -0,0 +1,9 @@+extensions:+  - PatternSynonyms+  - ExplicitNamespaces+input: |+  module Demo (Nat (data Zero, data Succ)) where+  x = 1+status: pass+ast: |-+  Module {ModuleHead {"Demo", [ExportWith{"Nat", [IEBundledMember{IEBundledNamespaceData, "Zero"}, IEBundledMember{IEBundledNamespaceData, "Succ"}]}]}, [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]}
+ test/Test/Fixtures/golden/module/export-spec-data-namespace.yaml view
@@ -0,0 +1,8 @@+extensions:+  - ExplicitNamespaces+input: |+  module Demo (data Zero) where+  x = 1+status: pass+ast: |-+  Module {ModuleHead {"Demo", [ExportAbs{IEEntityNamespaceData, "Zero"}]}, [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]}
+ test/Test/Fixtures/golden/module/expr-type-sig-kind-sig-bare.yaml view
@@ -0,0 +1,5 @@+extensions: [KindSignatures, PartialTypeSignatures]+input: |+  x = a :: _ :: _+status: fail+reason: GHC rejects a bare kind signature as the type in an expression signature
+ test/Test/Fixtures/golden/module/fixity-multi-operator.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  infix ^, ++ast: |-+  Module {[DeclFixity Infix Nothing Nothing [UnqualifiedName {"^"}, UnqualifiedName {"+"}]]}+status: pass
+ test/Test/Fixtures/golden/module/fixity-operator-backtick.yaml view
@@ -0,0 +1,9 @@+extensions: []+input: |+  module D9 where+  infixl 5 `foo`+  foo :: a -> a -> a+  foo = undefined+ast: |-+  Module {ModuleHead {"D9"}, [DeclFixity InfixL Nothing 5 [UnqualifiedName {"foo"}], DeclTypeSig ["foo"] (TFun (TVar "a") (TFun (TVar "a") (TVar "a"))), DeclValue (PatternBind (PVar "foo") (EVar "undefined"))]}+status: pass
+ test/Test/Fixtures/golden/module/fixity-operator.yaml view
@@ -0,0 +1,9 @@+extensions: []+input: |+  module D9 where+  infixr 5 <++>+  (<++>) :: [a] -> [a] -> [a]+  (<++>) = (++ )+ast: |-+  Module {ModuleHead {"D9"}, [DeclFixity InfixR Nothing 5 [UnqualifiedName {"<++>"}], DeclTypeSig ["<++>"] (TFun (TList [TVar "a"]) (TFun (TList [TVar "a"]) (TList [TVar "a"]))), DeclValue (PatternBind (PVar "<++>") (EVar "++"))]}+status: pass
+ test/Test/Fixtures/golden/module/forall-kinded-inferred-binder.yaml view
@@ -0,0 +1,13 @@+extensions:+  - ExplicitForAll+  - KindSignatures+input: |+  module ForallKindedInferredBinder where++  import Data.Kind (Type)++  f :: forall {a :: Type}. a -> a+  f x = x+status: pass+ast: |-+  Module {ModuleHead {"ForallKindedInferredBinder"}, [ImportDecl {"Data.Kind", ImportSpec {[ImportItemAbs{UnqualifiedName {"Type"}}]}}], [DeclTypeSig ["f"] (TForall [TyVarBinder {"a", Just (TCon "Type"), TyVarBInferred}] (TFun (TVar "a") (TVar "a"))), DeclValue (FunctionBind "f" [Match {MatchHeadPrefix, [PVar "x"], EVar "x"}])]}
+ test/Test/Fixtures/golden/module/gadt-promoted-cons-operator.yaml view
@@ -0,0 +1,7 @@+extensions: [GHC2021, TypeOperators, GADTSyntax]+input: |+  data Union f as where+    This :: !(f a) -> Union f (a : as)+ast: |-+  Module {[DeclData (DataDecl {Prefix "Union" [TyVarBinder {"f"}, TyVarBinder {"as"}], [GadtCon {[UnqualifiedName {"This"}], GadtPrefixBody {[(BangType {True, TParen (TApp (TVar "f") (TVar "a"))})], TApp (TApp (TCon "Union") (TVar "f")) (TParen (TInfix (TVar "a") ":" (TVar "as")))}}]})]}+status: pass
+ test/Test/Fixtures/golden/module/guard-expression-type-signature.yaml view
@@ -0,0 +1,11 @@+extensions: []+input: |+  module GuardExpressionTypeSignature where++  f :: Bool -> Bool+  f x+    | x :: Bool = True+    | otherwise = False+ast: |-+  Module {ModuleHead {"GuardExpressionTypeSignature"}, [DeclTypeSig ["f"] (TFun (TCon "Bool") (TCon "Bool")), DeclValue (FunctionBind "f" [Match {MatchHeadPrefix, [PVar "x"], GuardedRhss [GuardedRhs {[GuardExpr (ETypeSig (EVar "x") (TCon "Bool"))], EVar "True"}, GuardedRhs {[GuardExpr (EVar "otherwise")], EVar "False"}]}])]}+status: pass
+ test/Test/Fixtures/golden/module/guard-view-pattern.yaml view
@@ -0,0 +1,7 @@+extensions: [PatternGuards, ViewPatterns]+input: |+  module GuardViewPattern where+  f x | (view -> Just y) <- x = y+ast: |-+  Module {ModuleHead {"GuardViewPattern"}, [DeclValue (FunctionBind "f" [Match {MatchHeadPrefix, [PVar "x"], GuardedRhss [GuardedRhs {[GuardPat (PParen (PView (EVar "view") (PCon "Just" [PVar "y"]))) (EVar "x")], EVar "y"}]}])]}+status: pass
+ test/Test/Fixtures/golden/module/implicit-module.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  x = 1+  y = x+ast: |-+  Module {[DeclValue (PatternBind (PVar "x") (EInt 1 TInteger)), DeclValue (PatternBind (PVar "y") (EVar "x"))]}+status: pass
+ test/Test/Fixtures/golden/module/import-spec-bundled-data-members.yaml view
@@ -0,0 +1,10 @@+extensions:+  - PatternSynonyms+  - ExplicitNamespaces+input: |+  module Demo where+  import PatternSynonymsSource (Nat (data Zero, data Succ))+  x = 1+status: pass+ast: |-+  Module {ModuleHead {"Demo"}, [ImportDecl {"PatternSynonymsSource", ImportSpec {[ImportItemWith{UnqualifiedName {"Nat"}, [IEBundledMember{IEBundledNamespaceData, "Zero"}, IEBundledMember{IEBundledNamespaceData, "Succ"}]}]}}], [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]}
+ test/Test/Fixtures/golden/module/import-spec-data-namespace.yaml view
@@ -0,0 +1,9 @@+extensions:+  - ExplicitNamespaces+input: |+  module Demo where+  import PatternSynonymsSource (data Zero)+  x = 1+status: pass+ast: |-+  Module {ModuleHead {"Demo"}, [ImportDecl {"PatternSynonymsSource", ImportSpec {[ImportItemAbs{IEEntityNamespaceData, UnqualifiedName {"Zero"}}]}}], [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]}
+ test/Test/Fixtures/golden/module/infix-app-prefix-minus.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  module Demo where+  f = id $ - 1+ast: |-+  Module {ModuleHead {"Demo"}, [DeclValue (PatternBind (PVar "f") (EInfix (EVar "id") "$" (ENegate (EInt 1 TInteger))))]}+status: pass
+ test/Test/Fixtures/golden/module/infix-funlhs-minus-int-pattern.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  M.XnIFig - 0 = x+ast: |-+  Module {[DeclValue (FunctionBind "-" [Match {MatchHeadInfix, [PCon "M" "XnIFig" [], PLit (LitInt 0 TInteger)], EVar "x"}])]}+status: pass
+ test/Test/Fixtures/golden/module/infix-funlhs-minus-string-pattern.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  M.H - "" = x+ast: |-+  Module {[DeclValue (FunctionBind "-" [Match {MatchHeadInfix, [PCon "M" "H" [], PLit (LitString "")], EVar "x"}])]}+status: pass
+ test/Test/Fixtures/golden/module/infix-funlhs-th-splice-pattern.yaml view
@@ -0,0 +1,9 @@+extensions: [TemplateHaskell]+input: |+  {-# LANGUAGE TemplateHaskell #-}+  module InfixFunlhsThSplicePattern where++  $splice `fn` () = ()+ast: |-+  Module {ModuleHead {"InfixFunlhsThSplicePattern"}, [TemplateHaskell], [DeclValue (FunctionBind "fn" [Match {MatchHeadInfix, [PSplice (EVar "splice"), PTuple []], ETuple []}])]}+status: pass
+ test/Test/Fixtures/golden/module/inlinable-pragma.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  {-# INLINABLE w #-}+ast: |-+  Module {[DeclPragma PragmaInline "INLINABLE" "w"]}+status: pass
+ test/Test/Fixtures/golden/module/instance-infix-identifier-head.yaml view
@@ -0,0 +1,8 @@+extensions: []+input: |+  module M where+  class xs `Infix` ys+  instance as `Infix` bs+ast: |-+  Module {ModuleHead {"M"}, [DeclClass (ClassDecl {Infix "xs" "Infix" "ys"}), DeclInstance (InstanceDecl {TInfix (TVar "as") "Infix" (TVar "bs")})]}+status: pass
+ test/Test/Fixtures/golden/module/instance-no-args.yaml view
@@ -0,0 +1,8 @@+extensions: []+input: |+  module Inst where+  class Foo+  instance Foo+ast: |-+  Module {ModuleHead {"Inst"}, [DeclClass (ClassDecl {Prefix "Foo"}), DeclInstance (InstanceDecl {TCon "Foo"})]}+status: pass
+ test/Test/Fixtures/golden/module/instance-parenthesized-head-multiline.yaml view
@@ -0,0 +1,19 @@+extensions: []+input: |+  module ParenthesizedInstanceHead where++  import qualified Data.List as List++  class Collect a where+    collect :: a -> [a]++  data Box a = Box a++  instance+      Eq a+      => (Collect (Box a))+    where+      collect value = List.reverse [value]+status: pass+ast: |-+  Module {ModuleHead {"ParenthesizedInstanceHead"}, [ImportDecl {"Data.List", True, "List"}], [DeclClass (ClassDecl {Prefix "Collect" [TyVarBinder {"a"}], [ClassItemTypeSig {[UnqualifiedName {"collect"}], TFun (TVar "a") (TList [TVar "a"])}]}), DeclData (DataDecl {Prefix "Box" [TyVarBinder {"a"}], [PrefixCon {UnqualifiedName {"Box"}, [BangType {TVar "a"}]}]}), DeclInstance (InstanceDecl {[TApp (TCon "Eq") (TVar "a")], TParen (TApp (TCon "Collect") (TParen (TApp (TCon "Box") (TVar "a")))), [InstanceItemBind (FunctionBind "collect" [Match {MatchHeadPrefix, [PVar "value"], EApp (EVar "List" "reverse") (EList [EVar "value"])}])]})]}
+ test/Test/Fixtures/golden/module/instance-promoted-unit-infix-head.yaml view
@@ -0,0 +1,11 @@+extensions: [DataKinds, FlexibleInstances, TypeOperators]+input: |+  {-# LANGUAGE DataKinds #-}+  {-# LANGUAGE FlexibleInstances #-}+  {-# LANGUAGE TypeOperators #-}+  module M where+  class Infix a b+  instance '() `Infix` ()+ast: |-+  Module {ModuleHead {"M"}, [DataKinds, FlexibleInstances, TypeOperators], [DeclClass (ClassDecl {Prefix "Infix" [TyVarBinder {"a"}, TyVarBinder {"b"}]}), DeclInstance (InstanceDecl {TInfix (TTuple Promoted []) "Infix" (TTuple [])})]}+status: pass
+ test/Test/Fixtures/golden/module/javascript-ffi-imports.yaml view
@@ -0,0 +1,11 @@+extensions:+  - JavaScriptFFI+input: |+  {-# LANGUAGE JavaScriptFFI #-}+  module JavaScriptFFIImport where+  foreign import javascript "((x,y) => { return x + y; })" js_add :: Int -> Int -> Int+  foreign import javascript interruptible "((i,cont) => { return cont(i); })" js_cont :: Int -> IO Int+  foreign import javascript unsafe "performance.now" js_now :: IO Double+ast: |-+  Module {ModuleHead {"JavaScriptFFIImport"}, [JavaScriptFFI], [DeclForeign (ForeignDecl {ForeignImport, JavaScript, ForeignEntityNamed "((x,y) => { return x + y; })", UnqualifiedName {"js_add"}, TFun (TCon "Int") (TFun (TCon "Int") (TCon "Int"))}), DeclForeign (ForeignDecl {ForeignImport, JavaScript, Interruptible, ForeignEntityNamed "((i,cont) => { return cont(i); })", UnqualifiedName {"js_cont"}, TFun (TCon "Int") (TApp (TCon "IO") (TCon "Int"))}), DeclForeign (ForeignDecl {ForeignImport, JavaScript, Unsafe, ForeignEntityNamed "performance.now", UnqualifiedName {"js_now"}, TApp (TCon "IO") (TCon "Double")})]}+status: pass
+ test/Test/Fixtures/golden/module/lambda-case-unparenthesized-type-pattern.yaml view
@@ -0,0 +1,5 @@+extensions: [LambdaCase]+input: |+  x = \case _ :: T -> ()+status: fail+reason: GHC rejects unparenthesized pattern type signatures in case alternatives
+ test/Test/Fixtures/golden/module/linear-types.yaml view
@@ -0,0 +1,15 @@+extensions: [LinearTypes, GADTSyntax]+input: |+  f :: a %1 -> b+  f :: a %m -> b+  f :: a %One -> b+  f :: a %Many -> b+  h :: A %1 -> C+  h x = g y+    where+      %1 y = f x+  x = let %1 f = u in f+  data T3 a m where MkT3 :: a %m -> T3 a m+ast: |-+  Module {[DeclTypeSig ["f"] (TFun ArrowLinear (TVar "a") (TVar "b")), DeclTypeSig ["f"] (TFun ArrowExplicit (TVar "m") (TVar "a") (TVar "b")), DeclTypeSig ["f"] (TFun ArrowExplicit (TCon "One") (TVar "a") (TVar "b")), DeclTypeSig ["f"] (TFun ArrowExplicit (TCon "Many") (TVar "a") (TVar "b")), DeclTypeSig ["h"] (TFun ArrowLinear (TCon "A") (TCon "C")), DeclValue (FunctionBind "h" [Match {MatchHeadPrefix, [PVar "x"], EApp (EVar "g") (EVar "y") Just [DeclValue (PatternBind LinearMultiplicityTag (PVar "y") (EApp (EVar "f") (EVar "x")))]}]), DeclValue (PatternBind (PVar "x") (ELetDecls [DeclValue (PatternBind LinearMultiplicityTag (PVar "f") (EVar "u"))] (EVar "f"))), DeclData (DataDecl {Prefix "T3" [TyVarBinder {"a"}, TyVarBinder {"m"}], [GadtCon {[UnqualifiedName {"MkT3"}], GadtPrefixBody {[(BangType {TVar "a"} , ArrowExplicit (TVar "m"))], TApp (TApp (TCon "T3") (TVar "a")) (TVar "m")}}]})]}+status: pass
+ test/Test/Fixtures/golden/module/literate/bird-style-indented.yaml view
@@ -0,0 +1,10 @@+extensions: []+input: |+  > module IndentedBird where+  > +  > main = do+  >   putStrLn "Hello"+  >   where+  >     x = 1+status: xfail+reason: Bird-style with indented Haskell code.
+ test/Test/Fixtures/golden/module/literate/bird-style-interleaved.yaml view
@@ -0,0 +1,13 @@+extensions: []+input: |+  > module BirdStyleInterleaved where++  Interleaving some text.++  > x = 1++  More text.++  > y = 2+status: xfail+reason: Interleaved Bird-style literate Haskell.
+ test/Test/Fixtures/golden/module/literate/bird-style.yaml view
@@ -0,0 +1,12 @@+extensions: []+input: |+  This is a literate Haskell file.+  The code starts with a greater-than sign.++  > module BirdStyle where+  > +  > main = putStrLn "Bird style!"++  And then some more text here.+status: xfail+reason: Basic Bird-style literate Haskell.
+ test/Test/Fixtures/golden/module/literate/latex-style-interleaved.yaml view
@@ -0,0 +1,13 @@+extensions: []+input: |+  \begin{code}+  module LatexInterleaved where+  \end{code}++  Some text in between.++  \begin{code}+  x = 1+  \end{code}+status: xfail+reason: Interleaved LaTeX-style literate Haskell.
+ test/Test/Fixtures/golden/module/literate/latex-style-with-other-envs.yaml view
@@ -0,0 +1,16 @@+extensions: []+input: |+  \begin{document}+  This is a LaTeX document.++  \begin{code}+  module LatexWithOtherEnvs where+  x = 1+  \end{code}++  \begin{itemize}+    \item Point 1+  \end{itemize}+  \end{document}+status: xfail+reason: LaTeX-style with other LaTeX environments.
+ test/Test/Fixtures/golden/module/literate/latex-style.yaml view
@@ -0,0 +1,14 @@+extensions: []+input: |+  This is a LaTeX-style literate Haskell file.++  \begin{code}+  module LatexStyle where++  main :: IO ()+  main = putStrLn "LaTeX style!"+  \end{code}++  Outside the code environment, everything is a comment.+status: xfail+reason: Basic LaTeX-style literate Haskell.
+ test/Test/Fixtures/golden/module/magic-hash-basic.yaml view
@@ -0,0 +1,9 @@+extensions: [MagicHash]+input: |+  {-# LANGUAGE MagicHash #-}+  module MagicHashBasic where+  x# :: Int#+  x# = 42#+ast: |-+  Module {ModuleHead {"MagicHashBasic"}, [MagicHash], [DeclTypeSig ["x#"] (TCon "Int#"), DeclValue (PatternBind (PVar "x#") (EInt 42 TIntHash))]}+status: pass
+ test/Test/Fixtures/golden/module/magichash-record-dot-bare.yaml view
@@ -0,0 +1,5 @@+extensions: [MagicHash, OverloadedRecordDot]+input: |+  x = 'a'#.a+status: fail+reason: GHC rejects bare record-dot access after hash-ending MagicHash literals
+ test/Test/Fixtures/golden/module/minimal.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  module Demo where+  x = 1+ast: |-+  Module {ModuleHead {"Demo"}, [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]}+status: pass
+ test/Test/Fixtures/golden/module/missing-equals.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  module Demo where+  x 1+ast: |-+status: fail+reason: missing equals in declaration
+ test/Test/Fixtures/golden/module/multiway-if-guard-bare-type-sig.yaml view
@@ -0,0 +1,5 @@+extensions: [MultiWayIf, PartialTypeSignatures]+input: |+  x = if | a :: _ -> ()+status: fail+reason: GHC rejects a bare guard expression type signature before a case-style arrow
+ test/Test/Fixtures/golden/module/newtype-operator-field-polymorphic.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  newtype Managed a = Managed { (>>-) :: a -> a }+ast: |-+  Module {[DeclNewtype (NewtypeDecl {Prefix "Managed" [TyVarBinder {"a"}], RecordCon "Managed" [FieldDecl [">>-"] (TFun (TVar "a") (TVar "a"))]})]}+status: pass
+ test/Test/Fixtures/golden/module/newtype-operator-field.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  newtype T = MkT { ($$) :: Int }+ast: |-+  Module {[DeclNewtype (NewtypeDecl {Prefix "T", RecordCon "MkT" [FieldDecl ["$$"] (TCon "Int")]})]}+status: pass
+ test/Test/Fixtures/golden/module/parser-fuzz-data-deriving-empty.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  data A deriving ()+ast: |-+  Module {[DeclData (DataDecl {Prefix "A", [DerivingClause {[]}]})]}+status: pass
+ test/Test/Fixtures/golden/module/pattern-synonym-basic.yaml view
@@ -0,0 +1,7 @@+extensions:+  - PatternSynonyms+input: |+  pattern Pair x y = (x, y)+ast: |-+  Module {[DeclPatSyn (PatSynDecl {UnqualifiedName {"Pair"}, PatSynPrefixArgs ["x", "y"], PTuple [PVar "x", PVar "y"], PatSynBidirectional})]}+status: pass
+ test/Test/Fixtures/golden/module/pragma/empty-pragma.yaml view
@@ -0,0 +1,8 @@+extensions: []+input: |+  {-##-}+  module EmptyPragma where+  x = 1+ast: |-+  Module {ModuleHead {"EmptyPragma"}, [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]}+status: pass
+ test/Test/Fixtures/golden/module/pragma/language-no-cpp.yaml view
@@ -0,0 +1,8 @@+extensions: []+input: |+  {-# LANGUAGE NoCPP #-}+  module LanguageNoCPP where+  x = 1+ast: |-+  Module {ModuleHead {"LanguageNoCPP"}, [DisableExtension CPP], [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]}+status: pass
+ test/Test/Fixtures/golden/module/pragma/options-glasgow-exts-magic-hash.yaml view
@@ -0,0 +1,8 @@+extensions: []+input: |+  {-# OPTIONS -fglasgow-exts #-}+  module OptionsGlasgowExtsMagicHash where+  x# = 42#+ast: |-+  Module {ModuleHead {"OptionsGlasgowExtsMagicHash"}, [ConstrainedClassMethods, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, ExistentialQuantification, ExplicitNamespaces, FlexibleContexts, FlexibleInstances, ForeignFunctionInterface, FunctionalDependencies, GeneralizedNewtypeDeriving, ImplicitParams, InterruptibleFFI, KindSignatures, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, ParallelListComp, PatternGuards, PostfixOperators, RankNTypes, RecursiveDo, ScopedTypeVariables, StandaloneDeriving, TypeOperators, TypeSynonymInstances, UnboxedTuples, UnicodeSyntax, UnliftedFFITypes], [DeclValue (PatternBind (PVar "x#") (EInt 42 TIntHash))]}+status: pass
+ test/Test/Fixtures/golden/module/prefix-pattern-qualifiers.yaml view
@@ -0,0 +1,20 @@+extensions:+  - BangPatterns+  - ViewPatterns+input: |+  {-# LANGUAGE BangPatterns #-}+  {-# LANGUAGE ViewPatterns #-}+  module PrefixPatternQualifiers where++  comp xs = [y | K !y ~(Just z) q@(Right _) ((negate -> n)) (-1) <- xs]++  guardK xs+    | K !y ~(Just z) q@(Right _) ((negate -> n)) (-1) <- xs = y+  guardK _ = 0++  doK xs = do+    K !y ~(Just z) q@(Right _) ((negate -> n)) (-1) <- xs+    pure y+ast: |-+  Module {ModuleHead {"PrefixPatternQualifiers"}, [BangPatterns, ViewPatterns], [DeclValue (FunctionBind "comp" [Match {MatchHeadPrefix, [PVar "xs"], EListComp (EVar "y") [CompGen (PCon "K" [PStrict (PVar "y"), PIrrefutable (PParen (PCon "Just" [PVar "z"])), PAs UnqualifiedName {"q"} (PParen (PCon "Right" [PWildcard])), PParen (PParen (PView (EVar "negate") (PVar "n"))), PParen (PNegLit (LitInt 1 TInteger))]) (EVar "xs")]}]), DeclValue (FunctionBind "guardK" [Match {MatchHeadPrefix, [PVar "xs"], GuardedRhss [GuardedRhs {[GuardPat (PCon "K" [PStrict (PVar "y"), PIrrefutable (PParen (PCon "Just" [PVar "z"])), PAs UnqualifiedName {"q"} (PParen (PCon "Right" [PWildcard])), PParen (PParen (PView (EVar "negate") (PVar "n"))), PParen (PNegLit (LitInt 1 TInteger))]) (EVar "xs")], EVar "y"}]}]), DeclValue (FunctionBind "guardK" [Match {MatchHeadPrefix, [PWildcard], EInt 0 TInteger}]), DeclValue (FunctionBind "doK" [Match {MatchHeadPrefix, [PVar "xs"], EDo [DoBind (PCon "K" [PStrict (PVar "y"), PIrrefutable (PParen (PCon "Just" [PVar "z"])), PAs UnqualifiedName {"q"} (PParen (PCon "Right" [PWildcard])), PParen (PParen (PView (EVar "negate") (PVar "n"))), PParen (PNegLit (LitInt 1 TInteger))]) (EVar "xs"), DoExpr (EApp (EVar "pure") (EVar "y"))]}])]}+status: pass
+ test/Test/Fixtures/golden/module/prelude-bool-reexports.yaml view
@@ -0,0 +1,31 @@+extensions: []+input: |+  module Prelude+    ( Bool (..),+      Char,+      List (..),+      String,+      (&&),+      (++),+      not,+      otherwise,+      (||),+    )+  where++  import Data.Bool (Bool (..), not, otherwise, (&&), (||))++  data Char++  data List a = [] | a : [a]++  infixr 5 :++  type String = [Char]++  (++) :: [a] -> [a] -> [a]+  (++) [] ys = ys+  (++) (x : xs) ys = x : (xs ++ ys)+ast: |-+  Module {ModuleHead {"Prelude", [ExportAll{"Bool"}, ExportAbs{"Char"}, ExportAll{"List"}, ExportAbs{"String"}, ExportVar{"&&"}, ExportVar{"++"}, ExportVar{"not"}, ExportVar{"otherwise"}, ExportVar{"||"}]}, [ImportDecl {"Data.Bool", ImportSpec {[ImportItemAll{UnqualifiedName {"Bool"}}, ImportItemVar{UnqualifiedName {"not"}}, ImportItemVar{UnqualifiedName {"otherwise"}}, ImportItemVar{UnqualifiedName {"&&"}}, ImportItemVar{UnqualifiedName {"||"}}]}}], [DeclData (DataDecl {Prefix "Char"}), DeclData (DataDecl {Prefix "List" [TyVarBinder {"a"}], [ListCon {}, InfixCon {BangType {TVar "a"}, UnqualifiedName {":"}, BangType {TList [TVar "a"]}}]}), DeclFixity InfixR Nothing 5 [UnqualifiedName {":"}], DeclTypeSyn (TypeSynDecl {Prefix "String", TList [TCon "Char"]}), DeclTypeSig ["++"] (TFun (TList [TVar "a"]) (TFun (TList [TVar "a"]) (TList [TVar "a"]))), DeclValue (FunctionBind "++" [Match {MatchHeadPrefix, [PList [], PVar "ys"], EVar "ys"}]), DeclValue (FunctionBind "++" [Match {MatchHeadPrefix, [PParen (PInfix (PVar "x") ":" (PVar "xs")), PVar "ys"], EInfix (EVar "x") ":" (EParen (EInfix (EVar "xs") "++" (EVar "ys")))}])]}+status: pass
+ test/Test/Fixtures/golden/module/proc-arrow-simple.yaml view
@@ -0,0 +1,7 @@+extensions: [Arrows]+input: |+  serveIndexHtml = proc _request ->+    returnA -< "response"+ast: |-+  Module {[DeclValue (PatternBind (PVar "serveIndexHtml") (EProc (PVar "_request") (CmdArrApp (EVar "returnA") HsFirstOrderApp (EString "response"))))]}+status: pass
+ test/Test/Fixtures/golden/module/proc-pattern-negative-literal.yaml view
@@ -0,0 +1,5 @@+extensions: [Arrows]+input: |+  x = proc -0 -> a -<< a+status: fail+reason: unparenthesized proc binders must be atomic patterns
+ test/Test/Fixtures/golden/module/promoted-parenthesized-qualified-name.yaml view
@@ -0,0 +1,5 @@+extensions: [DataKinds]+input: |+  type T = '(M.A)+status: fail+reason: GHC rejects parenthesized promoted constructor names
+ test/Test/Fixtures/golden/module/standalone-deriving-infix-paren-lhs.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  deriving instance ((C) '()) :+ ()+ast: |-+  Module {[DeclStandaloneDeriving (StandaloneDerivingDecl {TInfix (TParen (TApp (TParen (TCon "C")) (TTuple Promoted []))) ":+" (TTuple [])})]}+status: pass
+ test/Test/Fixtures/golden/module/standalone-deriving-no-args.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  deriving instance Foo+ast: |-+  Module {[DeclStandaloneDeriving (StandaloneDerivingDecl {TCon "Foo"})]}+status: pass
+ test/Test/Fixtures/golden/module/string-gap-operator-continuation.yaml view
@@ -0,0 +1,14 @@+extensions: []+input: |+  module StringGapLayout where+  f = "hello\+      \world" ++ "!"+ast: |-+  Module {ModuleHead {"StringGapLayout"}, [DeclValue (PatternBind (PVar "f") (EInfix (EString "helloworld") "++" (EString "!")))]}+status: pass+comment: |+  Operator continuation after a string gap must not trigger+  premature layout closure. The string ends on the same line as+  the operator, so no BOL processing should occur between them.+  This tests that layout uses the end line (not start line) of+  multi-line tokens for BOL detection.
+ test/Test/Fixtures/golden/module/string-gap-where-layout.yaml view
@@ -0,0 +1,18 @@+extensions: []+input: |+  module StringGapWhere where+  f = header ++ footer+    where+      header = "hello\+               \world"+      footer = "bye"+ast: |-+  Module {ModuleHead {"StringGapWhere"}, [DeclValue (PatternBind (PVar "f") (EInfix (EVar "header") "++" (EVar "footer") Just [DeclValue (PatternBind (PVar "header") (EString "helloworld")), DeclValue (PatternBind (PVar "footer") (EString "bye"))]))]}+status: pass+comment: |+  String gap inside a where block must not trigger premature layout+  closure. When a string literal with gaps spans multiple lines, the+  next token after the closing quote may appear on the same line as+  the string end but a different line from the string start. The+  layout engine must use the end line of the previous token for BOL+  detection, not the start line.
+ test/Test/Fixtures/golden/module/template-haskell-implicit-decl-splice.yaml view
@@ -0,0 +1,9 @@+extensions: [TemplateHaskell]+input: |+  {-# LANGUAGE TemplateHaskell #-}+  module TH_Implicit_Decl_Splice where++  return []+ast: |-+  Module {ModuleHead {"TH_Implicit_Decl_Splice"}, [TemplateHaskell], [DeclSplice (EApp (EVar "return") (EList []))]}+status: pass
+ test/Test/Fixtures/golden/module/template-haskell-operator-splice.yaml view
@@ -0,0 +1,10 @@+extensions: [TemplateHaskell]+input: |+  {-# LANGUAGE TemplateHaskell #-}+  module TH_Operator_Splice where++  x = $(&&)+  y = $(+)+ast: |-+  Module {ModuleHead {"TH_Operator_Splice"}, [TemplateHaskell], [DeclValue (PatternBind (PVar "x") (ETHSplice (EVar "&&"))), DeclValue (PatternBind (PVar "y") (ETHSplice (EVar "+")))]}+status: pass
+ test/Test/Fixtures/golden/module/th-decl-quote-infix-head-bare-type-sig.yaml view
@@ -0,0 +1,7 @@+extensions: [TemplateHaskell, PartialTypeSignatures]+input: |+  x = [d|+    _ + _ :: _ = a+    |]+status: fail+reason: GHC rejects a bare pattern type signature as an infix function-head operand
+ test/Test/Fixtures/golden/module/th-decl-quote-multi-decl.yaml view
@@ -0,0 +1,12 @@+extensions: [TemplateHaskell, QuasiQuotes]+input: |+  {-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+  module TH_Decl_Quote_MultiDecl where++  $(undefined [d|+    data Nat = Z | S Nat+    f x = x+    |])+ast: |-+  Module {ModuleHead {"TH_Decl_Quote_MultiDecl"}, [TemplateHaskell, QuasiQuotes], [DeclSplice (ETHSplice (EParen (EApp (EVar "undefined") (ETHDeclQuote [DeclData (DataDecl {Prefix "Nat", [PrefixCon {UnqualifiedName {"Z"}}, PrefixCon {UnqualifiedName {"S"}, [BangType {TCon "Nat"}]}]}), DeclValue (FunctionBind "f" [Match {MatchHeadPrefix, [PVar "x"], EVar "x"}])]))))]}+status: pass
+ test/Test/Fixtures/golden/module/th-name-quote-tuple-expression.yaml view
@@ -0,0 +1,5 @@+extensions: [TemplateHaskell]+input: |+  x = '(A,B)+status: fail+reason: GHC rejects tuple expressions as Template Haskell name quote bodies
+ test/Test/Fixtures/golden/module/th-pattern-quote-bare-type-sig.yaml view
@@ -0,0 +1,5 @@+extensions: [TemplateHaskell, PartialTypeSignatures]+input: |+  x = [p| _ :: _ |]+status: fail+reason: GHC rejects a bare top-level pattern type signature in a TH pattern quote
+ test/Test/Fixtures/golden/module/th-splice-bare-block.yaml view
@@ -0,0 +1,5 @@+extensions: [TemplateHaskell, MultiWayIf, BlockArguments]+input: |+  x = $if | [] -> []+status: fail+reason: GHC rejects a bare block expression as an untyped splice body
+ test/Test/Fixtures/golden/module/th-type-name-quote-wildcard.yaml view
@@ -0,0 +1,5 @@+extensions: [TemplateHaskell, PartialTypeSignatures]+input: |+  x = '' _+status: fail+reason: GHC rejects wildcard syntax as a TH type-name quote body
+ test/Test/Fixtures/golden/module/th-typed-splice-bare-block.yaml view
@@ -0,0 +1,5 @@+extensions: [TemplateHaskell, MultiWayIf, BlockArguments]+input: |+  x = $$if | [] -> []+status: fail+reason: GHC rejects a bare block expression as a typed splice body
+ test/Test/Fixtures/golden/module/type-equality-family-application.yaml view
@@ -0,0 +1,14 @@+extensions: [TypeFamilies]+input: |+  {-# LANGUAGE TypeFamilies #-}+  module Equality where+  type family IsUpperCased a+  data No+  data Upper+  data Cased a b+  class Casing a+  upperCased :: (Casing b, IsUpperCased a ~ No) => Cased a b -> Cased Upper b+  upperCased = undefined+ast: |-+  Module {ModuleHead {"Equality"}, [TypeFamilies], [DeclTypeFamilyDecl (TypeFamilyDecl {TypeHeadPrefix, True, TCon "IsUpperCased", [TyVarBinder {"a"}]}), DeclData (DataDecl {Prefix "No"}), DeclData (DataDecl {Prefix "Upper"}), DeclData (DataDecl {Prefix "Cased" [TyVarBinder {"a"}, TyVarBinder {"b"}]}), DeclClass (ClassDecl {Prefix "Casing" [TyVarBinder {"a"}]}), DeclTypeSig ["upperCased"] (TContext [TApp (TCon "Casing") (TVar "b"), TInfix (TApp (TCon "IsUpperCased") (TVar "a")) "~" (TCon "No")] (TFun (TApp (TApp (TCon "Cased") (TVar "a")) (TVar "b")) (TApp (TApp (TCon "Cased") (TCon "Upper")) (TVar "b")))), DeclValue (PatternBind (PVar "upperCased") (EVar "undefined"))]}+status: pass
+ test/Test/Fixtures/golden/module/type-family-instance-promoted-unit.yaml view
@@ -0,0 +1,10 @@+extensions: [DataKinds, TypeFamilies]+input: |+  {-# LANGUAGE DataKinds #-}+  {-# LANGUAGE TypeFamilies #-}+  module M where+  type family T a+  type instance T '() = ()+ast: |-+  Module {ModuleHead {"M"}, [DataKinds, TypeFamilies], [DeclTypeFamilyDecl (TypeFamilyDecl {TypeHeadPrefix, True, TCon "T", [TyVarBinder {"a"}]}), DeclTypeFamilyInst (TypeFamilyInst {TypeHeadPrefix, TApp (TCon "T") (TTuple Promoted []), TTuple []})]}+status: pass
+ test/Test/Fixtures/golden/module/type-role-no-roles.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  type role M+ast: |-+  Module {[DeclRoleAnnotation (RoleAnnotation {UnqualifiedName {"M"}, []})]}+status: pass
+ test/Test/Fixtures/golden/module/type-role-parenthesized-operator.yaml view
@@ -0,0 +1,6 @@+extensions: [GHC2021, RoleAnnotations]+input: |+  type role (:=) nominal nominal+status: pass+ast: |-+  Module {[DeclRoleAnnotation (RoleAnnotation {UnqualifiedName {":="}, [RoleNominal, RoleNominal]})]}
+ test/Test/Fixtures/golden/module/type-sig-infix-star-no-star-is-type.yaml view
@@ -0,0 +1,6 @@+extensions: [NoStarIsType]+input: |+  fn :: a * b+ast: |-+  Module {[DeclTypeSig ["fn"] (TInfix (TVar "a") "*" (TVar "b"))]}+status: pass
+ test/Test/Fixtures/golden/module/type-synonym-implicit-param.yaml view
@@ -0,0 +1,7 @@+extensions: [ImplicitParams, ConstraintKinds]+input: |+  module M where+  type CanCheck = (?checker :: Int)+ast: |-+  Module {ModuleHead {"M"}, [DeclTypeSyn (TypeSynDecl {Prefix "CanCheck", TParen (TImplicitParam "?checker" (TCon "Int"))})]}+status: pass
+ test/Test/Fixtures/golden/module/type-synonym-star-no-star-is-type.yaml view
@@ -0,0 +1,6 @@+extensions: [NoStarIsType]+input: |+  type X = (*)+ast: |-+  Module {[DeclTypeSyn (TypeSynDecl {Prefix "X", TCon "*"})]}+status: pass
+ test/Test/Fixtures/golden/module/type-synonym.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  module D6 where+  type Pair a = (a, a)+ast: |-+  Module {ModuleHead {"D6"}, [DeclTypeSyn (TypeSynDecl {Prefix "Pair" [TyVarBinder {"a"}], TTuple [TVar "a", TVar "a"]})]}+status: pass
+ test/Test/Fixtures/golden/module/type-tuple-shorthand-defaults.yaml view
@@ -0,0 +1,11 @@+extensions: [DataKinds, UnboxedTuples]+input: |+  {-# LANGUAGE DataKinds #-}+  {-# LANGUAGE UnboxedTuples #-}+  module M where+  x :: IO ()+  y :: IO '()+  z :: IO '(# #)+ast: |-+  Module {ModuleHead {"M"}, [DataKinds, UnboxedTuples], [DeclTypeSig ["x"] (TApp (TCon "IO") (TTuple [])), DeclTypeSig ["y"] (TApp (TCon "IO") (TTuple Promoted [])), DeclTypeSig ["z"] (TApp (TCon "IO") (TTuple Unboxed Promoted []))]}+status: pass
+ test/Test/Fixtures/golden/module/unboxed-tuples-basic.yaml view
@@ -0,0 +1,11 @@+extensions: [UnboxedTuples]+input: |+  {-# LANGUAGE UnboxedTuples #-}+  module UnboxedTuplesBasic where+  x = (# 1, 2 #)+  f (# a, b #) = a+  h :: (# Int, Int #) -> (# Int, Int #)+  h t = t+ast: |-+  Module {ModuleHead {"UnboxedTuplesBasic"}, [UnboxedTuples], [DeclValue (PatternBind (PVar "x") (ETuple Unboxed [EInt 1 TInteger, EInt 2 TInteger])), DeclValue (FunctionBind "f" [Match {MatchHeadPrefix, [PTuple Unboxed [PVar "a", PVar "b"]], EVar "a"}]), DeclTypeSig ["h"] (TFun (TTuple Unboxed [TCon "Int", TCon "Int"]) (TTuple Unboxed [TCon "Int", TCon "Int"])), DeclValue (FunctionBind "h" [Match {MatchHeadPrefix, [PVar "t"], EVar "t"}])]}+status: pass
+ test/Test/Fixtures/golden/module/unboxed-tuples-singleton.yaml view
@@ -0,0 +1,9 @@+extensions: [UnboxedTuples]+input: |+  {-# LANGUAGE UnboxedTuples #-}+  module UnboxedTuplesSingleton where+  x = (# 1 #)+  f (# y #) = y+ast: |-+  Module {ModuleHead {"UnboxedTuplesSingleton"}, [UnboxedTuples], [DeclValue (PatternBind (PVar "x") (ETuple Unboxed [EInt 1 TInteger])), DeclValue (FunctionBind "f" [Match {MatchHeadPrefix, [PTuple Unboxed [PVar "y"]], EVar "y"}])]}+status: pass
+ test/Test/Fixtures/golden/module/warning-pragma.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: |+  module Demo {-# WARNING "test warning" #-} where+  x = 1+status: pass+ast: |-+  Module {ModuleHead {"Demo", PragmaWarning "test warning"}, [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]}
+ test/Test/Fixtures/golden/pattern/deep-view-pattern.yaml view
@@ -0,0 +1,6 @@+extensions: [ViewPatterns]+input: |+  (a -> b -> c)+ast: |-+  PParen (PView (EVar "a") (PView (EVar "b") (PVar "c")))+status: pass
+ test/Test/Fixtures/golden/pattern/list-deep-view-pattern.yaml view
@@ -0,0 +1,6 @@+extensions: [ViewPatterns]+input: |+  [a -> b -> c]+ast: |-+  PList [PView (EVar "a") (PView (EVar "b") (PVar "c"))]+status: pass
+ test/Test/Fixtures/golden/pattern/mdo-view-pattern.yaml view
@@ -0,0 +1,6 @@+extensions: [RecursiveDo, ViewPatterns]+input: |+  (mdo { pure x } -> y)+ast: |-+  PParen (PView (EDo [DoExpr (EApp (EVar "pure") (EVar "x"))] (DoMdo)) (PVar "y"))+status: pass
+ test/Test/Fixtures/golden/pattern/paren-backtick-con-infix.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (x `Cons` xs)+ast: |-+  PParen (PInfix (PVar "x") "Cons" (PVar "xs"))+status: pass
+ test/Test/Fixtures/golden/pattern/paren-con-infix.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (a :+: b)+ast: |-+  PParen (PInfix (PVar "a") ":+:" (PVar "b"))+status: pass
+ test/Test/Fixtures/golden/pattern/paren-consym-double.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  ((:+))+ast: |-+  PParen (PCon ":+" [])+status: pass
+ test/Test/Fixtures/golden/pattern/paren-neg-literal.yaml view
@@ -0,0 +1,9 @@+extensions: []+input: |+  (Con -5)+ast: |-+status: fail+reason: >+  Negative literals are lpat (not apat) per Haskell Report, so they+  cannot appear as constructor arguments without parentheses.+  GHC also rejects this: "Parse error in pattern: Con - 5".
+ test/Test/Fixtures/golden/pattern/paren-nested-as.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (Con x@(Con' y _))+ast: |-+  PParen (PCon "Con" [PAs UnqualifiedName {"x"} (PParen (PCon "Con'" [PVar "y", PWildcard]))])+status: pass
+ test/Test/Fixtures/golden/pattern/paren-single.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (a)+ast: |-+  PParen (PVar "a")+status: pass
+ test/Test/Fixtures/golden/pattern/paren-varsym-single.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (+)+ast: |-+  PVar "+"+status: pass
+ test/Test/Fixtures/golden/pattern/record-field-view-pattern.yaml view
@@ -0,0 +1,6 @@+extensions: [ViewPatterns]+input: |+  Box {field = id -> x}+ast: |-+  PRecord "Box" {"field" = PView (EVar "id") (PVar "x")}+status: pass
+ test/Test/Fixtures/golden/pattern/tuple-nested-view-patterns.yaml view
@@ -0,0 +1,6 @@+extensions: [ViewPatterns]+input: |+  (a, fn arg -> Just (v -> t@Nothing), _)+ast: |-+  PTuple [PVar "a", PView (EApp (EVar "fn") (EVar "arg")) (PCon "Just" [PParen (PView (EVar "v") (PAs UnqualifiedName {"t"} (PCon "Nothing" [])))]), PWildcard]+status: pass
+ test/Test/Fixtures/golden/pattern/tuple-pair.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (a,b)+ast: |-+  PTuple [PVar "a", PVar "b"]+status: pass
+ test/Test/Fixtures/golden/pattern/tuple-strict-irrefutable.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+  (!a, ~b)+ast: |-+  PTuple [PStrict (PVar "a"), PIrrefutable (PVar "b")]+status: pass
+ test/Test/Fixtures/golden/pattern/unboxed-sum-first.yaml view
@@ -0,0 +1,6 @@+extensions: [UnboxedSums]+input: |+  (# a | #)+ast: |-+  PUnboxedSum 0 2 PVar "a"+status: pass
+ test/Test/Fixtures/golden/pattern/unboxed-sum-second.yaml view
@@ -0,0 +1,6 @@+extensions: [UnboxedSums]+input: |+  (# | a #)+ast: |-+  PUnboxedSum 1 2 PVar "a"+status: pass
+ test/Test/Fixtures/golden/pattern/unboxed-sum-view-as.yaml view
@@ -0,0 +1,6 @@+extensions: [UnboxedSums, ViewPatterns]+input: |+  (# | a -> b@c | #)+ast: |-+  PUnboxedSum 1 3 PView (EVar "a") (PAs UnqualifiedName {"b"} (PVar "c"))+status: pass
+ test/Test/Fixtures/golden/pattern/unboxed-sum-wildcard-middle.yaml view
@@ -0,0 +1,6 @@+extensions: [UnboxedSums]+input: |+  (# | _ | #)+ast: |-+  PUnboxedSum 1 3 PWildcard+status: pass
+ test/Test/Fixtures/golden/pattern/unboxed-tuple-pair.yaml view
@@ -0,0 +1,6 @@+extensions: [UnboxedTuples]+input: |+  (# a, b #)+ast: |-+  PTuple Unboxed [PVar "a", PVar "b"]+status: pass
+ test/Test/Fixtures/golden/pattern/unboxed-tuple-singleton.yaml view
@@ -0,0 +1,6 @@+extensions: [UnboxedTuples]+input: |+  (# x #)+ast: |-+  PTuple Unboxed [PVar "x"]+status: pass
+ test/Test/Fixtures/golden/pattern/unboxed-tuple-view-wildcard.yaml view
@@ -0,0 +1,6 @@+extensions: [UnboxedTuples, ViewPatterns]+input: |+  (# (== 0) -> True, _ #)+ast: |-+  PTuple Unboxed [PView (EParen (ESectionR "==" (EInt 0 TInteger))) (PCon "True" []), PWildcard]+status: pass
+ test/Test/Fixtures/golden/pattern/view-infix-function.yaml view
@@ -0,0 +1,6 @@+extensions: [ViewPatterns]+input: |+  (f . g -> x)+ast: |-+  PParen (PView (EInfix (EVar "f") "." (EVar "g")) (PVar "x"))+status: pass
+ test/Test/Fixtures/golden/pattern/view-pattern-section.yaml view
@@ -0,0 +1,6 @@+extensions: [ViewPatterns]+input: |+  ((== 0) -> True)+ast: |-+  PParen (PView (EParen (ESectionR "==" (EInt 0 TInteger))) (PCon "True" []))+status: pass
+ test/Test/Fixtures/golden/pragma/language-leading-comma.yaml view
@@ -0,0 +1,12 @@+extensions: []+input: |+  {-# LANGUAGE+      DataKinds+    , DeriveGeneric+    , DeriveDataTypeable+    #-}+  module Demo where+  x = 1+ast: |-+  Module {ModuleHead {"Demo"}, [DataKinds, DeriveGeneric, DeriveDataTypeable], [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]}+status: pass
+ test/Test/Fixtures/golden/pragma/language-multiple-multiline.yaml view
@@ -0,0 +1,10 @@+extensions: []+input: |+  {-# LANGUAGE BangPatterns,+               GADTs #-}+  {-# LANGUAGE ScopedTypeVariables #-}+  module Demo where+  x = 1+ast: |-+  Module {ModuleHead {"Demo"}, [BangPatterns, GADTs, ScopedTypeVariables], [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]}+status: pass
+ test/Test/Fixtures/lexer/comments/arrow-operator-in-expr.yaml view
@@ -0,0 +1,9 @@+extensions: []+input: |+  x --> y+tokens:+  - 'TkVarId "x"'+  - 'TkVarSym "-->"'+  - 'TkVarId "y"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/comments/comment-between-identifiers.yaml view
@@ -0,0 +1,10 @@+extensions: []+input: |+  x -- comment+  y+tokens:+  - 'TkVarId "x"'+  - 'TkLineComment'+  - 'TkVarId "y"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/comments/dash-dash-backtick-operator.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "--`"+tokens:+  - 'TkLineComment'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/comments/dash-dash-dollar-operator.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "--$"+tokens:+  - 'TkVarSym "--$"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/comments/dash-dash-foo-comment.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "--foo"+tokens:+  - 'TkLineComment'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/comments/dash-dash-gt-operator.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "-->"+tokens:+  - 'TkVarSym "-->"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/comments/nested-block-comment.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "{- outer {- inner -} outer -}"+tokens:+  - 'TkBlockComment'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/comments/pipe-dash-dash-operator.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "|--"+tokens:+  - 'TkVarSym "|--"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/comments/quadruple-dash-comment.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "----"+tokens:+  - 'TkLineComment'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/comments/simple-line-comment.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "-- simple comment"+tokens:+  - 'TkLineComment'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/comments/triple-dash-comment.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "---"+tokens:+  - 'TkLineComment'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/arrows-or-section.yaml view
@@ -0,0 +1,10 @@+extensions:+  - Arrows+input: "(|| True)"+tokens:+  - 'TkSpecialLParen'+  - 'TkVarSym "||"'+  - 'TkConId "True"'+  - 'TkSpecialRParen'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/char-literal-too-long.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "'ab'"+tokens:+  - 'TkError "invalid char literal"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/hex-fractional-no-exponent.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "0x5e.a"+tokens:+  - 'TkFloat 94.625 TFractional'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/multiline-escaped-triple-quote.yaml view
@@ -0,0 +1,9 @@+extensions: [MultilineStrings]+input: |+  """+  \"\"\"+  """+tokens:+  - 'TkString "\"\"\""'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/multiline-string-gap-before-close.yaml view
@@ -0,0 +1,11 @@+extensions: [MultilineStrings]+input: |+  """+  Line 1+  Line 2+  Line 3\+  \"""+tokens:+  - 'TkString "Line 1\nLine 2\nLine 3"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/multiline-unescaped-quotes.yaml view
@@ -0,0 +1,9 @@+extensions: [MultilineStrings]+input: |+  """+  "Hello"+  """+tokens:+  - 'TkString "\"Hello\""'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/negative-binary-integer.yaml view
@@ -0,0 +1,8 @@+# Negative binary integer with NegativeLiterals extension+extensions:+  - NegativeLiterals+input: "-0b101"+tokens:+  - 'TkInteger -5 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/negative-hex-float.yaml view
@@ -0,0 +1,8 @@+# Negative hex float with NegativeLiterals extension+extensions:+  - NegativeLiterals+input: "-0x1p2"+tokens:+  - 'TkFloat -4.0 TFractional'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/negative-hex-integer.yaml view
@@ -0,0 +1,8 @@+# Negative hex integer with NegativeLiterals extension+extensions:+  - NegativeLiterals+input: "-0x10"+tokens:+  - 'TkInteger -16 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/negative-magic-hash-double.yaml view
@@ -0,0 +1,7 @@+extensions:+  - MagicHash+input: "-2.5##"+tokens:+  - 'TkFloat (-5 % 2) TDoubleHash'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/negative-magic-hash-float.yaml view
@@ -0,0 +1,7 @@+extensions:+  - MagicHash+input: "-3.14#"+tokens:+  - 'TkFloat (-157 % 50) TFloatHash'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/negative-magic-hash-int.yaml view
@@ -0,0 +1,7 @@+extensions:+  - MagicHash+input: "-1#"+tokens:+  - 'TkInteger (-1) TIntHash'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/negative-magic-hash-no-merge-plain.yaml view
@@ -0,0 +1,8 @@+extensions:+  - MagicHash+input: "-1"+tokens:+  - 'TkVarSym "-"'+  - 'TkInteger 1 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/negative-octal-integer.yaml view
@@ -0,0 +1,8 @@+# Negative octal integer with NegativeLiterals extension+extensions:+  - NegativeLiterals+input: "-0o17"+tokens:+  - 'TkInteger -15 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/negative-with-extension.yaml view
@@ -0,0 +1,7 @@+extensions:+  - NegativeLiterals+input: "-10"+tokens:+  - 'TkInteger (-10) TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/negative-without-extension.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: "-10"+tokens:+  - 'TkVarSym "-"'+  - 'TkInteger 10 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/nested-let-layout-in.yaml view
@@ -0,0 +1,26 @@+extensions: []+input: |+  x = let y =+            let z = 1+             in z+       in y+tokens:+  - 'TkVarId "x"'+  - 'TkReservedEquals'+  - 'TkKeywordLet'+  - 'TkSpecialLBrace'+  - 'TkVarId "y"'+  - 'TkReservedEquals'+  - 'TkKeywordLet'+  - 'TkSpecialLBrace'+  - 'TkVarId "z"'+  - 'TkReservedEquals'+  - 'TkInteger 1 TInteger'+  - 'TkSpecialRBrace'+  - 'TkKeywordIn'+  - 'TkVarId "z"'+  - 'TkSpecialRBrace'+  - 'TkKeywordIn'+  - 'TkVarId "y"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/promoted-type-without-datakinds.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: "'True"+tokens:+  - "TkVarSym \"'\""+  - "TkConId \"True\""+  - "TkEOF"+status: pass
+ test/Test/Fixtures/lexer/core/qualified-consym.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "Data.List.:++"+tokens:+  - 'TkQConSym "Data.List" ":++"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/qualified-varsym-deep.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "A.B.C.++"+tokens:+  - 'TkQVarSym "A.B.C" "++"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/qualified-varsym.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "Prelude.+"+tokens:+  - 'TkQVarSym "Prelude" "+"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/shebang-leading-space.yaml view
@@ -0,0 +1,7 @@+# GHC also accepts an initial space before the shebang marker.+extensions: []+input: " #!/usr/bin/env runghc\nmain\n"+tokens:+  - 'TkVarId "main"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/shebang-leading.yaml view
@@ -0,0 +1,7 @@+# GHC treats an initial #! line as whitespace.+extensions: []+input: "#!/usr/bin/env runghc\nmain\n"+tokens:+  - 'TkVarId "main"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/string-escaped-quote.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: '"a\"b"'+tokens:+  - 'TkString "a\"b"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/string-gap-before-close.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: '"\+  \"'+tokens:+  - 'TkString ""'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/string-gap-before-escape-looking-char.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: '"\+  \c"'+tokens:+  - 'TkString "c"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/string-gap-mid-body.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: '"ab\+  \cd"'+tokens:+  - 'TkString "abcd"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/template-haskell-type-quote-spaced-name.yaml view
@@ -0,0 +1,10 @@+extensions:+  - TemplateHaskell+input: "x = '' name"+tokens:+  - 'TkVarId "x"'+  - 'TkReservedEquals'+  - 'TkTHTypeQuoteTick'+  - 'TkVarId "name"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/core/unterminated-string.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: '"unterminated'+tokens:+  - 'TkError "unterminated string literal"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/layout/do-if-then-else-at-layout.yaml view
@@ -0,0 +1,29 @@+extensions: [DoAndIfThenElse]+input: |+  f cond = do+    if cond+    then putStrLn "true"+    else putStrLn "false"+    putStrLn "done"+tokens:+  - 'TkVarId "f"'+  - 'TkVarId "cond"'+  - 'TkReservedEquals'+  - 'TkKeywordDo'+  - 'TkSpecialLBrace'+  - 'TkKeywordIf'+  - 'TkVarId "cond"'+  - 'TkSpecialSemicolon'+  - 'TkKeywordThen'+  - 'TkVarId "putStrLn"'+  - 'TkString "true"'+  - 'TkSpecialSemicolon'+  - 'TkKeywordElse'+  - 'TkVarId "putStrLn"'+  - 'TkString "false"'+  - 'TkSpecialSemicolon'+  - 'TkVarId "putStrLn"'+  - 'TkString "done"'+  - 'TkSpecialRBrace'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/layout/then-do-single-stmt.yaml view
@@ -0,0 +1,24 @@+extensions: [DoAndIfThenElse]+input: |+  if True+    then do+    error "err"+    else do+    error "blah"+tokens:+  - 'TkKeywordIf'+  - 'TkConId "True"'+  - 'TkKeywordThen'+  - 'TkKeywordDo'+  - 'TkSpecialLBrace'+  - 'TkVarId "error"'+  - 'TkString "err"'+  - 'TkSpecialRBrace'+  - 'TkKeywordElse'+  - 'TkKeywordDo'+  - 'TkSpecialLBrace'+  - 'TkVarId "error"'+  - 'TkString "blah"'+  - 'TkSpecialRBrace'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/layout/where-tabs-after-else.yaml view
@@ -0,0 +1,65 @@+extensions: []+input: |+  addExtension file ext = case B.uncons ext of+  	Nothing -> file+  	Just (x,_xs) -> joinDrive a $+  		if isExtSeparator x+  			then b <> ext+  			else b <> (extSeparator `B.cons` ext)+    where+  	(a,b) = splitDrive file+tokens:+  - 'TkVarId "addExtension"'+  - 'TkVarId "file"'+  - 'TkVarId "ext"'+  - 'TkReservedEquals'+  - 'TkKeywordCase'+  - 'TkQVarId "B" "uncons"'+  - 'TkVarId "ext"'+  - 'TkKeywordOf'+  - 'TkSpecialLBrace'+  - 'TkConId "Nothing"'+  - 'TkReservedRightArrow'+  - 'TkVarId "file"'+  - 'TkSpecialSemicolon'+  - 'TkConId "Just"'+  - 'TkSpecialLParen'+  - 'TkVarId "x"'+  - 'TkSpecialComma'+  - 'TkVarId "_xs"'+  - 'TkSpecialRParen'+  - 'TkReservedRightArrow'+  - 'TkVarId "joinDrive"'+  - 'TkVarId "a"'+  - 'TkVarSym "$"'+  - 'TkKeywordIf'+  - 'TkVarId "isExtSeparator"'+  - 'TkVarId "x"'+  - 'TkKeywordThen'+  - 'TkVarId "b"'+  - 'TkVarSym "<>"'+  - 'TkVarId "ext"'+  - 'TkKeywordElse'+  - 'TkVarId "b"'+  - 'TkVarSym "<>"'+  - 'TkSpecialLParen'+  - 'TkVarId "extSeparator"'+  - 'TkSpecialBacktick'+  - 'TkQVarId "B" "cons"'+  - 'TkSpecialBacktick'+  - 'TkVarId "ext"'+  - 'TkSpecialRParen'+  - 'TkSpecialRBrace'+  - 'TkKeywordWhere'+  - 'TkSpecialLBrace'+  - 'TkSpecialLParen'+  - 'TkVarId "a"'+  - 'TkSpecialComma'+  - 'TkVarId "b"'+  - 'TkSpecialRParen'+  - 'TkReservedEquals'+  - 'TkVarId "splitDrive"'+  - 'TkVarId "file"'+  - 'TkSpecialRBrace'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/module/empty-module.yaml view
@@ -0,0 +1,7 @@+extensions: []+input: ""+tokens:+  - 'TkSpecialLBrace'+  - 'TkSpecialRBrace'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/module/module-header-empty-body.yaml view
@@ -0,0 +1,10 @@+extensions: []+input: "module Demo where"+tokens:+  - 'TkKeywordModule'+  - 'TkConId "Demo"'+  - 'TkKeywordWhere'+  - 'TkSpecialLBrace'+  - 'TkSpecialRBrace'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/module/shebang-middle.yaml view
@@ -0,0 +1,17 @@+extensions: []+input: "module Demo where\nx = 1\n#!/usr/bin/env runghc\ny = 2\n"+tokens:+  - 'TkKeywordModule'+  - 'TkConId "Demo"'+  - 'TkKeywordWhere'+  - 'TkSpecialLBrace'+  - 'TkVarId "x"'+  - 'TkReservedEquals'+  - 'TkInteger 1 TInteger'+  - 'TkSpecialSemicolon'+  - 'TkVarId "y"'+  - 'TkReservedEquals'+  - 'TkInteger 2 TInteger'+  - 'TkSpecialRBrace'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/binary-double-underscore.yaml view
@@ -0,0 +1,8 @@+# Double underscore is valid per GHC NumericUnderscores+extensions:+  - NumericUnderscores+input: "0b1100_1011__1110_1111__0101_0011"+tokens:+  - 'TkInteger 13365075 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/binary-packbits.yaml view
@@ -0,0 +1,7 @@+extensions:+  - NumericUnderscores+input: "0b1_11_01_0000_0_111"+tokens:+  - 'TkInteger 7431 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/binary-with-extension.yaml view
@@ -0,0 +1,7 @@+extensions:+  - NumericUnderscores+input: "0b01_0000_0000"+tokens:+  - 'TkInteger 256 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/binary-without-extension.yaml view
@@ -0,0 +1,8 @@+# Without NumericUnderscores, underscore should not be part of the literal+extensions: []+input: "0b01_0000_0000"+tokens:+  - 'TkInteger 1 TInteger'+  - 'TkVarId "_0000_0000"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/decimal-double-underscore.yaml view
@@ -0,0 +1,8 @@+# Double underscore is valid per GHC NumericUnderscores+extensions:+  - NumericUnderscores+input: "1__000000"+tokens:+  - 'TkInteger 1000000 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/decimal-invalid-leading-underscore.yaml view
@@ -0,0 +1,9 @@+# Testing: _0001 (invalid - leading underscore on integer)+# GHC treats this as a variable/hole, not a number.+extensions:+  - NumericUnderscores+input: "_0001"+tokens:+  - 'TkVarId "_0001"'+  - "TkEOF"+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/decimal-trailing-underscore-invalid.yaml view
@@ -0,0 +1,9 @@+# Trailing underscore is invalid - lexer treats as separate tokens+extensions:+  - NumericUnderscores+input: "1000000_"+tokens:+  - 'TkInteger 1000000 TInteger'+  - TkKeywordUnderscore+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/decimal-with-extension.yaml view
@@ -0,0 +1,7 @@+extensions:+  - NumericUnderscores+input: "1_000_000"+tokens:+  - 'TkInteger 1000000 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/decimal-without-extension.yaml view
@@ -0,0 +1,8 @@+# Without NumericUnderscores, underscore should not be part of the literal+extensions: []+input: "1_000_000"+tokens:+  - 'TkInteger 1 TInteger'+  - 'TkVarId "_000_000"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/float-avogadro.yaml view
@@ -0,0 +1,7 @@+extensions:+  - NumericUnderscores+input: "6.022_140_857e+23"+tokens:+  - 'TkFloat 6.022140857e23 TFractional'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/float-exp-double-underscore-before-e.yaml view
@@ -0,0 +1,8 @@+# Double underscore before exponent marker is valid per GHC NumericUnderscores+extensions:+  - NumericUnderscores+input: "1__e+23"+tokens:+  - 'TkFloat 1.0e23 TFractional'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/float-exp-underscore-before-e.yaml view
@@ -0,0 +1,8 @@+# Underscore before exponent marker is valid per GHC NumericUnderscores+extensions:+  - NumericUnderscores+input: "1_e+23"+tokens:+  - 'TkFloat 1.0e23 TFractional'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/float-faraday.yaml view
@@ -0,0 +1,7 @@+extensions:+  - NumericUnderscores+input: "96_485.332_89"+tokens:+  - 'TkFloat 96485.33289 TFractional'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/float-invalid-trailing-underscore-exp.yaml view
@@ -0,0 +1,10 @@+# Testing: 1e+23_ (invalid - trailing underscore in exponent)+# Per GHC docs, this should be invalid+extensions:+  - NumericUnderscores+input: "1e+23_"+tokens:+  - 'TkFloat 1.0e23 TFractional'+  - TkKeywordUnderscore+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/float-invalid-trailing-underscore.yaml view
@@ -0,0 +1,10 @@+# Testing: 0.0001_ (invalid - trailing underscore after float)+# Per GHC docs, this should be invalid+extensions:+  - NumericUnderscores+input: "0.0001_"+tokens:+  - 'TkFloat 1.0e-4 TFractional'+  - TkKeywordUnderscore+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-dot.yaml view
@@ -0,0 +1,11 @@+# Testing: 0._0001+# GHC splits this as 0 . _0001 rather than a float token.+extensions:+  - NumericUnderscores+input: "0._0001"+tokens:+  - "TkInteger 0 TInteger"+  - 'TkVarSym "."'+  - 'TkVarId "_0001"'+  - "TkEOF"+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-e-no-sign.yaml view
@@ -0,0 +1,10 @@+# Testing: 1e_23 (invalid - underscore directly after exponent marker)+# GHC parses this as 1 followed by variable e_23, not a float.+extensions:+  - NumericUnderscores+input: "1e_23"+tokens:+  - "TkInteger 1 TInteger"+  - 'TkVarId "e_23"'+  - "TkEOF"+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-e.yaml view
@@ -0,0 +1,12 @@+# Testing: 1e_+23 (invalid - underscore after 'e')+# Per GHC docs, this should be invalid+extensions:+  - NumericUnderscores+input: "1e_+23"+tokens:+  - 'TkInteger 1 TInteger'+  - 'TkVarId "e_"'+  - 'TkVarSym "+"'+  - 'TkInteger 23 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-sign.yaml view
@@ -0,0 +1,12 @@+# Testing: 1e+_23 (invalid - underscore after sign in exponent)+# Per GHC docs, this should be invalid. Lexer splits it into separate tokens.+extensions:+  - NumericUnderscores+input: "1e+_23"+tokens:+  - "TkInteger 1 TInteger"+  - 'TkVarId "e"'+  - 'TkVarSym "+"'+  - 'TkVarId "_23"'+  - "TkEOF"+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-before-dot.yaml view
@@ -0,0 +1,13 @@+# Testing: 0_.0001 (invalid - underscore before decimal point)+# Per GHC docs, this should be invalid with NumericUnderscores+# The lexer should not accept underscore directly before the decimal point+extensions:+  - NumericUnderscores+input: "0_.0001"+tokens:+  - 'TkInteger 0 TInteger'+  - TkKeywordUnderscore+  - 'TkVarSym "."'+  - 'TkInteger 1 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/float-pi-with-extension.yaml view
@@ -0,0 +1,7 @@+extensions:+  - NumericUnderscores+input: "3.141_592_653_589_793"+tokens:+  - 'TkFloat 3.141592653589793 TFractional'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/float-pi-without-extension.yaml view
@@ -0,0 +1,8 @@+# Without NumericUnderscores, underscore should not be part of the literal+extensions: []+input: "3.141_592_653_589_793"+tokens:+  - 'TkFloat 3.141 TFractional'+  - 'TkVarId "_592_653_589_793"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/hex-double-leading-underscore.yaml view
@@ -0,0 +1,8 @@+# Double leading underscore after base prefix is valid per GHC NumericUnderscores+extensions:+  - NumericUnderscores+input: "0x__ffff"+tokens:+  - 'TkInteger 65535 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/hex-leading-underscore.yaml view
@@ -0,0 +1,8 @@+# Leading underscore after base prefix is valid per GHC NumericUnderscores+extensions:+  - NumericUnderscores+input: "0x_ffff"+tokens:+  - 'TkInteger 65535 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/hex-with-extension.yaml view
@@ -0,0 +1,7 @@+extensions:+  - NumericUnderscores+input: "0xff_00_00"+tokens:+  - 'TkInteger 16711680 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/hex-without-extension.yaml view
@@ -0,0 +1,8 @@+# Without NumericUnderscores, underscore should not be part of the literal+extensions: []+input: "0xff_00_00"+tokens:+  - 'TkInteger 255 TInteger'+  - 'TkVarId "_00_00"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/magic-hash-double-suffix.yaml view
@@ -0,0 +1,9 @@+extensions: [MagicHash]+input: |+  0## 0x0## 0.0##+tokens:+  - 'TkInteger 0 TWordHash'+  - 'TkInteger 0 TWordHash'+  - 'TkFloat 0.0 TDoubleHash'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/octal-with-extension.yaml view
@@ -0,0 +1,8 @@+# Octal literal with underscores+extensions:+  - NumericUnderscores+input: "0o777_777"+tokens:+  - 'TkInteger 262143 TInteger'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/numeric-underscores/octal-without-extension.yaml view
@@ -0,0 +1,8 @@+# Without NumericUnderscores, underscore should not be part of the literal+extensions: []+input: "0o777_777"+tokens:+  - 'TkInteger 511 TInteger'+  - 'TkVarId "_777"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/overloaded-labels/basic.yaml view
@@ -0,0 +1,8 @@+extensions: [OverloadedLabels]+input: |+  #typeUrl #"The quick brown fox"+tokens:+  - 'TkOverloadedLabel "typeUrl" "#typeUrl"'+  - 'TkOverloadedLabel "The quick brown fox" "#\"The quick brown fox\""'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/pragma/language-leading-comma.yaml view
@@ -0,0 +1,11 @@+extensions: []+input: |+  {-# LANGUAGE+      DataKinds+    , DeriveGeneric+    , DeriveDataTypeable+    #-}+tokens:+  - 'TkPragma (PragmaLanguage [EnableExtension DataKinds, EnableExtension DeriveGeneric, EnableExtension DeriveDataTypeable])'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/pragma/language-multiline.yaml view
@@ -0,0 +1,10 @@+extensions: []+input: |+  {-# LANGUAGE +        BangPatterns,+        GADTs +  #-}+tokens:+  - 'TkPragma (PragmaLanguage [EnableExtension BangPatterns, EnableExtension GADTs])'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/symbols/dollar-backtick-dollar.yaml view
@@ -0,0 +1,8 @@+extensions: []+input: "$`$"+tokens:+  - 'TkVarSym "$"'+  - 'TkSpecialBacktick'+  - 'TkVarSym "$"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/symbols/promoted-operator-with-space.yaml view
@@ -0,0 +1,8 @@+extensions:+  - DataKinds+input: "' :<>:"+tokens:+  - "TkVarSym \"'\""+  - "TkConSym \":<>:\""+  - "TkEOF"+status: pass
+ test/Test/Fixtures/lexer/symbols/unicode-em-dash-operator.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "——"+tokens:+  - 'TkVarSym "——"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/symbols/unicode-en-dash-operator.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "–"+tokens:+  - 'TkVarSym "–"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/symbols/unicode-undertie-operator.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "‿"+tokens:+  - 'TkVarSym "‿"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-identifiers/accented-latin.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "café"+tokens:+  - 'TkVarId "café"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-identifiers/greek-lowercase.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "αβγ"+tokens:+  - 'TkVarId "αβγ"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-identifiers/greek-uppercase.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "Σtype"+tokens:+  - 'TkConId "Σtype"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-identifiers/mixed-unicode-ascii.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "naïve"+tokens:+  - 'TkVarId "naïve"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-identifiers/titlecase.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "Džfoo"+tokens:+  - 'TkConId "Džfoo"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-identifiers/unicode-start-with-tail.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "λ123"+tokens:+  - 'TkVarId "λ123"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/arrow-tail-left.yaml view
@@ -0,0 +1,7 @@+extensions:+  - UnicodeSyntax+input: "⤙"+tokens:+  - 'TkVarSym "-<"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/arrow-tail-right.yaml view
@@ -0,0 +1,7 @@+extensions:+  - UnicodeSyntax+input: "⤚"+tokens:+  - 'TkVarSym ">-"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/banana-brackets.yaml view
@@ -0,0 +1,9 @@+extensions:+  - UnicodeSyntax+input: "⦇ x ⦈"+tokens:+  - 'TkVarSym "(|"'+  - 'TkVarId "x"'+  - 'TkVarSym "|)"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/double-arrow-tail-left.yaml view
@@ -0,0 +1,7 @@+extensions:+  - UnicodeSyntax+input: "⤛"+tokens:+  - 'TkVarSym "-<<"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/double-arrow-tail-right.yaml view
@@ -0,0 +1,7 @@+extensions:+  - UnicodeSyntax+input: "⤜"+tokens:+  - 'TkVarSym ">>-"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/double-arrow.yaml view
@@ -0,0 +1,10 @@+extensions:+  - UnicodeSyntax+input: "Eq a ⇒ a"+tokens:+  - 'TkConId "Eq"'+  - 'TkVarId "a"'+  - 'TkReservedDoubleArrow'+  - 'TkVarId "a"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/double-colon.yaml view
@@ -0,0 +1,9 @@+extensions:+  - UnicodeSyntax+input: "x ∷ Int"+tokens:+  - 'TkVarId "x"'+  - 'TkReservedDoubleColon'+  - 'TkConId "Int"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/forall.yaml view
@@ -0,0 +1,8 @@+extensions:+  - UnicodeSyntax+input: "∀ a"+tokens:+  - "TkKeywordForall"+  - 'TkVarId "a"'+  - "TkEOF"+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/full-signature.yaml view
@@ -0,0 +1,14 @@+extensions:+  - UnicodeSyntax+input: "id ∷ ∀ a . a → a"+tokens:+  - 'TkVarId "id"'+  - "TkReservedDoubleColon"+  - "TkKeywordForall"+  - 'TkVarId "a"'+  - 'TkVarSym "."'+  - 'TkVarId "a"'+  - "TkReservedRightArrow"+  - 'TkVarId "a"'+  - "TkEOF"+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/left-arrow.yaml view
@@ -0,0 +1,9 @@+extensions:+  - UnicodeSyntax+input: "x ← y"+tokens:+  - 'TkVarId "x"'+  - 'TkReservedLeftArrow'+  - 'TkVarId "y"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/linear-arrow.yaml view
@@ -0,0 +1,7 @@+extensions:+  - UnicodeSyntax+input: "⊸"+tokens:+  - 'TkLinearArrow'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/no-extension.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: "∷"+tokens:+  - 'TkVarSym "∷"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/right-arrow.yaml view
@@ -0,0 +1,9 @@+extensions:+  - UnicodeSyntax+input: "a → b"+tokens:+  - 'TkVarId "a"'+  - 'TkReservedRightArrow'+  - 'TkVarId "b"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/semantic-brackets.yaml view
@@ -0,0 +1,9 @@+extensions:+  - UnicodeSyntax+input: "⟦ x ⟧"+tokens:+  - 'TkVarSym "[|"'+  - 'TkVarId "x"'+  - 'TkVarSym "|]"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/lexer/unicode-syntax/star.yaml view
@@ -0,0 +1,7 @@+extensions:+  - UnicodeSyntax+input: "★"+tokens:+  - 'TkVarSym "★"'+  - 'TkEOF'+status: pass
+ test/Test/Fixtures/oracle/Arrows/case-nested-do-tuple-bind.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module ArrowCaseNestedDoTupleBind where++import Control.Arrow++f arrM g h j = proc x -> do+  requestMaybe <- arrM $ g -< x+  case requestMaybe of+    Just request -> do+      (a, b) <- g -< request+      arrM $ h -< (a, b)+      returnA -< Just a+    Nothing -> do+      arrM $ j -< ()+      returnA -< Nothing
+ test/Test/Fixtures/oracle/Arrows/command-infix-bnf-operands.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module M where++f = proc x -> case [] of { _ -> a -< x } `op` (b -< x)+g = proc x -> (a -< x) `op` if True then b -< x else c -< x+h = proc x -> (a -< x) `op` \_ -> b -< x+i = proc x -> (a -< x) `op` let y = x in b -< y+j = proc x -> (a -< x) `op` do { b -< x }
+ test/Test/Fixtures/oracle/Arrows/conditional-if-then-else.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module ArrowConditionalIfThenElse where++import Control.Arrow++f g h = proc (x, y) -> do+  if True+    then g -< x + 1+    else h -< y + 2
+ test/Test/Fixtures/oracle/Arrows/conditional-nested.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module ArrowConditionalNested where++import Control.Arrow++f g h k = proc (x, y) -> do+  if True+    then if False+           then g -< x+           else h -< y+    else k -< x + y
+ test/Test/Fixtures/oracle/Arrows/do.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module Do where++f g h = proc x -> do+  y <- g -< x+  h -< y
+ test/Test/Fixtures/oracle/Arrows/infix-expression-arrow-lhs.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+module M where++f = proc x -> [] `a` [] -< let y = (# #) in 846#
+ test/Test/Fixtures/oracle/Arrows/infix-in-do.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module ArrowInfixInDo where++import Control.Arrow++expr' term = proc x -> do+  returnA -< x+  <+> do+    y <- term -< ()+    expr' term -< x + y
+ test/Test/Fixtures/oracle/Arrows/infix-simple.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module ArrowInfixSimple where++import Control.Arrow++f g h = proc x -> (g -< x) <+> (h -< x + 1)
+ test/Test/Fixtures/oracle/Arrows/negated-proc.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module NegatedProc where++x = - proc _ -> a -<< ()
+ test/Test/Fixtures/oracle/Arrows/operator-dollar-left-of-arrow.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module ArrowOperatorDollarLeftOfArrow where++import Control.Arrow++f g h = proc x -> do+  y <- g $ h -< x+  returnA -< y
+ test/Test/Fixtures/oracle/Arrows/operator-fat-arrow-left.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module ArrowOperatorFatArrowLeft where++import Control.Arrow++f g = proc x -> g -< x
+ test/Test/Fixtures/oracle/Arrows/operator-fat-arrow-right.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module ArrowOperatorFatArrowRight where++import Control.Arrow++f g h = proc x -> do+  y <- g -< x+  h -< y
+ test/Test/Fixtures/oracle/Arrows/operator-or-section.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module ArrowOperatorOrSection where++fn = (|| True)
+ test/Test/Fixtures/oracle/Arrows/proc-block-let-arrow-lhs.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE BlockArguments #-}+module ProcBlockLetArrowLhs where++f g = proc x -> (g let { y = x } in y) -< ()
+ test/Test/Fixtures/oracle/Arrows/proc.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module Proc where++f g = proc x -> g -< x
+ test/Test/Fixtures/oracle/Arrows/rec-basic.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module ArrowRecBasic where++import Control.Arrow++counter a = proc reset -> do+  rec output <- returnA -< if reset then 0 else next+      next <- returnA -< output + 1+  returnA -< output
+ test/Test/Fixtures/oracle/Arrows/rec-multiple.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module ArrowRecMultiple where++import Control.Arrow++f g h = proc x -> do+  rec y <- g -< x + 1+      z <- h -< y + 2+  returnA -< (y, z)
+ test/Test/Fixtures/oracle/Arrows/unicode-conditional.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows, UnicodeSyntax #-}+module ArrowUnicodeConditional where++import Control.Arrow++f g h = proc (x, y) → do+  if True+    then g ⤙ x + 1+    else h ⤙ y + 2
+ test/Test/Fixtures/oracle/Arrows/unicode-fat-arrow-right.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows, UnicodeSyntax #-}+module ArrowUnicodeFatArrowRight where++import Control.Arrow++f g h = proc x → do+  y ← g ⤙ x+  h ⤙ y
+ test/Test/Fixtures/oracle/Arrows/unicode-rec.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows, UnicodeSyntax #-}+module ArrowUnicodeRec where++import Control.Arrow++counter a = proc reset → do+  rec output ← returnA ⤙ if reset then 0 else next+      next ← returnA ⤙ output + 1+  returnA ⤙ output
+ test/Test/Fixtures/oracle/BangPatterns/bang-case-alt.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BangPatterns #-}++module BangPatternsCaseAlt where++headStrict :: [Int] -> Maybe Int+headStrict xs =+  case xs of+    ![] -> Nothing+    !(y : _) -> Just y
+ test/Test/Fixtures/oracle/BangPatterns/bang-fun-arg.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BangPatterns #-}++module BangPatternsFunArg where++strictId :: Int -> Int+strictId !x = x
+ test/Test/Fixtures/oracle/BangPatterns/bang-lambda.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BangPatterns #-}++module BangPatternsLambda where++applyStrict :: (Int -> Int) -> Int -> Int+applyStrict f = (\ !x -> f x)
+ test/Test/Fixtures/oracle/BangPatterns/bang-let-binding.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BangPatterns #-}++module BangPatternsLetBinding where++strictPair :: (Int, Int) -> Int+strictPair pair =+  let !(x, y) = pair+   in x + y
+ test/Test/Fixtures/oracle/BangPatterns/bang-let-guarded.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BangPatterns #-}++module BangPatternsLetGuarded where++test :: Bool -> Int+test positive =+  let !x | True = 1+   in x
+ test/Test/Fixtures/oracle/BangPatterns/bang-parenthesized-operator-as-pattern.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BangPatterns #-}+module BangParenthesizedOperatorAsPattern where++data C = C++fn !(+)@C = ()
+ test/Test/Fixtures/oracle/BangPatterns/bang-where.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BangPatterns #-}++module BangPatternsWhere where++scale :: Int -> Int -> Int+scale factor input = go input+  where+    go !x = factor * x
+ test/Test/Fixtures/oracle/BangPatterns/prefix-pattern-qualifiers.hs view
@@ -0,0 +1,15 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}++module PrefixPatternQualifiers where++comp xs = [y | K !y ~(Just z) q@(Right _) ((negate -> n)) (-1) <- xs]++guardK xs+  | K !y ~(Just z) q@(Right _) ((negate -> n)) (-1) <- xs = y+guardK _ = 0++doK xs = do+  K !y ~(Just z) q@(Right _) ((negate -> n)) (-1) <- xs+  pure y
+ test/Test/Fixtures/oracle/BangPatterns/unpack-no-space-strictness.hs view
@@ -0,0 +1,2 @@+{- ORACLE_TEST pass -}+data Pair a = Null | Cons a {-# UNPACK #-}!(IORef (Pair a))
+ test/Test/Fixtures/oracle/BinaryLiterals/binary-literals-basic.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BinaryLiterals #-}++module BinaryLiteralsBasic where++maskA :: Int+maskA = 0b0001++maskB :: Int+maskB = 0B1010++combined :: Int+combined = maskA + maskB + 0b1111
+ test/Test/Fixtures/oracle/BinaryLiterals/binary-literals-negative.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BinaryLiterals #-}++module BinaryLiteralsNegative where++signedValues :: [Int]+signedValues = [0b1, -0b1, -0B10, 0b11]
+ test/Test/Fixtures/oracle/BinaryLiterals/binary-literals-patterns.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BinaryLiterals #-}++module BinaryLiteralsPatterns where++decodeBit :: Int -> String+decodeBit n = case n of+  0b0 -> "zero"+  0b1 -> "one"+  _ -> "many"
+ test/Test/Fixtures/oracle/BlockArguments/as-pattern-lambda.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021, BlockArguments #-}+module AsPatternLambda where++f = id \x@(Just y) -> y
+ test/Test/Fixtures/oracle/BlockArguments/basic-case.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BlockArguments #-}+module BasicCase where++f x = id case x of+  _ -> ()
+ test/Test/Fixtures/oracle/BlockArguments/basic-do.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BlockArguments #-}+module BasicDo where++f = id do+  pure ()
+ test/Test/Fixtures/oracle/BlockArguments/basic-if.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BlockArguments #-}+module BasicIf where++f x y z = id if x then y else z
+ test/Test/Fixtures/oracle/BlockArguments/basic-lambda.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BlockArguments #-}+module BasicLambda where++f = id \x -> x
+ test/Test/Fixtures/oracle/CPP/infix-funlhs-cpp-variants.hs view
@@ -0,0 +1,23 @@+{- ORACLE_TEST pass -}+{- Test infix function definitions with C preprocessor -}+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}+module InfixFunlhsCppVariants where++-- Basic infix+infixl 6 <.>+(<.>) :: Int -> Int -> Int+x <.> y = x * y++-- Infix with constructor patterns+infixr 5 <++>+(<++>) :: Maybe a -> Maybe a -> Maybe a+(Just x) <++> _ = Just x+Nothing <++> y = y++#ifdef DEBUG+-- Infix inside CPP conditional+infix 4 <=>+(<=>) :: Int -> Int -> Ordering+x <=> y = compare x y+#endif
+ test/Test/Fixtures/oracle/CPP/macro-expansion-block-comment-literal.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE CPP #-}+module MacroExpansionBlockCommentLiteral where++#define HET 0x68657462 /* 'h' 'e' 't' 'b' */++f x = case x of+  HET -> ()+  _ -> ()
+ test/Test/Fixtures/oracle/ClassGuards/guarded-method-comprehensive.hs view
@@ -0,0 +1,19 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++class C a where+  simple :: a -> a+  simple x = x++  guarded :: a -> a -> a+  guarded x y | x == y = x+             | otherwise = y++  patternGuard :: Maybe a -> a -> a+  patternGuard mx y | Just x <- mx = x+                    | otherwise = y++  letGuard :: a -> a+  letGuard x | let y = x+             , y == x = y+             | otherwise = x
+ test/Test/Fixtures/oracle/ClassGuards/guarded-method-variations.hs view
@@ -0,0 +1,15 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++class C a b where+  multiParam :: a -> b -> Bool+  multiParam x y | x == x = True+                 | otherwise = False++  infixMethod :: a -> a -> a+  x `infixMethod` y | x == y = x+                    | otherwise = y++  multipleEquations :: a -> a+  multipleEquations x = x+  multipleEquations _ = undefined
+ test/Test/Fixtures/oracle/ClassGuards/guarded-method.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++class C a where+  f :: a -> a -> a+  f x y | x == y = x+        | otherwise = y
+ test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-kind-signature-rhs-roundtrip.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}++module ConstraintKindSignatureRhsRoundtrip where++import Data.Coerce (Coercible)+import Data.Kind (Constraint)++type Coercible2 f = (forall a b c d. (Coercible a b, Coercible c d) => Coercible (f a c) (f b d) :: Constraint)
+ test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-poly-arity-zero.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++f :: (() ~ () => a) -> a+f x = x
+ test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-poly-paren-infix-equality.hs view
@@ -0,0 +1,28 @@+{- ORACLE_TEST pass -}+{- Tests infix type operators after parenthesized expressions in constraints. -}+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+import Data.Type.Equality (type (==))++-- Parenthesized infix type expression followed by ~ in constraint+f1 :: (a == b) ~ 'True => a -> b+f1 = undefined++-- Same with double parens (the workaround that always worked)+f2 :: ((a == b) ~ 'True) => a -> b+f2 = undefined++-- Parenthesized type application followed by ~ in constraint+f3 :: (Maybe a) ~ Maybe b => a -> b+f3 = undefined++-- Type family application with parens followed by ~+type family F a+f4 :: (F a) ~ Bool => a -> a+f4 = undefined++-- In comma-separated constraint list with parenthesized infix item+f5 :: (Eq a, (a == b) ~ 'True) => a -> b+f5 = undefined
+ test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-poly-type-equality.hs view
@@ -0,0 +1,31 @@+{- ORACLE_TEST pass -}+{- Tests constraint polymorphism with type equality constraints using (~). -}+{-# LANGUAGE GHC2021 #-}++-- Zero-arity constraint in parenthesized constrained type+f1 :: (() ~ () => a) -> a+f1 x = x++-- Zero-arity constraint without outer parens+f2 :: () ~ () => a -> a+f2 x = x++-- Multiple type equalities+f3 :: (a ~ b, b ~ c) => a -> c+f3 x = x++-- Type equality with complex types+f4 :: (Maybe a ~ Maybe b) => a -> b+f4 x = x++-- Type equality mixed with class constraints+f5 :: (Eq a, a ~ b) => b -> Bool+f5 x = x == x++-- Nested constrained type+f6 :: ((a ~ b) => a) -> b+f6 x = x++-- Type equality with Proxy+f7 :: Proxy a ~ Proxy b => a -> b+f7 x = x
+ test/Test/Fixtures/oracle/DataKinds/builtin-cons-type.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+module BuiltinConsType where++x :: (:)+x = undefined
+ test/Test/Fixtures/oracle/DataKinds/datakinds-numeric-type-literal.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+module M where+import Data.Proxy+_1 :: Proxy 1+_1 = Proxy
+ test/Test/Fixtures/oracle/DataKinds/list-promoted-kind.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+module ListPromotedKind where++import Data.Proxy+fn :: Proxy (() ': '[])+fn = undefined
+ test/Test/Fixtures/oracle/DataKinds/promoted-builtin.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+module PromotedBuiltin where++type T = "Hello"
+ test/Test/Fixtures/oracle/DataKinds/promoted-cons-kind.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+module PromotedConsKind where++type T = a ': b
+ test/Test/Fixtures/oracle/DataKinds/promoted-ctor.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+module PromotedCtor where++data Nat = Zero | Succ Nat+type T = 'Zero
+ test/Test/Fixtures/oracle/DataKinds/promoted-empty-list-type-constructor.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+module PromotedEmptyListTypeConstructor where++type T = '[]
+ test/Test/Fixtures/oracle/DataKinds/promoted-list.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+module PromotedList where++type T = '[Int, String]
+ test/Test/Fixtures/oracle/DataKinds/promoted-string-type-operator.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds, TypeOperators #-}++module PromotedTypeOperatorWithStrings where++type Msg = 'Text "msg1" ':$$: 'Text "msg2"
+ test/Test/Fixtures/oracle/DataKinds/promoted-tuple-leading-char.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}++module PromotedTupleLeadingChar where++import GHC.TypeLits (Symbol)++type family DropHash (value :: Maybe (Char, Symbol)) :: Symbol where+  DropHash ('Just '( '#', rest)) = rest+  DropHash 'Nothing = ""
+ test/Test/Fixtures/oracle/DataKinds/promoted-tuple.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+module PromotedTuple where++type T = '(Int, String)
+ test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-chained.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds, TypeOperators #-}++module PromotedTypeOperatorChained where++-- Multiple promoted type operators chained together+type Chain = 'Text "a" ':$$: 'Text "b" ':$$: 'Text "c"
+ test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-minus.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds, TypeOperators #-}++module PromotedTypeOperatorMinus where++type T1 = a '- b
+ test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-with-names.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds, TypeOperators #-}++module PromotedTypeOperatorWithNames where++-- Promoted type operator with type variables+type T1 = a ':$$: b++-- Promoted type operator with type constructors+type T2 = Maybe ':$$: Either++-- Promoted type operator with concrete types+type T3 = Int ':$$: Bool
+ test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-with-space.hs view
@@ -0,0 +1,20 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module PromotedTypeOperatorWithSpace where++import GHC.TypeLits (TypeError, ErrorMessage(..), Symbol, Nat)++-- Regression test: the promotion tick before a type operator with intervening+-- whitespace (e.g. ' :<>:) was not recognized by the lexer, causing the+-- 'where' keyword in a closed type family to be mis-parsed as an unexpected+-- token.  This snippet parses with GHC but previously failed with aihc-parser.++type family ShowConstraint (s :: Symbol) (n :: Nat) :: Symbol where+  ShowConstraint s n = TypeError ('Text "value " ' :<>: 'ShowType n ' :<>: 'Text " exceeds limit for " ' :<>: 'ShowType s)++-- Multiple chained promoted operators with space before tick.+type family ConstraintMsg (s :: Symbol) (n :: Nat) :: Symbol where+  ConstraintMsg s n = TypeError ('Text "Invalid NonEmptyText. Needs to be <= " ' :<>: 'ShowType n ' :<>: 'Text " characters. Has " ' :<>: 'ShowType n ' :<>: 'Text " characters.")
+ test/Test/Fixtures/oracle/DataKinds/standalone-deriving-infix-promoted-lhs.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++module StandaloneDerivingInfixPromotedLHS where++class a :+ b++deriving instance ((C) '()) :+ ()
+ test/Test/Fixtures/oracle/DataKinds/unquoted-list-type-edge-cases.hs view
@@ -0,0 +1,22 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitForAll #-}+module UnquotedListTypeEdgeCases where++-- Single element (should still work)+type Single = [Int]++-- Two elements+type Two = [Int, Bool]++-- Three elements+type Three = [Int, Bool, String]++-- Multiple elements with type variables (need forall to bind them)+type WithVars = forall a b c. [a, b, c]++-- Nested list types (all elements must have same kind [*])+type Nested = [[Int, Bool], [String, Bool]]++-- Promoted with quote (should still work)+type Promoted = '[Int, Bool, String]
+ test/Test/Fixtures/oracle/DataKinds/unquoted-list-type.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+module UnquotedListType where++type T = [Int, Bool]
+ test/Test/Fixtures/oracle/Declarations/empty-where.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}++module EmptyWhere where++-- Empty where clause (syntactically valid, though semantically useless)+test = x+  where {}
+ test/Test/Fixtures/oracle/Declarations/guarded-where-tuple-pattern.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}++module GuardedWhereTuplePattern where++-- Parser fails to handle guarded patterns with tuple patterns in where clauses+f :: Int -> Int+f x = y+  where+    (a, b)+      | x <= 0 = (0, 1)+      | otherwise = (1, 0)+    y = a
+ test/Test/Fixtures/oracle/Declarations/incomplete-case.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+instance Cls T1 where+  val = case val of
+ test/Test/Fixtures/oracle/Declarations/rope-uncons.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+unconsRope :: Rope -> Maybe (Char, Rope)+unconsRope text =+    let x = unRope text+    in  case F.viewl x of+            F.EmptyL -> Nothing+            (F.:<) piece x' ->+                case S.uncons piece of+                    Nothing -> Nothing+                    Just (c, piece') -> Just (c, Rope ((F.<|) piece' x'))
+ test/Test/Fixtures/oracle/DefaultSignatures/basic.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DefaultSignatures #-}+module Basic where++class C a where+  f :: a -> Int+  default f :: (D a) => a -> Int+  f = g
+ test/Test/Fixtures/oracle/DefaultSignatures/context.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DefaultSignatures #-}+module Context where++class C a where+  f :: a -> Int+  default f :: D a => a -> Int+  f = g
+ test/Test/Fixtures/oracle/DefaultSignatures/equality.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DefaultSignatures #-}+module Equality where++class Inj a where+  inj :: a -> a+  default inj :: (p ~ a) => p -> a+  inj = \x -> x
+ test/Test/Fixtures/oracle/DerivingStrategies/deriving-multiple-clauses.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DerivingStrategies #-}++module DerivingStrategiesMultipleClauses where++data Box a = Box a+  deriving stock (Eq)+  deriving stock (Show)
+ test/Test/Fixtures/oracle/DerivingStrategies/deriving-newtype-list.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DerivingStrategies #-}++module DerivingStrategiesNewtypeList where++newtype Total = Total Int+  deriving newtype Eq
+ test/Test/Fixtures/oracle/DerivingStrategies/deriving-newtype.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DerivingStrategies #-}++module DerivingStrategiesNewtype where++newtype Age = Age Int+  deriving newtype (Eq, Ord, Show)
+ test/Test/Fixtures/oracle/DerivingStrategies/deriving-stock-multi.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DerivingStrategies #-}++module DerivingStrategiesStockMulti where++data Pair a = Pair a a+  deriving stock (Eq, Show)
+ test/Test/Fixtures/oracle/DerivingStrategies/deriving-stock-single.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DerivingStrategies #-}++module DerivingStrategiesStockSingle where++data Tag = Tag+  deriving stock (Eq)
+ test/Test/Fixtures/oracle/DerivingVia/basic.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DerivingVia #-}+module Basic where++newtype MyInt = MyInt Int+  deriving Show via Int
+ test/Test/Fixtures/oracle/DerivingVia/complex-via.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DerivingVia #-}+module ComplexVia where++newtype T a = T a+  deriving Eq via (Maybe a)
+ test/Test/Fixtures/oracle/DerivingVia/deriving-via-mvector.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingVia #-}++module DerivingViaMVector where++import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as GM+import qualified Data.Vector.Unboxed as U++data TestPair a b = TestPair a b++deriving via (TestPair a b `U.As` (a, b)) instance (U.Unbox a, U.Unbox b) => GM.MVector U.MVector (TestPair a b)+deriving via (TestPair a b `U.As` (a, b)) instance (U.Unbox a, U.Unbox b) => G.Vector   U.Vector  (TestPair a b)
+ test/Test/Fixtures/oracle/DerivingVia/multiple-classes.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DerivingVia #-}+module MultipleClasses where++newtype MyInt = MyInt Int+  deriving (Eq, Ord) via Int
+ test/Test/Fixtures/oracle/DerivingVia/multiple-via-clauses-context-boundary.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyDataDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StarIsType #-}+{-# LANGUAGE TypeOperators #-}+module MultipleViaClausesContextBoundary where++class (a :: *) :+ (b :: Symbol)++data C a+  deriving () via *+  deriving () via (:+) => 'm'
+ test/Test/Fixtures/oracle/DerivingVia/standalone-via-instance.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DerivingVia #-}++module StandaloneViaInstance where++deriving via+  (LiftingSelect (ContT r) m)+  instance+    (MonadSelect r' m) =>+    MonadSelect r' (ContT r m)
+ test/Test/Fixtures/oracle/DerivingVia/standalone.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE StandaloneDeriving #-}+module Standalone where++newtype MyInt = MyInt Int+deriving via Int instance Show MyInt
+ test/Test/Fixtures/oracle/DoAndIfThenElse/bare-let-in-do-explicit.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}++module BareLetInDoExplicit where++-- Explicit empty braces in do block+test = do+  let {}+  x <- undefined+  return ()
+ test/Test/Fixtures/oracle/DoAndIfThenElse/bare-let-in-do-multiple.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}++module BareLetInDoMultiple where++-- Multiple empty lets in do block+test = do+  let+  let {}+  x <- undefined+  return ()
+ test/Test/Fixtures/oracle/DoAndIfThenElse/bare-let-in-do.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}++module BareLetInDo where++test = do+  let+  x <- undefined+  return ()
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-at-layout.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DoAndIfThenElse #-}++-- Test case: then and else at column of parent do with no inner do.+-- This should NOT close the outer do layout.+module DoAndIfThenElseThenElseAtLayout where++atLayout :: Bool -> IO ()+atLayout cond = do+  if cond+  then putStrLn "true"+  else putStrLn "false"+  putStrLn "done"
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-basic.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DoAndIfThenElse #-}++module DoAndIfThenElseBasic where++choose :: Bool -> Maybe Int+choose cond = do+  if cond+  then pure 1+  else pure 2
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-case-layout.hs view
@@ -0,0 +1,17 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DoAndIfThenElse #-}++-- Test case: 'then do' followed by 'case' expression, then 'else do'.+-- The 'case' block at same column as 'then' should be inside then-do.+-- The 'else' at same column should close then-do and case before else-do.+module DoAndIfThenElseCaseLayout where++toCaseLayout :: IO ()+toCaseLayout = do+  if True+    then do+    case undefined of+      Left err -> error err+      Right obj -> return obj+    else do+    return ()
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-else-do-if-layout.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DoAndIfThenElse #-}++-- Test case: inner 'if-then-else' inside 'else do' layout block where the+-- outer if-then-else is on one line. The else-do layout must stay open across+-- the nested conditional and only close when the outer branch ends.+-- Minimized from http-download-0.2.1.0 Verified.hs:322.+module DoAndIfThenElseElseDoIfLayout where++foo = if a then b else do+    if c then d else e
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-else-do-multiline-inner-if.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DoAndIfThenElse #-}++-- Test case: multiline inner 'if-then-else' as the first statement in an+-- 'else do' layout block. The outer else-do layout must not close on the+-- inner branch markers before the statement finishes.+module DoAndIfThenElseElseDoMultilineInnerIf where++fn =+  if False then+    return True+  else do+      if hidden /= 0 then+        return True+      else+        return False
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-following-stmt.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DoAndIfThenElse #-}++module DoAndIfThenElseFollowingStmt where++pipeline :: Bool -> Maybe Int+pipeline cond = do+  x <- if cond+       then pure 10+       else pure 20+  pure (x + 1)
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-let-layout.hs view
@@ -0,0 +1,17 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DoAndIfThenElse #-}++-- Test case: 'then do' followed by 'let' expression, then 'else do'.+-- The 'let' block at same column as 'then' should be inside then-do.+-- The 'else' at same column should close then-do and let before else-do.+module DoAndIfThenElseLetLayout where++withLet :: IO ()+withLet = do+  if True+    then do+    let x = 1+        y = 2+    return (x + y)+    else do+    return 0
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-nested-do.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DoAndIfThenElse #-}++module DoAndIfThenElseNestedDo where++nested :: Bool -> Maybe Int+nested cond = do+  if cond+  then do+    x <- pure 1+    pure x+  else do+    y <- pure 2+    pure y
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-nested-if.hs view
@@ -0,0 +1,18 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DoAndIfThenElse #-}++-- Test case: nested if-then-else inside 'then do' and 'else do'.+-- Multiple levels of nesting should work correctly.+module DoAndIfThenElseNestedIf where++nestedIf :: Bool -> Bool -> IO ()+nestedIf a b = do+  if a+    then do+    if b+      then do+      putStrLn "a and b"+      else do+      putStrLn "a and not b"+    else do+    putStrLn "not a"
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-then-do-if-layout.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DoAndIfThenElse #-}++-- Test case: inner 'if-then-else' inside 'then do' layout block where the+-- outer if-then-else has 'then do' on one line. The then-do layout must stay+-- open across the nested conditional and only close for the outer else.+module DoAndIfThenElseThenDoIfLayout where++foo = if a then do+    if c then d else e+    else b
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-then-do-multi-stmt.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DoAndIfThenElse #-}++-- Test case: 'then do' and 'else do' where inner do has multiple statements.+-- The 'else' at column 5 should close the inner do at column 5.+module DoAndIfThenElseThenDoMultiStmt where++multiStmt :: IO ()+multiStmt = do+  if True+    then do+    putStrLn "a"+    putStrLn "b"+    else do+    putStrLn "c"+    putStrLn "d"
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-then-do-single-stmt.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DoAndIfThenElse #-}++-- Test case: 'then do' and 'else do' with single statements at same indent as 'else'.+-- This tests the parse-error rule for closing implicit layouts before 'else'.+module DoAndIfThenElseThenDoSingleStmt where++getCachedJSONQuery :: IO ()+getCachedJSONQuery = do+  if True+    then do+    error "err"+    else do+    error "blah"
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-block-alternative.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+module AttoparsecExpr where++rassocP :: Maybe Int+rassocP = do+  f <- Just 1+  y <- do+    z <- Just 2+    Just (f + z)+  pure (f + y)+  <|> Just 0
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-infix-backtick-continuation.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++module RollbarInfixDo where++catch :: IO a -> (String -> IO a) -> IO a+catch = undefined++test :: IO (Maybe Int)+test = do+    x <- return 42+    return (Just x)+    `catch` (\e -> return Nothing)
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-infix-continuation.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DoAndIfThenElse #-}+module DoInfixContinuation where++-- Infix operator at the same indent level continues the previous+-- expression rather than starting a new statement (parse-error rule).+f x y = do+  x+  + y
+ test/Test/Fixtures/oracle/DoAndIfThenElse/do-let-in-multiline-bindings.hs view
@@ -0,0 +1,15 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}++module DoLetInMultilineBindings where++f x = do+  let a =+        case x of+          True -> 1+          False -> 2+      b =+        case x of+          True -> 3+          False -> 4+    in if x then a else b
+ test/Test/Fixtures/oracle/DoAndIfThenElse/let-expression-do-statement-roundtrip.hs view
@@ -0,0 +1,20 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}++module LetExpressionDoStatementRoundtrip where++withLocalFunction :: IO ()+withLocalFunction = do+  let+    loop n =+      if n <= 0+        then return ()+        else loop (n - 1)+   in loop 2++withLocalPattern :: IO ()+withLocalPattern = do+  let+    (x, y) = (1 :: Int, 2 :: Int)+    total = x + y+   in print total
+ test/Test/Fixtures/oracle/EmptyCase/empty-case-basic.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyCase #-}++module EmptyCaseBasic where++data Void++absurd :: Void -> a+absurd v = case v of {}
+ test/Test/Fixtures/oracle/EmptyCase/empty-case-implicit-eof.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyCase #-}++module EmptyCaseImplicitEof where++data Void++absurdAfterAlt :: Bool -> Void -> a+absurdAfterAlt b v = case b of True -> case v of
+ test/Test/Fixtures/oracle/EmptyCase/empty-case-implicit-rparen.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyCase #-}++module EmptyCaseImplicitRParen where++data Void++absurdInParens :: Bool -> Void -> a+absurdInParens b v = (case b of True -> case v of)
+ test/Test/Fixtures/oracle/EmptyCase/empty-case-let.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyCase #-}++module EmptyCaseLet where++data Zero++eliminate :: Zero -> Bool+eliminate x =+  let impossible y = case y of {}+   in impossible x
+ test/Test/Fixtures/oracle/EmptyCase/empty-case-multiline-type-param.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyCase #-}++module EmptyCaseMultilineTypeParam where++data Test+ a++x = 1
+ test/Test/Fixtures/oracle/EmptyCase/empty-case-where.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyCase #-}++module EmptyCaseWhere where++data Never++consume :: Never -> Int+consume x =+  whereImpossible x+  where+    whereImpossible y = case y of {}
+ test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-basic.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyDataDecls #-}++module EmptyDataDeclsBasic where++data Empty
+ test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-export.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyDataDecls #-}++module EmptyDataDeclsExport (Empty, Phantom) where++data Empty++data Phantom a
+ test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-kind-context.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE KindSignatures #-}++module EmptyDataDeclsWithKindContext where++data (:+) :: C => ()
+ test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-multi.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyDataDecls #-}++module EmptyDataDeclsMulti where++data A++data B a
+ test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-param.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyDataDecls #-}++module EmptyDataDeclsParam where++data Phantom a
+ test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-with-kind.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE KindSignatures #-}++module EmptyDataDeclsWithKind where++import Data.Kind (Type)++data Tagged (a :: Type)
+ test/Test/Fixtures/oracle/EmptyDataDeriving/basic.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE EmptyDataDeriving #-}+module Basic where++data Empty+  deriving Show
+ test/Test/Fixtures/oracle/EmptyDataDeriving/gadt.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE EmptyDataDeriving #-}+module GADT where++data Empty where+  deriving Show
+ test/Test/Fixtures/oracle/EmptyDataDeriving/multiple.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE EmptyDataDeriving #-}+module Multiple where++data Empty+  deriving (Eq, Ord, Show)
+ test/Test/Fixtures/oracle/ExistentialQuantification/existential-infix-constructor.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExistentialQuantification #-}++module ExistentialInfixConstructor where++data PairBox = forall a b. (Show a, Show b) => a :&: b++pairRender :: PairBox -> String+pairRender (x :&: y) = show x ++ show y
+ test/Test/Fixtures/oracle/ExistentialQuantification/existential-infix-parenthesized-context.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExistentialQuantification #-}++module ExistentialInfixParenthesizedContext where++data A = forall yk. ((BgpBGa whd1 UdHfta), (F)) => a `A` A++useA :: A -> String+useA _ = "ok"
+ test/Test/Fixtures/oracle/ExistentialQuantification/existential-multi-constructor.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExistentialQuantification #-}++module ExistentialMultiConstructor where++data Some = forall a. Some a | forall b. Eq b => EqSome b b++isEqual :: Some -> Bool+isEqual (Some _) = False+isEqual (EqSome x y) = x == y
+ test/Test/Fixtures/oracle/ExistentialQuantification/existential-prefix-context.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExistentialQuantification #-}++module ExistentialPrefixContext where++data Box = forall a. Show a => Box a++render :: Box -> String+render (Box x) = show x
+ test/Test/Fixtures/oracle/ExistentialQuantification/existential-prefix-nested-parenthesized-context.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExistentialQuantification #-}++module ExistentialPrefixNestedParenthesizedContext where++data A = forall a. ((Show a)) => A a+data B = forall a. ((((Show a)))) => B a
+ test/Test/Fixtures/oracle/ExistentialQuantification/existential-record-context.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExistentialQuantification #-}++module ExistentialRecordContext where++data Packed = forall a. Eq a => Packed {leftValue :: a, rightValue :: a}++same :: Packed -> Bool+same (Packed x y) = x == y
+ test/Test/Fixtures/oracle/ExplicitForAll/forall-class-method.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitForAll #-}++module ExplicitForAllClassMethod where++class Poly f where+  poly :: forall a. f a -> f a
+ test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-head.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ScopedTypeVariables #-}++module ForallInstanceHead where++class C a++instance forall a. C a where
+ test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-kind-signature.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures #-}++module ForallInstanceWithKindSignature where++class C a++instance forall (a :: *). C a where
+ test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-multiple-binders.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures #-}++module ForallInstanceMultipleBinders where++class C a b++instance forall a b. C a b where
+ test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-overlap.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}++module ForallInstanceWithOverlap where++class C a++instance {-# OVERLAPPING #-} forall a. C [a] where
+ test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-with-context.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}++module ForallInstanceWithContext where++class C a++instance forall a. Show a => C a where
+ test/Test/Fixtures/oracle/ExplicitForAll/forall-kinded-inferred-binder.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE KindSignatures #-}++module ForallKindedInferredBinder where++import Data.Kind (Type)++f :: forall {a :: Type}. a -> a+f x = x
+ test/Test/Fixtures/oracle/ExplicitForAll/forall-local-signature.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitForAll #-}++module ExplicitForAllLocalSignature where++outer :: Int -> Int+outer n =+  let local :: forall a. a -> a+      local x = x+   in local n
+ test/Test/Fixtures/oracle/ExplicitForAll/forall-multiline-nested-constraint.hs view
@@ -0,0 +1,21 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE TypeFamilies #-}++module ForallMultilineNestedConstraint where++import Data.Kind (Constraint, Type)++class Compat a where+  type CompatConstraint a :: Type -> Constraint+  type CompatF a :: Type -> Type++getCompatible+    :: forall a.+       ( Compat a+       , (CompatConstraint a) a+       )+    => (forall c. (Compat c, (CompatConstraint a) c) => (CompatF a) c)+    -> (CompatF a) a+getCompatible = undefined
+ test/Test/Fixtures/oracle/ExplicitForAll/forall-nested-arrow.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitForAll #-}++module ExplicitForAllNestedArrow where++apply :: (forall a. a -> a) -> Int+apply f = f 3
+ test/Test/Fixtures/oracle/ExplicitForAll/forall-no-space-after-dot.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010, ExplicitForAll, RankNTypes #-}+module ForallNoSpaceAfterDot where++data ExactPi = Approximate (forall a.Floating a => a)
+ test/Test/Fixtures/oracle/ExplicitForAll/forall-top-level.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitForAll #-}++module ExplicitForAllTopLevel where++identity :: forall a. a -> a+identity x = x
+ test/Test/Fixtures/oracle/ExplicitForAll/forall-with-context.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitForAll #-}++module ExplicitForAllWithContext where++render :: forall a. Show a => a -> String+render = show
+ test/Test/Fixtures/oracle/ExplicitForAll/instance-forall.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+module ExplicitForAllInstance where++class C a where+  c :: a -> ()++instance forall a. C [a] where+  c _ = ()
+ test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-basic-modifiers.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitLevelImports #-}++module ExplicitLevelBasicModifiers where++import quote Data.List+import splice Data.Maybe++useMaybe :: a -> Maybe a+useMaybe = Just
+ test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-with-as.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitLevelImports #-}++module ExplicitLevelWithAs where++import quote Data.List as L+import splice Data.Maybe as M++useAliases :: [a] -> a -> a+useAliases xs fallback = M.fromMaybe fallback (L.listToMaybe xs)
+ test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-with-hiding.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitLevelImports #-}++module ExplicitLevelWithHiding where++import quote Prelude hiding (map)+import splice Data.List hiding (foldl)++useFilter :: (a -> Bool) -> [a] -> [a]+useFilter = filter
+ test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-with-import-list.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitLevelImports #-}++module ExplicitLevelWithImportList where++import quote Data.List (map)+import splice Data.Maybe (fromMaybe)++useMap :: [Int] -> [Int]+useMap = map
+ test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-export-type-data-wildcards.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}++module ExplicitNamespacesExportTypeDataWildcards+  ( type Token,+    -- GHC 9.16 adds namespace wildcards in import/export items.+    -- Enable this when the oracle switches to GHC 9.16:+    -- type ..,+    -- data ..,+  ) where++data Token = Token
+ test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-export-type-wildcard-with-value.hs view
@@ -0,0 +1,15 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}++module ExplicitNamespacesExportTypeWildcardWithValue+  ( type Proxy,+    f,+    -- GHC 9.16 adds namespace wildcards in import/export items.+    -- Enable this when the oracle switches to GHC 9.16:+    -- type ..,+  ) where++import Data.Proxy (Proxy)++f :: Proxy Int+f = Proxy
+ test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-export-type.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}++module ExplicitNamespacesExportType (type Token(..), makeToken) where++data Token = Token++makeToken :: Token+makeToken = Token
+ test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-fixity-data-operator.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE TypeOperators #-}++module ExplicitNamespacesFixityDataOperator where++-- GHC 9.10 accepts this syntax for data operators with explicit namespace.+infixr 0 data $++data a $ b = Dollar a b
+ test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-fixity-edge-cases.hs view
@@ -0,0 +1,26 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE TypeOperators #-}++module ExplicitNamespacesFixityEdgeCases where++-- Test fixity with type namespace and precedence+infixl 7 type ***++-- Test fixity with data namespace and no precedence+infix data :+:++-- Test fixity with type namespace and precedence 0+infixr 0 type ==>++-- Test regular fixity without namespace (should still work)+infix 5 +++++-- Test multiple operators with data namespace+infixl 3 data @@+++type a *** b = (a, b)+type a ==> b = Either a b++data a :+: b = Left a | Right b+data a @@+ b = Plus a b
+ test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-fixity-type-operator.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE TypeOperators #-}++module ExplicitNamespacesFixityTypeOperator where++-- GHC 9.10 accepts this syntax for type operators with explicit namespace.+infixl 9 type $++type a $ b = Either a b
+ test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-data-wildcard.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}++module ExplicitNamespacesImportDataWildcard where++-- GHC 9.16 adds namespace wildcards in import/export items.+-- Enable this when the oracle switches to GHC 9.16:+-- import M (data ..)++x :: ()+x = ()
+ test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-list.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}++module ExplicitNamespacesImportList where++import Data.Kind (type Type)
+ test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-type-data-wildcards.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}++module ExplicitNamespacesImportTypeDataWildcards where++-- GHC 9.16 adds namespace wildcards in import/export items.+-- Enable this when the oracle switches to GHC 9.16:+-- import M (type .., data ..)++import Data.Proxy (type Proxy (..))++mkProxy :: Proxy Int+mkProxy = Proxy
+ test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-type-wildcard.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}++module ExplicitNamespacesImportTypeWildcard where++-- GHC 9.16 adds namespace wildcards in import/export items.+-- Enable this when the oracle switches to GHC 9.16:+-- import Data.Proxy (type ..)++import Data.Proxy (type Proxy (..))++mkProxy :: Proxy Int+mkProxy = Proxy
+ test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-type.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}++module ExplicitNamespacesImportType where++import Data.Proxy (type Proxy (..))++mkProxy :: Proxy Int+mkProxy = Proxy
+ test/Test/Fixtures/oracle/ExplicitNamespaces/export-qualified-operator.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++module ExportQualifiedOperator (+    (M..&.)+) where++import qualified Data.Bits as M
+ test/Test/Fixtures/oracle/ExportSyntax/export-spec-all.hs view
@@ -0,0 +1,19 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}++module Export (+  varId, ConId, (+), (:+),+  Qual.varId, Qual.ConId, (Qual.+), (Qual.:+),+  Qual.ConId(..), (Qual.:+)(..),+  ConId(UnQual, unqual, (:+) ), Qual.ConId(UnQual, unqual, (:+) ), (:+)(UnQual, unqual, (:+))+) where++varId :: Int+varId = 1++data ConId = UnQual | Other++data a :+ b = a :+: b++unqual :: Int+unqual = 2
+ test/Test/Fixtures/oracle/ExportSyntax/qualified-constructor-export.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++module QualifiedConstructorExport (+  M.C(M.A1, M.A2)+  ) where++import M+
+ test/Test/Fixtures/oracle/ExportSyntax/qualified-export-mixed.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}++module QualifiedExportEdgeCases (+  M.T(M.X, M.Y),+  N.C(..)+  ) where++import M+import N+
+ test/Test/Fixtures/oracle/Exports/export-empty-bundled-type.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}++module ExportsEmptyBundledType (Text()) where++data Text = Text
+ test/Test/Fixtures/oracle/ExtendedLiterals/custom-operator-hash.hs view
@@ -0,0 +1,20 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ExtendedLiterals #-}++f64_predecessorIEEE#+  :: Double#+  -> Double#+f64_predecessorIEEE#+  value+  = symetric_result+  where+    symetric_result+      = negateDouble#+      $# f64_successorIEEE#+      $# negateDouble#+      $# value++    infixr 0 $#+    ($#) :: (Double# -> Double#) -> Double# -> Double#+    f $# x = f x
+ test/Test/Fixtures/oracle/ExtendedLiterals/signed.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExtendedLiterals #-}+{-# LANGUAGE MagicHash #-}+module Signed where++x = 123#Int8+y = 123#Int16+z = 123#Int32+w = 123#Int64
+ test/Test/Fixtures/oracle/ExtendedLiterals/unsigned.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExtendedLiterals #-}+{-# LANGUAGE MagicHash #-}+module Unsigned where++x = 123#Word8+y = 123#Word16+z = 123#Word32+w = 123#Word64
+ test/Test/Fixtures/oracle/FlexibleInstances/flexible-instance-empty-no-where.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FlexibleInstances #-}++module FlexibleInstanceEmptyNoWhere where++class Unconstrained1 a++instance Unconstrained1 a
+ test/Test/Fixtures/oracle/FlexibleInstances/flexible-instance-empty-where.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FlexibleInstances #-}++module FlexibleInstanceEmptyWhere where++class Unconstrained2 a++instance Unconstrained2 a where
+ test/Test/Fixtures/oracle/FlexibleInstances/flexible-instance-with-braces.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FlexibleInstances #-}+instance Validity Scientific where {}
+ test/Test/Fixtures/oracle/FlexibleInstances/instance-unit.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE KindSignatures, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+module InstanceUnit where++class Unit x++instance Unit a
+ test/Test/Fixtures/oracle/FlexibleInstances/parenthesized-empty-list-instance.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FlexibleInstances #-}+module ParenthesizedEmptyListInstance where++class C a++instance C ([])
+ test/Test/Fixtures/oracle/ForeignFunctionInterface/capi-interruptible-header-symbol.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE InterruptibleFFI #-}++module X where++import Foreign.C.Types (CInt (..))++foreign import capi interruptible "termbox.h tb_peek_event"+  tb_peek_event :: IO CInt
+ test/Test/Fixtures/oracle/ForeignFunctionInterface/ctype-data-two-strings.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE CApiFFI #-}++module CtypeDataTwoStrings where++data {-# CTYPE "termbox.h" "struct tb_cell" #-} Tb_cell = Tb_cell
+ test/Test/Fixtures/oracle/ForeignFunctionInterface/ctype-newtype.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE CApiFFI #-}++module CtypeNewtype where++import Foreign.C.Types (CInt (..))++newtype {-# CTYPE "signed int" #-} Fixed = Fixed CInt
+ test/Test/Fixtures/oracle/ForeignFunctionInterface/export.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module Export where++f :: Int -> Int+f x = x++foreign export ccall "f" f :: Int -> Int
+ test/Test/Fixtures/oracle/ForeignFunctionInterface/import.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module Import where++foreign import ccall "f" f :: Int -> Int
+ test/Test/Fixtures/oracle/ForeignFunctionInterface/safety.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module Safety where++foreign import ccall safe "f" f_safe :: Int -> Int+foreign import ccall unsafe "g" f_unsafe :: Int -> Int
+ test/Test/Fixtures/oracle/ForeignFunctionInterface/stdcall.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module StdCall where++foreign import stdcall "f" f :: Int -> Int
+ test/Test/Fixtures/oracle/FunctionalDependencies/fundep-bidirectional.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module FunctionalDependenciesBidirectional where++class Iso a b | a -> b, b -> a where+  to :: a -> b+  from :: b -> a
+ test/Test/Fixtures/oracle/FunctionalDependencies/fundep-class-instance.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module FunctionalDependenciesClassInstance where++class Convert a b | a -> b where+  convert :: a -> b++instance Convert Int Integer where+  convert = toInteger
+ test/Test/Fixtures/oracle/FunctionalDependencies/fundep-empty-left.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module FunctionalDependenciesEmptyLeft where++class KeepRight a b | -> b where+  keepRight :: a -> b
+ test/Test/Fixtures/oracle/FunctionalDependencies/fundep-empty-right.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module FunctionalDependenciesEmptyRight where++class KeepLeft a b | a -> where+  keepLeft :: a -> b -> a
+ test/Test/Fixtures/oracle/FunctionalDependencies/fundep-multi-left.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module FunctionalDependenciesMultiLeft where++class Merge a b c | a b -> c where+  merge :: a -> b -> c
+ test/Test/Fixtures/oracle/FunctionalDependencies/fundep-single.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module FunctionalDependenciesSingle where++class Collects e c | c -> e where+  insert :: e -> c -> c
+ test/Test/Fixtures/oracle/FunctionalDependencies/fundep-with-context.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module FunctionalDependenciesWithContext where++class Show a => Pretty a b | a -> b where+  pretty :: a -> b
+ test/Test/Fixtures/oracle/GADTSyntax/gadt-context.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTSyntax #-}++module GadtContext where++data Set a where+  MkSet :: Eq a => [a] -> Set a++data NumInst a where+  MkNumInst :: Num a => NumInst a
+ test/Test/Fixtures/oracle/GADTSyntax/gadt-deriving.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTSyntax #-}++module GadtDeriving where++data Maybe1 a where {+    Nothing1 :: Maybe1 a ;+    Just1    :: a -> Maybe1 a+  } deriving (Eq, Ord)++data Maybe2 a = Nothing2 | Just2 a+     deriving (Eq, Ord)
+ test/Test/Fixtures/oracle/GADTSyntax/gadt-existential.hs view
@@ -0,0 +1,17 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE ExistentialQuantification #-}++module GadtExistential where++-- Existential with traditional syntax+data Foo = forall a. MkFoo a (a -> Bool)++-- Same thing with GADT syntax+data Foo' where+  MkFoo' :: a -> (a -> Bool) -> Foo'++-- Multiple constructors including nullary+data Bar where+   MkBar :: a -> (a -> Bool) -> Bar+   Nil   :: Bar
+ test/Test/Fixtures/oracle/GADTSyntax/gadt-infix.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTSyntax #-}++module GadtInfix where++infix 6 :--:+data T a where+  (:--:) :: Int -> Bool -> T Int
+ test/Test/Fixtures/oracle/GADTSyntax/gadt-maybe.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTSyntax #-}++module GadtMaybe where++data Maybe a where+    Nothing :: Maybe a+    Just    :: a -> Maybe a
+ test/Test/Fixtures/oracle/GADTSyntax/gadt-multi-con.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTSyntax #-}++module GadtMultiCon where++data T a where+  T1, T2 :: a -> T a+  T3 :: T a
+ test/Test/Fixtures/oracle/GADTSyntax/gadt-newtype.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTSyntax #-}++module GadtNewtype where++newtype Down a where+  Down :: a -> Down a
+ test/Test/Fixtures/oracle/GADTSyntax/gadt-record.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTSyntax #-}++module GadtRecord where++data Person where+    Adult :: { name :: String, children :: [Person] } -> Person+    Child :: Show a => { name :: !String, funny :: a } -> Person
+ test/Test/Fixtures/oracle/GADTSyntax/gadt-strict.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTSyntax #-}++module GadtStrict where++data Term a where+    Lit    :: !Int -> Term Int+    If     :: Term Bool -> !(Term a) -> !(Term a) -> Term a+    Pair   :: Term a -> Term b -> Term (a, b)
+ test/Test/Fixtures/oracle/GADTs/constructor-kind-binder.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+module GadtConstructorKindBinder where++data T where+  C :: (x :: *) -> T
+ test/Test/Fixtures/oracle/GADTs/gadt-promoted-cons-in-type.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NoListTuplePuns #-}+{-# LANGUAGE TypeFamilies #-}++module UnionPromotedCons where++import Data.List (List)++data Union f (as :: List u) where+  This :: f a -> Union f (a : as)+  That :: Union f as -> Union f (a : as)
+ test/Test/Fixtures/oracle/GADTs/gadts-basic.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTs #-}++module GADTsBasic where++data Term a where+  TInt :: Int -> Term Int+  TBool :: Bool -> Term Bool
+ test/Test/Fixtures/oracle/GADTs/gadts-pattern-match.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTs #-}++module GADTSPatternMatch where++data Expr a where+  EInt :: Int -> Expr Int+  EAdd :: Expr Int -> Expr Int -> Expr Int++eval :: Expr Int -> Int+eval e = case e of+  EInt n -> n+  EAdd l r -> eval l + eval r
+ test/Test/Fixtures/oracle/GADTs/gadts-record.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTs #-}++module GADTsRecord where++data Box a where+  MkIntBox :: {unIntBox :: Int} -> Box Int+  MkBoolBox :: {unBoolBox :: Bool} -> Box Bool
+ test/Test/Fixtures/oracle/GHCPrimSpecific/foreign-import-prim.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+module ForeignImportPrim where++import GHC.Exts (Addr#, State#, RealWorld)++foreign import prim "stg_myPrimOp" myPrimOp# :: Addr# -> State# RealWorld -> (# State# RealWorld, Int# #)
+ test/Test/Fixtures/oracle/GHCPrimSpecific/list-constructor.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ListConstructor where++data List a = [] | a : List a
+ test/Test/Fixtures/oracle/GHCPrimSpecific/negative-fixity.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NegativeLiterals #-}+module NegativeFixity where++infixr -1 ->
+ test/Test/Fixtures/oracle/GHCPrimSpecific/reserved-op-fixity.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module ReservedOpFixity where++infixr 5 :+infix 4 ~
+ test/Test/Fixtures/oracle/GHCPrimSpecific/tuple-constructor.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module TupleConstructor where++data Unit = ()++data Tuple2 a b = (a, b)++data Tuple3 a b c = (a, b, c)
+ test/Test/Fixtures/oracle/GHCPrimSpecific/unboxed-sum-constructor.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedSums #-}+module UnboxedSumConstructor where++data Sum2# a b+  = (# a | #)+  | (# | b #)++data Sum3# a b c+  = (# a | | #)+  | (# | b | #)+  | (# | | c #)
+ test/Test/Fixtures/oracle/GHCPrimSpecific/unboxed-tuple-constructor.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+module UnboxedTupleConstructor where++data Unit# = (# #)++data Tuple2# a b = (# a, b #)++data Tuple3# a b c = (# a, b, c #)
+ test/Test/Fixtures/oracle/Hackage/aftovolio-bang-pattern-on-constructor.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BangPatterns #-}+module A where+f x = case x of+  !EQ -> True+  _ -> False
+ test/Test/Fixtures/oracle/Hackage/aftovolio-negation-operator-precedence.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module A where+f l = (-l - 1)
+ test/Test/Fixtures/oracle/Hackage/aftovolio-negative-literal-spacing.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module A where+f x = x == - 1
+ test/Test/Fixtures/oracle/Hackage/agda-where-guarded-type-sig-xfail.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module AgdaWhereGuardedTypeSig where++f x = y+  where+    y :: Int+      | x > 0     = 1+      | otherwise = 0
+ test/Test/Fixtures/oracle/Hackage/alex-conapp-pattern-in-cons.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module A where+data T = C Int+f (C x : xs) = x
+ test/Test/Fixtures/oracle/Hackage/alsa-core-empty-instance-where-layout.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+module Sound.ALSA.Exception where++class Exception a++data T = T++instance Exception T where++checkResult :: Integral a => String -> a -> IO a+checkResult = undefined
+ test/Test/Fixtures/oracle/Hackage/barbies-parenthesized-infix-operator-instance.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}+module BarbiesParenthesizedInfixOperatorInstance where++instance (c & d) a
+ test/Test/Fixtures/oracle/Hackage/bnfc-meta-nested-prefix-cons-pattern-pass.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module A where++f ((:) ((:) a b) c) = a
+ test/Test/Fixtures/oracle/Hackage/bnfc-meta-prefix-cons-pattern-pass.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module A where++f xs = case xs of+  (:) x ys -> x+  [] -> error "empty"
+ test/Test/Fixtures/oracle/Hackage/cabal-dollar-do-let-in.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+module CabalDollarDoLetIn where++f neededLibWays =+  run+    $ do+      let+          neededLibWaysSet = fromList neededLibWays+          useDynamicToo = static `member` neededLibWaysSet && dynamic `member` neededLibWaysSet+          orderedBuilds+            | useDynamicToo = [buildStaticAndDynamicToo]+            | otherwise = build <$> neededLibWays+          buildStaticAndDynamicToo = run dynamic+       in sequence_ orderedBuilds
+ test/Test/Fixtures/oracle/Hackage/citeproc-newtype-parens.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module CiteprocNewtypeParens where++newtype (ReferenceMap a) = ReferenceMap { unReferenceMap :: [(a)] }+  deriving (Show)
+ test/Test/Fixtures/oracle/Hackage/configurator-export-case-alt-dollar-plus.hs view
@@ -0,0 +1,20 @@+{- ORACLE_TEST pass -}++module M where++import Data.List.NonEmpty (NonEmpty (..), toList)+import Text.PrettyPrint (Doc, ($+$), (<+>))+import qualified Text.PrettyPrint as P++keysToDoc :: NonEmpty (String, Either Int String) -> Doc+keysToDoc l@((_, Right _) :| _) =+  P.vcat . addSep 0 $+    [groupToDoc n g | (n, Right g) <- toList l]+  where+    addSep _ = id+    groupToDoc k g =+      case True of+        True -> P.text k <+> P.lbrace+        False -> P.text k $+$ P.lbrace+        $+$ P.nest 4 (P.text g)+        $+$ P.rbrace
+ test/Test/Fixtures/oracle/Hackage/csp-let-lhs-infix-roundtrip.hs view
@@ -0,0 +1,15 @@+{- ORACLE_TEST pass -}+module CspLetLhsInfixRoundtrip where++f dvcs' =+  unsafePerformIO $+    runAmb $ do+      dvcs <- lift $ readIORef dvcs'+      let+        loop [] = return ()+        loop (d : ds) =+          do+            dvcABinding d+            filterM (liftM not . dvcIsBound) ds >>= loop+       in filterM (liftM not . dvcIsBound) dvcs >>= loop+      lift $ result dvcs
+ test/Test/Fixtures/oracle/Hackage/diagrams-contrib-hash-line-directive.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module A where+r = x+  # line
+ test/Test/Fixtures/oracle/Hackage/diagrams-contrib-negation-precedence.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module A where+f = - 1 / 2
+ test/Test/Fixtures/oracle/Hackage/dns-transform-list-comp.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}+module A where+import GHC.Exts (the, groupWith)+f ts = [ (the x, y) | t <- ts, let x = t, let y = t, then group by x using groupWith ]
+ test/Test/Fixtures/oracle/Hackage/enumset-sizeof.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module EnumsetTakeWhileSizeOf where++f x = takeWhile (< sizeOf x * 8)
+ test/Test/Fixtures/oracle/Hackage/force-layout-parenthesized-lens-op-arg.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ForceLayoutParenthesizedLensArg where++stepPos p = pos %~ (.+^ p ^. vel) $ p
+ test/Test/Fixtures/oracle/Hackage/friendly-time-append-seconds-lambda.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module FriendlyTimeAppendSecondsLambda where++secondsAgo = \f -> (++ " seconds" ++ dir f)
+ test/Test/Fixtures/oracle/Hackage/functor-products-associated-injective-type-family.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-}++module M where++import Data.Kind (Type)++class FProd (f :: Type -> Type) where+  type Elem f = (i :: f k -> k -> Type) | i -> f
+ test/Test/Fixtures/oracle/Hackage/generic-lens-core-paren-infix-type-family.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module GenericLensCoreParenInfixTypeFamily where++type family (a ++ b)
+ test/Test/Fixtures/oracle/Hackage/generic-lens-core-promoted-error-message-list-cons.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+module M where++type M1 = '[ 'Text "alpha" ':<>: 'Text "beta", 'Text "gamma" ]
+ test/Test/Fixtures/oracle/Hackage/generic-lens-core-promoted-error-message-list-singleton.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+module M where++type M1 = '[ 'Text "alpha" ':<>: 'Text "beta" ]
+ test/Test/Fixtures/oracle/Hackage/generick-associated-type-default-signatures-xfail.hs view
@@ -0,0 +1,23 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module GenericKAssociatedTypeDefaultSignaturesXFail where++class GenericK (f :: k) where+  type family RepK f :: LoT k -> Type++  fromK :: f :@@: x -> RepK f x+  default+    fromK :: (Generic (f :@@: x), Conv (Rep (f :@@: x)) (RepK f) x)+          => f :@@: x -> RepK f x+  fromK = toKindGenerics . from++  toK :: RepK f x -> f :@@: x+  default+    toK :: (Generic (f :@@: x), Conv (Rep (f :@@: x)) (RepK f) x)+        => RepK f x -> f :@@: x+  toK = to . toGhcGenerics
+ test/Test/Fixtures/oracle/Hackage/ghc-events-concat-if-chain-roundtrip-xfail.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module GhcEventsConcatIfChainRoundtripXfail where++f a b c d e =+  "cost centre " <> a+  <> " " <> b+  <> " in " <> c+  <> " at " <> d+  <> if e then " CAF" else ""
+ test/Test/Fixtures/oracle/Hackage/ghc-events-record-pattern-roundtrip-xfail.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module GhcEventsRecordPatternRoundtripXfail where+data Event = Event { ref :: Int }+f (Event {ref = ref}) = ref
+ test/Test/Fixtures/oracle/Hackage/ghc-exactprint-parenthesised-class-head.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module A where++class (Monad m) => (HasTransform m) where+  liftT :: Int -> m Int
+ test/Test/Fixtures/oracle/Hackage/ghc-hs-meta-record-field-view-pattern.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ViewPatterns #-}++module M where++data Box = Box {field :: Int}++f (Box {field = id -> x}) = x
+ test/Test/Fixtures/oracle/Hackage/graphviz-percent-section.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module A where++f = (%1)
+ test/Test/Fixtures/oracle/Hackage/happy-lib-negative-magic-hash-expression.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}+module A where++import GHC.Exts++-- Negative MagicHash literal in expression context.+-- GHC treats -42# as a single literal token, not negation applied to 42#.+x :: Int#+x = -42#
+ test/Test/Fixtures/oracle/Hackage/happy-lib-negative-magic-hash-multiple-patterns.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}+module A where++import GHC.Exts++-- Multiple negative MagicHash patterns in function equations.+f :: Int# -> Int+f  0#   = 0+f -1#   = 1+f -100# = 2+f  _    = 3
+ test/Test/Fixtures/oracle/Hackage/happy-lib-negative-magic-hash-pattern.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}+module A where++import GHC.Exts++f :: Int# -> Int+f  0# = 0+f -1# = 1+f  _  = 2
+ test/Test/Fixtures/oracle/Hackage/happy-meta-scc-pragma-expr.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module HappyMetaSccPragmaExpr where+f x = {-# SCC "label" #-} x
+ test/Test/Fixtures/oracle/Hackage/hmatrix-scc-pragma-xfail.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module A where+f x = {-# SCC "name" #-} x
+ test/Test/Fixtures/oracle/Hackage/hmatrix-unicode-operator.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}+module A where+(——) = undefined
+ test/Test/Fixtures/oracle/Hackage/hpdf-typed-pattern-let-in-do.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+module HpdfTypedPatternLetInDo where++f xs = do+  let [a, b] :: [Double] = xs+      total = a + b+   in pure total
+ test/Test/Fixtures/oracle/Hackage/ihaskell-type-annotation-in-do-case-if-xfail.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module IHaskellTypeAnnotationInDoCaseIf where++f flag y = do+  case y of+    Right b ->+      if flag+        then b :: [Int]+        else b
+ test/Test/Fixtures/oracle/Hackage/import-type-empty-constructors-xfail.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ImportTypeEmptyConstructorsXFail where++import Data.Text (Text(), unpack)
+ test/Test/Fixtures/oracle/Hackage/indents-expected-message.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module IndentsExpectedMessage where++f ref pos =+  (<?> prettyIndentation ref ++ " (started at line " ++ prettyLine ref ++ ")")+    (unexpected pos)
+ test/Test/Fixtures/oracle/Hackage/indexed-profunctors-hash-dot-export.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE OverloadedLabels #-}++module IndexedProfunctorsHashDotExport+  ( (#.),+  )+where++(#.) x y = x
+ test/Test/Fixtures/oracle/Hackage/json-spec-elm-lambda-cases.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module M where++f = \cases+  True False -> 0+  _ _ -> 1
+ test/Test/Fixtures/oracle/Hackage/kind-apply-spine-lot.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}++module M where++data LoT k++data a :&&: b++type family SpineLoT (tys :: LoT k) = (tys' :: LoT k) | tys' -> tys where+  SpineLoT (a ':&&: as) = a ':&&: SpineLoT as+  SpineLoT 'LoT0 = 'LoT0
+ test/Test/Fixtures/oracle/Hackage/liquid-fixpoint-do-comment-layout.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module A where++f = do {- a -} x+       {- b -} y
+ test/Test/Fixtures/oracle/Hackage/liquid-fixpoint-do-multiline-comment-layout.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module A where++fn = do   {-+       -} hello+          world
+ test/Test/Fixtures/oracle/Hackage/manifolds-core-unicode-subscript-identifier.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}++module M where++f p₀ = p₀
+ test/Test/Fixtures/oracle/Hackage/manifolds-core-unicode-superscript-identifier.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}++module M where++data S⁰_ r = PositiveHalfSphere
+ test/Test/Fixtures/oracle/Hackage/memotrie-associated-data-family-operator.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module MemoTrieAssociatedDataFamilyOperator where++class C a where+  data (:*:) a :: * -> *
+ test/Test/Fixtures/oracle/Hackage/mixed-types-num-type-sig-in-if-then-branch.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module A where+f = if True then x :: Int else x
+ test/Test/Fixtures/oracle/Hackage/mptc-parenthesized-two-args-trailing.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiParamTypeClasses #-}+module A where+class C a b c+instance (C Int Bool) Char where
+ test/Test/Fixtures/oracle/Hackage/named-text-kind-annotated-type-synonym.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}++module M where++import GHC.TypeLits (Symbol)++type NameStyle = Symbol++type UTF8 = "UTF8" :: NameStyle
+ test/Test/Fixtures/oracle/Hackage/nonempty-containers-pattern-synonym-where-infix.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}+module A where++data T a = a :<| a++pattern x :> y <- x :<| y+  where+    (a :<| b) :> c = a :<| (b :<| c)
+ test/Test/Fixtures/oracle/Hackage/nonempty-containers-qualified-instance.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module A where+import qualified Data.Aeson as A+instance A.ToJSON a => A.ToJSON [a] where+  toJSON = undefined
+ test/Test/Fixtures/oracle/Hackage/nonempty-containers-where-indent.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+module A where+f k m0+  = case compare k 0 of+      GT+        -> Just+             $ case (g m1, g m2) of+                 (Nothing, Nothing) -> x+                 (Just _, Just n2) -> y+      where+          (m1, m2) = split k m0
+ test/Test/Fixtures/oracle/Hackage/oops-injective-type-family.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilyDependencies #-}++module M where++import Data.Kind (Constraint)++type family All (cs :: [Constraint]) = (c :: Constraint) | c -> cs where+  All '[] = ()
+ test/Test/Fixtures/oracle/Hackage/pandoc-arrow-case-pattern-guard-xfail.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE PatternGuards #-}+module PandocArrowCasePatternGuard where++import Control.Arrow++f = proc x -> do+  case x of+    Right y | p y -> returnA -< y+    Left _ -> returnA -< 0
+ test/Test/Fixtures/oracle/Hackage/pantry-local-signature-let-in-do.hs view
@@ -0,0 +1,18 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+module PantryLocalSignatureLetInDo where++f x = do+  let+      err = Left x++      test :: Eq a => Maybe a -> a -> Bool+      test (Just y) z = y == z+      test Nothing _ = True++      tests =+        [ test (Just x) x+        , test Nothing x+        ]++   in if and tests then Right x else err
+ test/Test/Fixtures/oracle/Hackage/parenthesized-prefix-no-trailing.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module A where+class C a+instance (C Int) where
+ test/Test/Fixtures/oracle/Hackage/pqueue-infix-pattern-synonym-where-clause.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}+module A where+pattern (:<) :: (a, b) -> [(a, b)] -> [(a, b)]+pattern x :< xs <- (x : xs)+  where+    (a, b) :< xs = (a, b) : xs
+ test/Test/Fixtures/oracle/Hackage/ratio-int-parenthesized-compare.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module RatioIntParenthesizedCompare where++enumFromTo n m = takeWhile (<= m + 1 / 2) (enumFrom n)
+ test/Test/Fixtures/oracle/Hackage/resourcet-export-pattern-synonym-after-dotdot.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module M (T (.., P)) where++data T = A++pattern P :: T+pattern P = A
+ test/Test/Fixtures/oracle/Hackage/roundingfiasco-word64-binary-literal-case-alt.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE ExtendedLiterals #-}+{-# LANGUAGE MagicHash #-}++module M where++f x = case x of+  0b0#Word64 -> 0#
+ test/Test/Fixtures/oracle/Hackage/row-types-nbsp-layout.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module RowTypesNbspLayout where++type family F a where+  F a = a+  F b = b
+ test/Test/Fixtures/oracle/Hackage/sbv-function-head-at-operator.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+f e (@) = do+  undefined+
+ test/Test/Fixtures/oracle/Hackage/sbv-function-head-type-sig.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+f (fn :: Int -> Int) = fn+
+ test/Test/Fixtures/oracle/Hackage/sbv-gadt-record-at-field.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module S where++data family C++data instance C where+  (:+) :: {(@) :: Int} -> C
+ test/Test/Fixtures/oracle/Hackage/sbv-promoted-string-type-app-pattern-xfail.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeAbstractions #-}+{-# LANGUAGE DataKinds #-}+module SbvPromotedStringTypeAppPattern where++import GHC.TypeLits++data Forall (a :: Symbol) = Forall Int++f (Forall @"xs" x) = x
+ test/Test/Fixtures/oracle/Hackage/sbv-template-splice-instance-head.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module S where++class C a++instance C $(pure Int)
+ test/Test/Fixtures/oracle/Hackage/sbv-typed-infix-app-roundtrip.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+f = (fromBytes :: Int -> Int) 1 # other 2+
+ test/Test/Fixtures/oracle/Hackage/sbv-unicode-varid-method.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module S where++class C α where+  ﬧ :: α -> α+
+ test/Test/Fixtures/oracle/Hackage/shake-pattern-guard-type-signature.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+module ShakePatternGuardTypeSignature where++f e =+  case () of+    _+      | Nothing <- fromException e :: Maybe ShakeException+      , Just x <- fromException e ->+          x+    _ -> e
+ test/Test/Fixtures/oracle/Hackage/slack-web-type-annotation-in-if-then-else.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module SlackWebTypeAnnotationInIfThenElse where++f = if x then y :: T else z
+ test/Test/Fixtures/oracle/Hackage/snap-core-mptc-parenthesized-instance-head.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiParamTypeClasses #-}+module A where+class C a b+instance (C Int) Bool where
+ test/Test/Fixtures/oracle/Hackage/snap-core-scc-pragma-in-binding.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module A where+f = g+  where+    g = {-# SCC "name" #-} undefined
+ test/Test/Fixtures/oracle/Hackage/sop-core-paren-backtick-instance-head.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+module SopCoreParenBacktickInstanceHead where++class (f `C` g) x+instance (f `C` g) x
+ test/Test/Fixtures/oracle/Hackage/splitmix-distributions-negation-parens.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module SplitmixDistributionsNegationParens where++zipfLike a u =+  let xInt = floor (u ** (- 1 / (a - 1)))+   in xInt++weibullLike a b x =+  return $ (- 1 / a * log (1 - x)) ** 1 / b
+ test/Test/Fixtures/oracle/Hackage/srtree-if-arithmetic-sequence-bound.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module SrtreeIfArithmeticSequenceBound where++f maxSize =+  randomFrom [if maxSize > 4 then 4 else 1 .. maxSize]
+ test/Test/Fixtures/oracle/Hackage/standalone-deriving-parenthesized-prefix.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+module A where+class C a b+deriving instance (C Int) Bool
+ test/Test/Fixtures/oracle/Hackage/symbolize-export-double-hash-identifier.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}++module M (f##) where++f## = undefined
+ test/Test/Fixtures/oracle/Hackage/tao-example-promoted-lists-roundtrip.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}++module TaoExamplePromotedListsRoundtrip where++import Data.Proxy (Proxy(Proxy))++type OneToFour = '[1, 2, 3, 4]+type Empty = '[]++unitTests :: Proxy ('[ '[1, 2, 3], '[4] ])+unitTests = Proxy :: Proxy ('[ '[1, 2, 3], '[4] ])
+ test/Test/Fixtures/oracle/Hackage/termbox-bundled-pattern-export.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module M (T (.., P)) where++data T = T++pattern P :: T+pattern P = T
+ test/Test/Fixtures/oracle/Hackage/test-fun-type-operator-context.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}+module TestFunTypeOperatorContextXfail where++data Var = Var++data Expr = Expr++data Ctx = (Var, Expr) :. Ctx
+ test/Test/Fixtures/oracle/Hackage/thyme-lambda-record-wildcard-xfail.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RecordWildCards #-}+module ThymeLambdaRecordWildcard where++f = (\ TimeZone {..} -> undefined, \ TimeZone {..} -> undefined)
+ test/Test/Fixtures/oracle/Hackage/traverse-with-class-th-tuple-name-quote.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module TraverseWithClassTHTupleNameQuote where++f = ''(,)
+ test/Test/Fixtures/oracle/Hackage/type-set-type-instance-dollar-application.hs view
@@ -0,0 +1,17 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module M where++import Data.Kind (Type)++type a >-> b = (b -> Type) -> a -> Type++type family ($) (f :: a >-> b) (x :: a) :: b++data InsertElse t t' ts :: () >-> k++type instance InsertElse t t' ts $ '() = t
+ test/Test/Fixtures/oracle/Hackage/typelevel-tools-yj-infix-instance-context.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}++module M where++class (xs :: [k]) `IsPrefixOf` (ys :: [k])++instance (xs `IsPrefixOf` ys) => (x ': xs) `IsPrefixOf` (x ': ys)
+ test/Test/Fixtures/oracle/Hackage/typelevel-tools-yj-infix-instance-head.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}++module M where++class (xs :: [k]) `IsPrefixOf` (ys :: [k])++instance '[] `IsPrefixOf` ys
+ test/Test/Fixtures/oracle/Hackage/vinyl-type-family-default-compound-rhs.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module VinylTypeFamilyDefaultCompoundRhs where++class C f where+  type T f = f Int
+ test/Test/Fixtures/oracle/Hackage/web3-ethereum-conpat-infix-parens.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module Web3EthereumConpatInfixParens where+f (Just _ : _) = ()
+ test/Test/Fixtures/oracle/Hackage/web3-ethereum-record-wildcard-lambda-parens.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RecordWildCards #-}+module Web3EthereumRecordWildcardLambdaParens where+data T = T {x :: Int}+f = \T{..} -> x
+ test/Test/Fixtures/oracle/HexFloatLiterals/hex-float-literals-basic.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE HexFloatLiterals #-}++module HexFloatLiteralsBasic where++unit :: Double+unit = 0x1p0++shifted :: Double+shifted = 0x1p4
+ test/Test/Fixtures/oracle/HexFloatLiterals/hex-float-literals-fraction.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE HexFloatLiterals #-}++module HexFloatLiteralsFraction where++half :: Double+half = 0x1p-1++fractional :: Double+fractional = 0x1.8p1
+ test/Test/Fixtures/oracle/HexFloatLiterals/hex-float-literals-list.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE HexFloatLiterals #-}++module HexFloatLiteralsList where++constants :: [Double]+constants = [0X1.0p0, 0x1.2p3, -0x1p2, 0xAp-1]
+ test/Test/Fixtures/oracle/ImplicitParams/binding.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ImplicitParams #-}+module Binding where++f = ?x where ?x = 10
+ test/Test/Fixtures/oracle/ImplicitParams/complicated-type.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ImplicitParams #-}+module ComplicatedType where++sort :: (?cmp :: a -> a -> Bool) => [a] -> [a]+sort [] = []+sort (x:xs) = insert x (sort xs)+  where+    insert y [] = [y]+    insert y (z:zs) = if ?cmp y z then y : z : zs else z : insert y zs
+ test/Test/Fixtures/oracle/ImplicitParams/gadts.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+module GADTsImplicitParams where++data T where+  MkT :: (?f :: Int) => T
+ test/Test/Fixtures/oracle/ImplicitParams/infix-operators.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ImplicitParams #-}+module InfixOperators where++f t = let { ?x = t; ?y = ?x + 1 } in ?x + ?y
+ test/Test/Fixtures/oracle/ImplicitParams/keyword-names.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ImplicitParams #-}+module KeywordNames where++f :: (?case :: Int, ?let :: Int, ?where :: Int, ?do :: Int) => Int+f = ?case + ?let + ?where + ?do
+ test/Test/Fixtures/oracle/ImplicitParams/let-bindings.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ImplicitParams #-}+module LetBindings where++f t = let { ?x = t; ?y = ?x + (1::Int) } in ?x + ?y
+ test/Test/Fixtures/oracle/ImplicitParams/standalone-implicit-param.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ImplicitParams #-}++module StandaloneImplicitParam where++-- Implicit parameter in standalone type position (e.g. type synonym body)+f :: (?x :: Int) => (?y :: Bool) => Int -> Int+f = ?x
+ test/Test/Fixtures/oracle/ImplicitParams/type-synonym-implicit-param.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010, ImplicitParams, ConstraintKinds #-}++-- Implicit parameter syntax in type synonyms+type CanCheck = (?checker :: Int)++f :: CanCheck => Int+f = ?checker
+ test/Test/Fixtures/oracle/ImplicitParams/type.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ImplicitParams #-}+module Type where++f :: (?x :: Int) => Int+f = ?x
+ test/Test/Fixtures/oracle/ImportQualifiedPost/import-qualified-post-as.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ImportQualifiedPost #-}++module ImportQualifiedPostAs where++import Data.Map qualified as M++fromPairs :: [(Int, Int)] -> M.Map Int Int+fromPairs = M.fromList
+ test/Test/Fixtures/oracle/ImportQualifiedPost/import-qualified-post-basic.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ImportQualifiedPost #-}++module ImportQualifiedPostBasic where++import Data.List qualified as List++sorted :: [Int] -> [Int]+sorted = List.sort
+ test/Test/Fixtures/oracle/ImportQualifiedPost/import-qualified-post-hiding.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ImportQualifiedPost #-}++module ImportQualifiedPostHiding where++import Prelude qualified as P hiding (mapM)++liftMaybe :: a -> Maybe a+liftMaybe = P.pure
+ test/Test/Fixtures/oracle/InstanceSigs/instance-sig-basic.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE InstanceSigs #-}++module InstanceSigsBasic where++class Render a where+  render :: a -> String++instance Render Int where+  render :: Int -> String+  render = show
+ test/Test/Fixtures/oracle/InstanceSigs/instance-sig-constrained.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE InstanceSigs #-}++module InstanceSigsConstrained where++class Collect a where+  collect :: a -> [String]++instance Show a => Collect [a] where+  collect :: [a] -> [String]+  collect = map show
+ test/Test/Fixtures/oracle/InstanceSigs/instance-sig-default.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE InstanceSigs #-}++module InstanceSigsDefault where++class Pretty a where+  pretty :: a -> String++instance Pretty Bool where+  pretty :: Bool -> String+  pretty True = "true"+  pretty False = "false"
+ test/Test/Fixtures/oracle/InstanceSigs/instance-sig-multi-method.hs view
@@ -0,0 +1,15 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE InstanceSigs #-}++module InstanceSigsMultiMethod where++class Ops a where+  incr :: a -> a+  asString :: a -> String++instance Ops Int where+  incr :: Int -> Int+  incr x = x + 1++  asString :: Int -> String+  asString = show
+ test/Test/Fixtures/oracle/InstanceSigs/instance-sig-where-layout.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE InstanceSigs #-}++module InstanceSigsWhereLayout where++class Measure a where+  measure :: a -> Int++instance Measure [a] where+  measure :: [a] -> Int+  measure xs =+    let go ys = length ys+     in go xs
+ test/Test/Fixtures/oracle/KindSignatures/forall-body-kindsig-forall-subject.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PartialTypeSignatures #-}++module ForallBodyKindSigForallSubject where++type T = forall a. forall a. forall a. _ :: _
+ test/Test/Fixtures/oracle/KindSignatures/kindsig-class-head-star.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StarIsType #-}++module KindSignaturesClassHeadStar where++class Unit (x :: *)
+ test/Test/Fixtures/oracle/KindSignatures/kindsig-class-head.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE KindSignatures #-}++module KindSignaturesClassHead where++import Data.Kind (Type)++class Runs (f :: Type -> Type) where+  runF :: f a -> f a
+ test/Test/Fixtures/oracle/KindSignatures/kindsig-constraint.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE KindSignatures #-}++module KindSignaturesConstraint where++import Data.Kind (Constraint, Type)++class (c :: Type -> Constraint) => UsesConstraint c where+  useConstraint :: c a => a -> a
+ test/Test/Fixtures/oracle/KindSignatures/kindsig-data-param.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE KindSignatures #-}++module KindSignaturesDataParam where++import Data.Kind (Type)++data Proxy (a :: Type) = Proxy
+ test/Test/Fixtures/oracle/KindSignatures/kindsig-higher-kinded.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE KindSignatures #-}++module KindSignaturesHigherKinded where++import Data.Kind (Type)++data App (f :: Type -> Type) (a :: Type) = App (f a)
+ test/Test/Fixtures/oracle/KindSignatures/kindsig-multiple-constraints.hs view
@@ -0,0 +1,18 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE KindSignatures #-}++module KindSignaturesMultipleConstraints where++import Data.Kind (Constraint, Type)++-- Multiple constraints with kind annotations+class (c1 :: Type -> Constraint, c2 :: Type -> Constraint) => MultiConstraint c1 c2 where+  multiMethod :: (c1 a, c2 a) => a -> a++-- Mixed: regular constraint + kind-annotated constraint+class (Show a, c :: Type -> Constraint) => MixedConstraint c a where+  mixedMethod :: c a => a -> String++-- Nested parentheses with kind annotation+class ((c :: Type -> Constraint)) => NestedParens c where+  nestedMethod :: c a => a -> a
+ test/Test/Fixtures/oracle/KindSignatures/kindsig-newtype.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE KindSignatures #-}++module KindSignaturesNewtype where++import Data.Kind (Type)++newtype Wrapped (f :: Type -> Type) a = Wrapped (f a)
+ test/Test/Fixtures/oracle/LambdaCase/do-where-after-module.hs view
@@ -0,0 +1,18 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++module Foreign.C.Struct.Ord where++import Language.Haskell.TH++f xs = do+	cr <- newName "checkResult"+	letE [valD (varP cr) (normalB $ g cr) []]+		undefined++g fn = do+	x <- newName "x"+	undefined+	where+	h = '[]
+ test/Test/Fixtures/oracle/LambdaCase/lambda-case-application-with-guards.hs view
@@ -0,0 +1,21 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module LambdaCaseInfixApplication where++parseCommandLineOptions originalParsedOptions =+  if _packages transformedOptions == mempty then+    Left noPackagesError+  else+    Right transformedOptions+  where transformedOptions =+          (Options <$> __command+           <*> \case+             f | __withFlake f -> Flake+               | (hasShellArg . __shellPackages) f -> Flake+             _ | otherwise -> Traditional+           <*> __prioritiseLocalPinnedSystem) originalParsedOptions+        hasShellArg (Just ("shell":_)) = True+        hasShellArg _ = False++data Mode = Flake | Traditional
+ test/Test/Fixtures/oracle/LambdaCase/lambda-case-basic.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module LambdaCaseBasic where++describeBool :: Bool -> String+describeBool = \case+  True -> "yes"+  False -> "no"
+ test/Test/Fixtures/oracle/LambdaCase/lambda-case-cases-binder.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module LambdaCaseCasesBinder where++identityCases :: a -> a+identityCases = \cases -> cases
+ test/Test/Fixtures/oracle/LambdaCase/lambda-case-empty.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module LambdaCaseEmpty where++absurdBool :: Bool -> Int+absurdBool = \case {}
+ test/Test/Fixtures/oracle/LambdaCase/lambda-case-guards.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module LambdaCaseGuards where++parity :: Int -> String+parity = \case+  n | even n -> "even"+  _ -> "odd"
+ test/Test/Fixtures/oracle/LambdaCase/lambda-case-in-application.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module LambdaCaseInApplication where++describeMany :: [Maybe Int] -> [String]+describeMany =+  map+    (\case+        Just n -> "just"+        Nothing -> "nothing"+    )
+ test/Test/Fixtures/oracle/LambdaCase/lambda-case-locally-bound.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module LambdaCaseLocallyBound where++select :: Either Int Int -> Int+select e =+  let pick = \case+        Left x -> x+        Right y -> y+   in pick e
+ test/Test/Fixtures/oracle/LambdaCase/lambda-case-nested.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module LambdaCaseNested where++choose :: Either Int String -> Int+choose = \case+  Left n -> n+  Right _ ->+    (\case+        Just k -> k+        Nothing -> 0+    )+      (Just 1)
+ test/Test/Fixtures/oracle/LambdaCase/lambda-case-quasiquote-guard.hs view
@@ -0,0 +1,19 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+module LambdaCaseQuasiQuoteGuard where++import Language.Haskell.TH.Quote (QuasiQuoter (..))++j :: QuasiQuoter+j =+  QuasiQuoter+    { quoteExp = \_ -> [| True |],+      quotePat = error "quotePat unused",+      quoteType = error "quoteType unused",+      quoteDec = error "quoteDec unused"+    }++a = \case+  x | [j|ok|] -> '5'
+ test/Test/Fixtures/oracle/LambdaCase/parenthesized-empty-lambda-case.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module M where++x = (\case)
+ test/Test/Fixtures/oracle/LambdaCase/parenthesized-empty-lambda-cases.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module M where++x = (\cases)
+ test/Test/Fixtures/oracle/Layout/case-where.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module CaseWhere where++run r =+    case r of+    OK n             -> ()+    where+    x = ()
+ test/Test/Fixtures/oracle/Layout/duplicate-where.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+module DuplicateWhere where++selectByEntity :: [Int] -> (String, String) -> Maybe String+selectByEntity inputs (tSel, tName) = case gerArgs (filter areEq inputs) of+  [] -> Nothing+  args -> Just (tSel ++ tName ++ show args)+    where++  where+    gerArgs = map show+    areEq (sel, v) = sel == 0 && tName == v
+ test/Test/Fixtures/oracle/Layout/guard-let-layout-where-case.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+module GuardLetLayoutWhereCase where++a | let+  []+    | 'J' =+      case 'm'# of+        "" -> ""+    where { (-257) ♛⸵ (x, _) = () }+  [a||] = let {  } in 0+  = ' []
+ test/Test/Fixtures/oracle/Layout/implicit-layout-stress.hs view
@@ -0,0 +1,356 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE Arrows #-}+module ImplicitLayoutStress where++-- =============================================================================+-- Case expressions in various contexts+-- =============================================================================++-- Case in boxed tuple+caseInBoxedTuple x = (case x of y -> y, 1)++-- Case in unboxed tuple+caseInUnboxedTuple x = (# case x of y -> y, 1 #)++-- Case in unboxed sum+caseInUnboxedSum x = (# case x of y -> y | #)++-- Case in list+caseInList x = [case x of y -> y]++-- Case as function argument+caseAsArg x = id (case x of y -> y)++-- Case in infix expression+caseInInfix x = case x of y -> y + 1++-- Nested case expressions+nestedCase x y = case x of+  0 -> case y of+    0 -> "both zero"+    _ -> "x zero"+  _ -> case y of+    0 -> "y zero"+    _ -> "neither zero"++-- Case with multiple alternatives+caseMultiAlt x = case x of+  0 -> "zero"+  1 -> "one"+  _ -> "other"++-- Case with guards+caseWithGuards x = case x of+  n | n < 0 -> "negative"+    | n > 0 -> "positive"+    | otherwise -> "zero"++-- Case with where clause+caseWithWhere x = case x of+  n -> result+  where+    result = n + 1++-- =============================================================================+-- Do expressions in various contexts+-- =============================================================================++-- Do in boxed tuple+doInBoxedTuple = (do x <- pure 1; pure x, 2)++-- Do in unboxed tuple+doInUnboxedTuple = (# do x <- pure 1; pure x, 2 #)++-- Do in list+doInList = [do x <- pure 1; pure x]++-- Do as function argument+doAsArg = id (do x <- pure 1; pure x)++-- Nested do expressions+nestedDo = do+  x <- do+    y <- pure 1+    pure (y + 1)+  pure x++-- Do with let+doWithLet = do+  let x = 1+  pure x++-- Do with multiple statements+doMultiStmt = do+  x <- pure 1+  y <- pure 2+  z <- pure 3+  pure (x + y + z)++-- =============================================================================+-- Let expressions in various contexts+-- =============================================================================++-- Let in boxed tuple+letInBoxedTuple = (let x = 1 in x, 2)++-- Let in unboxed tuple+letInUnboxedTuple = (# let x = 1 in x, 2 #)++-- Let in list+letInList = [let x = 1 in x]++-- Let as function argument+letAsArg = id (let x = 1 in x)++-- Nested let expressions+nestedLet = let x = let y = 1 in y + 1 in x + 1++-- Let with multiple bindings+letMultiBindings = let+  x = 1+  y = 2+  z = 3+  in x + y + z++-- Let with where in binding+letWithWhere = let+  f x = y where y = x + 1+  in f 1++-- =============================================================================+-- If expressions in various contexts+-- =============================================================================++-- If in boxed tuple+ifInBoxedTuple x = (if x then 1 else 2, 3)++-- If in unboxed tuple+ifInUnboxedTuple x = (# if x then 1 else 2, 3 #)++-- If in list+ifInList x = [if x then 1 else 2]++-- Nested if expressions+nestedIf x y = if x+  then if y then 1 else 2+  else if y then 3 else 4++-- If with do in branches+ifWithDo x = if x+  then do+    y <- pure 1+    pure y+  else do+    z <- pure 2+    pure z++-- If with case in branches+ifWithCase x y = if x+  then case y of+    0 -> "zero"+    _ -> "nonzero"+  else "x is false"++-- =============================================================================+-- Lambda expressions in various contexts+-- =============================================================================++-- Lambda in boxed tuple+lambdaInBoxedTuple = (\x -> x + 1, 2)++-- Lambda in unboxed tuple+lambdaInUnboxedTuple = (# \x -> x + 1, 2 #)++-- Lambda in list+lambdaInList = [\x -> x + 1]++-- Lambda with case body+lambdaWithCase = \x -> case x of+  0 -> "zero"+  _ -> "nonzero"++-- Lambda with do body+lambdaWithDo = \x -> do+  y <- pure x+  pure (y + 1)++-- Lambda with let body+lambdaWithLet = \x -> let y = x + 1 in y++-- =============================================================================+-- Lambda-case in various contexts+-- =============================================================================++-- Lambda-case in boxed tuple+lambdaCaseInBoxedTuple = (\case 0 -> "zero"; _ -> "other", 1)++-- Lambda-case in unboxed tuple+lambdaCaseInUnboxedTuple = (# \case 0 -> "zero"; _ -> "other", 1 #)++-- Lambda-case in list+lambdaCaseInList = [\case 0 -> "zero"; _ -> "other"]++-- Lambda-case with guards+lambdaCaseWithGuards = \case+  n | n < 0 -> "negative"+    | n > 0 -> "positive"+    | otherwise -> "zero"++-- Lambda-case with where+lambdaCaseWithWhere = \case+  n -> result+  where+    result = "processed"++-- =============================================================================+-- Multi-way if in various contexts+-- =============================================================================++-- Multi-way if basic+multiWayIfBasic x = if+  | x < 0 -> "negative"+  | x > 0 -> "positive"+  | otherwise -> "zero"++-- Multi-way if in boxed tuple+multiWayIfInBoxedTuple x = (if | x -> 1 | otherwise -> 2, 3)++-- Multi-way if in unboxed tuple+multiWayIfInUnboxedTuple x = (# if | x -> 1 | otherwise -> 2, 3 #)++-- Multi-way if nested+multiWayIfNested x y = if+  | x < 0 -> if+      | y < 0 -> "both negative"+      | otherwise -> "x negative"+  | otherwise -> if+      | y < 0 -> "y negative"+      | otherwise -> "both non-negative"++-- =============================================================================+-- Complex nesting and combinations+-- =============================================================================++-- Case inside do inside let+complexNesting1 x = let+  f y = do+    z <- pure y+    case z of+      0 -> pure "zero"+      _ -> pure "nonzero"+  in f x++-- Do inside case inside lambda+complexNesting2 = \x -> case x of+  0 -> do+    y <- pure "zero"+    pure y+  _ -> do+    y <- pure "nonzero"+    pure y++-- Let inside lambda inside case+complexNesting3 x = case x of+  0 -> \y -> let z = y + 1 in z+  _ -> \y -> let z = y - 1 in z++-- Multiple layout constructs at same level+multipleLayoutSameLevel = do+  x <- case True of+    True -> pure 1+    False -> pure 2+  y <- let z = 3 in pure z+  pure (x + y)++-- Deeply nested case+deeplyNestedCase a b c d = case a of+  True -> case b of+    True -> case c of+      True -> case d of+        True -> "all true"+        False -> "d false"+      False -> "c false"+    False -> "b false"+  False -> "a false"++-- =============================================================================+-- Layout with operators and sections+-- =============================================================================++-- Case in operator section+caseInSection x = (+ case x of y -> y)++-- Do in operator application+doInOperator = 1 + (do x <- pure 2; pure x)++-- Let in infix chain+letInInfixChain = 1 + let x = 2 in x + 3++-- =============================================================================+-- Layout in record contexts+-- =============================================================================++data MyRecord = MyRecord { myField :: Int }++-- Case in record construction+caseInRecord x = MyRecord { myField = case x of y -> y }++-- Do in record update+doInRecordUpdate r = r { myField = head (do x <- [1]; pure x) }++-- =============================================================================+-- Layout in type signature contexts+-- =============================================================================++-- Expression with type signature containing layout+withTypeSig :: Int -> String+withTypeSig x = case x of+  0 -> "zero"+  _ -> "nonzero"++-- Let with type signature on binding+letWithTypeSig = let+  f :: Int -> Int+  f x = x + 1+  in f 1++-- =============================================================================+-- Edge cases with semicolons and layout+-- =============================================================================++-- Explicit semicolons in implicit layout+explicitSemicolons x = case x of+  0 -> "zero"; 1 -> "one"+  _ -> "other"++-- Mixed explicit and implicit+mixedLayout x = case x of { 0 -> "zero"; 1 -> "one" }++-- Empty case alternatives (needs EmptyCase extension, skip)+-- emptyCase x = case x of {}++-- =============================================================================+-- Layout with comments+-- =============================================================================++-- Case with comments between alternatives+caseWithComments x = case x of+  -- First alternative+  0 -> "zero"+  -- Second alternative+  1 -> "one"+  -- Default+  _ -> "other"++-- Do with comments+doWithComments = do+  -- First statement+  x <- pure 1+  -- Second statement+  y <- pure 2+  -- Result+  pure (x + y)
+ test/Test/Fixtures/oracle/Layout/nested-case-where.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+module NestedCaseWhere where++-- where clause after nested case expressions should attach to the+-- enclosing function binding, not the outer case alternative.+f k m0+  = case compare k 0 of+      GT+        -> case m0 of+             [] -> Nothing+             _ -> Just k+      where+          g = k + 1
+ test/Test/Fixtures/oracle/Layout/top-level-where-deprecated-boundary.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+module TopLevelWhereDeprecatedBoundary where++sortDirShape :: Int -> Int+sortDirShape = sortDirBy id  where++  -- HELPER:+sortDirBy :: (Int -> Int) -> Int -> Int+sortDirBy f = f++{-# DEPRECATED free "Use dirTree instead" #-}+free :: Int+free = 1
+ test/Test/Fixtures/oracle/Layout/triple-nested-case-where.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+module TripleNestedCaseWhere where++-- where clause after triply nested case expressions.+-- Tests that closeBeforeWhere correctly closes all enclosing+-- LayoutCaseAlternative contexts.+f x y z =+  case x of+    True ->+      case y of+        True ->+          case z of+            True -> x+            False -> y+    where+        g = x
+ test/Test/Fixtures/oracle/LinearTypes/linear-arrow-basic.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+module LinearArrowBasic where++f :: a %1 -> b+f = undefined
+ test/Test/Fixtures/oracle/LinearTypes/linear-arrow-many.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+module LinearArrowMany where++f :: a %Many -> b+f = undefined
+ test/Test/Fixtures/oracle/LinearTypes/linear-arrow-nested.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+module LinearArrowNested where++f :: (a %1 -> b) %1 -> a -> b+f g x = g x
+ test/Test/Fixtures/oracle/LinearTypes/linear-arrow-poly.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+module LinearArrowPoly where++f :: a %m -> b+f = undefined
+ test/Test/Fixtures/oracle/LinearTypes/linear-arrow-promoted-many.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+module LinearArrowPromotedMany where++f :: a %'Many -> b+f = undefined
+ test/Test/Fixtures/oracle/LinearTypes/linear-arrow-spaced-not-linear.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE DataKinds #-}+module LinearArrowSpacedNotLinear where++-- GHC parses "% 1" (space between % and 1) as the type operator % applied to+-- 1, making the arrow unrestricted: fn :: (a % 1) -> b.+-- Only "%1" (no space) is parsed as a linear multiplicity annotation.+fn :: a % 1 -> b+fn = undefined
+ test/Test/Fixtures/oracle/LinearTypes/linear-arrow-unicode.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE UnicodeSyntax #-}+module LinearArrowUnicode where++f :: a ⊸ b+f = undefined
+ test/Test/Fixtures/oracle/LinearTypes/linear-gadt-constructor.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE GADTs #-}+module LinearGADTConstructor where++data T a b c where+  MkT :: a -> b %1 -> c %1 -> T a b c
+ test/Test/Fixtures/oracle/LinearTypes/linear-let-binding.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+module LinearLetBinding where++h :: Int -> Int+h x = let %1 y = x in y
+ test/Test/Fixtures/oracle/LinearTypes/linear-let-many-binding.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+module LinearLetManyBinding where++h :: Int -> Int+h x = let %Many y = x in y
+ test/Test/Fixtures/oracle/LinearTypes/linear-newtype.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+module LinearNewtype where++newtype Wrap a = Wrap { unwrap :: a }
+ test/Test/Fixtures/oracle/LinearTypes/linear-record-field-many.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+module LinearRecordFieldMany where++data T a b = MkT { x %'Many :: a, y :: b }
+ test/Test/Fixtures/oracle/LinearTypes/linear-record-field-poly.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+module LinearRecordFieldPoly where++data T a m = MkT { x %m :: a }
+ test/Test/Fixtures/oracle/LinearTypes/linear-where-binding.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LinearTypes #-}+module LinearWhereBinding where++h :: Int -> Int+h x = y+  where+    %1 y = x
+ test/Test/Fixtures/oracle/LocalFixity/local-infix-let.hs view
@@ -0,0 +1,2 @@+{- ORACLE_TEST pass -}+main = let { infixl 7 *%; x = 5 *% 3 *% 2 } in x
+ test/Test/Fixtures/oracle/LocalFixity/local-infix-multi-ops.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+f x = x .>. (y .<. z)+  where+    infixl 4 .>., .<.+    (.>.) = (>)+    (.<.) = (<)+    y = 10+    z = 5
+ test/Test/Fixtures/oracle/LocalFixity/local-infix-multiple.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+f x y = x .+. y+  where+    infixl 6 .+.+    infixr 5 .*.+    (.+.) a b = a + b+    (.*.) a b = a * b
+ test/Test/Fixtures/oracle/LocalFixity/local-infix-where.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+instance FromHttpApiData (BackendKey DB.MongoContext) where+    parseUrlPiece input = do+      MongoKey <$> readTextData s+      where+        infixl 3 <!>+        Left _ <!> y = y+        x      <!> _ = x
+ test/Test/Fixtures/oracle/LocalTypeSignatures/let-binding-signature.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module LetBindingSignature where++f = let x :: Double = 1 in x
+ test/Test/Fixtures/oracle/LocalTypeSignatures/where-binding-signature.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module WhereBindingSignature where++f = x+  where+    x :: Double = 1
+ test/Test/Fixtures/oracle/MagicHash/basic.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}+module Basic where++x# :: Int#+x# = 42#
+ test/Test/Fixtures/oracle/MagicHash/infix-operator-layout.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}++module MagicHashOperatorLayout where++fn = val+  #! val
+ test/Test/Fixtures/oracle/MagicHash/literals.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}+module Literals where++c# = 'a'#+s# = "hello"#
+ test/Test/Fixtures/oracle/MagicHash/negated-primitive-spaced.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}+module NegatedPrimitiveSpaced where++x = - 10#
+ test/Test/Fixtures/oracle/MagicHash/word-literal-double-hash.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}++module WordLiteralDoubleHash where++import GHC.Exts++f = W# 0##
+ test/Test/Fixtures/oracle/MultiParamTypeClasses/lawful-instance.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiParamTypeClasses   #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE ConstraintKinds         #-}+{-# LANGUAGE UndecidableSuperclasses #-}+module LawfulInstance where++class c t => Lawful c t
+ test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-class-basic.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiParamTypeClasses #-}++module MultiParamTypeClassesClassBasic where++class Converts a b where+  convert :: a -> b
+ test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-constrained-method.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiParamTypeClasses #-}++module MultiParamTypeClassesConstrainedMethod where++class Render a b where+  render :: Show a => a -> b -> String
+ test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-deriving-with-type-arg.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiParamTypeClasses #-}++module MptcDerivingWithTypeArg where++newtype SequenceIdT s m = SequenceIdT m deriving (MonadState s, MonadTrans)
+ test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-instance-basic.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiParamTypeClasses #-}++module MultiParamTypeClassesInstanceBasic where++class Combine a b where+  combine :: a -> b -> (a, b)++instance Combine Int Bool where+  combine a b = (a, b)
+ test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-superclass.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiParamTypeClasses #-}++module MultiParamTypeClassesSuperclass where++class Parent a b where+  parent :: a -> b++class Parent a b => Child a b where+  child :: a -> b
+ test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-three-params.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiParamTypeClasses #-}++module MultiParamTypeClassesThreeParams where++class Rel a b c where+  relate :: a -> b -> c++instance Rel Int Int Int where+  relate x y = x + y
+ test/Test/Fixtures/oracle/MultiWayIf/basic.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+module Basic where++val :: Int -> String+val n = if | n < 0     -> "negative"+           | n == 0    -> "zero"+           | otherwise -> "positive"
+ test/Test/Fixtures/oracle/MultiWayIf/indented.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+module Indented where++f :: Int -> Int -> Int+f x y = if+  | x > 0, y > 0 -> x + y+  | x < 0        -> -x+  | otherwise    -> y
+ test/Test/Fixtures/oracle/MultiWayIf/infix-branch-type-signature.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}++module InfixBranchTypeSignature where++x = if | True -> a+  + b :: Int
+ test/Test/Fixtures/oracle/MultiWayIf/left-infix-roundtrip.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+module MultiWayIfLeftInfixRoundtrip where++f = (if | True -> ()) `a` 'x'
+ test/Test/Fixtures/oracle/MultiWayIf/multiway-if-infix-roundtrip.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+module MultiWayIfInfixRoundtrip where++f = x +++  if | True -> ()
+ test/Test/Fixtures/oracle/MultiWayIf/nested.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+module Nested where++f :: Int -> Int -> Int+f x y = if | x > 0 -> if | y > 0 -> x + y+                         | otherwise -> x+           | otherwise -> y
+ test/Test/Fixtures/oracle/MultiWayIf/non-aligned-guards.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+module NonAlignedGuards where++f :: Bool -> Bool -> Int+f x y = if | x -> 1+            | y -> 2+              | otherwise -> 3
+ test/Test/Fixtures/oracle/MultiWayIf/offside-infix.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+module OffsideInfix where++f =+    if | True+       ->+        1+     + 2
+ test/Test/Fixtures/oracle/MultiWayIf/pattern-guard-type-signature-unboxed-sum.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnboxedTuples #-}++module PatternGuardTypeSignatureUnboxedSum where++(#+      |+      | []+      |  #) =+   if | (# #) <- (() :: (# (# [a||] | C #) | * #))+        -> 0
+ test/Test/Fixtures/oracle/MultiWayIf/pattern-guards.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+module PatternGuards where++f :: Maybe Int -> Int+f m = if | Just x <- m, x > 0 -> x+         | otherwise          -> 0
+ test/Test/Fixtures/oracle/MultilineStrings/basic.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultilineStrings #-}+module Basic where++s :: String+s = """+    Hello,+    World!+    """
+ test/Test/Fixtures/oracle/MultilineStrings/empty.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultilineStrings #-}+module Empty where++s :: String+s = """"""
+ test/Test/Fixtures/oracle/MultilineStrings/escape.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultilineStrings #-}+module Escape where++s :: String+s = """+    Line 1\nLine 2+    """
+ test/Test/Fixtures/oracle/MultilineStrings/escaped-quote-with-continuation.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}++x = [+    (A, "\+\")+  , (B, "\+\c")+  ]
+ test/Test/Fixtures/oracle/MultilineStrings/help-message-unicode-quote.hs view
@@ -0,0 +1,26 @@+{- ORACLE_TEST pass -}+helpMessage :: Bool -- ^ 'True' when showing in a terminal.+            -> String -- ^ Executable program name.+            -> String+helpMessage is_terminal name = usageInfo header options ++ footer+  where+    b = bold is_terminal+    bu = boldUnderline is_terminal+    header = "A tool to generate reports from .tix and .mix files\n\+\\n\+\" ++ bu "USAGE:" ++ " " ++ b name ++ " [OPTIONS] TARGET\n\+\\n\+\" ++ bu "ARGUMENTS:" ++ "\n\+\  <TARGET>  Either a path to a .tix file or a 'TOOL:TEST_SUITE'.\n\+\            Supported TOOL values are 'stack' and 'cabal'.\n\+\            When the TOOL is 'stack' and building a project with\n\+\            multiple packages, use 'all' as the TEST_SUITE value\n\+\            to specify the combined report.\n\+\\n\+\" ++ bu "OPTIONS:"+    footer = "\+\\n\+\For more info, see:\n\+\\n\+\  https://github.com/8c6794b6/hpc-codecov#readme\n\+\"
+ test/Test/Fixtures/oracle/MultilineStrings/indentation.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultilineStrings #-}+module Indentation where++s :: String+s = """+      This is indented+    by two spaces.+    """
+ test/Test/Fixtures/oracle/MultilineStrings/manual-linebreaks.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultilineStrings #-}+module ManualLinebreaks where++s :: String+s = """+    Hello \&+    World+    """
+ test/Test/Fixtures/oracle/MultilineStrings/single-line.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultilineStrings #-}+module SingleLine where++s :: String+s = """One line"""
+ test/Test/Fixtures/oracle/MultilineStrings/string-gap-type-error-indentation.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}++module StringGapTypeErrorIndentation where++import Data.Kind (Constraint)+import GHC.TypeLits (ErrorMessage (Text), TypeError)++type family UrlAlphabet k :: Constraint where+  UrlAlphabet 'True = ()+  UrlAlphabet _ = TypeError+    ( 'Text "Cannot prove base64 value is encoded using the url-safe \+            \alphabet. Please re-encode using the url-safe encoders, or use \+            \a lenient decoder for the url-safe alphabet instead."+    )
+ test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-case.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NamedFieldPuns #-}++module NamedFieldPunsCase where++data Point = Point {x :: Int, y :: Int}++sumPoint :: Point -> Int+sumPoint p =+  case p of+    Point {x, y} -> x + y
+ test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-construct.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NamedFieldPuns #-}++module NamedFieldPunsConstruct where++data Person = Person {name :: String, age :: Int}++mkPerson :: String -> Int -> Person+mkPerson name age = Person {name, age}
+ test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-let.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NamedFieldPuns #-}++module NamedFieldPunsLet where++data User = User {userName :: String, userId :: Int}++render :: User -> String+render u =+  let User {userName, userId} = u+   in userName ++ "#" ++ show userId
+ test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-mixed.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NamedFieldPuns #-}++module NamedFieldPunsMixed where++data Config = Config {host :: String, port :: Int, secure :: Bool}++normalize :: Config -> Config+normalize Config {host, port, secure = _} = Config {host, port, secure = True}
+ test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-pattern.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NamedFieldPuns #-}++module NamedFieldPunsPattern where++data Person = Person {name :: String, age :: Int}++greet :: Person -> String+greet Person {name} = "hello " ++ name
+ test/Test/Fixtures/oracle/NamedFieldPuns/record-unpack-pragma.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NamedFieldPuns #-}++data BQueue a = BQueue+  { bqRead :: {-# UNPACK #-}!Int+  }
+ test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-expression-signature.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NamedWildCards #-}++module NamedWildcardExpressionSignature where++identityExpr :: Int+identityExpr = (id :: _b -> _b) 7
+ test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-forall.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NamedWildCards, ExplicitForAll #-}++module NamedWildcardForall where++poly :: forall _a. _a -> _a+poly x = x
+ test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-multi-hole.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NamedWildCards #-}++module NamedWildcardMultiHole where++pair :: _x -> _y -> (_x, _y)+pair x y = (x, y)
+ test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-top-signature.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NamedWildCards #-}++module NamedWildcardTopSignature where++identity :: _a -> _a+identity x = x
+ test/Test/Fixtures/oracle/NonEmptyPattern/associativity.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+module NonEmptyPattern where++import Data.List.NonEmpty (NonEmpty(..))++f (x :| y : ys) = undefined+f _ = undefined
+ test/Test/Fixtures/oracle/NonEmptyPattern/cons-chain.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+module ConsChain where++f (x : y : z : zs) = undefined+f _ = undefined
+ test/Test/Fixtures/oracle/NonEmptyPattern/explicit-parens.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+module ExplicitParens where++import Data.List.NonEmpty (NonEmpty(..))++f ((x :| y) : ys) = undefined+f _ = undefined
+ test/Test/Fixtures/oracle/NondecreasingIndentation/nested-do-deep.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NondecreasingIndentation #-}++-- NondecreasingIndentation: deeply nested do blocks at the same indentation.++module NondecreasingDeepNestedDo where++f = do+  do+    do+      do+      action+  where+    action = undefined
+ test/Test/Fixtures/oracle/NondecreasingIndentation/nested-do-lambda.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NondecreasingIndentation #-}++-- NondecreasingIndentation allows nested do blocks at the same indentation level,+-- including with nested lambdas.++module NondecreasingNestedDo where++f = g $ \x -> do+    g $ \y -> do+    action x y+  where+    g = undefined+    action = undefined
+ test/Test/Fixtures/oracle/NondecreasingIndentation/nested-do-simple.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NondecreasingIndentation #-}++-- NondecreasingIndentation: simple nested do at same indentation level.++module NondecreasingNestedDoSimple where++f = do+  do+  action+  where+    action = undefined
+ test/Test/Fixtures/oracle/NullaryTypeClasses/nullary-class.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module NullaryClass where++class BearerAuthNotEnabled
+ test/Test/Fixtures/oracle/NumericUnderscores/numeric-underscores-floating.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NumericUnderscores #-}++module NumericUnderscoresFloating where++piApprox :: Double+piApprox = 3.141_592_653_589_793++avogadro :: Double+avogadro = 6.022_140_76e23
+ test/Test/Fixtures/oracle/NumericUnderscores/numeric-underscores-integers.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NumericUnderscores #-}++module NumericUnderscoresIntegers where++million :: Integer+million = 1_000_000++hexWord :: Integer+hexWord = 0xDEAD_BEEF
+ test/Test/Fixtures/oracle/NumericUnderscores/numeric-underscores-pattern.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NumericUnderscores #-}++module NumericUnderscoresPattern where++classify :: Integer -> String+classify n = case n of+  1_024 -> "kibi"+  65_536 -> "mebi"+  _ -> "other"
+ test/Test/Fixtures/oracle/OverlappingInstances/foldable-ranger-overlappable.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeOperators #-}++module OverlappingInstanceRangeR where++data RangeR a b = NilR | (RangeR a b) :++ b++instance {-# OVERLAPPABLE #-}+        Foldable (RangeR 0 (m - 1)) => Foldable (RangeR 0 m) where+        foldr (-<) z = \case NilR -> z; xs :++ x -> foldr (-<) (x -< z) xs
+ test/Test/Fixtures/oracle/OverlappingInstances/instance-incoherent-pragma.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}++module InstanceIncoherentPragma where++class Select a where+  select :: a -> String++instance {-# INCOHERENT #-} Select [a] where+  select _ = "list"++instance Select [Int] where+  select _ = "ints"
+ test/Test/Fixtures/oracle/OverlappingInstances/instance-overlappable-pragma.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}++module InstanceOverlappablePragma where++class Select a where+  select :: a -> String++instance {-# OVERLAPPABLE #-} Select [a] where+  select _ = "list"++instance Select [Int] where+  select _ = "ints"
+ test/Test/Fixtures/oracle/OverlappingInstances/instance-overlapping-pragma.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}++module InstanceOverlappingPragma where++class Select a where+  select :: a -> String++instance {-# OVERLAPPING #-} Select [Int] where+  select _ = "ints"++instance Select [a] where+  select _ = "list"
+ test/Test/Fixtures/oracle/OverlappingInstances/instance-overlaps-pragma.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}++module InstanceOverlapsPragma where++class Select a where+  select :: a -> String++instance {-# OVERLAPS #-} Select [Int] where+  select _ = "ints"++instance Select [a] where+  select _ = "list"
+ test/Test/Fixtures/oracle/OverloadedLabels/basic.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+module OverloadedLabelsBasic where++import GHC.OverloadedLabels (IsLabel (..))++data Label = Label++instance IsLabel "typeUrl" Label where+  fromLabel = Label++x :: Label+x = #typeUrl
+ test/Test/Fixtures/oracle/OverloadedLabels/hash-prefix-operator.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE OverloadedLabels #-}+module HashPrefixOperator where++-- '#' followed by a symbol character should be parsed as a variable operator,+-- not as an overloaded label. GHC accepts this even with OverloadedLabels enabled.+(#⥹) = (+)++x = 1 #⥹ 2
+ test/Test/Fixtures/oracle/OverloadedLabels/infix-overloaded-label.hs view
@@ -0,0 +1,20 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}++module InfixOverloadedLabel where++import GHC.OverloadedLabels++data L = L++instance IsLabel "a" L where+  fromLabel = L++(^.) :: a -> L -> ()+(^.) = undefined++f :: ()+f = undefined ^. #a
+ test/Test/Fixtures/oracle/OverloadedLabels/negated-label.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE OverloadedLabels #-}+module NegatedLabel where++x = - #label
+ test/Test/Fixtures/oracle/OverloadedLabels/quoted.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+module OverloadedLabelsQuoted where++import GHC.OverloadedLabels (IsLabel (..))++data Label = Label++instance IsLabel "The quick brown fox" Label where+  fromLabel = Label++x :: Label+x = #"The quick brown fox"
+ test/Test/Fixtures/oracle/PackageImports/package-imports-basic.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PackageImports #-}++module PackageImportsBasic where++import "base" Prelude+import "containers" Data.Map (Map)++usesMap :: Maybe (Map Int Int)+usesMap = Nothing
+ test/Test/Fixtures/oracle/PackageImports/package-imports-qualified-post.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ImportQualifiedPost #-}++module PackageImportsQualifiedPost where++import "base" Prelude+import "containers" Data.Map qualified as M++fromListMap :: [(Int, Int)] -> M.Map Int Int+fromListMap = M.fromList
+ test/Test/Fixtures/oracle/PackageImports/package-imports-qualified.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PackageImports #-}++module PackageImportsQualified where++import "base" Prelude hiding (map)+import "containers" Data.Map as M++mapSize :: M.Map Int Int -> Int+mapSize = M.size
+ test/Test/Fixtures/oracle/PackageImports/safe-import-variations.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Safe, PackageImports #-}++module SafeImportVariations where++-- Safe import with package+import safe "base" Control.Applicative (pure)++-- Safe import without package+import safe Data.Maybe (Maybe)++-- Safe qualified import+import safe qualified Data.List as L++-- Safe qualified import with package+import safe qualified "base" Data.List as List
+ test/Test/Fixtures/oracle/PackageImports/safe-package-import.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Safe, PackageImports #-}++module SafePackageImport where++import safe "base" Control.Applicative (pure)
+ test/Test/Fixtures/oracle/ParallelListComp/parallel-list-comp-basic.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module ParallelListCompBasic where++pairs :: [a] -> [b] -> [(a, b)]+pairs xs ys = [ (x, y) | x <- xs | y <- ys ]
+ test/Test/Fixtures/oracle/Parens/arrow-command-infix-rhs-nested.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module M where++x = proc _ -> do+            [] -<< []+           `a` (([] -<< []) + ([] -< []))
+ test/Test/Fixtures/oracle/Parens/arrow-infix-chain-rhs.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module M where++import Control.Arrow++f a b c = proc x -> (a -< x) <+> (b -< x) <+> (c -< x)
+ test/Test/Fixtures/oracle/Parens/arrow-rhs-typesig.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module M where++import Control.Arrow++f = proc string -> do+  count <- sumC -< 1 :: Integer+  returnA -< count
+ test/Test/Fixtures/oracle/Parens/case-type-signature.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE EmptyCase #-}+module M where++x = case a of {} :: Int
+ test/Test/Fixtures/oracle/Parens/context-forall-kind-signature.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}++module ContextForallKindSignature where++import Data.Kind (Type)++type S = () => forall a. a :: Type
+ test/Test/Fixtures/oracle/Parens/data-forall-kind-sig.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module M where++data T = forall (a :: T). C a
+ test/Test/Fixtures/oracle/Parens/do-let-in-expression-stmt.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module DoLetInExpressionStmt where++f m = do+  let x = 1 in m x
+ test/Test/Fixtures/oracle/Parens/do-type-signature.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE PartialTypeSignatures #-}+module M where++x = do+  a+ :: _
+ test/Test/Fixtures/oracle/Parens/infix-head-infix-pattern.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module M where++x = let _ + _ :+ _ = () in []
+ test/Test/Fixtures/oracle/Parens/infix-lambda.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module M where++warnIfNullable r = when True $ P $ \s ->+  Right (s {warnings = WarnNullableRExp pos w : warnings s}, ())
+ test/Test/Fixtures/oracle/Parens/infix-pneg.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module M where++x (_ :+ -0) = 0+x (-0 :+ _) = 0++_ + -0 = 0+-0 + _ = 0
+ test/Test/Fixtures/oracle/Parens/lambda-case-type-signature.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module M where++x = \case :: Int
+ test/Test/Fixtures/oracle/Parens/lambda-cases-infix-lhs.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module M where++x = \cases + y
+ test/Test/Fixtures/oracle/Parens/lambda-cases-type-signature.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module M where++x = \cases :: Int
+ test/Test/Fixtures/oracle/Parens/lambda-guard-expression-with-qualifier.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module M where++x =+  case [() ..] of+    _+      | \_ -> ()+      , a+      -> a
+ test/Test/Fixtures/oracle/Parens/lambda-guard-expression.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module M where++x =+  case [() ..] of+    _+      | \_ -> ()+      -> a
+ test/Test/Fixtures/oracle/Parens/list-comp-then-parallel-list-comp.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE TransformListComp #-}+module M where++x = [[] | then [[] | [] | then [] by []] by []]
+ test/Test/Fixtures/oracle/Parens/list-comp-then-type-quote.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TransformListComp #-}+module M where++x = [[] | then [t| _ |] by []]
+ test/Test/Fixtures/oracle/Parens/log-base-modify-seq-parens.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}++module MonoidAppendParen where++appendToRef ref msg' = ref (<> msg' <> "\n")
+ test/Test/Fixtures/oracle/Parens/monad-metrics-section-operator-paren.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ParenSectionExponent where++nsToUs = (/ 10^(3 :: Int))
+ test/Test/Fixtures/oracle/Parens/multiway-if-infix-rhs.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+module M where++actorVulnerable condAnyHarmfulFoeAdj condCanMelee condManyThreatAdj condSupport1 condSolo condInMelee heavilyDistressed fleeingMakesSense =+  return $!+    fleeingMakesSense+      && if | condAnyHarmfulFoeAdj ->+              not condCanMelee || condManyThreatAdj && not condSupport1 && not condSolo+            | condInMelee -> False+            | heavilyDistressed -> True+            | otherwise -> False+      && condCanFlee
+ test/Test/Fixtures/oracle/Parens/multiway-if-type-signature.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PartialTypeSignatures #-}+module M where++x = if | let _ = ()+          -> a+ :: _
+ test/Test/Fixtures/oracle/Parens/negated-lambda.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module M where++x = - \ _ -> ()
+ test/Test/Fixtures/oracle/Parens/negative-bit.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module M where++n = -bit (w - 1)
+ test/Test/Fixtures/oracle/Parens/negative-one.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module M where++svDecrement x = svAddConstant x (-1 :: Integer)
+ test/Test/Fixtures/oracle/Parens/nonfinal-case-block-arg.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BlockArguments #-}+module M where++x = finally+  case a of+    True -> b+    False -> c+  do+    d
+ test/Test/Fixtures/oracle/Parens/numeric-record-dot.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE OverloadedRecordDot #-}++module M where++x = 0.x
+ test/Test/Fixtures/oracle/Parens/proc-case-guard.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Arrows #-}+module M where++x = case () of _ | proc _ -> a -<< () -> ()
+ test/Test/Fixtures/oracle/Parens/qualified-con-pattern-signature-bind.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PartialTypeSignatures #-}+module M where++x = let A.C :: _ = [] in []
+ test/Test/Fixtures/oracle/Parens/qualified-splice.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module M where++x = $A.a
+ test/Test/Fixtures/oracle/Parens/scc-typesig.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module M where++n = {-# SCC "tag" #-} fn arg :: ()
+ test/Test/Fixtures/oracle/Parens/seq-infix-lambda.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module M where++n = \(n1 `Inf` n2 `Inf` ns) -> ()++fn (a `App` b `App` c) = ()
+ test/Test/Fixtures/oracle/Parens/th-instance-dollar.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module M where++x = [d| instance X $a |]
+ test/Test/Fixtures/oracle/Parens/th-name-quote-record-dot.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TemplateHaskell #-}++module M where++x = ' ().a
+ test/Test/Fixtures/oracle/Parens/th-proxy-dollar.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module M where++x = [| Proxy :: Proxy $a |]
+ test/Test/Fixtures/oracle/Parens/th-qualified-splice-record-dot-base.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TemplateHaskell #-}++module M where++x = ($A.a).a
+ test/Test/Fixtures/oracle/Parens/th-splice-record-dot-bare.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TemplateHaskell #-}++module M where++x = $().a
+ test/Test/Fixtures/oracle/Parens/th-type-name-quote-record-dot.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TemplateHaskell #-}++module M where++x = '' ().a
+ test/Test/Fixtures/oracle/Parens/th-typed-splice-record-dot-bare.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TemplateHaskell #-}++module M where++x = $$().a
+ test/Test/Fixtures/oracle/Parens/trailing-if.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module M where++x = do fn $ val ++ if True then "\n" else ""++x = show a ++ ":" ++ show b ++ if b == d then "" else '-' : show d
+ test/Test/Fixtures/oracle/Parens/typed-splice-unit.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module M where++x = $$()++y = $()
+ test/Test/Fixtures/oracle/Parens/typesig-lambda.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module M where++n = \(Just a :: Maybe ()) -> a
+ test/Test/Fixtures/oracle/Parens/view-pattern-block-app-arg.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE ViewPatterns #-}++module ViewPatternBlockAppArg where++f (#+     []+       if | let {  }+              ->+               []+       []+      -> _+     |  #) = ()
+ test/Test/Fixtures/oracle/Parens/view-pattern-if-multiway-if-type-signature.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE ViewPatterns #-}+module M where++x (#+     | if [] then [] else if | []+                                ->+                                 []+                                  :: _+      -> _+     |  #) = ()
+ test/Test/Fixtures/oracle/Parens/view-pattern-list-multiway-if-type-signature.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ViewPatterns #-}+module M where++x [if | []+        ->+         []+          :: _+   -> _] = ()
+ test/Test/Fixtures/oracle/Parens/view-pattern-multiway-if-type-signature.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE ViewPatterns #-}+module M where++x (#+     | if | []+              ->+               []+                :: _+      -> _+     |  #) = ()
+ test/Test/Fixtures/oracle/ParenthesizedTypeHead/class-parens.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module A where++class (MyClass a) where+  myMethod :: a -> Int
+ test/Test/Fixtures/oracle/ParenthesizedTypeHead/data-parens-multi-params.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module A where++data (Map k v) = Map [(k, v)]
+ test/Test/Fixtures/oracle/ParenthesizedTypeHead/data-parens-tail-params.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module A where++data (Pair a) b = Pair a b
+ test/Test/Fixtures/oracle/ParenthesizedTypeHead/newtype-parens-single-param.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module A where++newtype (Wrapper a) = Wrapper a
+ test/Test/Fixtures/oracle/ParenthesizedTypeHead/type-synonym-parens.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module A where++type (Synonym a) = [a]
+ test/Test/Fixtures/oracle/PartialTypeSignatures/just1.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PartialTypeSignatures #-}+module Just1 where++just1 :: _ Int+just1 = Just 1
+ test/Test/Fixtures/oracle/PartialTypeSignatures/just2.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PartialTypeSignatures #-}+module Just2 where++just2 :: Maybe _+just2 = Just False
+ test/Test/Fixtures/oracle/PartialTypeSignatures/let-binding.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PartialTypeSignatures #-}+module LetBinding where++x = let y :: _; y = False in y
+ test/Test/Fixtures/oracle/PartialTypeSignatures/list1.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PartialTypeSignatures #-}+module List1 where++list :: _ Int+list = [1]
+ test/Test/Fixtures/oracle/PartialTypeSignatures/list2.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PartialTypeSignatures #-}+module List2 where++list :: [_]+list = [1]
+ test/Test/Fixtures/oracle/PartialTypeSignatures/multi-constraint.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PartialTypeSignatures #-}+module MultiConstraint where++x :: (Enum a, _) => a -> String+x = show
+ test/Test/Fixtures/oracle/PartialTypeSignatures/named-wildcard.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE NamedWildCards #-}+module NamedWildcard where++f :: _a -> Int+f x = 42
+ test/Test/Fixtures/oracle/PartialTypeSignatures/pattern-wildcard.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PartialTypeSignatures #-}+module PatternWildcard where++foo :: _+foo (x :: _) = (x :: _)
+ test/Test/Fixtures/oracle/PartialTypeSignatures/qualified-constraint.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PartialTypeSignatures #-}+module QualifiedConstraint where++x :: _ => a -> String+x = show
+ test/Test/Fixtures/oracle/PartialTypeSignatures/wildcard.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PartialTypeSignatures #-}+module Wildcard where++f :: _ -> Int+f x = 42
+ test/Test/Fixtures/oracle/PatternGuards/pattern-guard-case-alt.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternGuards #-}++module PatternGuardCaseAlt where++asPair :: Maybe a -> [a]+asPair value =+  case value of+    m+      | Just x <- m -> [x, x]+      | otherwise -> []
+ test/Test/Fixtures/oracle/PatternGuards/pattern-guard-let-in-expression.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternGuards #-}++module PatternGuardLetInExpression where++guardLetInExpr :: Int -> Int+guardLetInExpr n+  | let x = 1 in x > 0 = n+  | otherwise = 0
+ test/Test/Fixtures/oracle/PatternGuards/pattern-guard-multi-qualifiers.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternGuards #-}++module PatternGuardMultiQualifiers where++firstPositive :: [Int] -> Int+firstPositive xs+  | y : _ <- xs, y > 0 = y+  | otherwise = 0
+ test/Test/Fixtures/oracle/PatternGuards/pattern-guard-single.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternGuards #-}++module PatternGuardSingle where++headOrZero :: [Int] -> Int+headOrZero xs+  | y : _ <- xs = y+  | otherwise = 0
+ test/Test/Fixtures/oracle/PatternGuards/pattern-guard-with-let.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternGuards #-}++module PatternGuardWithLet where++safeDivHead :: Int -> [Int] -> Int+safeDivHead n xs+  | y : _ <- xs, let q = quot n y, q >= 0 = q+  | otherwise = 0
+ test/Test/Fixtures/oracle/PatternOperators/infix-function-equation-infix-pattern-operands.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module InfixFunctionEquationInfixPatternOperands where++data List a = Nil | a :&: List a++a :&: as == b :&: bs = ()
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-bidirectional-prefix.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsBidirectionalPrefix where++data T = T Int++pattern P :: Int -> T+pattern P x = T x++mk :: Int -> T+mk x = P x
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-complete-pragma.hs view
@@ -0,0 +1,18 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsCompletePragma where++data Nat = Z | S Nat++pattern Zero :: Nat+pattern Zero = Z++pattern Succ :: Nat -> Nat+pattern Succ n = S n++{-# COMPLETE Zero, Succ #-}++toInt :: Nat -> Int+toInt Zero = 0+toInt (Succ n) = 1 + toInt n
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicit-where-view-pattern-layout.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++module PatternSynonymsExplicitWhereViewPatternLayout where++pattern P r <- (T ((2 / pi *) -> r))+  where+    P r = T $ r * pi / 2
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional-infix-backtick.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}+module A where+pattern x `Cons` xs <- (x : xs)+  where+    x `Cons` xs = x : xs
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional-infix-conapp.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}+module A where+data Pair a b = MkPair a b+pattern (:<) :: Pair a b -> [Pair a b] -> [Pair a b]+pattern x :< xs <- (x : xs)+  where+    (MkPair a b) :< xs = MkPair a b : xs
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional-infix-symbol.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}+module A where+pattern (:<) :: a -> [a] -> [a]+pattern x :< xs <- (x : xs)+  where+    x :< xs = x : xs
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsExplicitlyBidirectional where++pattern NonEmpty :: a -> [a] -> [a]+pattern NonEmpty x xs <- (x : xs)+  where+    NonEmpty x xs = x : xs++headOr :: a -> [a] -> a+headOr d (NonEmpty x _) = x+headOr d [] = d
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-data-keyword.hs view
@@ -0,0 +1,15 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsExportDataKeyword+  ( pattern Zero,+    pattern Succ,+  ) where++data Nat = Z | S Nat++pattern Zero :: Nat+pattern Zero = Z++pattern Succ :: Nat -> Nat+pattern Succ n = S n
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-double-dot.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}+module PatternSynonymsExportDoubleDot+  ( X+      ( A,+        B,+        ..+      ),+  )+where++data X = A | B
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-pattern-keyword.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ExplicitNamespaces #-}++module PatternSynonymsExportPatternKeyword+  ( pattern Zero,+    pattern Succ,+  ) where++data Nat = Z | S Nat++pattern Zero :: Nat+pattern Zero = Z++pattern Succ :: Nat -> Nat+pattern Succ n = S n
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-pattern-wildcard.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ExplicitNamespaces #-}++module PatternSynonymsExportPatternWildcard+  ( pattern Zero,+    -- GHC 9.16 adds namespace wildcards in import/export items.+    -- Enable this when the oracle switches to GHC 9.16:+    -- pattern ..,+  ) where++pattern Zero :: ()+pattern Zero = ()
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-data-keyword.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsImportDataKeyword where++import PatternSynonymsSource (pattern Zero, pattern Succ)++buildZero = Zero+buildOne = Succ Zero
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-export-bundled-data.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsImportExportBundledData+  ( Nat (Zero, Succ),+  ) where++import PatternSynonymsSource (Nat (Zero, Succ))++fromNat Zero = 0+fromNat (Succ n) = 1 + fromNat n
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-export-bundled.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ExplicitNamespaces #-}++module PatternSynonymsImportExportBundled+  ( Nat (Zero, Succ),+  ) where++import PatternSynonymsSource (Nat (Zero, Succ))++fromNat Zero = 0+fromNat (Succ n) = 1 + fromNat n
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-pattern-keyword.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ExplicitNamespaces #-}++module PatternSynonymsImportPatternKeyword where++import PatternSynonymsSource (pattern Zero, pattern Succ)++buildZero = Zero+buildOne = Succ Zero
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-pattern-wildcard.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ExplicitNamespaces #-}++module PatternSynonymsImportPatternWildcard where++-- GHC 9.16 adds namespace wildcards in import/export items.+-- Enable this when the oracle switches to GHC 9.16:+-- import M (pattern ..)++buildZero = Zero++pattern Zero :: ()+pattern Zero = ()
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-infix-backticks.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsInfixBackticks where++data Pair a = Pair a a++pattern PairP :: a -> a -> Pair a+pattern x `PairP` y = Pair x y+infix 5 `PairP`++swap :: Pair a -> Pair a+swap (x `PairP` y) = y `PairP` x
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-infix-symbol.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsInfixSymbol where++data Pair a = Pair a a++pattern (:*:) :: a -> a -> Pair a+pattern x :*: y = Pair x y+infix 6 :*:++swap :: Pair a -> Pair a+swap (x :*: y) = y :*: x
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-inline-pragmas.hs view
@@ -0,0 +1,15 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsInlinePragmas where++data Wrapped = Wrapped Int++pattern Wrap :: Int -> Wrapped+pattern Wrap n = Wrapped n++{-# INLINE Wrap #-}+{-# NOINLINE [0] Wrap #-}++build :: Int -> Wrapped+build = Wrap
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-record-bidirectional.hs view
@@ -0,0 +1,15 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsRecordBidirectional where++data Point = MkPoint Int Int++pattern Point :: Int -> Int -> Point+pattern Point {xCoord, yCoord} = MkPoint xCoord yCoord++origin :: Point+origin = Point {xCoord = 0, yCoord = 0}++shiftX :: Int -> Point -> Point+shiftX dx p = p {xCoord = xCoord p + dx}
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-record-unidirectional.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsRecordUnidirectional where++data Point = MkPoint Int Int++pattern PointU :: Int -> Int -> Point+pattern PointU {xOnly, yOnly} <- MkPoint xOnly yOnly++xValue :: Point -> Int+xValue PointU {xOnly} = xOnly
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-signature-basic.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsSignatureBasic where++pattern Head :: a -> [a]+pattern Head x <- (x : _)++firstOr :: a -> [a] -> a+firstOr d (Head x) = x+firstOr d [] = d
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-signature-dual-context.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsSignatureDualContext where++pattern HeadEq :: Eq a => () => a -> [a]+pattern HeadEq x <- (x : _)++isHead :: Eq a => a -> [a] -> Bool+isHead y (HeadEq x) = x == y+isHead _ [] = False
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-signature-type-application.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitForAll, KindSignatures, PatternSynonyms, PolyKinds, TypeApplications #-}+module PatternSynonymsSignatureTypeApplication where++import Data.Kind (Type)+import Data.Typeable (Typeable)+import Type.Reflection (TypeRep)++pattern TypeRep :: forall {k :: Type} (a :: k). () => Typeable @k a => TypeRep @k a
+ test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-unidirectional-prefix.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}++module PatternSynonymsUnidirectionalPrefix where++data T = T Int++pattern P :: Int -> T+pattern P x <- T x++isP :: T -> Bool+isP (P _) = True+isP _ = False
+ test/Test/Fixtures/oracle/PatternSyntax/case-cons-continuation.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}++module CaseConsContinuation where++data E = A | B | C++f :: E -> String+f x =+  case x of+    A -> "a"+    B -> "b"+    C -> "c"+  : "tail"
+ test/Test/Fixtures/oracle/PatternSyntax/case-dollar-continuation.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module CaseDollarContinuation where++f x y =+  case x of+    Just z -> z+    Nothing -> id+    $ y
+ test/Test/Fixtures/oracle/PatternSyntax/infix-function-pattern.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++module InfixFunctionPattern where++f :: T -> T -> T+x #|# _ = x+_ #|# y = y
+ test/Test/Fixtures/oracle/PatternSyntax/list-irrefutable-infix-patterns.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++module ListInfixPatterns where++-- List patterns in infix function heads+[] `append` ys = ys+(x : xs) `append` ys = x : xs ++ ys++-- Irrefutable patterns in infix function heads  +~x `combine` y = x+x `combine` ~y = y
+ test/Test/Fixtures/oracle/PatternSyntax/multiple-operator-patterns.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module MultipleOperatorPatterns where++data Expr a = Const a | Plus a a | Minus a a | Times a a | Divide a a++foldExpr c (+) (-) (*) (/) = fold+  where+    fold x = undefined
+ test/Test/Fixtures/oracle/PatternSyntax/nested-parenthesized-operator-as-pattern.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}++module NestedParenthesizedOperatorAsPattern where++data C = C++fn (+)@(+)@C = ()
+ test/Test/Fixtures/oracle/PatternSyntax/operator-pattern.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}++module OperatorPattern where++data Expr a = Plus a a++foldExpr (+) = fold+    where+        fold (Plus x y) = fold x + fold y
+ test/Test/Fixtures/oracle/PatternSyntax/operator-section-in-pattern.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}++module OperatorSectionInPattern where++class Eq1 f where+  liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool++data Free f a = Pure a | Impure (f (Free f a))++instance Eq1 f => Eq1 (Free f) where+  liftEq (==) (Pure a) (Pure b) = a == b+  liftEq (==) (Impure a) (Impure b) = undefined+  liftEq _ _ _ = False
+ test/Test/Fixtures/oracle/PatternSyntax/question-mark-operator-pattern.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module QuestionMarkOperatorPattern where++foldl' (??) z xs = (foldr (?!) id xs) z+  where+    x ?! g = g . (?? x)
+ test/Test/Fixtures/oracle/PatternSyntax/wildcard-infix-patterns.hs view
@@ -0,0 +1,24 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++module WildcardInfixPatterns where++-- Both sides wildcards+_ #|# _ = True++-- Left wildcard, right variable+_ #|# y = y++-- Left variable, right wildcard  +x #|# _ = x++-- Both variables (already worked)+a #|# b = a++-- With constructor patterns+_ #|#: _ = []+x #|#: xs = x : xs++-- With nested patterns+_ #||# (Just _) = True+(Just _) #||# _ = True
+ test/Test/Fixtures/oracle/Patterns/cons-pattern-nested-parens.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}++-- Roundtrip now works correctly for nested cons patterns+f xs = go xs where+  go (x1:x2:xs) = (x1, x2) : go (x2:xs)+  go [x] = []+  go _ = []
+ test/Test/Fixtures/oracle/Patterns/escaped-backslash-cons-pattern.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module X where++go xs = case xs of+  '^' : '\\' : xs -> '\^\' : go xs+  ys -> ys
+ test/Test/Fixtures/oracle/Patterns/prefix-constructor-nothing.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+module PrefixConstructorNothing where++data T = T (Maybe Int) (Maybe Int)++f (T Nothing Nothing) = ()+f _ = ()
+ test/Test/Fixtures/oracle/Patterns/qualified-constructor-sym-record.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+-- Regression test: A.:+ is the :+ constructor from module A, not a single+-- constructor named "A.:+". Verify that qualified symbolic constructors+-- parse correctly in record patterns.+module QualifiedConstructorSymRecord where++f x = x+  where+    g (A.:+) {} = ()
+ test/Test/Fixtures/oracle/PolyKinds/kind-paren-forall-minimal.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PolyKinds, ExplicitForAll #-}++module KindParenForall where++f :: forall k (a :: k). a+f = undefined
+ test/Test/Fixtures/oracle/PolyKinds/paren-kind-forall.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PolyKinds, TypeApplications, ExplicitForAll #-}++module ParenKindForall where++import Data.Proxy++class C a where c :: proxy a -> Integer++f :: forall k (a :: k). C a => Integer+f = c (Proxy @a)
+ test/Test/Fixtures/oracle/QualifiedDo/basic.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE QualifiedDo #-}+module Basic where++x = M.do+  return ()
+ test/Test/Fixtures/oracle/QualifiedDo/qualified-do-bind.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE QualifiedDo #-}+module QualifiedDoBind where++f = M.do+  x <- action+  return x
+ test/Test/Fixtures/oracle/QualifiedDo/qualified-do-let.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE QualifiedDo #-}+module QualifiedDoLet where++f = M.do+  let x = 1+  return x
+ test/Test/Fixtures/oracle/QualifiedDo/qualified-mdo-bind.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE QualifiedDo, RecursiveDo #-}+module QualifiedMdoBind where++f = M.mdo+  x <- action+  return x
+ test/Test/Fixtures/oracle/QuantifiedConstraints/constraint-operators.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE QuantifiedConstraints #-}++module QuantifiedConstraintOperators where++class (p => q) => p |- q+instance (p => q) => p |- q+class (p,q) => p & q+instance (p,q) => p & q
+ test/Test/Fixtures/oracle/QuasiQuotes/decl-quasiquote.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE QuasiQuotes #-}+module DeclQuasiQuote where+[qq||]
+ test/Test/Fixtures/oracle/QuasiQuotes/expr-quasiquote-jmacro.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE QuasiQuotes #-}+module ExprQuasiQuoteJMacro where++-- Regression test for quasi-quote expressions in equation right-hand sides+-- (e.g. happstack-jmacro style)+scoped :: a -> b+scoped js = [jmacro| (function { `(js)`; })(); |]
+ test/Test/Fixtures/oracle/QuasiQuotes/expr-quasiquote.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE QuasiQuotes #-}+module ExprQuasiQuote where++x = [sql|select * from users where id = 1|]
+ test/Test/Fixtures/oracle/QuasiQuotes/pat-quasiquote.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE QuasiQuotes #-}+module PatQuasiQuote where++isMatch [sql|user:{id}|] = True+isMatch _ = False
+ test/Test/Fixtures/oracle/QuasiQuotes/quasiquote-d-layout-case-payload.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE QuasiQuotes #-}+module QuasiQuoteDLayoutCasePayload where++[] = [d| a | case case [] of+  $a -> 0.0 of {  } = '' C |]
+ test/Test/Fixtures/oracle/QuasiQuotes/type-quasiquote.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE QuasiQuotes #-}+module TypeQuasiQuote where++f :: [sql|INT|] -> Int+f _ = 0
+ test/Test/Fixtures/oracle/RecordOperators/newtype-operator-field.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++newtype Managed a = Managed { (>>-) :: a -> a }
+ test/Test/Fixtures/oracle/RecordSyntax/as-field-construction.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}++data Node = Node {as :: Int}++f :: Node+f = Node {as = 1}
+ test/Test/Fixtures/oracle/RecordSyntax/operator-field.hs view
@@ -0,0 +1,2 @@+{- ORACLE_TEST pass -}+newtype T = MkT { ($$) :: Int }
+ test/Test/Fixtures/oracle/RecordWildCards/construction.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RecordWildCards #-}+module Construction where++data Point = Point { x, y :: Int }++f x y = Point{..}
+ test/Test/Fixtures/oracle/RecordWildCards/do-binding.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RecordWildCards #-}+module DoBinding where++x = do+  Loc {..} <- location+  pure ()
+ test/Test/Fixtures/oracle/RecordWildCards/do-tuple-as-pattern-deep.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RecordWildCards #-}+{- Test deeply nested as-pattern in tuple -}+module DoTupleAsPatternDeep where++data T = T { field :: Int }++f mx = do+  (a, (b, c@T {..}), d) <- mx+  return undefined
+ test/Test/Fixtures/oracle/RecordWildCards/do-tuple-as-pattern-simple.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{- Test nested as-pattern in tuple (simple constructor application) -}+module DoTupleAsPatternSimple where++data T a = T a++f mx = do+  (a, b@(T x)) <- mx+  return undefined
+ test/Test/Fixtures/oracle/RecordWildCards/do-tuple-as-pattern.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RecordWildCards #-}+module DoTupleAsPattern where++data T = T { field :: Int }++f mx = do+  (a, b@T {..}) <- mx+  return undefined
+ test/Test/Fixtures/oracle/RecordWildCards/function-pattern.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RecordWildCards #-}+module FunctionPattern where++data Record = Record { a :: Int, b :: Double }+fn Record{..} = ()
+ test/Test/Fixtures/oracle/RecordWildCards/function-tuple-as-pattern.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RecordWildCards #-}+{- Test nested as-pattern in function pattern binding (not in do-block) -}+module FunctionTupleAsPattern where++data T = T { field :: Int }++f (a, b@T {..}) = undefined
+ test/Test/Fixtures/oracle/RecordWildCards/mixed.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RecordWildCards #-}+module Mixed where++data Point = Point { x, y :: Int }++f Point{x, ..} = x + y
+ test/Test/Fixtures/oracle/RecordWildCards/pattern.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RecordWildCards #-}+module Pattern where++data Point = Point { x, y :: Int }++f Point{..} = x + y
+ test/Test/Fixtures/oracle/RecursiveDo/mdo-view-pattern.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ViewPatterns #-}++module MDoViewPattern where++f :: a -> a+f (mdo pure x -> y) = y
+ test/Test/Fixtures/oracle/RecursiveDo/mdo.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RecursiveDo #-}+module MDo where++f = mdo+  x <- return 1+  return x
+ test/Test/Fixtures/oracle/RecursiveDo/rec.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RecursiveDo #-}+module Rec where++f = do+  rec+    x <- return 1+  return x
+ test/Test/Fixtures/oracle/RequiredTypeArguments/basic.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RequiredTypeArguments #-}+module Basic where++x = f (type Int) 5
+ test/Test/Fixtures/oracle/RequiredTypeArguments/pattern.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RequiredTypeArguments #-}+module Pattern where++f (type a) x = x
+ test/Test/Fixtures/oracle/RoleAnnotations/role-multi-parameter.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RoleAnnotations #-}++module RoleMultiParameter where++type role MultiBox representational phantom+data MultiBox a b = MultiBox a
+ test/Test/Fixtures/oracle/RoleAnnotations/role-on-class-after-definition.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RoleAnnotations #-}++module RoleOnClassAfterDefinition where++class C a b where+  method :: a -> b -> ()++type role C representational _
+ test/Test/Fixtures/oracle/RoleAnnotations/role-on-newtype.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RoleAnnotations #-}++module RoleOnNewtype where++type role Wrap nominal+newtype Wrap a = Wrap a
+ test/Test/Fixtures/oracle/RoleAnnotations/role-parenthesized-operator.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RoleAnnotations #-}++module RoleParenthesizedOperator where++data a := b = Pair a b++type role (:=) nominal nominal
+ test/Test/Fixtures/oracle/RoleAnnotations/role-single-parameter.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RoleAnnotations #-}++module RoleSingleParameter where++type role NominalBox nominal+data NominalBox a = NominalBox a
+ test/Test/Fixtures/oracle/RoleAnnotations/role-with-infer.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE RoleAnnotations #-}++module RoleWithInfer where++type role InferBox _ nominal+data InferBox a b = InferBox b
+ test/Test/Fixtures/oracle/ScopedTypeVariables/constructor-pattern-type-sig-equation.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ScopedTypeVariables #-}+module ConstructorPatternTypeSigEquation where++C :: forall a. Show a => a = C
+ test/Test/Fixtures/oracle/ScopedTypeVariables/pattern-type-sig-equation-where.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ScopedTypeVariables #-}+module PatternTypeSigEquationWhere where++f :: Int = x+  where x = 42
+ test/Test/Fixtures/oracle/ScopedTypeVariables/pattern-type-sig-equation.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ScopedTypeVariables #-}+module PatternTypeSigEquation where++f :: Int = 0
+ test/Test/Fixtures/oracle/ScopedTypeVariables/typed-do-bind.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ScopedTypeVariables #-}+module ScopedTypeVariablesTypedDoBind where++f :: Monad m => m Int -> m Int+f gen = do+  x :: Int <- gen+  pure x
+ test/Test/Fixtures/oracle/SourceImports/source-qualified-import.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ImportQualifiedPost #-}++module SourceImportQualified where++import {-# SOURCE #-} qualified Test.ChasingBottoms.IsBottom as B
+ test/Test/Fixtures/oracle/StandaloneDeriving/partial-type-sig.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE PartialTypeSignatures #-}+module PartialTypeSigDeriving where++data Foo a = Foo a++deriving instance _ => Eq (Foo a)
+ test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-basic.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneDeriving #-}++module StandaloneDerivingBasic where++data Box a = Box a++deriving instance Eq a => Eq (Box a)
+ test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-forall.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++module StandaloneDerivingForall where++class C a++deriving instance forall a. C a
+ test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-layout.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneDeriving #-}++module StandaloneDerivingLayout where++data W a = W a++deriving instance+  Show a => Show (W a)
+ test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-multi-arg.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneDeriving #-}++module StandaloneDerivingMultiArg where++data Triple a b c = Triple a b c++deriving instance (Eq a, Eq b, Eq c) => Eq (Triple a b c)
+ test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-nested-type.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}++module StandaloneDerivingNestedType where++data Wrapper f a = Wrapper (f a)++deriving instance Eq (f a) => Eq (Wrapper f a)+deriving instance Show (f a) => Show (Wrapper f a)
+ test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-no-context.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneDeriving #-}++module StandaloneDerivingNoContext where++data Pair = Pair Int Int++deriving instance Eq Pair+deriving instance Show Pair
+ test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-parenthesized.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneDeriving #-}++module StandaloneDerivingParenthesized where++data Tree a = Leaf a | Branch (Tree a) (Tree a)++deriving instance (Eq a) => Eq (Tree a)
+ test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-qualified.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneDeriving #-}++module StandaloneDerivingQualified where++import qualified Data.Ord as Ord++data Box a = Box a++deriving instance Ord.Ord a => Ord.Ord (Box a)
+ test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-strategy-anyclass.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}++module StandaloneDerivingStrategyAnyclass where++class Default a where+  def :: a++data Unit = Unit++deriving anyclass instance Default Unit
+ test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-strategy-newtype.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}++module StandaloneDerivingStrategyNewtype where++newtype Age = Age Int++deriving newtype instance Eq Age+deriving newtype instance Show Age+deriving newtype instance Num Age
+ test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-strategy-stock.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}++module StandaloneDerivingStrategyStock where++data Box a = Box a++deriving stock instance Eq a => Eq (Box a)+deriving stock instance Show a => Show (Box a)
+ test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-type-application.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}++module StandaloneDerivingTypeApplication where++data Proxy a = Proxy++deriving instance Eq (Proxy Int)+deriving instance Show (Proxy Int)
+ test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-with-context.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneDeriving #-}++module StandaloneDerivingWithContext where++data PairBox a b = PairBox a b++deriving instance (Eq a, Eq b) => Eq (PairBox a b)
+ test/Test/Fixtures/oracle/StandaloneKindSignatures/dependent-kind-variable.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneKindSignatures, PolyKinds, ExplicitForAll #-}++module DependentKindVariable where++type Foo :: forall {k}. k -> *+data Foo x = Foo
+ test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-chained-visible-forall.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RequiredTypeArguments #-}++module StandaloneKindChainedVisibleForall where++import Data.Kind (Type)++type Family :: forall (name :: Name) -> forall (ks :: Params name). ParamsProxy name ks -> forall (args :: Args name ks) -> Exp (Res name ks args)
+ test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-class.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneKindSignatures #-}++module StandaloneKindClass where++import Data.Kind (Constraint, Type)++type HasValue :: Type -> Constraint+class HasValue a where+  getValue :: a -> a
+ test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-data-inline-gadt.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds, StandaloneKindSignatures #-}++module InlineKindSignatureData where++import Data.Kind (Type)++data T :: Type -> Type where+  MkT :: a -> T a
+ test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-data.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneKindSignatures #-}++module StandaloneKindData where++import Data.Kind (Type)++type Box :: Type -> Type+data Box a = Box a
+ test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-higher-order.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneKindSignatures #-}++module StandaloneKindHigherOrder where++import Data.Kind (Type)++type Apply :: (Type -> Type) -> Type -> Type+type Apply f a = f a
+ test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-nested-bare-kind-signature.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneKindSignatures #-}++module StandaloneKindNestedBareKindSignature where++type T :: _ :: _+data T
+ test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-newtype-traditional.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds, StandaloneKindSignatures #-}++module InlineKindSignatureNewtypeTraditional where++import Data.Kind (Type)++newtype T :: Type -> Type where+  MkT :: ()
+ test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-newtype-unlifted.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds, StandaloneKindSignatures #-}++module InlineKindSignatureGADT where++newtype T :: TYPE 'WordRep where+  MkT :: ()
+ test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-nullary.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneKindSignatures #-}++module StandaloneKindNullary where++import Data.Kind (Type)++type Range :: Type+data Range = Range
+ test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-type-operator-data.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeOperators #-}++module StandaloneKindTypeOperatorData where++import Data.Kind (Type)++type (:+:) :: Type -> Type -> Type+data a :+: b = L
+ test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-type-synonym.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneKindSignatures #-}++module StandaloneKindTypeSynonym where++import Data.Kind (Type)++type Pair :: Type -> Type -> Type+type Pair a b = (a, b)
+ test/Test/Fixtures/oracle/StrictData/lazy-field-annotation.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module LazyFieldAnnotation where++data MapF k v r = TipF | BinF Int k ~v r r
+ test/Test/Fixtures/oracle/TemplateHaskell/domain-aeson-qualified-operator-name-quote.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module DomainAesonQualifiedOperatorNameQuote where++import qualified Prelude as P++f required =+  if required+    then '(P.+)+    else '(P.-)
+ test/Test/Fixtures/oracle/TemplateHaskell/file-embed-lzma-typed-quote-let-splice.hs view
@@ -0,0 +1,15 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskellQuotes #-}++module FileEmbedLzmaTypedQuoteLetSplice where++import Language.Haskell.TH.Syntax (Code, Q)++x :: Code Q Int+x = [||1||]++f =+  [||+  let embedded = $$(x)+   in embedded+  ||]
+ test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-cpp-both.hs view
@@ -0,0 +1,18 @@+{- ORACLE_TEST pass -}+{- Test infix function definitions with both TH and CPP -}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+module InfixFunlhsThAndCpp where++infixr 5 </>+(</>) :: Path b Dir -> Path Rel t -> Path b t+(</>) (Path a) (Path b) = Path (a ++ b)++#ifdef DEBUG+debugInfo :: String+debugInfo = "debug mode"+#endif++-- Template Haskell splice alongside infix+showPath :: Path b t -> String+showPath = $(varE 'show)
+ test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-splice-interaction.hs view
@@ -0,0 +1,24 @@+{- ORACLE_TEST pass -}+{- Ensure TH splices work correctly alongside infix definitions -}+{-# LANGUAGE TemplateHaskell #-}+module InfixFunlhsThSpliceInteraction where++import Language.Haskell.TH++-- Infix definition followed by splice+infixl 6 <#>+(<#>) :: Int -> Int -> Int+x <#> y = x * y++-- Splice that generates a definition+$(pure [])++-- Another infix after splice  +infixr 5 <+>+(<+>) :: String -> String -> String+x <+> y = x ++ y++-- Infix with pattern that could look like splice+infix 4 `app`+app :: (a -> b) -> a -> b+f `app` x = f x
+ test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-splice-pattern.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module InfixFunlhsThSplicePattern where++$splice `fn` () = ()
+ test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-variants.hs view
@@ -0,0 +1,26 @@+{- ORACLE_TEST pass -}+{- Test infix function definitions with TemplateHaskell -}+{-# LANGUAGE TemplateHaskell #-}+module InfixFunlhsThVariants where++-- Basic infix with operator symbol+infixl 6 <+>+(<+>) :: Int -> Int -> Int+x <+> y = x + y++-- Infix with multiple patterns after parenthesized operator+infixr 5 </>+(</>) :: Path b Dir -> Path Rel t -> Path b t+(</>) (Path a) (Path b) = Path (a ++ b)++-- Infix with wildcards+infix 4 `matches`+matches :: String -> String -> Bool+[] `matches` [] = True+_ `matches` _ = False++-- Multiple equations with infix+infixr 3 ***+(***) :: Int -> Int -> Int+x *** 0 = 0+x *** y = x + (x *** (y - 1))
+ test/Test/Fixtures/oracle/TemplateHaskell/negated-splice-spaced.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module NegatedSpliceSpaced where++x = - $a
+ test/Test/Fixtures/oracle/TemplateHaskell/th-empty-list-name-quote.hs view
@@ -0,0 +1,20 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module THEmptyListNameQuote where++import Language.Haskell.TH++-- TH value name quote for the empty list constructor+emptyListName :: Name+emptyListName = '[]++-- TH type name quote for the list type constructor+listTypeName :: Name+listTypeName = ''[]++-- Both in a where clause to exercise layout interaction+f :: Name -> Name+f x = result+  where+    result = if x == '[] then ''[] else x
+ test/Test/Fixtures/oracle/TemplateHaskell/th-empty-list-quote-after-arrow.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module X where++import Language.Haskell.TH++headOfType ArrowT = ''(->)+headOfType ListT = ''[]
+ test/Test/Fixtures/oracle/TemplateHaskell/th-quote-promoted-arrow.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module THQuotePromotedArrow where++f = ''(->)
+ test/Test/Fixtures/oracle/TemplateHaskell/th-quote-tick-operator.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE DataKinds #-}++module THQuoteTickOperator where++type (:>) a b = '(a, b)++test = ''(:>)
+ test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_data_decl.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Decl_Quote_Data_Decl where++import Language.Haskell.TH (Dec, Q)++decl :: Q [Dec]+decl = [d| data Nat = Z |]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_empty.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Decl_Quote_Empty where++import Language.Haskell.TH (Dec, Q)++-- Empty declaration quotes are valid syntax+emptyDecls :: Q [Dec]+emptyDecls = [d| |]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_gadt.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+module TH_Decl_Quote_GADT where++import Language.Haskell.TH (Dec, Q)++decl :: Q [Dec]+decl = [d|+  data Expr a where+    Lit :: Int -> Expr Int+    Add :: Expr Int -> Expr Int -> Expr Int+  |]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_guard_fun_sig.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++-- Guard expression inside a TH declaration quote with a function-type+-- annotation.  The '->' in 'Int -> Bool' must be parsed as a function+-- type arrow, not confused with a case alternative arrow.  Regression+-- test for a parser bug that caused the outer declaration to misparse+-- when the inner guarded RHS contained ':: T -> T2'.++module THDeclQuoteGuardFunSig where++f = [d|y | z :: Int -> Bool = z|]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_in_do.hs view
@@ -0,0 +1,15 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module TH_Decl_Quote_In_Do where++import Language.Haskell.TH (Dec, Q)++-- Declaration quote inside a do block+mkDecls :: Q [Dec]+mkDecls = do+  let x = 1+  [d|+    val :: Int+    val = 42+    |]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_mixed_semi.hs view
@@ -0,0 +1,17 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module TH_Decl_Quote_Mixed_Semi where++import Language.Haskell.TH (Dec, Q)++-- Mixed explicit semicolons and newlines+mkDecls :: Q [Dec]+mkDecls =+  [d|+    x :: Int+    x = 1++    y :: Int+    y = 2+    |]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_multi_newlines.hs view
@@ -0,0 +1,17 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module TH_Decl_Quote_Multi_Newlines where++import Language.Haskell.TH (Dec, Q)++-- Multiple declarations separated by newlines (layout)+mkDecls :: Q [Dec]+mkDecls =+  [d|+    foo :: Int -> Int+    foo x = x + 1++    bar :: String+    bar = "hello"+    |]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_multiple.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Decl_Quote_Multiple where++import Language.Haskell.TH (Dec, Q)++decl :: Q [Dec]+decl = [d| data Nat = Z | S Nat |]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_newtype.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Decl_Quote_Newtype where++import Language.Haskell.TH (Dec, Q)++decl :: Q [Dec]+decl = [d| newtype Wrapper a = Wrapper a |]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_record.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Decl_Quote_Record where++import Language.Haskell.TH (Dec, Q)++decl :: Q [Dec]+decl = [d|+  data Person = Person+    { name :: String+    , age :: Int+    }+  |]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_type_synonym.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Decl_Quote_Type_Synonym where++import Language.Haskell.TH (Dec, Q)++decl :: Q [Dec]+decl = [d| type StringList = [String] |]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_with_sig.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module THDeclQuoteWithSig where++import Language.Haskell.TH++mkX0 :: DecsQ+mkX0 =+  [d|+    x :: s -> b+    x = undefined+    |]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_implicit_splice_decl.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Implicit_Splice_Decl where++return []
+ test/Test/Fixtures/oracle/TemplateHaskell/th_negated_typed_splice_type_app.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+module TH_Negated_Typed_Splice_TypeApp where++-- Regression test: negation of a type-applied typed splice.+-- The pretty-printer must parenthesize the argument of ENegate when it+-- starts with a TH typed splice ($$), even after a type application is+-- applied to it, so that the lexer does not merge '-' and '$$' into the+-- single operator token '-$$'.+--+-- Without the fix, addDeclParens produced  f = -$$("") @C+-- which the lexer tokenised as TkVarSym "-$$", causing a parse failure.+-- With the fix it produces  f = -($$("") @C)  which round-trips correctly.+f = -($$("") @C)+g = -($$expr @T)
+ test/Test/Fixtures/oracle/TemplateHaskell/th_nested_splice.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Nested_Splice where++x = [| 1 + $y |]+z = [|| 1 + $$y ||]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_operator_splice_e.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Operator_Splice_E where++x = $(&&)+y = $(+)
+ test/Test/Fixtures/oracle/TemplateHaskell/th_operator_splice_p.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Operator_Splice_P where++x $(*) = ()
+ test/Test/Fixtures/oracle/TemplateHaskell/th_promoted_cons_edge_cases.hs view
@@ -0,0 +1,33 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module TH_Promoted_Cons_Edge_Cases where++-- Test 1: TH quote followed by promoted cons in same module+''Int++f1 :: x (a ': b ': c)+f1 = undefined++-- Test 2: Nested promoted cons+f2 :: x (a ': (b ': c))+f2 = undefined++-- Test 3: Multiple TH quotes before promoted cons+''Bool+''Char+f3 :: x (a ': b)+f3 = undefined++-- Test 4: Promoted cons in function type signature+f4 :: (a ': b) -> (c ': d)+f4 = undefined++-- Test 5: Promoted cons with complex types+data Foo+data Bar++f5 :: x (Foo ': Bar ': '[])+f5 = undefined
+ test/Test/Fixtures/oracle/TemplateHaskell/th_quote_then_promoted_cons.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module TH_Quote_Then_Promoted_Cons where++data FSDir+''FSDir++f :: x (FSDir ': r)+f = undefined
+ test/Test/Fixtures/oracle/TemplateHaskell/th_singletons_type_sig.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module THSingletonsWithTypeSig where++x =+  singletons+    [d|+      f :: Int -> Int+      f y = y+      |]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_splice_decl.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Splice_Decl where++$decl++$(makeLenses ''Foo)
+ test/Test/Fixtures/oracle/TemplateHaskell/th_splice_e.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Splice_E where++x = $expr+y = $(expr arg)
+ test/Test/Fixtures/oracle/TemplateHaskell/th_splice_p.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Splice_P where++f $pat = True+g $(pat arg) = False
+ test/Test/Fixtures/oracle/TemplateHaskell/th_splice_t.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Splice_T where++type T = $typ+type U = $(typ arg)
+ test/Test/Fixtures/oracle/TemplateHaskell/th_type_splice_decl_quote_infix_body.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++module TH_TypeSpliceDeclQuoteInfixBody where++x = [d| instance Show $(return $ ConT name) where show _ = abbrev |]
+ test/Test/Fixtures/oracle/TemplateHaskell/th_typed_splice.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module TH_Typed_Splice where++x = $$expr+y = $$(expr arg)
+ test/Test/Fixtures/oracle/TemplateHaskell/th_value_quote_still_works.hs view
@@ -0,0 +1,30 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++module TH_Value_Quote_Not_Broken where++-- Test that regular TH value quotes still work+valueQuote = 'justConstructor++justConstructor :: Maybe a -> Bool+justConstructor (Just _) = True+justConstructor Nothing = False++-- Test TH type quotes+typeQuote = ''Int++-- Test promoted cons in types (should work alongside TH)+data HList (xs :: [*])++cons :: HList (a ': b)+cons = undefined++-- Test promoted empty list+empty :: HList '[]+empty = undefined++-- Test promoted list syntax+list :: HList '[Int, Bool]+list = undefined
+ test/Test/Fixtures/oracle/TemplateHaskell/top-level-infix-splices.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}++$(fmap concat $ mapM deriveOnce [1..7])+concat <$> uncurry mkMap `mapM` [ (i, n) | n <- [2 .. 10], i <- [0 .. n - 1] ]
+ test/Test/Fixtures/oracle/TemplateHaskell/type-quote-constrained-signature.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module TypeQuoteConstrainedSignature where++x = [t| C |] :: (:+) => ()
+ test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_all_quote_forms.hs view
@@ -0,0 +1,38 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskellQuotes #-}++module THQ_All_Quote_Forms where++import Language.Haskell.TH (Dec, Name, Pat, Type)+import Language.Haskell.TH.Syntax (Code, Exp, Q)++exprSplice :: Q Exp+exprSplice = $x++typedExprSplice :: Code Q Int+typedExprSplice = $$x++exprQuote :: Q Exp+exprQuote = [|expr|]++typedExprQuote :: Code Q Int+typedExprQuote = [||expr||]++declQuote :: Q [Dec]+declQuote = [d|quotedDecl = 1|]++typeQuote :: Q Type+typeQuote = [t|Maybe Int|]++patQuote :: Q Pat+patQuote = [p|Just patName|]++nameQuote :: Name+nameQuote = 'id++typeNameQuote :: Name+typeNameQuote = ''Maybe++$(topLevelExprSplice)++$$(topLevelTypedExprSplice)
+ test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_arrow_type.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase, TemplateHaskellQuotes #-}++module THQuoteArrowType where++data Type = ArrowT | AppT Type Type++headOfType :: Type -> Name+headOfType = \case+  ArrowT -> ''(->)+  AppT t _ -> headOfType t
+ test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_name_quote.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskellQuotes #-}+module THQ_Name_Quote where++fName = 'map+trueName = 'True+fNameSpace = ' map
+ test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_op_quote.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskellQuotes #-}+module THQ_Op_Quote where++opName = '(+)+conOpName = '(:)
+ test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_paren_op.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE TemplateHaskell #-}++module THQuoteTickOperator where++f = ''(:>)
+ test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_d.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskellQuotes #-}+module THQ_Quote_D where++decl = [d| f x = x |]
+ test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_e.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskellQuotes #-}+module THQ_Quote_E where++f = [| 1 + 2 |]+g = [e| 1 + 2 |]
+ test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_p.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskellQuotes #-}+module THQ_Quote_P where++pat = [p| Just x |]
+ test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_t.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskellQuotes #-}+module THQ_Quote_T where++typ = [t| Int -> Int |]
+ test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_type_quote.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskellQuotes #-}+module THQ_Type_Quote where++tName = ''Int+cName = ''Eq+tNameSpace = ''Int
+ test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_typed_quote.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskellQuotes #-}+module THQ_Typed_Quote where++tq = [|| 1 + 2 ||]+tqe = [e|| 1 + 2 ||]
+ test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_typed_splice.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskellQuotes #-}++module THQ_Typed_Splice where++import Language.Haskell.TH.Syntax (Code, Q)++x :: Code Q Int+x = $$x
+ test/Test/Fixtures/oracle/TemplateHaskellQuotes/type-quote-splice-type-application.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module TypeQuoteSpliceTypeApplication where++import Language.Haskell.TH++data a := b++f c v = [t|$c := $v|]
+ test/Test/Fixtures/oracle/TransformListComp/group-after-guard.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}+module GroupAfterGuard where+import GHC.Exts (groupWith)+f xs = [ x | x <- xs, x > 0, then group by x using groupWith ]
+ test/Test/Fixtures/oracle/TransformListComp/group-by-using.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}+module GroupByUsing where+import GHC.Exts (the, groupWith)+f xs = [ (the x, y) | x <- xs, y <- ys, then group by x using groupWith ]
+ test/Test/Fixtures/oracle/TransformListComp/group-using.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}+module GroupUsing where+f xs = [ x | x <- xs, then group using inits ]
+ test/Test/Fixtures/oracle/TransformListComp/let-before-group.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}+module LetBeforeGroup where+import GHC.Exts (the, groupWith)+f xs = [ (the k, vs) | x <- xs, let k = fst x, let vs = snd x, then group by k using groupWith ]
+ test/Test/Fixtures/oracle/TransformListComp/multiple-transforms.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}+module MultipleTransforms where+import GHC.Exts (the, groupWith, sortWith)+output = [ (the dept, sum salary)+         | (name, dept, salary) <- employees+         , then group by dept using groupWith+         , then sortWith by (sum salary)+         , then take 5 ]
+ test/Test/Fixtures/oracle/TransformListComp/then-by-closed-boundaries.hs view
@@ -0,0 +1,20 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TransformListComp #-}+{-# LANGUAGE TypeApplications #-}++module ThenByClosedBoundaries where++closedApp xs = [x | x <- xs, then f x by x]++closedNegate xs = [x | x <- xs, then -x by x]++closedTypeApp xs = [x | x <- xs, then f @T by x]++closedValueNameQuote xs = [x | x <- xs, then '[] by x]++closedTypeNameQuote xs = [x | x <- xs, then ''T by x]++groupByClosedApp xs = [x | x <- xs, then group by f x using g]++type T = ()
+ test/Test/Fixtures/oracle/TransformListComp/then-by-complex-expr.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}+module ThenByComplexExpr where+f xs = [ (x, y) | x <- xs, y <- ys, then sortWith by (x + y) ]
+ test/Test/Fixtures/oracle/TransformListComp/then-by-lambda-case.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TransformListComp #-}++module TransformListCompThenByLambdaCase where++x = [ []+    | let _ = []+    , then []+      `a` \case+        _ -> [] by []+    ]
+ test/Test/Fixtures/oracle/TransformListComp/then-f-by-e.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}+module ThenFByE where+f xs = [ x | x <- xs, then sortWith by x ]
+ test/Test/Fixtures/oracle/TransformListComp/then-f-single.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}+module ThenFSingle where+f xs = [ x | x <- xs, then reverse ]
+ test/Test/Fixtures/oracle/TransformListComp/then-f.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}+module ThenF where+f xs = [ x | x <- xs, then take 5 ]
+ test/Test/Fixtures/oracle/TransformListComp/then-infix-expr.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}+module ThenInfixExpr where+f xs = [ x | x <- xs, then reverse . sort ]
+ test/Test/Fixtures/oracle/TransformListComp/then-paren-fn.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}+module ThenParenFn where+f xs = [ x | x <- xs, then (take 3) ]
+ test/Test/Fixtures/oracle/TransformListComp/then-qualified-fn.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}+module ThenQualifiedFn where+f xs = [ x | x <- xs, then Data.List.sort ]
+ test/Test/Fixtures/oracle/TuplePatterns/list-comp.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+module TuplePatterns where++f = [(,) x () | (,) x () <- []]
+ test/Test/Fixtures/oracle/TupleSections/tuple-section-left.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TupleSections #-}++module TupleSectionLeft where++pairWithOne :: Int -> (Int, Int)+pairWithOne = (1,)
+ test/Test/Fixtures/oracle/TupleSections/tuple-section-middle.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TupleSections #-}++module TupleSectionMiddle where++fillMiddle :: Int -> (Int, Int, Int)+fillMiddle = (,2,)
+ test/Test/Fixtures/oracle/TupleSections/tuple-section-nested.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TupleSections #-}++module TupleSectionNested where++nested :: Int -> ((Int, Int), Int)+nested = ((,3),)
+ test/Test/Fixtures/oracle/TupleSections/tuple-section-right.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TupleSections #-}++module TupleSectionRight where++pairWithLast :: Int -> (Int, Int)+pairWithLast = (,1)
+ test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction-chained-application.hs view
@@ -0,0 +1,17 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeAbstractions #-}++module TypeSynonymAbstractionChainedApplication where++import Data.Kind (Type)++type PairType :: forall k. (k -> Type) -> (k -> Type) -> k -> Type+data PairType f g a++type IOWitness :: forall k. k -> Type+data IOWitness a++type Witnessed :: forall k. k -> Type+type Witnessed @k = PairType @k (IOWitness @k) (IOWitness @k)
+ test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction-parenthesized-partial-application.hs view
@@ -0,0 +1,17 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeAbstractions #-}++module TypeSynonymAbstractionParenthesizedPartialApplication where++import Data.Kind (Type)++type PairType :: forall k. (k -> Type) -> k -> Type+data PairType f a++type IOWitness :: forall k. k -> Type+data IOWitness a++type Witnessed :: forall k. k -> Type+type Witnessed @k = (PairType @k) IOWitness
+ test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction-partial-application.hs view
@@ -0,0 +1,17 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeAbstractions #-}++module TypeSynonymAbstractionPartialApplicationXFail where++import Data.Kind (Type)++type PairType :: forall k. (k -> Type) -> k -> Type+data PairType f a++type IOWitness :: forall k. k -> Type+data IOWitness a++type Witnessed :: forall k. k -> Type+type Witnessed @k = PairType @k IOWitness
+ test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeAbstractions #-}++module TypeSynonymAbstraction where++import Data.Kind (Type)++data Proxy (a :: k) = Proxy++type Witnessed :: forall k. (k -> Type) -> k -> Type+type Witnessed @k (f :: k -> Type) (a :: k) = Proxy a
+ test/Test/Fixtures/oracle/TypeApplications/type-applications-chained.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+module TypeApplicationsChained where++f :: a -> b -> a+f x _ = x++x :: Int+x = f @Int @Bool 1 True
+ test/Test/Fixtures/oracle/TypeApplications/type-applications-expr-basic.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeApplications #-}+module TypeApplicationsExprBasic where++f :: a -> b -> a+f x _ = x++h :: (Int, Int)+h = (f 2 @Int 3, f @Int @Bool 1 True)
+ test/Test/Fixtures/oracle/TypeApplications/type-applications-let-where.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeApplications #-}+module TypeApplicationsLetWhere where++f :: a -> a+f x = x++g :: Int+g = let y = f @Int 1 in y++h :: Int+h = result+  where result = f @Int 2
+ test/Test/Fixtures/oracle/TypeApplications/type-applications-list-type.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeApplications #-}+module TypeApplicationsListType where++f :: a -> a+f x = x++x :: [Int]+x = f @[Int] [1, 2, 3]
+ test/Test/Fixtures/oracle/TypeApplications/type-applications-no-space.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeApplications #-}+module TypeApplicationsNoSpace where++f :: a -> a+f x = x++x :: Int+x = f @Int 1
+ test/Test/Fixtures/oracle/TypeApplications/type-applications-paren-type.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeApplications #-}+module TypeApplicationsParenType where++f :: a -> a+f x = x++x :: Maybe Int+x = f @(Maybe Int) (Just 1)
+ test/Test/Fixtures/oracle/TypeApplications/visible-type-application-star-is-type.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++data Proxy (a :: *) = Proxy++x :: Proxy (*)+x = Proxy @(*)
+ test/Test/Fixtures/oracle/TypeData/basic.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeData #-}+module Basic where++type data Nat = Zero | Succ Nat
+ test/Test/Fixtures/oracle/TypeFamilies/associated-data-family-infix-instance.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module AssociatedDataFamilyInfixInstance where++data X = X++class C a where+  data a :->: b++instance C X where+  data a :->: b = VoidTrie
+ test/Test/Fixtures/oracle/TypeFamilies/associated-data-infix-operator.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module AssociatedDataInfixOperator where++class C a where+  data x :*: y :: *
+ test/Test/Fixtures/oracle/TypeFamilies/associated-data.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module AssociatedData where++import Data.Kind (Type)++class GMapKey k where+  data GMap k :: Type -> Type
+ test/Test/Fixtures/oracle/TypeFamilies/associated-type-default.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}++module AssociatedTypeDefault where++-- Type family default equation without 'instance' keyword.+-- GHC allows: type F a = <rhs> inside a class body as shorthand for+-- type instance F a = <rhs>.+class Foo n where+  type O n+  type O n = Int
+ test/Test/Fixtures/oracle/TypeFamilies/associated-type-injectivity.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-}+module AssociatedTypeInjectivity where++class C a where+  type Elem a = r | r -> a
+ test/Test/Fixtures/oracle/TypeFamilies/associated-type.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module AssociatedType where++import Data.Kind (Type)++class Collects ce where+  type Elem ce :: Type
+ test/Test/Fixtures/oracle/TypeFamilies/basic.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module Basic where++type family F a
+ test/Test/Fixtures/oracle/TypeFamilies/closed-type-family-forall.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies, ExplicitForAll #-}+module ClosedTypeFamilyForAll where++type family R a where+  forall t a. R (t a) = [a]+  forall a.   R a     = a
+ test/Test/Fixtures/oracle/TypeFamilies/closed-type-family.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module ClosedTypeFamily where++type family F a where+  F Int = String+  F a = a
+ test/Test/Fixtures/oracle/TypeFamilies/data-family-index.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module DataFamilyIndex where++import Data.Kind (Type)++data family GMap k :: Type -> Type
+ test/Test/Fixtures/oracle/TypeFamilies/data-family.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module DataFamily where++data family D a
+ test/Test/Fixtures/oracle/TypeFamilies/data-instance-gadt.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies, GADTs #-}+module DataInstanceGADT where++data family G a b+data instance G [a] b where+   G1 :: c -> G [Int] b+   G2 :: G [a] Bool
+ test/Test/Fixtures/oracle/TypeFamilies/data-instance-in-class-instance.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}++module DataInstanceInClassInstance where++import qualified Data.Map as Map++class Lookupable v where+    data Lookup v a++instance Lookupable (Map.Map k v) where+    data instance Lookup (Map.Map k v) a = LookupResult (Maybe a)
+ test/Test/Fixtures/oracle/TypeFamilies/data-instance-kind-signature.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}++module DataInstanceKindSignature where++import Data.Kind (Type)++data family Fam a :: Type -> Type++data instance Fam () :: Type -> Type where+  F :: Fam () Int
+ test/Test/Fixtures/oracle/TypeFamilies/data-instance.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module DataInstance where++data family GMap k v+data instance GMap (Either a b) v = GMapEither (GMap a v) (GMap b v)
+ test/Test/Fixtures/oracle/TypeFamilies/default-associated-type-wildcard.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module DefaultAssociatedTypeWildcard where++class C a where+  type F a+  type F _ = ()
+ test/Test/Fixtures/oracle/TypeFamilies/default-type-instance.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module DefaultTypeInstance where++class IsBoolMap v where+  type Key v+  type instance Key v = Int
+ test/Test/Fixtures/oracle/TypeFamilies/explicit-forall.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies, ExplicitForAll, PolyKinds #-}+module ExplicitForAll where++data family F a+data instance forall a (b :: Proxy a). F (Proxy b) = FProxy Bool
+ test/Test/Fixtures/oracle/TypeFamilies/infix-type-family-equation.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module InfixTypeFamilyEquation where++type family a ** b where+  a ** b = ()
+ test/Test/Fixtures/oracle/TypeFamilies/infix-type-family-head.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module InfixTypeFamilyHead where++type family l `And` r where+  l `And` r = l
+ test/Test/Fixtures/oracle/TypeFamilies/infix-type-family-symbol.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module InfixTypeFamilySymbol where++type family (***) a b
+ test/Test/Fixtures/oracle/TypeFamilies/multiline-import-type-family.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+import Generic.Data.Function.FoldMap.Constructor+  ( GFoldMapC(gFoldMapC)+  , GenericFoldMap(type GenericFoldMapM) )
+ test/Test/Fixtures/oracle/TypeFamilies/multiple-associated-instances.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module MultipleAssociatedInstances where++class GMapKey k where+  data GMap k v++data Flob++instance GMapKey Flob where+  data GMap Flob [v] = G1 v+  data GMap Flob Int = G2 Int
+ test/Test/Fixtures/oracle/TypeFamilies/newtype-instance-in-class-instance.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}++module NewtypeInstanceInClassInstance where++import qualified Data.Map as Map++class Wrappable v where+    type Wrap v a++instance Wrappable (Map.Map k v) where+    newtype instance Wrap (Map.Map k v) a = WrapResult (Maybe a)
+ test/Test/Fixtures/oracle/TypeFamilies/newtype-instance.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module NewtypeInstance where++data family T a+newtype instance T Char = TC Bool
+ test/Test/Fixtures/oracle/TypeFamilies/paren-infix-type-family-backtick.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}++module ParenInfixTypeFamilyBacktick where++type family (a `And` b)
+ test/Test/Fixtures/oracle/TypeFamilies/paren-infix-type-family-with-result-sig.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}++module ParenInfixTypeFamilyWithResultSig where++type family ((a :: [k]) ++ (b :: [k])) :: [k]
+ test/Test/Fixtures/oracle/TypeFamilies/polykinded-type-family.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies, PolyKinds #-}+module PolykindedTypeFamily where++type family J a :: k+type instance J Int = Bool+type instance J Int = Maybe
+ test/Test/Fixtures/oracle/TypeFamilies/promoted-types-in-equations.hs view
@@ -0,0 +1,27 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds, TypeFamilies, KindSignatures #-}+module PromotedTypesInTypeFamilyEquations where++-- Type family with promoted empty list in equation+type family HeadList (xs :: [*]) :: * where+  HeadList '[] = Int+  HeadList (x ': xs) = x++-- Type family with promoted cons in equation+type family Append (xs :: [*]) (ys :: [*]) :: [*] where+  Append '[] ys = ys+  Append (x ': xs) ys = x ': Append xs ys++-- Type family with promoted tuple+type family FstPair (a :: *) (b :: *) :: * where+  FstPair '(a, b) = a++-- Type family with promoted constructor+type family IsTrue (b :: Bool) where+  IsTrue 'True = Int+  IsTrue 'False = Char++-- Type family combining [*] kind parameter and promoted equations+type family F (xs :: [*]) (r :: *) :: * where+  F '[] r = r+  F (x ': xs) r = x
+ test/Test/Fixtures/oracle/TypeFamilies/star-list-kind-equations.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds, TypeFamilies #-}+module StarListKindTypeFamily where++type family F (xs :: [*]) (r :: *) :: * where+  F '[] r = r
+ test/Test/Fixtures/oracle/TypeFamilies/type-equality-family-application.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module TypeEqualityFamilyApplication where++type family IsUpperCased a++data No+data Upper+data Cased a b++class Casing a++upperCased :: (Casing b, IsUpperCased a ~ No) => Cased a b -> Cased Upper b+upperCased = undefined
+ test/Test/Fixtures/oracle/TypeFamilies/type-family-arity.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module TypeFamilyArity where++import Data.Kind (Type)++type family F a b :: Type -> Type
+ test/Test/Fixtures/oracle/TypeFamilies/type-family-equation-backtick-operator.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module TypeFamilyEquationBacktickOperator where++type family F a where+  F a = And l r++type family And l r where+  And l r = l
+ test/Test/Fixtures/oracle/TypeFamilies/type-family-function-instance.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}++module TypeFamilyFunctionInstance where++import qualified Data.Map as Map++instance Ord k => Function (Map.Map k v) where+    type instance Domain (Map.Map k v) = k+    type instance Codomain (Map.Map k v) = Maybe v
+ test/Test/Fixtures/oracle/TypeFamilies/type-family-infix-star-equation.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoStarIsType #-}++type family (a :: ExactPi') * (b :: ExactPi') :: ExactPi' where+  'ExactPi z p q * 'ExactPi z' p' q' = 'ExactPi undefined undefined undefined
+ test/Test/Fixtures/oracle/TypeFamilies/type-family-unicode-quote.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}++type family Map (f :: k -> l) (xs :: [k]) = (ys :: [l]) where+  Map f (x ': xs) = f x ': Map f xs+  Map f '[] = '[]
+ test/Test/Fixtures/oracle/TypeFamilies/type-instance-rhs-kind-annotation.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}++module TypeInstanceRhsKindAnnotation where++import Data.Kind (Type)++type instance Sing = SIndex as a :: Index as a -> Type
+ test/Test/Fixtures/oracle/TypeFamilies/type-instance.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module TypeInstance where++type family Elem c+type instance Elem [e] = e
+ test/Test/Fixtures/oracle/TypeFamilies/unpos-promoted-tuple.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}++module UnPosPromotedTuple where++type family UnPos (x :: k1) :: k2 where+  UnPos ('Pos x) = x+  UnPos '( 'Pos x, 'Pos y) = '(x, y)
+ test/Test/Fixtures/oracle/TypeFamilies/wildcards.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeFamilies #-}+module Wildcards where++import Data.Kind (Type)++data family F a b :: Type+data instance F Int _ = FInt Int++type family T a :: Type+type instance T (a,_) = a++newtype instance F Bool a = FBoolA (a -> Int)
+ test/Test/Fixtures/oracle/TypeLevelOperators/constraint-implication.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators, DataKinds #-}+class (ks :: [(Type -> Type -> Type) -> Constraint]) |- (k :: (Type -> Type -> Type) -> Constraint) where+  implies :: Satisfies p ks => (k p => p a b) -> p a b
+ test/Test/Fixtures/oracle/TypeLevelOperators/parenthesized-minus-operator.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}++module ParenthesizedMinusOperator where++f :: Int (-) String+f = undefined
+ test/Test/Fixtures/oracle/TypeLevelOperators/subtraction-in-constraint.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE DataKinds #-}++import GHC.TypeNats++f :: KnownNat (n - m) => proxy n -> proxy m+f = undefined
+ test/Test/Fixtures/oracle/TypeLevelOperators/subtraction-type-signature.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}++module TypeLevelSubtractionSignature where++f :: Int - String -> Bool+f = undefined
+ test/Test/Fixtures/oracle/TypeLevelOperators/subtraction-type-synonym.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}++module TypeLevelSubtractionSynonym where++type a - b = Either a b++f :: Int - String+f = undefined
+ test/Test/Fixtures/oracle/TypeOperators/constraint-operator-class.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}++module ConstraintOperatorClass where++class (c1 a, c2 a) => (:&&:) c1 c2 a
+ test/Test/Fixtures/oracle/TypeOperators/infix-constructor-boxed-pair.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}++module InfixConstructorBoxedPair where++data D = (a, b) :. Int
+ test/Test/Fixtures/oracle/TypeOperators/infix-constructor-boxed-unit.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}++module InfixConstructorBoxedUnit where++data D = () :. Int
+ test/Test/Fixtures/oracle/TypeOperators/infix-data-head-kinded-binders.hs view
@@ -0,0 +1,17 @@+{- ORACLE_TEST pass -}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}++module InfixDataHeadKindedBinders where++import Data.Kind (Type)+import GHC.TypeLits (Symbol)++data ListKey a++data (key :: Symbol) := (value :: Type)+  where+    (:=) :: ListKey a -> b -> a := b
+ test/Test/Fixtures/oracle/TypeOperators/infix-instance-head-type-app.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}++module InfixInstanceHeadTypeApp where++class a :=> b where+  ins :: a -> b++instance Class b a => () :=> Class b a where+  ins = Sub Dict
+ test/Test/Fixtures/oracle/TypeOperators/star-is-type-application-signature.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++data Proxy a = Proxy++mulProxy :: Proxy a -> Proxy b -> Proxy (a * b)+mulProxy _ _ = Proxy
+ test/Test/Fixtures/oracle/TypeOperators/type-compose-constraint.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}++module TypeComposeConstraint where++import Data.Functor.Compose++class (f (g x)) => (f `Compose` g) x
+ test/Test/Fixtures/oracle/TypeOperators/type-family-operator-extended.hs view
@@ -0,0 +1,19 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators, TypeFamilies #-}++-- Additional test cases for type families with operator names.++module TypeFamilyOperatorExtended where++-- Parenthesized variable operator (starts with non-:)+type family (++) a b++-- Parenthesized constructor operator (starts with :)+type family (:++:) a b++-- Type family with operator and kind signature+type family (<?>) a b :: Bool++-- Multiple type families with operators+type family (<>) a b+type family (><) a b c
+ test/Test/Fixtures/oracle/TypeOperators/type-family-operator.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators, TypeFamilies #-}++-- Type families with operator names are supported.++module TypeFamilyOperator where++type family (++) a b
+ test/Test/Fixtures/oracle/TypeOperators/type-operator-class.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}++module TypeOperatorClass where++infix 4 :=:+class a :=: b where+  proof :: a -> b -> ()
+ test/Test/Fixtures/oracle/TypeOperators/type-operator-data-infix.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}++module TypeOperatorDataInfix where++infixr 5 :+:+data a :+: b = InL a | InR b
+ test/Test/Fixtures/oracle/TypeOperators/type-operator-data.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++module TypeOperatorData where++data (f :+: g) e = Left' (f e) | Right' (g e)
+ test/Test/Fixtures/oracle/TypeOperators/type-operator-gadt-constraint.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+module TypeLevelKVList where++data (:=) key v++data KVList xs where+  KVCons :: KnownSymbol key => key := v -> KVList xs -> KVList ((key := v) ': xs)
+ test/Test/Fixtures/oracle/TypeOperators/type-operator-qualified-constraint.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds, TypeOperators #-}+module TypeOperatorQualifiedConstraint where++import GHC.TypeLits++f :: (1 <= 2) => ()+f = ()
+ test/Test/Fixtures/oracle/TypeOperators/type-operator-signature.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}++module TypeOperatorSignature where++infixr 5 :+:+data a :+: b = L a | R b++foldEither :: (a -> c) -> (b -> c) -> (a :+: b) -> c+foldEither f _ (L a) = f a+foldEither _ g (R b) = g b
+ test/Test/Fixtures/oracle/TypeOperators/type-operator-type-synonym-paren.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}++module TypeOperatorTypeSynonymParen where++type (:+:) = (,)++usePlus :: Int :+: Int+usePlus = (1, 2)
+ test/Test/Fixtures/oracle/TypeOperators/type-operator-type-synonym.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}++module TypeOperatorTypeSynonym where++infixr 6 :*:+type a :*: b = (a, b)
+ test/Test/Fixtures/oracle/TypeOperators/type-synonym-operator-kinded-params.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}++module TypeSynonymOperatorKindedParams where++type (a :: k1) <= (b :: k2) = (a <=? b) ~ 'True
+ test/Test/Fixtures/oracle/TypeOperators/type-variable-operator-type-synonym.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}++module TypeVariableOperatorTypeSynonym where++type f ~> g = f -> g
+ test/Test/Fixtures/oracle/TypeSignatureGuards/constructor-equation.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module TypeSignatureGuardsConstructorEquation where++C :: D = C
+ test/Test/Fixtures/oracle/TypeSignatureGuards/where-clause.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+module TypeSignatureGuards where++f = y+  where+    y :: Int+      | True = 1
+ test/Test/Fixtures/oracle/UnboxedSums/basic.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedSums #-}+module Basic where++x = (# 1 | #)+y = (# | 2 #)
+ test/Test/Fixtures/oracle/UnboxedSums/multiway-if-expression.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE UnboxedSums #-}++module MultiWayIfExpression where++x = (# | if | True -> () #)
+ test/Test/Fixtures/oracle/UnboxedSums/newtype-maybe-hash-unboxed-sum.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ExplicitForAll #-}++module NewtypeMaybeHashUnboxedSum where++newtype Maybe# :: forall (r :: RuntimeRep). TYPE r -> TYPE ('SumRep '[ 'TupleRep '[], r]) where+  Maybe# :: forall (r :: RuntimeRep) (a :: TYPE r). (# (# #) | a #) -> Maybe# @r a
+ test/Test/Fixtures/oracle/UnboxedSums/pattern.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedSums #-}+module Pattern where++f x = case x of+  (# | y #) -> y+  (# y | #) -> y
+ test/Test/Fixtures/oracle/UnboxedSums/type.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedSums #-}+module Type where++f :: (# Int | Int #) -> Int+f (# x | #) = x+f (# | y #) = y
+ test/Test/Fixtures/oracle/UnboxedSums/unboxed-sum-list-comp.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ParallelListComp #-}+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedSums #-}++module UnboxedSumListComp where++-- List comprehension nested inside an unboxed sum expression.+-- The first | is the comprehension qualifier separator;+-- the second | is the unboxed sum alternative separator.+x src = (# [e | e <- src] | #)
+ test/Test/Fixtures/oracle/UnboxedTuples/basic.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedTuples #-}+module Basic where++x = (# 1, 2 #)
+ test/Test/Fixtures/oracle/UnboxedTuples/case-in-unboxed-tuple.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedTuples #-}+module CaseInUnboxedTuple where++f x = (# case x of y -> y #)
+ test/Test/Fixtures/oracle/UnboxedTuples/infix-constructor-unboxed-singleton.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnboxedTuples #-}++module InfixConstructorUnboxedSingleton where++data D = (# a #) :. Int
+ test/Test/Fixtures/oracle/UnboxedTuples/infix-constructor-unboxed-unit.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnboxedTuples #-}++module InfixConstructorUnboxedUnit where++data D = (# #) :. Int
+ test/Test/Fixtures/oracle/UnboxedTuples/layout-expressions.hs view
@@ -0,0 +1,25 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE LambdaCase #-}+module LayoutExpressions where++-- do expression in unboxed tuple+f1 = (# do x <- pure 1; pure x #)++-- if expression in unboxed tuple+f2 x = (# if x then 1 else 2 #)++-- let expression in unboxed tuple+f3 = (# let y = 1 in y #)++-- lambda in unboxed tuple+f4 = (# \x -> x + 1 #)++-- lambda-case in unboxed tuple+f5 = (# \case 0 -> "zero"; _ -> "other" #)++-- nested case in unboxed tuple+f6 x y = (# case x of { 0 -> case y of { 0 -> 0; _ -> 1 }; _ -> 2 } #)++-- multiple layout expressions in unboxed tuple+f7 x = (# case x of y -> y, do pure 1 #)
+ test/Test/Fixtures/oracle/UnboxedTuples/multiline-explicit-layout.hs view
@@ -0,0 +1,23 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedTuples #-}+module MultilineExplicitLayout where {++x :: Int -> (# Int, Int #);+x n =+  (#+    n+  , 2+  #);++f :: (# Int, Int #) -> Int;+f+  (# a+   , _+   #) = a;++g :: (# Int+      , Int #) -> (# Int+                  , Int #);+g t = t++}
+ test/Test/Fixtures/oracle/UnboxedTuples/multiline-implicit-layout.hs view
@@ -0,0 +1,21 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedTuples #-}+module MultilineImplicitLayout where++x :: Int -> (# Int, Int #)+x n =+  (#+    n+  , 2+  #)++f :: (# Int, Int #) -> Int+f+  (# a+   , _+   #) = a++g :: (# Int+      , Int #) -> (# Int+                  , Int #)+g t = t
+ test/Test/Fixtures/oracle/UnboxedTuples/pattern.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedTuples #-}+module Pattern where++f (# x, y #) = x
+ test/Test/Fixtures/oracle/UnboxedTuples/singleton-pattern.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedTuples #-}++module SingletonPattern where++f (# x #) = x
+ test/Test/Fixtures/oracle/UnboxedTuples/singleton-type.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedTuples #-}+module SingletonType where++f :: (# Int #) -> (# Int #)+f (# x #) = (# x #)++g :: (# "hello" #) -> (# "hello" #)+g (# x #) = (# x #)++h :: (# 42 #) -> (# 42 #)+h (# x #) = (# x #)
+ test/Test/Fixtures/oracle/UnboxedTuples/singleton.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedTuples #-}+module Singleton where++x = (# 1 #)++f (# y #) = y
+ test/Test/Fixtures/oracle/UnboxedTuples/type.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedTuples #-}+module Type where++f :: (# Int, Int #) -> (# Int, Int #)+f x = x
+ test/Test/Fixtures/oracle/UnboxedTuples/unboxed-tuple-visible-type-application.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedTuples #-}++module UnboxedTupleVisibleTypeApplication where++x = (, ) @(# * | 'C #)
+ test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-export-module.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}++module UnicodeExportModule (module ℳℴ𝒹1.ℳℴ𝒹2.ℳℴ𝒹3) where++import ℳℴ𝒹1.ℳℴ𝒹2.ℳℴ𝒹3 (x)
+ test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-import-multiple.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}++module UnicodeImportMultiple where++import ℳℴ𝒹1.ℳℴ𝒹2.ℳℴ𝒹3 (x)+import 𝔐𝔬𝔡1.𝔐𝔬𝔡2.𝔐𝔬𝔡3 (y)+import qualified 𝓜𝓸𝓭𝟏.𝓜𝓸𝓭𝟐.𝓜𝓸𝓭𝟑 as M++combined :: Int+combined = x + y + M.z
+ test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-import-qualified.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}++module UnicodeImportQualified where++import qualified 𝔐𝔬𝔡1.𝔐𝔬𝔡2.𝔐𝔬𝔡3 as M++useY :: Int+useY = M.y
+ test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-import-simple.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}++module UnicodeImportSimple where++import ℳℴ𝒹1.ℳℴ𝒹2.ℳℴ𝒹3 (x)++useX :: Int+useX = x
+ test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-module-bold-script.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}++module 𝓜𝓸𝓭𝟏.𝓜𝓸𝓭𝟐.𝓜𝓸𝓭𝟑 where++z :: Int+z = 3
+ test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-module-fraktur.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}++module 𝔐𝔬𝔡1.𝔐𝔬𝔡2.𝔐𝔬𝔡3 where++y :: Int+y = 2
+ test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-module-math-bold-italic.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}++module ℳℴ𝒹1.ℳℴ𝒹2.ℳℴ𝒹3 where++x :: Int+x = 1
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-bind-arrow.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}++module UnicodeSyntaxDo where++testDo ∷ IO ()+testDo = do+  x ← return 42+  y ← return 99+  return ()
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-class-arrow.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}++module UnicodeClassArrow where++class Foo a where+  foo ∷ a → a
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-class-typevar.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}++-- Unicode type variables in class heads are now handled correctly.++module UnicodeClassTypeVar where++class Foo α where+  foo :: α
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-composition-operator.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}++module UnicodeCompositionOperator where++infixr 9 •+(•) :: (b -> c) -> (a -> b) -> (a -> c)+f • g = \x -> f (g x)++data SpecificScreenNumber = SpecificScreenNumber Int++fromSpecificScreenNumber :: SpecificScreenNumber -> Int+fromSpecificScreenNumber = undefined++instance Show SpecificScreenNumber where+  show = fromSpecificScreenNumber • succ • show
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-constraint.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ExplicitForAll #-}++module UnicodeSyntaxConstraint where++showTwice ∷ ∀ a . Show a ⇒ a → String+showTwice x = show x ++ show x
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-double-colon.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}++module UnicodeSyntaxDoubleColon where++identity :: Int -> Int+identity x = x++-- Same with Unicode+identityU ∷ Int → Int+identityU x = x
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-forall.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ExplicitForAll #-}++module UnicodeSyntaxForall where++identity ∷ ∀ a . a → a+identity x = x
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-identifier-continuation.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}++module UnicodeIdentifierContinuation where++data ((s :: αₛ -> αₛ -> *) :×: (t :: αₜ -> αₜ -> *)) :: (αₛ, αₜ) -> (αₛ, αₜ) -> * where+  (:×:) :: s aₛ bₛ -> t aₜ bₜ -> (s :×: t) '(aₛ, aₜ) '(bₛ, bₜ)
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-lambda.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}++module UnicodeSyntaxLambda where++-- Lambda with Unicode arrow+incrementLambda ∷ Int → Int+incrementLambda = \x → x + 1++-- Higher-order with Unicode arrows+applyTwice ∷ (Int → Int) → Int → Int+applyTwice f x = f (f x)
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-asterism.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module UnicodeOperatorAsterism where++(⁂) :: Int -> Int -> Int+(⁂) = (+)
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-double-exclamation.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module UnicodeOperatorDoubleExclamation where++(‼) :: [a] -> Int -> a+(‼) = (!!)
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-en-dash.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module UnicodeOperatorEnDash where++(–) :: Int -> Int -> Int+(–) = (+)
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-undertie.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module UnicodeOperatorUndertie where++(‿) :: Int -> Int -> Int+(‿) = (+)
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-rank-n.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE RankNTypes #-}++module UnicodeSyntaxRankN where++-- Rank-N type with Unicode+runST ∷ (∀ s . ST s a) → a+runST = undefined++data ST s a = MkST
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-star-expression-operator.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}++module UnicodeStarExpressionOperator where++infixl 7 ★++(★) ∷ Int → Int → Int+(★) = (*)++value ∷ Int+value = 2 ★ 3
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-star-type.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StarIsType #-}+{-# LANGUAGE UnicodeSyntax #-}++module UnicodeStarType where++type StarKind = ★
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-data.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}++-- Unicode type variable in data declaration++module UnicodeTypeVarData where++data Tree α = Leaf α | Node (Tree α) (Tree α)
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-multiple.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}++-- Multiple unicode type variables in class declaration++module UnicodeTypeVarMultiple where++class Functor φ where+  fmap :: (α → β) → φ α → φ β
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-newtype.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}++-- Unicode type variable in newtype declaration++module UnicodeTypeVarNewtype where++newtype Wrapper ψ = Wrap { unwrap :: ψ }
+ test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-synonym.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnicodeSyntax #-}++-- Unicode type variable in type synonym++module UnicodeTypeVarSynonym where++type Identity α = α
+ test/Test/Fixtures/oracle/ViewPatterns/nested-view-pattern-lambda.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ViewPatterns #-}++module NestedViewPatternLambda where++import Language.Haskell.TH++toExp :: Expr -> TH.Exp+toExp d (Expr.HsLam _ _ (Expr.MG _ (unLoc -> (map unLoc -> [Expr.Match _ _ (unLoc -> map unLoc -> ps) (Expr.GRHSs _ (NE.toList -> [unLoc -> Expr.GRHS _ _ (unLoc -> e)]) _)])))) = TH.LamE (fmap (toPat d) ps) (toExp d e)
+ test/Test/Fixtures/oracle/ViewPatterns/view-pattern-case-alternative.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ViewPatterns #-}++module ViewPatternCaseAlternative where++anyIdx :: a -> Maybe Int+anyIdx = undefined++f :: [a] -> Int+f x = case x of+  [anyIdx -> Just i] -> i+  _ -> 0
+ test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-casealt.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ViewPatterns #-}++module ViewPatternsCaseAlt where++project :: a -> a+project x = x++useCase :: a -> a+useCase input =+  case input of+    (project -> x) -> x
+ test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-comp-parallel.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ParallelListComp #-}+{- ORACLE_TEST pass -}+{-# LANGUAGE ViewPatterns #-}++module ViewPatternsCompParallel where++-- View pattern inside a parallel list comprehension generator.+-- The first | separates the comprehension body from qualifiers;+-- the second | starts a parallel qualifier group.+x e y = [e | (() -> r) <- [e] | x <- y]
+ test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-funarg.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ViewPatterns #-}++module ViewPatternsFunArg where++project :: a -> a+project x = x++useView :: a -> a+useView (project -> x) = x
+ test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-guard-qualifier.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ViewPatterns #-}++module ViewPatternsGuardQualifier where++f :: Maybe Int -> Int+f x+  | (id -> Just y) <- x = y+  | otherwise = 0
+ test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-patbind.hs view
@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ViewPatterns #-}++module ViewPatternsPatBind where++project :: a -> a+project x = x++bound :: a+(project -> bound) = project value+  where+    value = error "fixture"
+ test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-funarg.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ViewPatterns #-}++module ViewPatternsTupleFunArg where++f (id -> x, y) = x
+ test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-middle.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ViewPatterns #-}++module ViewPatternsTupleMiddle where++f :: (a, b -> c, d) -> b -> (a, c, d)+f (x, g -> y, z) b = (x, g b, z)
+ test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-multiple.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ViewPatterns #-}++module ViewPatternsTupleMultiple where++f :: (a -> b, c -> d, e) -> a -> c -> (b, d, e)+f (g -> x, h -> y, z) a c = (g a, h c, z)
+ test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-nested.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ViewPatterns #-}++module ViewPatternsTupleNested where++f :: (a -> b, (c -> d, e)) -> a -> c -> (b, d, e)+f (g -> x, (h -> y, z)) a c = (g a, h c, z)
+ test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-second.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ViewPatterns #-}++module ViewPatternsTupleSecond where++f :: (a, b -> c) -> b -> (a, c)+f (x, g -> y) b = (x, g b)
+ test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-unboxed-sum.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedSums #-}+{- ORACLE_TEST pass -}+{-# LANGUAGE ViewPatterns #-}++module ViewPatternsUnboxedSum where++-- View pattern inside an unboxed sum pattern.+-- The -> is the view pattern arrow; the | is the unboxed sum separator.+f :: (# Int | () #) -> Int+f (# g -> x | #) = x
+ test/Test/Fixtures/oracle/Whitespace/form-feed-in-binding.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module FormFeedInBinding where++x = 1++y = 2
+ test/Test/Fixtures/oracle/Whitespace/form-feed-in-expression.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module FormFeedInExpression where++x = 1 ++  2
+ test/Test/Fixtures/oracle/Whitespace/form-feed-multiple.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module FormFeedMultiple where++x = 1++y = 2++z = 3
+ test/Test/Fixtures/oracle/Whitespace/form-feed-top-level.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module FormFeedTopLevel where++x = 1
+ test/Test/Fixtures/oracle/Whitespace/unicode-whitespace-top-level.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module UnicodeWhitespaceTopLevel where++x = 1+ +y = 2
+ test/Test/Fixtures/oracle/Whitespace/vertical-tab-top-level.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module VerticalTabTopLevel where++x = 1++y = 2
+ test/Test/Fixtures/oracle/haskell2010/cls-default.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}++class Cls a where a :&: as == b :&: bs = ()
+ test/Test/Fixtures/oracle/haskell2010/comments/dash-dash-backtick-comment.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}++module DashDashBacktickComment where++x = 1+--`+y = 2
+ test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-class-package-imports.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PackageImports #-}+module X where++import "filepath" System.OsString.Internal.Types (OsString (..))
+ test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-ffi-capi-calling-convention.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MagicHash #-}+module X where++import Foreign.C.Types (CULLong)++foreign import capi unsafe "HsXXHash.h hs_XXH3_64bits_withSeed_offset" unsafe_xxh3_64bit_withSeed_ba :: Int -> Int -> IO CULLong
+ test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-generic-instances-kind-arrow.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BangPatterns, FlexibleInstances, KindSignatures,+             ScopedTypeVariables, TypeOperators,+             MultiParamTypeClasses, GADTs, FlexibleContexts #-}+module X where++x :: Int+x = 1
+ test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-lowlevel-cpp-ifdef.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE CPP #-}+module X where++#ifdef HASHABLE_RANDOM_SEED+x :: Int+x = 1+#else+x :: Int+x = 2+#endif
+ test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-mix-cpp-if.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE CPP #-}+module X where++#if WORD_SIZE_IN_BITS == 64+x :: Int+x = 64+#else+x :: Int+x = 32+#endif
+ test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-properties-unboxed-tuples.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+module X where++import GHC.Exts (Int#)++f :: Int# -> (# Int#, Int# #)+f x = (# x, x #)
+ test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-regress-cpp-have-mmap.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE CPP #-}+module X where++#ifdef HAVE_MMAP+x :: Int+x = 1+#endif
+ test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-xxh3-cpp-include.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE CPP #-}+module X where++#include "MachDeps.h"
+ test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-xxhash-tests-numeric-underscores.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NumericUnderscores #-}+module X where++x :: Integer+x = 0xc77b_3abb_6f87_acd9
+ test/Test/Fixtures/oracle/haskell2010/corpus/vinyl-loeb-rloeb-section.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}++module VinylLoebRloebSection where++rloeb x = go where go = rmap (($ go) . getCompose) x
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-default-funlhs.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D34 where+class C a where { op :: a -> a; op x = x }
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-default-layout.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module ClassDefaultLayout where+class C a where+  op :: a -> a+  op = id
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-default-var.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D33 where+class C a where { op :: a -> a; op = id }
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-fixity.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D35 where+class C a where { (<+>) :: a -> a -> a; infixl 6 <+> }
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-multiple-defaults.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module ClassMultipleDefaults where+class C a where+  foo :: a -> a+  foo = id++  bar :: a -> Int+  bar x = 42
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-signature-context.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D32 where+class C a where { op :: Num b => a -> b -> a }
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-signature.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D31 where+class C a where { op :: a -> a }
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-minimal.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D25 where+class C a
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-super-paren-empty.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D28 where+class () => C a
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-super-paren-multiple.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D30 where+class (Eq a, Show a) => C a
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-super-paren-single.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D29 where+class (Eq a) => C a
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-super-simple.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D27 where+class Eq a => C a
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-universe-some.hs view
@@ -0,0 +1,19 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+module UniverseSome (+  UniverseSome (..),+  FiniteSome (..),+  ) where++import Data.List (genericLength)++class UniverseSome f where+  universeSome :: [f a]++class UniverseSome f => FiniteSome f where+  universeFSome :: [f a]+  universeFSome = universeSome++  cardinalitySome :: Int+  cardinalitySome = genericLength (universeFSome :: [f Int])
+ test/Test/Fixtures/oracle/haskell2010/declarations/class-where-empty.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D26 where+class C a where {}
+ test/Test/Fixtures/oracle/haskell2010/declarations/class.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module D7 where+class Eq a => Named a where+  nameOf :: a -> String
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-abstract.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D24 where+data Abstract a
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-context.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}+module D12 where+data Eq a => Set a = NilSet | ConsSet a (Set a)
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-deriving-empty.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D23 where+data Phantom a = Phantom deriving ()
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-deriving-single.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D22 where+data Flag = On | Off deriving Eq
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-infix-strict-left.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D16 where+data T = !Int :*: Bool
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-infix-strict-right.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D17 where+data T = Int :*: !Bool
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-infix.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D15 where+data Pair a = a :*: a
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-prefix-positional.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D13 where+data Box a = Box a
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-prefix-strict.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D14 where+data Pair a = Pair !a a
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-record-empty.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D18 where+data Unit = Unit {}
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-record-fields.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D19 where+data Person = Person { name :: String, age :: Int }
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-record-function-type-simple.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module M where+data X = X { f :: Int -> Int }
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-record-function-type.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module M where+data Target a = Target {+    lTarget  :: a -> Double+  , glTarget :: Maybe (a -> a)+  }
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-record-grouped-fields.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D20 where+data Point = Point { x, y :: Int }
+ test/Test/Fixtures/oracle/haskell2010/declarations/data-record-strict-field.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D21 where+data StrictRec = StrictRec { payload :: !Int }
+ test/Test/Fixtures/oracle/haskell2010/declarations/data.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D4 where+data Color = Red | Blue
+ test/Test/Fixtures/oracle/haskell2010/declarations/default.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D10 where+default (Integer, Double)
+ test/Test/Fixtures/oracle/haskell2010/declarations/deriving.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D11 where+data Mode = Fast | Slow deriving (Eq, Show)
+ test/Test/Fixtures/oracle/haskell2010/declarations/fixity-unicode-op.hs view
@@ -0,0 +1,23 @@+{- ORACLE_TEST pass -}+module FixityUnicodeOp where++-- Sm (MathSymbol): ring operator ∘+infixr 9 ∘++(∘) :: (b -> c) -> (a -> b) -> (a -> c)+(∘) f g x = f (g x)++compose :: (Int -> String)+compose = show ∘ fromEnum++-- Sc (CurrencySymbol): currency sign ¤+infixr 9 ¤++(¤) :: (b -> c) -> (a -> b) -> (a -> c)+(¤) f g x = f (g x)++-- So (OtherSymbol): copyright sign ©+infixr 9 ©++(©) :: (b -> c) -> (a -> b) -> (a -> c)+(©) f g x = f (g x)
+ test/Test/Fixtures/oracle/haskell2010/declarations/fixity.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module D9 where+infixr 5 <++>+(<++>) :: [a] -> [a] -> [a]+(<++>) = (++ )
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-append-list-pattern.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+module InfixAppendListPattern where++data Infinite a = a :~ Infinite a++append :: [a] -> Infinite a -> Infinite a+[] `append` ys = ys+(x : xs) `append` ys = x :~ (xs `append` ys)
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-con.hs view
@@ -0,0 +1,2 @@+{- ORACLE_TEST pass -}+data A a b = a `Infix` b
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-backtick.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module InfixFunlhsBacktick where+x `myOp` y = x + y
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-bang.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module InfixFunlhsBang where+x ! y = ()
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-basic.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module InfixFunlhs where+x <+> y = x + y
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-class.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module InfixFunlhsClass where+class MyClass a where+  x <+> y = undefined
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-guarded.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module InfixFunlhsGuarded where+x <=> y+  | x < y = LT+  | x > y = GT+  | otherwise = EQ
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-instance-prefix-pattern.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+module InfixFunlhsInstancePrefixPattern where++data P = Z | S P++instance Num P where+  S m - S n = m - n
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-instance.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module InfixFunlhsInstance where+data Box a = Box a+instance Eq a => Eq (Box a) where+  Box x == Box y = x == y
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-lambda.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module InfixFunlhsLambda where+mb ?> x = mb >>= \b -> when b x
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-let.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module InfixFunlhsLet where+f = let x <+> y = x + y in 1 <+> 2
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-local-pattern.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module InfixFunlhsLocalPattern where++data Expr = Var | Expr :$ Expr++f = x+  where+    a :$ b `g` c+      | True = x
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-local.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module InfixFunlhsLocal where+f = g+  where+    x <+> y = x + y+    g = 1 <+> 2
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-minus-constructor-patterns.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module InfixFunlhsMinusConstructorPatterns where++data P = Z | S P++-- Infix function head with minus operator and constructor patterns+S m - S n = m - n+Z - x = x+x - Z = x
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-minus-negative-literal.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module InfixFunlhsMinusNegativeLiteral where++-- Infix function head with minus operator+x - y = x + (-1)++-- Negative literal patterns+f (-5) = "negative five"+f x = "other"
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-pattern.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module InfixFunlhsPattern where+(Just a) <||> _ = Just a+Nothing <||> b = b
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-th-cpp.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+module InfixFunlhsThCpp where+infixr 5 </>+(</>) :: Path b Dir -> Path Rel t -> Path b t+(</>) (Path a) (Path b) = Path (a ++ b)
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-tilde.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module InfixFunlhsTilde where+x ~ y = ()
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-where-empty.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module InfixFunlhsWhereEmpty where+-- An infix function definition with an explicit empty where clause+x `myOp` y = x where {}
+ test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-with-sig.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module InfixFunlhsWithSig where+(<+>) :: Int -> Int -> Int+x <+> y = x + y
+ test/Test/Fixtures/oracle/haskell2010/declarations/instance-method-guards.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module M where+class Class a where+  fn :: a -> ()+instance Class X where+  fn a | True = ()
+ test/Test/Fixtures/oracle/haskell2010/declarations/instance-tuple-type-constructor.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module M where+class Extractable f where+  runSingleton :: f a -> a+instance Extractable ((,,) w s) where+  runSingleton (_,_,x) = x
+ test/Test/Fixtures/oracle/haskell2010/declarations/instance.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module D8 where+data Box a = Box a+instance Eq a => Eq (Box a) where+  Box x == Box y = x == y
+ test/Test/Fixtures/oracle/haskell2010/declarations/mixed-infix-prefix-bang.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BangPatterns #-}+module MixedInfixPrefixBang where+a ! b = a + b+f !x = x
+ test/Test/Fixtures/oracle/haskell2010/declarations/multiple-equations.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module D2 where+f [] = 0+f (_:xs) = 1 + f xs
+ test/Test/Fixtures/oracle/haskell2010/declarations/newtype.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D5 where+newtype Wrap a = Wrap a
+ test/Test/Fixtures/oracle/haskell2010/declarations/operator-funlhs-infix-application-backtick.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module M where+(g `op` h) x = g (h x)
+ test/Test/Fixtures/oracle/haskell2010/declarations/operator-funlhs-infix-application.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module M where+(g . h) x = g (h x)
+ test/Test/Fixtures/oracle/haskell2010/declarations/pattern-binding.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D3 where+(x, y) = (1, 2)
+ test/Test/Fixtures/oracle/haskell2010/declarations/pattern-synonym-negative-literal.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module PatternSynNegativeLiteral where++pattern GL_NEXT_BUFFER_NV = -2 :: GLenum+pattern GL_SKIP_COMPONENTS1_NV = -6 :: GLenum+pattern GL_SKIP_COMPONENTS2_NV = -5 :: GLenum+pattern GL_SKIP_COMPONENTS3_NV = -4 :: GLenum+pattern GL_SKIP_COMPONENTS4_NV = -3 :: GLenum
+ test/Test/Fixtures/oracle/haskell2010/declarations/type-signature-context-multiline.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+module DTypeSigCtxMultiline where++memo :: (Ord a)+     => (a -> b)+     -> (a -> b)+memo f = f
+ test/Test/Fixtures/oracle/haskell2010/declarations/type-signature.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module D1 where+idInt :: Int -> Int+idInt x = x
+ test/Test/Fixtures/oracle/haskell2010/declarations/type-synonym.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module D6 where+type Pair a = (a, a)
+ test/Test/Fixtures/oracle/haskell2010/declarations/where-empty-braces.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module WhereEmptyBraces where+-- An explicit empty where clause is valid syntax+f x = x where {}
+ test/Test/Fixtures/oracle/haskell2010/expressions/application-constructor-partial.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS303AppConstructorPartial where+data D = D Int Int+x = D 1
+ test/Test/Fixtures/oracle/haskell2010/expressions/application-left-assoc.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS303AppLeftAssoc where+f a b = a + b+x = f 1 2
+ test/Test/Fixtures/oracle/haskell2010/expressions/arithmetic-seq.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module X10 where+x = [1,3..21]+y = [1..10]
+ test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from-then-to.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS310FromThenTo where+x = [1, 3 .. 10]
+ test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from-then.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS310FromThen where+x = [1, 3 ..]
+ test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from-to.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS310FromTo where+x = [1 .. 10]
+ test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS310From where+x = [1 ..]
+ test/Test/Fixtures/oracle/haskell2010/expressions/atoms-gcon-listcon.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS302GConList where+x = []
+ test/Test/Fixtures/oracle/haskell2010/expressions/atoms-gcon-tuplecon.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS302GConTuple where+x = (,,)
+ test/Test/Fixtures/oracle/haskell2010/expressions/atoms-gcon-unit.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS302GConUnit where+x = ()
+ test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-all.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module ExprS302LiteralAll where+xDecimal = 42+xFloat = 3.14+xChar = 'a'+xString = "abc"
+ test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-char.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS302LiteralChar where+x = 'a'
+ test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-float.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS302LiteralFloat where+x = 1.5
+ test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-int.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS302LiteralInt where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-string.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS302LiteralString where+x = "abc"
+ test/Test/Fixtures/oracle/haskell2010/expressions/atoms-qcon.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS302QCon where+data D = C+x = C
+ test/Test/Fixtures/oracle/haskell2010/expressions/atoms-qvar.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS302QVar where+x = Prelude.map
+ test/Test/Fixtures/oracle/haskell2010/expressions/case-basic.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS313CaseBasic where+x n = case n of { 0 -> 1; _ -> 2 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/case-guarded-alts.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS313CaseGuardedAlts where+x n = case n of { m | m > 0 -> m; _ -> 0 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/case-infix-rhs.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X where+x = a + case b of { c -> d }
+ test/Test/Fixtures/oracle/haskell2010/expressions/case-of.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module X2 where+x m = case m of+  Nothing -> 0+  Just n -> n
+ test/Test/Fixtures/oracle/haskell2010/expressions/conditional-basic.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS306ConditionalBasic where+x n = if n > 0 then n else 0
+ test/Test/Fixtures/oracle/haskell2010/expressions/conditional-semicolons.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS306ConditionalSemicolons where+x n = if n > 0; then n; else 0
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-as-argument.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X where+x = f (do a;b)
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-bind-stmt.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS314DoBindStmt where+x = do { n <- Just 1; return n }
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-empty-let-expression.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}++module DoEmptyLetExpression where++x = do let in ()
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-in-list.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X where+x = [do a;b]
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-in-parens.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X where+x = (do a;b)
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-infix-rhs.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X where+x = y <$ do a;b
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-let-function-binding-nested.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+module ExprDoLetFunctionBindingNested where++memoIO f = do+    v <- newMVar M.empty+    let f' x = do+            m <- readMVar v+            case M.lookup x m of+                Nothing -> do let { r = f x }; modifyMVar_ v (return . M.insert x r); return r+                Just r  -> return r+    return f'
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-let-stmt.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS314DoLetStmt where+x = do { let { n = 1 }; return n }
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-notation.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module X7 where+x = do+  a <- Just 1+  b <- Just 2+  return (a + b)
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-semicolon-let.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}++-- Explicit semicolons followed by let in do notation+f = do+  ;let x = 1+  ;x
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-semicolon-mixed.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}++-- Explicit semicolons with different statement types+f = do+  ;let x = 1+  ;y <- return x+  ;return y
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-semicolon-multiple.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}++-- Multiple explicit semicolons in do notation+f = do+  ;;let x = 1+  ;;x
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-sequence-stmts.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS314DoSequenceStmts where+x = do { a <- Just 1; b <- Just 2; return (a + b) }
+ test/Test/Fixtures/oracle/haskell2010/expressions/do-single-expression.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS314DoSingleExpression where+x = do { Just 1 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/errors-error.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS301Error where+x = error "boom"
+ test/Test/Fixtures/oracle/haskell2010/expressions/errors-undefined.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS301Undefined where+x = undefined
+ test/Test/Fixtures/oracle/haskell2010/expressions/existential-forall.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExistentialForall where++toJSON ((f :: f a) :=> (g :: g a)) = ()
+ test/Test/Fixtures/oracle/haskell2010/expressions/expr-type-signature-basic.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS316TypeSigBasic where+x = (1 :: Int)
+ test/Test/Fixtures/oracle/haskell2010/expressions/expr-type-signature-context.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS316TypeSigContext where+x = ((+1) :: Num a => a -> a)
+ test/Test/Fixtures/oracle/haskell2010/expressions/guard-expression-type-signature-fun.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+-- Guard expression type signatures may contain function arrows.+-- In equation context the arrow is unambiguous (RHS uses '=', not '->'),+-- so ':: T -> T2' must be parsed as a function type, not as the alternative+-- arrow. Regression test for a bug where typeInfixParser was used in all+-- guard contexts, rejecting '->' in types.++module GuardExpressionTypeSignatureFun where++f :: (Int -> Bool) -> Int -> Int+f p x+  | p :: Int -> Bool = x + 1+  | otherwise = x
+ test/Test/Fixtures/oracle/haskell2010/expressions/guard-expression-type-signature.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}++module GuardExpressionTypeSignature where++f :: Bool -> Bool+f x+  | x :: Bool = True+  | otherwise = False
+ test/Test/Fixtures/oracle/haskell2010/expressions/if-infix-rhs.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X where+x = a + if b then c else d
+ test/Test/Fixtures/oracle/haskell2010/expressions/if-then-else.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X1 where+x = if True then 1 else 0
+ test/Test/Fixtures/oracle/haskell2010/expressions/infix-qconop.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS304InfixQConOp where+x = 1 : 2 : []
+ test/Test/Fixtures/oracle/haskell2010/expressions/infix-qvarop.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS304InfixQVarOp where+x = 1 + 2
+ test/Test/Fixtures/oracle/haskell2010/expressions/lambda-infix-rhs.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X where+x = a + \y -> y
+ test/Test/Fixtures/oracle/haskell2010/expressions/lambda-multi-apat.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS303LambdaMulti where+x = (\a b -> a + b) 1 2
+ test/Test/Fixtures/oracle/haskell2010/expressions/lambda-pattern-apat.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS303LambdaPattern where+x = (\(a, b) -> a) (1, 2)
+ test/Test/Fixtures/oracle/haskell2010/expressions/lambda-single-apat.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS303LambdaSingle where+x = (\n -> n) 1
+ test/Test/Fixtures/oracle/haskell2010/expressions/lambda.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X4 where+x = \n -> n + 1
+ test/Test/Fixtures/oracle/haskell2010/expressions/let-basic.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS312LetBasic where+x = let y = 1 in y
+ test/Test/Fixtures/oracle/haskell2010/expressions/let-in.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X3 where+x n = let y = n + 1 in y * 2
+ test/Test/Fixtures/oracle/haskell2010/expressions/let-infix-rhs.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X where+x = a + let y = z in y
+ test/Test/Fixtures/oracle/haskell2010/expressions/let-multiple-decls.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS312LetMultipleDecls where+x = let y = 1; z = 2 in y + z
+ test/Test/Fixtures/oracle/haskell2010/expressions/let-nested-layout.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+module ExprS312LetNestedLayout where++x = let y =+          let z = 1+           in z+     in y
+ test/Test/Fixtures/oracle/haskell2010/expressions/list-comprehension.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X9 where+x = [n * 2 | n <- [1..10], odd n]
+ test/Test/Fixtures/oracle/haskell2010/expressions/list-empty.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS307ListEmpty where+x = []
+ test/Test/Fixtures/oracle/haskell2010/expressions/list-multiple.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS307ListMultiple where+x = [1, 2, 3]
+ test/Test/Fixtures/oracle/haskell2010/expressions/list-singleton.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS307ListSingleton where+x = [1]
+ test/Test/Fixtures/oracle/haskell2010/expressions/list-tuple.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X5 where+x = ([1,2,3], (1,2,3))
+ test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-generator.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS311Generator where+x xs = [n | n <- xs]
+ test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-guards.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS311Guards where+x xs = [n | n <- xs, n > 0]
+ test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-let-qualifier.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS311LetQualifier where+x xs = [m | n <- xs, let m = n + 1]
+ test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-multi-generator.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS311MultiGenerator where+x xs ys = [(a, b) | a <- xs, b <- ys]
+ test/Test/Fixtures/oracle/haskell2010/expressions/minus-with-parenthesized-negation.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS304MinusParenNeg where+x = 1 - (-2)
+ test/Test/Fixtures/oracle/haskell2010/expressions/operators-backtick-conid.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS302BacktickConid where+data Pair = Pair Int Int+x = 1 `Pair` 2
+ test/Test/Fixtures/oracle/haskell2010/expressions/operators-backtick-varid.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS302BacktickVarid where+x = 5 `mod` 2
+ test/Test/Fixtures/oracle/haskell2010/expressions/operators-conop-colon.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS302ConopColon where+x = 1 : []
+ test/Test/Fixtures/oracle/haskell2010/expressions/operators-varsym-paren.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS302VarsymParen where+x = (+) 1 2
+ test/Test/Fixtures/oracle/haskell2010/expressions/paren-reserved-at-section.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE Haskell2010 #-}+module ParenReservedAtSection where++(@) :: a -> b -> a+(@) x _ = x++test = (@ ())
+ test/Test/Fixtures/oracle/haskell2010/expressions/paren-section-fmap.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+module ParenSectionFmap where++writePandocWith f wo =+    (foo . f <$>)+    undefined
+ test/Test/Fixtures/oracle/haskell2010/expressions/paren-section-multiple-ops.hs view
@@ -0,0 +1,17 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}+module ParenSectionMultipleOps where++-- Multiple infix operators followed by trailing section operator+test1 = (a . b . c <$>)+test2 = (a + b -)+test3 = (a `f` b `g` c <*>)++-- Nested sections with infix+test4 = ((x + y) <$>)+test5 = ((a . b) <*>)++-- Complex real-world pattern+writePandocWith f g =+    (foo . f . g <$>)+    undefined
+ test/Test/Fixtures/oracle/haskell2010/expressions/parenthesized-expression.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS309Paren where+x = (1 + 2)
+ test/Test/Fixtures/oracle/haskell2010/expressions/pattern-as-pattern.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS317PatAsPattern where+x xs = case xs of { ys@(y:_) -> y; [] -> 0 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/pattern-constructor-application.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS317PatConstructorApplication where+data Box = Box Int+x b = case b of { Box n -> n }
+ test/Test/Fixtures/oracle/haskell2010/expressions/pattern-infix-constructor.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS317PatInfixConstructor where+x xs = case xs of { y:ys -> y; [] -> 0 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/pattern-irrefutable.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS317PatIrrefutable where+x v = (\ ~(a, b) -> a) v
+ test/Test/Fixtures/oracle/haskell2010/expressions/pattern-labeled.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS317PatLabeled where+data R = R { a :: Int, b :: Int }+x r = case r of { R { a = n } -> n }
+ test/Test/Fixtures/oracle/haskell2010/expressions/pattern-list.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS317PatList where+x xs = case xs of { [a, b] -> a + b; _ -> 0 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/pattern-literal.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS317PatLiteral where+x n = case n of { 1 -> 1; _ -> 0 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/pattern-negative-literal.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS317PatNegativeLiteral where+x n = case n of { -1 -> 1; _ -> 0 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/pattern-nullary-constructor.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS317PatNullaryConstructor where+data D = C+x d = case d of { C -> 1 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/pattern-parenthesized.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS317PatParenthesized where+x t = case t of { (n) -> n }
+ test/Test/Fixtures/oracle/haskell2010/expressions/pattern-tuple.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS317PatTuple where+x t = case t of { (a, b) -> a + b }
+ test/Test/Fixtures/oracle/haskell2010/expressions/pattern-wildcard.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS317PatWildcard where+x t = case t of { (_, _) -> 1 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/prefix-negation.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS304PrefixNegation where+x = -1
+ test/Test/Fixtures/oracle/haskell2010/expressions/qualified-dot-section-right.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module ExprQualifiedDotSectionRight where++import qualified Prelude as Foo++x = (Foo.. Foo.id)
+ test/Test/Fixtures/oracle/haskell2010/expressions/record-construction-empty.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS315RecordConstructionEmpty where+data R = R {}+x = R {}
+ test/Test/Fixtures/oracle/haskell2010/expressions/record-construction-fields.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS315RecordConstructionFields where+data R = R { a :: Int, b :: Int }+x = R { a = 1, b = 2 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/record-construction-qualified-field.hs view
@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+module RecordConstructionQualifiedField where++data R = R {fieldA :: Int, fieldB :: Int}++-- Construction with a qualified field name+x = R {Qual.fieldA = 1, fieldB = 2}++-- Update with a qualified field name+y = x {Qual.fieldA = 10}++-- Mixed local and qualified fields in construction+z = R {fieldA = 3, Qual.fieldB = 4}
+ test/Test/Fixtures/oracle/haskell2010/expressions/record-field-selection.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS315FieldSelection where+data R = R { a :: Int }+x r = a r
+ test/Test/Fixtures/oracle/haskell2010/expressions/record-update-chained.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS315RecordUpdateChained where+data R = R { a :: Int, b :: Int }+x r = r { a = 1 } { b = 2 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/record-update-multiple.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS315RecordUpdateMultiple where+data R = R { a :: Int, b :: Int }+x r = r { a = 3, b = 4 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/record-update-paren-base.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS315RecordUpdateParenBase where+data R = R { a :: Int }+x r = (f r) { a = 1 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/record-update-single.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module ExprS315RecordUpdateSingle where+data R = R { a :: Int, b :: Int }+x r = r { a = 3 }
+ test/Test/Fixtures/oracle/haskell2010/expressions/reserved-as.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+module ReservedKeywordAs where++reserved :: as+reserved = undefined++arg as = as
+ test/Test/Fixtures/oracle/haskell2010/expressions/section-backtick-left.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS305SectionBacktickLeft where+x = map (`div` 2) [2, 4, 6]
+ test/Test/Fixtures/oracle/haskell2010/expressions/section-backtick-right.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS305SectionBacktickRight where+x = map (2 `div`) [2, 4, 6]
+ test/Test/Fixtures/oracle/haskell2010/expressions/section-bang.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprSectionBang where+f = (! 3)
+ test/Test/Fixtures/oracle/haskell2010/expressions/section-left.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS305SectionLeft where+x = map (1+) [1, 2, 3]
+ test/Test/Fixtures/oracle/haskell2010/expressions/section-right.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS305SectionRight where+x = map (+1) [1, 2, 3]
+ test/Test/Fixtures/oracle/haskell2010/expressions/sections.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module X6 where+x = map (+1) [1,2,3]+y = map (1+) [1,2,3]
+ test/Test/Fixtures/oracle/haskell2010/expressions/tuple-pair.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS308TuplePair where+x = (1, 2)
+ test/Test/Fixtures/oracle/haskell2010/expressions/tuple-triple.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS308TupleTriple where+x = (1, 2, 3)
+ test/Test/Fixtures/oracle/haskell2010/expressions/unit-expression.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module ExprS309Unit where+x = ()
+ test/Test/Fixtures/oracle/haskell2010/expressions/where-clause.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module X8 where+x n = y + 1 where y = n * 2
+ test/Test/Fixtures/oracle/haskell2010/exprs/if-typed-condition-and-else-signature.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE StarIsType #-}+module IfTypedConditionAndElseSignature where++a = if a :: * then a else [] :: C => '7'
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-export-ccall-named.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ExportCcallNamed where+addInt :: Int -> Int -> Int+addInt a b = a + b+foreign export ccall "addInt" addInt :: Int -> Int -> Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-export-ccall-omitted-entity.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ExportCcallOmittedEntity where+addOne :: Int -> Int+addOne n = n + 1+foreign export ccall addOne :: Int -> Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-export-stdcall-named.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ExportStdcallNamed where+mulInt :: Int -> Int -> Int+mulInt a b = a * b+foreign export stdcall "mulInt" mulInt :: Int -> Int -> Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-address-header-cid.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportAddressHeaderCid where+foreign import ccall "errno.h &errno" errnoPtr :: Ptr Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-address-only.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportAddressOnly where+foreign import ccall "&" errnoPtr :: Ptr Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ccall-basic.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportCcallBasic where+foreign import ccall "puts" c_puts :: String -> IO Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ccall-safe.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportCcallSafe where+foreign import ccall safe "puts" c_puts_safe :: String -> IO Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ccall-unsafe.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportCcallUnsafe where+foreign import ccall unsafe "puts" c_puts_unsafe :: String -> IO Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-dynamic.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportDynamic where+foreign import ccall "dynamic" mkFun :: Ptr (Int -> IO Int) -> (Int -> IO Int)
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-arrow.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportFtypeArrow where+foreign import ccall "plus1" plus1 :: Int -> IO Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-frtype-only.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportFtypeFrtypeOnly where+foreign import ccall "get_errno" getErrno :: Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-multi-arg.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportFtypeMultiArg where+foreign import ccall "plus" plus :: Int -> Int -> IO Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-result-unit.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportFtypeResultUnit where+foreign import ccall "tick" tick :: IO ()
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-impent-omitted.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportImpentOmitted where+foreign import ccall c_atoi :: String -> IO Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-dynamic-name.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportStaticDynamicName where+foreign import ccall "static dynamic" dynamicFn :: IO Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-header-cid.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportStaticHeaderCid where+foreign import ccall "static math.h sin" c_sin :: Double -> Double
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-header-default-cid.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportStaticHeaderDefaultCid where+foreign import ccall "static math.h" c_cos :: Double -> Double
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-wrapper-name.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportStaticWrapperName where+foreign import ccall "static wrapper" wrapperFn :: IO Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-stdcall-basic.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportStdcallBasic where+foreign import stdcall "puts" s_puts :: String -> IO Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-wrapper.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8ImportWrapper where+foreign import ccall "wrapper" wrapFun :: (Int -> IO Int) -> IO (Ptr (Int -> IO Int))
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-lexical-identifiers.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module FfiS8LexicalIdentifiers where+ccall = 1+stdcall = 2+foreignName = ccall + stdcall
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-mixed-import-export.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8MixedImportExport where+foreign import ccall "atoi" c_atoi :: String -> IO Int+inc :: Int -> Int+inc n = n + 1+foreign export ccall "inc" inc :: Int -> Int
+ test/Test/Fixtures/oracle/haskell2010/ffi/s8-multiple-foreign-decls.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module FfiS8MultipleForeignDecls where+foreign import ccall unsafe "plus1" plus1 :: Int -> IO Int+foreign import ccall safe "plus2" plus2 :: Int -> IO Int+foreign import ccall "plus3" plus3 :: Int -> IO Int
+ test/Test/Fixtures/oracle/haskell2010/identifiers/by-varid.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module ByVarId where++by :: ()+by = ()++useBy :: ()+useBy = by
+ test/Test/Fixtures/oracle/haskell2010/identifiers/pattern-comprehensive.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+module Test ( pattern ) where+import Mod ( pattern )+import Mod hiding ( pattern )+fn1 pattern = ()+fn2 = \pattern -> ()+fn3 :: pattern+fn4 = () `pattern` ()+a `pattern` b = ()+infix `pattern`
+ test/Test/Fixtures/oracle/haskell2010/identifiers/pattern-keyword.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module PatternAsIdentifier where++pattern :: Int -> Int+pattern x = x
+ test/Test/Fixtures/oracle/haskell2010/identifiers/unicode-lowercase.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+module Main where++αβγ :: Int+αβγ = 42++café :: String+café = "hello"++naïve :: Bool+naïve = True
+ test/Test/Fixtures/oracle/haskell2010/identifiers/unicode-uppercase.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module Main where++data Σthing = Σthing Int
+ test/Test/Fixtures/oracle/haskell2010/identifiers/using-varid.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module UsingVarId where++using :: ()+using = ()++useUsing :: ()+useUsing = using
+ test/Test/Fixtures/oracle/haskell2010/layout/do-where-if-then-do-nested.hs view
@@ -0,0 +1,19 @@+{- ORACLE_TEST pass -}+-- Test: do block with where clause containing nested if-then-do with let and nested if+module DoWhereIfThenDoNested where++f = do+    return ()+  where+    g = do+        if not True then do+            s <- return "hello"+            let ls' = s : undefined+            if s == "x" then do+                return ()+            else+                return ()+        else+            return ()+    h = 1+    i = 2
+ test/Test/Fixtures/oracle/haskell2010/layout/do-where-layout-multi.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+-- Test: where clause at same column as do statements closes do block (multiple bindings)+module DoWhereLayoutMulti where+testMulti a b = do+  x+  y+  where+    x = a+    y = b
+ test/Test/Fixtures/oracle/haskell2010/layout/do-where-layout.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+-- Test: where clause at same column as do statement closes do block+module DoWhereLayout where+testDoWhereLayout a = do+  action+  where action = a
+ test/Test/Fixtures/oracle/haskell2010/layout/let-layout.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module L1 where+x =+  let a = 1+      b = 2+  in a + b
+ test/Test/Fixtures/oracle/haskell2010/layout/where-layout.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module L2 where+x n = a + b+  where+    a = n + 1+    b = n + 2
+ test/Test/Fixtures/oracle/haskell2010/lexical/block-comments.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module K1 where+{- block+   comment -}+x = 1
+ test/Test/Fixtures/oracle/haskell2010/lexical/chars-escape-sequences.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module K2 where++x = '\SOH'+y = '\137'+z = '\CAN'
+ test/Test/Fixtures/oracle/haskell2010/lexical/numeric-literals.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module K3 where+x = 10+y = 0x10+z = 3.14
+ test/Test/Fixtures/oracle/haskell2010/lexical/operators.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module K4 where+x = (1 + 2) * 3+y = 3 `div` 2
+ test/Test/Fixtures/oracle/haskell2010/lexical/strings-chars.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module K2 where+x = "hello"+y = 'a'
+ test/Test/Fixtures/oracle/haskell2010/lexical/strings-escape-sequences.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module K2 where++x = "\\SO\\&H"+y = "\\137\\&9"+z = "Here is a backslant \\\\ as well as \\137, \\\n         \\a numeric escape character, and \\^X, a control character."
+ test/Test/Fixtures/oracle/haskell2010/lexical/strings-multiline.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module K2 where++x = "This string spans\+     \ multiple lines."
+ test/Test/Fixtures/oracle/haskell2010/modules/application.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module App where+f = g x+h = g (k 2)
+ test/Test/Fixtures/oracle/haskell2010/modules/astack.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+module AStack( Stack, push, pop, top, size ) where+{data Stack a = Empty +              | MkStack a (Stack a)+;push :: a -> Stack a -> Stack a+;push x s = MkStack x s+;size :: Stack a -> Int+;size s = length (stkToLst s) where+            {stkToLst Empty = []+            ;stkToLst (MkStack x s) = x:xs where {xs = stkToLst s+}};pop :: Stack a -> (a, Stack a)+;pop (MkStack x s)+   = (x, case s of {r -> i r where {i x = x}}) -- (pop Empty) is an error+;top :: Stack a -> a+;top (MkStack x s) = x -- (top Empty) is an error+}
+ test/Test/Fixtures/oracle/haskell2010/modules/comments.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module C where+-- comment+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/deprecated-roundtrip.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module DeprecatedRoundtrip+  {-# DEPRECATED "Use SomethingElse instead" #-}+  where++y = 2
+ test/Test/Fixtures/oracle/haskell2010/modules/empty-source.hs view
@@ -0,0 +1,1 @@+{- ORACLE_TEST pass -}
+ test/Test/Fixtures/oracle/haskell2010/modules/export-var-operator.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module Test ((</$>)) where+(</$>) = undefined
+ test/Test/Fixtures/oracle/haskell2010/modules/exports.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module E (x, T(..)) where+x = 1+data T = A | B
+ test/Test/Fixtures/oracle/haskell2010/modules/implicit.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+x = 1+y = x
+ test/Test/Fixtures/oracle/haskell2010/modules/import-as.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module IA where+import Data.Maybe as M+x = M.fromMaybe 0 Nothing
+ test/Test/Fixtures/oracle/haskell2010/modules/import-hiding.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module IH where+import Data.List hiding (map)+x = foldr (+) 0 [1,2,3]
+ test/Test/Fixtures/oracle/haskell2010/modules/import-only.hs view
@@ -0,0 +1,2 @@+{- ORACLE_TEST pass -}+import Data.List
+ test/Test/Fixtures/oracle/haskell2010/modules/import-operator.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeOperators #-}+module ImportOperator where+import Data.Type.Equality ((:~~:)(..))
+ test/Test/Fixtures/oracle/haskell2010/modules/import-qualified.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module IQ where+import qualified Data.List as L+x = L.length []
+ test/Test/Fixtures/oracle/haskell2010/modules/import-var-operator.hs view
@@ -0,0 +1,2 @@+{- ORACLE_TEST pass -}+import           Control.Applicative       ((<$>))
+ test/Test/Fixtures/oracle/haskell2010/modules/minimal.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module M where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/multi-imports.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module IM where+import Data.Maybe+import Data.List+x = fromMaybe 0 (listToMaybe [1,2])
+ test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-export-list-items-split.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module MultilineDefinitionExportListItemsSplit+  ( x+  , T(..)+  )+  where++x = 1+data T = A | B
+ test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-export-list-split.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module+  MultilineDefinitionExportListSplit+  (x, T(..))+where++x = 1+data T = A | B
+ test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-module-split.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module+  MultilineDefinitionModuleSplit where++x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-where-split.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module MultilineDefinitionWhereSplit+  where++x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module+  MultilineDefinition+where++x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-mixed-comments-multi-above-single-below.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{- a+   multi-line comment before pragma -}+{-# LANGUAGE ForeignFunctionInterface #-}+-- a single-line comment below pragma+module DemoMixedMultiAboveSingleBelow where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-mixed-comments-single-above-multi-below.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+-- a single-line comment before pragma+{-# LANGUAGE ForeignFunctionInterface #-}+{- a+   multi-line comment below pragma -}+module DemoMixedSingleAboveMultiBelow where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiline-comment-above-below.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{- a+   multi-line comment before pragma -}+{-# LANGUAGE ForeignFunctionInterface #-}+{- a+   multi-line comment below pragma -}+module DemoMultiLineAboveBelow where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiline-comment-above.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{- a+   multi-line comment before pragma -}+{-# LANGUAGE ForeignFunctionInterface #-}+module DemoMultiLineAbove where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiline-comment-below.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+{- a+   multi-line comment below pragma -}+module DemoMultiLineBelow where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiple-multiline-comments.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{- before first pragma -}+{-# LANGUAGE ForeignFunctionInterface #-}+{- between pragmas -}+{-# LANGUAGE ScopedTypeVariables #-}+{- after second pragma -}+module DemoMultiplePragmasMultiLineComments where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiple-singleline-comments.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+-- before first pragma+{-# LANGUAGE ForeignFunctionInterface #-}+-- between pragmas+{-# LANGUAGE ScopedTypeVariables #-}+-- after second pragma+module DemoMultiplePragmasSingleLineComments where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiple.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-}+module DemoMultiplePragmas where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-singleline-comment-above-below.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+-- a single-line comment before pragma+{-# LANGUAGE ForeignFunctionInterface #-}+-- a single-line comment below pragma+module DemoSingleLineAboveBelow where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-singleline-comment-above.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+-- a single-line comment before pragma+{-# LANGUAGE ForeignFunctionInterface #-}+module DemoSingleLineAbove where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-singleline-comment-below.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+-- a single-line comment below pragma+module DemoSingleLineBelow where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ForeignFunctionInterface #-}+module Demo where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-export-module-modid.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ExportModuleModid (module Data.Maybe, x) where+import Data.Maybe+x = fromMaybe 0 Nothing
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycls-abstract.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module S5ExportQtyClsAbstract (Eq) where+x = True
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycls-all.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module S5ExportQtyClsAll (Eq(..)) where+x = True
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycls-methods.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module S5ExportQtyClsMethods (Ord(compare)) where+x = EQ
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycon-abstract.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module S5ExportQtyConAbstract (Maybe) where+x = Just 1
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycon-all.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module S5ExportQtyConAll (Maybe(..)) where+x = Just 1
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycon-cnames.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module S5ExportQtyConCNames (Maybe(Nothing, Just)) where+x = Just 1
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qvar-operator.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module S5ExportQVarOperator ((</$>)) where+(</$>) = const
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qvar.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module S5ExportQVar (x) where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-as-explicit-list.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportAsExplicitList where+import Data.Maybe as M (fromMaybe)+x = M.fromMaybe 0 Nothing
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-as-hiding.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportAsHiding where+import Data.Maybe as M hiding (fromMaybe)+x = M.isNothing Nothing
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-as.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportAs where+import Data.Maybe as M+x = M.fromMaybe 0 Nothing
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-empty-list.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportEmptyList where+import Data.Maybe ()+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycls-all.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportExplicitTyClsAll where+import Prelude (Ord(..))+x = EQ
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycls-methods.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportExplicitTyClsMethods where+import Prelude (Ord(compare))+x = compare 1 2
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycls.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportExplicitTyCls where+import Prelude (Ord)+x = EQ
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycon-all.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportExplicitTyConAll where+import Data.Maybe (Maybe(..))+x = Just 1
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycon-cnames.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportExplicitTyConCNames where+import Data.Maybe (Maybe(Nothing, Just))+x = Just 1
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycon.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportExplicitTyCon where+import Data.Maybe (Maybe)+x = Just 1
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-var.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportExplicitVar where+import Data.Maybe (maybe)+x = maybe 0 id (Just 1)
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-hiding-empty.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportHidingEmpty where+import Data.Maybe hiding ()+x = fromMaybe 0 Nothing
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-hiding-var.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportHidingVar where+import Data.Maybe hiding (maybe)+x = fromMaybe 0 Nothing
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-plain.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportPlain where+import Data.Maybe+x = fromMaybe 0 Nothing
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-qualified-as.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportQualifiedAs where+import qualified Data.Maybe as M+x = M.fromMaybe 0 Nothing
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-qualified-hiding-var.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportQualifiedHidingVar where+import qualified Data.Maybe hiding (fromMaybe)+x = Data.Maybe.isJust Nothing
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-qualified.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportQualified where+import qualified Data.Maybe+x = Data.Maybe.fromMaybe 0 Nothing
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-import-trailing-comma.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module S5ImportTrailingComma where+import Foreign.Ptr (Ptr, )+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-module-body-impdecls-topdecls-braces.hs view
@@ -0,0 +1,2 @@+{- ORACLE_TEST pass -}+{ import Data.Maybe ; x = 1 }
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-module-body-imports-only-braces.hs view
@@ -0,0 +1,2 @@+{- ORACLE_TEST pass -}+{ import Data.Maybe }
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-module-body-topdecls-only-braces.hs view
@@ -0,0 +1,2 @@+{- ORACLE_TEST pass -}+{ x = 1 }
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-module-empty-exports.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module S5ModuleEmptyExports () where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-module-explicit-no-exports.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module S5ModuleExplicitNoExports where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/s5-module-exports-trailing-comma.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module S5ModuleExportsTrailingComma (x,) where+x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/warning-roundtrip.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module WarningRoundtrip+  {-# WARNING "This is a test warning" #-}+  where++x = 1
+ test/Test/Fixtures/oracle/haskell2010/modules/whitespace-source.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+   ++
+ test/Test/Fixtures/oracle/haskell2010/patterns/as-pattern.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module P3 where+x s@(h:_) = (h, s)+x [] = ('_', [])
+ test/Test/Fixtures/oracle/haskell2010/patterns/constructor.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module P1 where+data T = A Int | B+x (A n) = n+x B = 0
+ test/Test/Fixtures/oracle/haskell2010/patterns/contexts.hs view
@@ -0,0 +1,24 @@+{- ORACLE_TEST pass -}+module P10 where++funcApply a b c = a b c++funcMaybe Nothing (Just a) = a+funcMaybe (Just a) Nothing = a++funcAs (a@b) = b++letPattern = let Just x = Nothing in x+wherePattern = y where Just y = Nothing++lambdaPattern = (\(x:_) -> x) [1, 2, 3]++casePattern value = case value of+  Just x -> x+  Nothing -> 0++listCompPattern xs = [x | Just x <- xs]++doPattern = do+  Just x <- Just 1+  pure x
+ test/Test/Fixtures/oracle/haskell2010/patterns/guards.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module P5 where+x n+  | n < 0 = -1+  | n == 0 = 0+  | otherwise = 1
+ test/Test/Fixtures/oracle/haskell2010/patterns/infix-constructor.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module P6 where++headOrZero (x : _) = x+headOrZero [] = 0
+ test/Test/Fixtures/oracle/haskell2010/patterns/irrefutable.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module P4 where+x ~(a,b) = a + b
+ test/Test/Fixtures/oracle/haskell2010/patterns/labeled.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+module P8 where++data Pair = Pair { left :: Int, right :: Int }++leftValue Pair { left = x, right = _ } = x+isPair Pair {} = True
+ test/Test/Fixtures/oracle/haskell2010/patterns/literal-wildcard-parenthesized.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+module P9 where++isA 'a' = True+isA _ = False++unwrap ((x)) = x
+ test/Test/Fixtures/oracle/haskell2010/patterns/negative-literal.hs view
@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+module P7 where++intSign (-1) = 0+intSign n = n++floatSign (-1.0) = 0.0+floatSign x = x
+ test/Test/Fixtures/oracle/haskell2010/patterns/nested-record.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module PatternNestedRecord where++delete (HKey k@(HKey' f _)) (HSet xs count) = ()
+ test/Test/Fixtures/oracle/haskell2010/patterns/tuple-list.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module P2 where+x (a,b) = a + b+y (h:t) = h + length t+y [] = 0
+ test/Test/Fixtures/oracle/haskell2010/types/context-multi-vars.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module T5 where+f, g :: Num a => a -> a+f x = x + 1+g x = x * 2
+ test/Test/Fixtures/oracle/haskell2010/types/context.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module T1 where+f :: (Eq a, Show a) => a -> String+f x = if x == x then show x else "no"
+ test/Test/Fixtures/oracle/haskell2010/types/empty-list-type-constructor.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module EmptyListTypeConstructor where++type T = []
+ test/Test/Fixtures/oracle/haskell2010/types/function-type-constructor-partial.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module T15 where+toMaybe :: (->) a (Maybe a)+toMaybe x = Just x
+ test/Test/Fixtures/oracle/haskell2010/types/function-type-constructor.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module T14 where+apply :: (->) a b -> a -> b+apply f x = f x
+ test/Test/Fixtures/oracle/haskell2010/types/guard-inline-signature.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module T11 where+choose :: Bool -> Bool+choose b+  | (not b :: Bool) = True+  | otherwise = False
+ test/Test/Fixtures/oracle/haskell2010/types/inline-signature-basic.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module T7 where+value :: Int+value = (1 + 2 :: Int)
+ test/Test/Fixtures/oracle/haskell2010/types/inline-signature-context.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module T8 where+inc :: Int -> Int+inc = ((+ 1) :: Num a => a -> a)
+ test/Test/Fixtures/oracle/haskell2010/types/inline-signature-lambda.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module T9 where+idInt :: Int -> Int+idInt = (\x -> x :: Int)
+ test/Test/Fixtures/oracle/haskell2010/types/let-signature.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+module T10 where+f :: Int -> Int+f n =+  let y :: Int+      y = n + 1+   in y
+ test/Test/Fixtures/oracle/haskell2010/types/list-type-constructor.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module T12 where+idList :: [a] -> [a]+idList xs = xs
+ test/Test/Fixtures/oracle/haskell2010/types/maybe-type-constructor.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module T13 where+withDefault :: Maybe a -> a -> a+withDefault mx fallback = case mx of+  Just x -> x+  Nothing -> fallback
+ test/Test/Fixtures/oracle/haskell2010/types/multi-vars-signature.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module T4 where+f, g :: Int -> Int+f x = x + 1+g x = x - 1
+ test/Test/Fixtures/oracle/haskell2010/types/nested-maybe-list.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module T17 where+normalize :: Maybe [a] -> [a]+normalize mx = case mx of+  Just xs -> xs+  Nothing -> []
+ test/Test/Fixtures/oracle/haskell2010/types/newtype-record-field-multiline-application.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+newtype X = X { field :: Maybe+  Int }
+ test/Test/Fixtures/oracle/haskell2010/types/newtype-record-function-type.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module M where+newtype IOMcn a b = IOMcn { getIOMcn :: a -> IO b }
+ test/Test/Fixtures/oracle/haskell2010/types/newtype-record-layout-application.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module TNewtypeRecordLayoutApplication where++import Data.IORef (IORef)+import Data.Time.Clock (UTCTime)++newtype TimeSince = TimeSince+  { sinceRef :: IORef UTCTime+  }
+ test/Test/Fixtures/oracle/haskell2010/types/newtype-record.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module T3 where+newtype UserId = UserId { unUserId :: Int }
+ test/Test/Fixtures/oracle/haskell2010/types/signature-where.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+module T6 where+f :: Int -> Int+f n = helper n+  where+    helper :: Int -> Int+    helper x = x + 1
+ test/Test/Fixtures/oracle/haskell2010/types/tuple-list-types.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module T2 where+f :: [Int] -> (Int, Int)+f xs = (length xs, sum xs)
+ test/Test/Fixtures/oracle/haskell2010/types/tuple-type-constructor-prefix.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module M where+f :: (,) a b -> Int+f = undefined
+ test/Test/Fixtures/oracle/haskell2010/types/tuple-type-constructor.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module T16 where+pair :: (,) a b -> (a, b)+pair x = x
+ test/Test/Fixtures/oracle/negation-infix-chain-in-parens.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module A where+f x = (-x + 1)
+ test/Test/Fixtures/oracle/negation-infix-chain-top-level.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module A where+f x = - x + 1
+ test/Test/Fixtures/oracle/negation-multi-operator-chain-in-parens.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module A where+f x y z = (-x * y + z)
+ test/Test/Fixtures/oracle/negation-multi-operator-chain-top-level.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module A where+f = - 1 * 2 + 3
+ test/Test/Fixtures/oracle/negation-of-parenthesized-expr.hs view
@@ -0,0 +1,3 @@+{- ORACLE_TEST pass -}+module A where+f x y = (-(x + y))
+ test/Test/Fixtures/oracle/pragma/CompletePragmas.hs view
@@ -0,0 +1,56 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module CompletePragmas where++data Choice a = Choice Bool a++pattern LeftChoice :: a -> Choice a+pattern LeftChoice a = Choice False a++pattern RightChoice :: a -> Choice a+pattern RightChoice a = Choice True a++{-# COMPLETE LeftChoice, RightChoice #-}++choiceToInt :: Choice Int -> Int+choiceToInt (LeftChoice n) = n+choiceToInt (RightChoice n) = negate n++data Proxy a = Proxy++class IsEmpty a where+  isEmpty :: a -> Bool++class IsCons a where+  type Elt a+  isCons :: a -> Maybe (Elt a, a)++pattern Empty :: IsEmpty a => a+pattern Empty <- (isEmpty -> True)++pattern Cons :: IsCons a => Elt a -> a -> a+pattern Cons x xs <- (isCons -> Just (x, xs))++instance IsEmpty (Proxy a) where+  isEmpty Proxy = True++instance IsEmpty [a] where+  isEmpty = null++instance IsCons [a] where+  type Elt [a] = a+  isCons [] = Nothing+  isCons (x:xs) = Just (x, xs)++{-# COMPLETE Empty :: Proxy #-}+{-# COMPLETE Empty, Cons :: [] #-}++proxyCase :: Proxy a -> Int+proxyCase Empty = 0++listCase :: [a] -> Int+listCase Empty = 0+listCase (Cons _ _) = 1
+ test/Test/Fixtures/oracle/pragma/DeclWarnings.hs view
@@ -0,0 +1,27 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE PatternSynonyms #-}++module DeclWarnings where++data T = T1 | T2+newtype Wrap = Wrap Int+class C a where+  methodC :: a -> Int++legacy :: Int+legacy = 10++unsafeHeadish :: [a] -> a+unsafeHeadish (x:_) = x+unsafeHeadish [] = error "empty"++pattern D :: ()+pattern D = ()++data DType = MkDType++{-# DEPRECATED legacy, C, T ["Do not use these", "Use replacements instead"] #-}+{-# WARNING in "x-partial" unsafeHeadish "This function is partial" #-}+{-# DEPRECATED data D "This deprecates only the pattern synonym D" #-}+{-# DEPRECATED type DType "This deprecates only the type constructor DType" #-}
+ test/Test/Fixtures/oracle/pragma/ExportWarningsModuleReexport.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+module ExportWarningsModuleReexport+  ( {-# DEPRECATED "This declaration has moved to ExportWarningsModuleSource" #-}+      module ExportWarningsModuleSource+  ) where++import ExportWarningsModuleSource
+ test/Test/Fixtures/oracle/pragma/ExportWarningsReexport.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module ExportWarningsReexport+  ( {-# DEPRECATED "Import g from ExportWarningsImport instead" #-} g+  ) where++import ExportWarningsImport (g)
+ test/Test/Fixtures/oracle/pragma/FileHeaderPragmas.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# OPTIONS_GHC -Wall #-}+{-# INCLUDE "compat.h" #-}++module FileHeaderPragmas where++foreign import ccall unsafe "math.h sin" c_sin :: Double -> Double++answer :: Int+answer = 42
+ test/Test/Fixtures/oracle/pragma/InlinablePragmas.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+module InlinablePragmas where++biggish :: Int -> Int+biggish n = sum (map (+1) [0 .. n])+{-# INLINABLE biggish #-}++altSpelling :: Int -> Int+altSpelling n = product [1 .. max 1 n]+{-# INLINEABLE [1] altSpelling #-}++inlinableUntilPhase :: Int -> Int+inlinableUntilPhase n = n * n+{-# INLINABLE [~1] inlinableUntilPhase #-}
+ test/Test/Fixtures/oracle/pragma/InlinablePragmasInInstance.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+module InlinablePragmasInInstance where++class C a where+  foo :: a -> Int+  bar :: a -> Int++data A = A++instance C A where+  {-# INLINABLE foo #-}+  foo _ = 0+  {-# INLINABLE bar #-}+  bar _ = 1
+ test/Test/Fixtures/oracle/pragma/InlinePragmas.hs view
@@ -0,0 +1,32 @@+{- ORACLE_TEST pass -}+module InlinePragmas where++inlineTop :: Int -> Int+inlineTop x = x + 1+{-# INLINE inlineTop #-}++inlinePhase :: Int -> Int+inlinePhase x = x * 2+{-# INLINE [1] inlinePhase #-}++inlineUntilPhase :: Int -> Int+inlineUntilPhase x = x - 1+{-# INLINE [~1] inlineUntilPhase #-}++localInline :: Int -> Int+localInline x =+  let helper :: Int -> Int+      helper y = y + 10+      {-# INLINE helper #-}+  in helper x++class DefaultInline a where+  opDefault :: a -> a+  opDefault x = x+  {-# INLINE opDefault #-}++newtype Box = Box Int++instance DefaultInline Box where+  {-# INLINE opDefault #-}+  opDefault (Box n) = Box (n + 1)
+ test/Test/Fixtures/oracle/pragma/InlinePragmasAfterBindingInInstance.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+module InlinePragmasAfterBindingInInstance where++import Foreign.Storable (Storable (..))+import Foreign.Ptr (castPtr)++newtype LE16 = LE16 {fromLE16 :: Int}++instance Storable LE16 where+  { sizeOf _ = sizeOf (undefined :: Int);+    {-# INLINE sizeOf #-};+    alignment _ = alignment (undefined :: Int);+    {-# INLINE alignment #-};+  }
+ test/Test/Fixtures/oracle/pragma/InstanceWarnings.hs view
@@ -0,0 +1,16 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE StandaloneDeriving #-}++module InstanceWarnings where++data T1 = MkT1+newtype T2 = MkT2 Int++instance {-# DEPRECATED "Do not use Show T1" #-} Show T1 where+  show MkT1 = "MkT1"++newtype G1 = MkG1 Int+instance {-# WARNING "Do not use Eq G1" #-} Eq G1 where+  MkG1 a == MkG1 b = a == b++deriving instance {-# DEPRECATED "Eq T2 will be removed" #-} Eq T2
+ test/Test/Fixtures/oracle/pragma/LineColumnPragmas.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module LineColumnPragmas where++{-# LINE 42 "GeneratedFrom.dsl" #-}++lineTagged :: Int+lineTagged =+  do {-# COLUMN 17 #-}+     pure 1
+ test/Test/Fixtures/oracle/pragma/MinimalPragma.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module MinimalPragma where++class PartialEq a where+  peq :: a -> a -> Bool+  pne :: a -> a -> Bool+  peq x y = not (pne x y)+  pne x y = not (peq x y)+  {-# MINIMAL peq | pne #-}
+ test/Test/Fixtures/oracle/pragma/ModuleDeprecated.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module ModuleDeprecated {-# DEPRECATED "Use New.ModuleDeprecated instead" #-} where++deprecatedValue :: Int+deprecatedValue = 2
+ test/Test/Fixtures/oracle/pragma/ModuleWarning.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module ModuleWarning {-# WARNING "This module is intentionally unstable" #-} where++warningValue :: Int+warningValue = 1
+ test/Test/Fixtures/oracle/pragma/NoInlinePragmas.hs view
@@ -0,0 +1,22 @@+{- ORACLE_TEST pass -}+module NoInlinePragmas where++neverInline :: Int -> Int+neverInline x = x + 100+{-# NOINLINE neverInline #-}++notInlineSynonym :: Int -> Int+notInlineSynonym x = x + 200+{-# NOTINLINE notInlineSynonym #-}++noinlinePhase :: Int -> Int+noinlinePhase x = x * 3+{-# NOINLINE [1] noinlinePhase #-}++noinlineUntilPhase :: Int -> Int+noinlineUntilPhase x = x * 4+{-# NOINLINE [~1] noinlineUntilPhase #-}++ruleCheap :: Int -> Int+ruleCheap x = x + 1+{-# INLINE CONLIKE ruleCheap #-}
+ test/Test/Fixtures/oracle/pragma/NoUnpackPragma.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module NoUnpackPragma where++data NoUnpack = NoUnpack {-# NOUNPACK #-} !(Int, Int)
+ test/Test/Fixtures/oracle/pragma/OpaquePragma.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module OpaquePragma where++opaqueFun :: Int -> Int+opaqueFun x = x + 1+{-# OPAQUE opaqueFun #-}
+ test/Test/Fixtures/oracle/pragma/OverlapPragmas.hs view
@@ -0,0 +1,22 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE FlexibleInstances #-}++module OverlapPragmas where++class Render a where+  render :: a -> String++instance {-# OVERLAPPABLE #-} Show a => Render [a] where+  render = show++instance {-# OVERLAPPING #-} Render [Char] where+  render = id++instance {-# OVERLAPS #-} Render Int where+  render = show++class Pick a where+  pick :: a -> String++instance {-# INCOHERENT #-} Pick a where+  pick _ = "fallback"
+ test/Test/Fixtures/oracle/pragma/RulesPragma.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module RulesPragma where++{-# RULES+"map/id" forall xs. map id xs = xs+#-}++useMapId :: [Int] -> [Int]+useMapId xs = map id xs
+ test/Test/Fixtures/oracle/pragma/SourceLoopA.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module SourceLoopA where++import {-# SOURCE #-} SourceLoopB++data A = A B++fromA :: A -> Int+fromA (A b) = fromB b
+ test/Test/Fixtures/oracle/pragma/SourceLoopB.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+module SourceLoopB where++import {-# SOURCE #-} SourceLoopA++data B = B A | B0++fromB :: B -> Int+fromB (B a) = fromA a+fromB B0 = 0
+ test/Test/Fixtures/oracle/pragma/SpecializeImportedDef.hs view
@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+module SpecializeImportedDef (lookupLike) where++lookupLike :: Eq a => [(a, b)] -> a -> Maybe b+lookupLike [] _ = Nothing+lookupLike ((k, v):xs) key+  | k == key = Just v+  | otherwise = lookupLike xs key+{-# INLINABLE lookupLike #-}
+ test/Test/Fixtures/oracle/pragma/SpecializeImportedUse.hs view
@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+module SpecializeImportedUse where++import SpecializeImportedDef (lookupLike)++data Tag = TagA | TagB deriving (Eq)++{-# SPECIALIZE lookupLike :: [(Tag, b)] -> Tag -> Maybe b #-}++findTagA :: [(Tag, b)] -> Maybe b+findTagA xs = lookupLike xs TagA
+ test/Test/Fixtures/oracle/pragma/SpecializeInstancePragma.hs view
@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+module SpecializeInstancePragma where++data Foo a = Foo a++data Bar = Bar deriving (Eq)++instance Eq a => Eq (Foo a) where+  {-# SPECIALIZE instance Eq (Foo [(Int, Bar)]) #-}+  Foo x == Foo y = x == y
+ test/Test/Fixtures/oracle/pragma/SpecializePragmas.hs view
@@ -0,0 +1,27 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TypeApplications #-}++module SpecializePragmas where++hammeredLookup :: Ord key => [(key, value)] -> key -> Maybe value+hammeredLookup [] _ = Nothing+hammeredLookup ((k, v):xs) key+  | k == key = Just v+  | otherwise = hammeredLookup xs key+{-# INLINABLE hammeredLookup #-}+{-# SPECIALIZE hammeredLookup :: [(Int, value)] -> Int -> Maybe value #-}+{-# SPECIALIZE hammeredLookup @Int #-}+{-# SPECIALIZE [0] hammeredLookup :: [(Char, value)] -> Char -> Maybe value #-}++fn :: Bool -> Int -> Int+fn b i = if b then i + 1 else i - 1+{-# SPECIALIZE fn True #-}+{-# SPECIALIZE fn False #-}++specInline :: Num a => a -> a+specInline x = x + x+{-# SPECIALIZE INLINE specInline :: Int -> Int #-}++specNoInline :: Num a => a -> a+specNoInline x = x * x+{-# SPECIALIZE NOINLINE [0] specNoInline :: Int -> Int #-}
+ test/Test/Fixtures/oracle/pragma/UnpackPragmaVariants.hs view
@@ -0,0 +1,14 @@+{- ORACLE_TEST pass -}+module UnpackPragmaVariants where++-- Test case-insensitive and extra whitespace+data X1 = X1 {-#     unpack      #-} !X1++-- Test no spaces around pragma name+data X2 = X2 {-#unpack#-} !X2++-- Test no spaces with NOUNPACK+data X3 = X3 {-#nounpack#-} !X3++-- Test extra whitespace with NOUNPACK+data X4 = X4 {-#    NOUNPACK   #-} !X4
+ test/Test/Fixtures/oracle/pragma/UnpackPragmas.hs view
@@ -0,0 +1,15 @@+{- ORACLE_TEST pass -}+module UnpackPragmas where++import Data.Word (Word8, Word32)++data Pair = Pair {-# UNPACK #-} !Int {-# UNPACK #-} !Int++data Nested = Nested {-# UNPACK #-} !Inner++data Inner = Inner {-# UNPACK #-} !Int {-# UNPACK #-} !Int++data WordPacked = WordPacked+  {-# UNPACK #-} !Word32+  {-# UNPACK #-} !Word8+  {-# UNPACK #-} !Word32
+ test/Test/Fixtures/oracle/pragma/declaration-warning.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+module DeclarationWarning where++x = ()+{-# WARNING x "w" #-}
+ test/Test/Fixtures/oracle/pragma/deprecated-addFileExtension.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module PragmaDeprecatedAddFileExtension where++addFileExtension :: ()+{-# DEPRECATED addFileExtension "Please use addExtension instead." #-}+addFileExtension = ()
+ test/Test/Fixtures/oracle/pragma/deprecated-prime-name.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module PragmaDeprecatedPrimeName where++ioMemo' :: ()+{-# DEPRECATED ioMemo' "Please just call the action directly." #-}+ioMemo' = ()
+ test/Test/Fixtures/oracle/pragma/export-warnings-reexport-lowercase.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module ExportWarningsReexportLowercase+  ( {-# deprecated "Import g from ExportWarningsImport instead" #-} g+  ) where++import ExportWarningsImport (g)
+ test/Test/Fixtures/oracle/pragma/inline-pragma-lowercase.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module InlinePragmaLowercase where++fn :: Int -> Int+fn x = x + 1+{-#inline fn#-}
+ test/Test/Fixtures/oracle/pragma/instance-deprecated-pragma-lowercase.hs view
@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+module InstanceDeprecatedPragmaLowercase where++data T1 = T1++instance {-#deprecated "Do not use Show T1" #-} Show T1 where+  show _ = "T1"
+ test/Test/Fixtures/oracle/pragma/multiple-multiline.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE BangPatterns,+             GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Demo where+x = 1
+ test/Test/Fixtures/oracle/pragma/scc-expression.hs view
@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}++module SCCPragmaExpression where++mapL f lx = cachedLatch ({-# SCC mapL #-} f <$> getValueL lx)
+ test/Test/Fixtures/oracle/pragma/source-import-lowercase.hs view
@@ -0,0 +1,4 @@+{- ORACLE_TEST pass -}+module SourceImportLowercase where++import {-# source #-} SourceLoopA
+ test/Test/Fixtures/oracle/pragma/unpack-pragma-lowercase.hs view
@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+module UnpackPragmaLowercase where++data Inner = Inner !Int++data Nested = Nested {-# unpack #-} !Inner
+ test/Test/Fixtures/performance/module/deeply-nested-type.yaml view
@@ -0,0 +1,5 @@+extensions:+  - ForeignFunctionInterface+status: pass+input: |+  fn :: (B -> (B -> (B -> (B -> (B -> (B -> (B -> (B -> (B -> (B -> (C -> ((Ptr C) -> (B -> ((Ptr C) -> (B -> (IO ()))))))))))))))))
+ test/Test/Fixtures/performance/module/nested-constructor-pattern.yaml view
@@ -0,0 +1,3 @@+extensions: []+input: |+  fn (A(A(A(A(A(A(A(A(A(A(A))))))))))) = 10
+ test/Test/HackageTester/Suite.hs view
@@ -0,0 +1,552 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.HackageTester.Suite+  ( hackageTesterTests,+  )+where++import Aihc.Cpp (IncludeKind (..), IncludeRequest (..), Result (..))+import Aihc.Parser.Syntax qualified as Syntax+import Control.Exception (bracket)+import CppSupport (preprocessForParserIfEnabled)+import Data.ByteString qualified as BS+import Data.List (isSuffixOf)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import GhcOracle (oracleModuleAstFingerprint)+import HackageSupport (fileInfoIncludeDirs, fileInfoPath, findTargetFilesFromCabal, resolveIncludeBestEffort)+import HackageTester.CLI (Options (..), parseOptionsPure)+import HackageTester.Model (FileResult (..), Outcome (..), Summary (..), shouldFailSummary, summarizeResults)+import System.Directory (createDirectory, getTemporaryDirectory, removeDirectoryRecursive, removeFile)+import System.FilePath ((</>))+import System.IO (hClose, openTempFile)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase)++hackageTesterTests :: TestTree+hackageTesterTests =+  testGroup+    "hackage-tester"+    [ testGroup+        "cli"+        [ testCase "parses required package argument" test_cliParsesPackage,+          testCase "parses optional flags" test_cliParsesOptionalFlags,+          testCase "rejects missing package" test_cliRejectsMissingPackage,+          testCase "rejects invalid jobs" test_cliRejectsInvalidJobs+        ],+      testGroup+        "summary"+        [ testCase "counts outcomes correctly" test_summaryCountsOutcomes,+          testCase "fails when no files were processed" test_zeroFilesFails+        ],+      testGroup+        "oracle"+        [ testCase "accepts No-prefixed LANGUAGE pragmas" test_oracleAcceptsNoPrefixedLanguagePragma,+          testCase "accepts LANGUAGE Haskell2010 pragmas" test_oracleAcceptsHaskell2010LanguagePragma,+          testCase "accepts mixed-case LANGUAGE pragmas" test_oracleAcceptsMixedCaseLanguagePragma,+          testCase "accepts NondecreasingIndentation pragmas" test_oracleAcceptsNondecreasingIndentationPragma,+          testCase "applies implied extensions" test_oracleAppliesImpliedExtensions,+          testCase "treats PolymorphicComponents as RankNTypes" test_oracleTreatsPolymorphicComponentsAsRankNTypes,+          testCase "defaults to Haskell2010 when language is omitted" test_oracleDefaultsToHaskell2010,+          testCase "uses Haskell2010 language defaults" test_oracleUsesHaskell2010Defaults,+          testCase "uses Haskell98 fallback defaults" test_oracleUsesHaskell98FallbackDefaults,+          testCase "handles CPP-defined LANGUAGE pragmas" test_oracleHandlesCppDefinedLanguagePragmas+        ],+      testGroup+        "package-selection"+        [ testCase "skips files from non-buildable components by default flags" test_skipsNonBuildableComponents,+          testCase "prefers top-level cabal when multiple cabal files exist" test_prefersTopLevelCabalWhenMultipleExist,+          testCase "collects include-dirs from cabal files" test_collectsIncludeDirs+        ],+      testGroup+        "cpp-macros"+        [ testCase "MIN_VERSION_base branch is taken" test_cppMinVersionBaseTrue,+          testCase "MIN_VERSION_ghc branch is taken" test_cppMinVersionGhcTrue,+          testCase "negated MIN_VERSION_ghc branch is not taken" test_cppNegatedMinVersionGhcFalse,+          testCase "MIN_VERSION_GLASGOW_HASKELL branch is taken" test_cppMinVersionGlasgowHaskellTrue,+          testCase "unknown MIN_VERSION package in include branch is taken" test_cppUnknownMinVersionFromIncludeTrue,+          testCase "cpp-options macros do not enable preprocessing without CPP extension" test_cppOptionsWithoutCppExtensionDoNotPreprocess+        ],+      testGroup+        "io"+        [ testCase "include resolution decodes invalid utf8 leniently" test_resolveIncludeLenientDecode+        ]+    ]++test_cliParsesPackage :: Assertion+test_cliParsesPackage =+  assertEqual+    "expected defaults with required package"+    (Right (Options "transformers" Nothing Nothing False False))+    (parseOptionsPure ["transformers"])++test_cliParsesOptionalFlags :: Assertion+test_cliParsesOptionalFlags =+  assertEqual+    "expected all optional flags to parse"+    (Right (Options "text" (Just "2.0.2") (Just 4) True True))+    (parseOptionsPure ["text", "--version", "2.0.2", "--jobs", "4", "--json", "--only-ghc-errors"])++test_cliRejectsMissingPackage :: Assertion+test_cliRejectsMissingPackage =+  assertLeftContaining "Missing: PACKAGE" (parseOptionsPure [])++test_cliRejectsInvalidJobs :: Assertion+test_cliRejectsInvalidJobs =+  assertLeftContaining "must be a positive integer" (parseOptionsPure ["bytestring", "--jobs", "0"])++test_summaryCountsOutcomes :: Assertion+test_summaryCountsOutcomes = do+  let results =+        [ FileResult "A.hs" OutcomeSuccess [] Nothing,+          FileResult "B.hs" OutcomeGhcError [] Nothing,+          FileResult "C.hs" OutcomeParseError [] Nothing,+          FileResult "D.hs" OutcomeRoundtripFail [] Nothing+        ]+      summary = summarizeResults results+  assertEqual "total files" 4 (totalFiles summary)+  assertEqual "successes" 1 (successCount summary)+  assertEqual "failures" 3 (failureCount summary)+  assertEqual "ghc errors" 1 (ghcErrors summary)+  assertEqual "parse errors" 1 (parseErrors summary)+  assertEqual "roundtrip fails" 1 (roundtripFails summary)++test_zeroFilesFails :: Assertion+test_zeroFilesFails =+  assertBool "expected empty run to fail" (shouldFailSummary (summarizeResults []))++test_oracleAcceptsNoPrefixedLanguagePragma :: Assertion+test_oracleAcceptsNoPrefixedLanguagePragma =+  case oracleModuleAstFingerprint "hackage-tester" Syntax.Haskell2010Edition [] source of+    Left err ->+      assertBool+        ("expected NoMonomorphismRestriction pragma to be accepted, got: " <> T.unpack err)+        False+    Right {} -> pure ()+  where+    source =+      T.unlines+        [ "{-# LANGUAGE NoMonomorphismRestriction #-}",+          "module A where",+          "x = 1"+        ]++test_oracleAcceptsHaskell2010LanguagePragma :: Assertion+test_oracleAcceptsHaskell2010LanguagePragma =+  case oracleModuleAstFingerprint "hackage-tester" Syntax.Haskell2010Edition [] source of+    Left err ->+      assertBool+        ("expected Haskell2010 language pragma to be accepted, got: " <> T.unpack err)+        False+    Right {} -> pure ()+  where+    source =+      T.unlines+        [ "{-# LANGUAGE Haskell2010 #-}",+          "module A where",+          "x = 1"+        ]++test_oracleAcceptsMixedCaseLanguagePragma :: Assertion+test_oracleAcceptsMixedCaseLanguagePragma =+  case oracleModuleAstFingerprint "hackage-tester" Syntax.Haskell2010Edition [] source of+    Left err ->+      assertBool+        ("expected mixed-case BlockArguments pragma to be accepted, got: " <> T.unpack err)+        False+    Right {} -> pure ()+  where+    source =+      T.unlines+        [ "{-# Language BlockArguments #-}",+          "module A where",+          "x = unsafePerformIO do",+          "  pure ()"+        ]++test_oracleAcceptsNondecreasingIndentationPragma :: Assertion+test_oracleAcceptsNondecreasingIndentationPragma =+  case oracleModuleAstFingerprint "hackage-tester" Syntax.Haskell2010Edition [] source of+    Left err ->+      assertBool+        ("expected NondecreasingIndentation pragma to be accepted, got: " <> T.unpack err)+        False+    Right {} -> pure ()+  where+    source =+      T.unlines+        [ "{-# LANGUAGE NondecreasingIndentation #-}",+          "module A where",+          "foo = case True of",+          "  True -> do",+          "  x <- pure ()",+          "  pure x"+        ]++test_oracleAppliesImpliedExtensions :: Assertion+test_oracleAppliesImpliedExtensions =+  case oracleModuleAstFingerprint "hackage-tester" Syntax.Haskell2010Edition [] source of+    Left err ->+      assertBool+        ("expected ScopedTypeVariables to imply ExplicitForAll, got: " <> T.unpack err)+        False+    Right {} -> pure ()+  where+    source =+      T.unlines+        [ "{-# LANGUAGE ScopedTypeVariables #-}",+          "module A where",+          "f :: forall a. a -> a",+          "f x = x"+        ]++test_oracleTreatsPolymorphicComponentsAsRankNTypes :: Assertion+test_oracleTreatsPolymorphicComponentsAsRankNTypes =+  case oracleModuleAstFingerprint "hackage-tester" Syntax.Haskell2010Edition [Syntax.EnableExtension Syntax.PolymorphicComponents] source of+    Left err ->+      assertBool+        ("expected PolymorphicComponents to imply RankNTypes and ExplicitForAll, got: " <> T.unpack err)+        False+    Right {} -> pure ()+  where+    source =+      T.unlines+        [ "module A where",+          "data R m = R { runR :: forall a. m a -> m a }"+        ]++test_oracleDefaultsToHaskell2010 :: Assertion+test_oracleDefaultsToHaskell2010 =+  case oracleModuleAstFingerprint "hackage-tester" Syntax.Haskell2010Edition [] source of+    Left err ->+      assertBool+        ("expected omitted language to default to Haskell2010 record syntax, got: " <> T.unpack err)+        False+    Right {} -> pure ()+  where+    source =+      T.unlines+        [ "module A where",+          "data R = R { field :: Int }"+        ]++test_oracleUsesHaskell2010Defaults :: Assertion+test_oracleUsesHaskell2010Defaults =+  case oracleModuleAstFingerprint "hackage-tester" Syntax.Haskell2010Edition [] source of+    Left err ->+      assertBool+        ("expected Haskell2010 defaults to enable traditional record syntax, got: " <> T.unpack err)+        False+    Right {} -> pure ()+  where+    source =+      T.unlines+        [ "module A where",+          "data R = R { field :: Int }"+        ]++test_oracleUsesHaskell98FallbackDefaults :: Assertion+test_oracleUsesHaskell98FallbackDefaults =+  case oracleModuleAstFingerprint "hackage-tester" Syntax.Haskell98Edition [] source of+    Left err ->+      assertBool+        ("expected Haskell98 fallback defaults to allow nondecreasing indentation, got: " <> T.unpack err)+        False+    Right {} -> pure ()+  where+    source =+      T.unlines+        [ "module A where",+          "foo bs = do",+          "  let fn offset x = id $ \\(a, b) -> do",+          "      pure (offset + b)",+          "  pure bs"+        ]++test_oracleHandlesCppDefinedLanguagePragmas :: Assertion+test_oracleHandlesCppDefinedLanguagePragmas =+  case oracleModuleAstFingerprint "hackage-tester" Syntax.Haskell2010Edition [] source of+    Left err ->+      assertBool+        ("expected oracle to honor CPP-defined LANGUAGE pragmas, got: " <> T.unpack err)+        False+    Right {} -> pure ()+  where+    source =+      T.unlines+        [ "{-# LANGUAGE CPP #-}",+          "#if 1",+          "{-# LANGUAGE LambdaCase #-}",+          "#endif",+          "module Test where",+          "x = \\case _ -> ()"+        ]++test_skipsNonBuildableComponents :: Assertion+test_skipsNonBuildableComponents =+  withTempDir "hackage-tester" $ \root -> do+    let cabalFile = root </> "demo.cabal"+        readmeFile = root </> "README.lhs"+        srcDir = root </> "src"+        mainFile = srcDir </> "Main.hs"++    createDirectory srcDir+    writeFile readmeFile "This is not buildable by default.\n"+    writeFile mainFile "main :: IO ()\nmain = pure ()\n"+    writeFile cabalFile sampleCabal++    files <- findTargetFilesFromCabal root+    let selected = map fileInfoPath files+    assertBool "expected Main.hs to be selected" (any ("src/Main.hs" `isSuffixOf`) selected)+    assertBool "expected README.lhs from disabled component to be skipped" (not (any ("README.lhs" `isSuffixOf`) selected))++test_prefersTopLevelCabalWhenMultipleExist :: Assertion+test_prefersTopLevelCabalWhenMultipleExist =+  withTempDir "hackage-tester" $ \root -> do+    let rootCabal = root </> "demo.cabal"+        nestedDir = root </> "testdata"+        nestedCabal = nestedDir </> "fixture.cabal"+        srcDir = root </> "src"+        mainFile = srcDir </> "Main.hs"++    createDirectory nestedDir+    createDirectory srcDir+    writeFile mainFile "module Main where\nmain :: IO ()\nmain = pure ()\n"+    writeFile rootCabal sampleCabal+    writeFile nestedCabal nestedFixtureCabal++    files <- findTargetFilesFromCabal root+    let selected = map fileInfoPath files+    assertBool "expected Main.hs from top-level package to be selected" (any ("src/Main.hs" `isSuffixOf`) selected)++test_collectsIncludeDirs :: Assertion+test_collectsIncludeDirs =+  withTempDir "hackage-tester" $ \root -> do+    let cabalFile = root </> "demo.cabal"+        srcDir = root </> "src"+        mainFile = srcDir </> "Main.hs"+        expectedIncludeDir = root </> "generated" </> "include"++    createDirectory srcDir+    writeFile mainFile "module Main where\nmain :: IO ()\nmain = pure ()\n"+    writeFile cabalFile includeDirCabal++    files <- findTargetFilesFromCabal root+    case files of+      [fileInfo] ->+        assertEqual+          "expected cabal include-dirs to be preserved"+          [expectedIncludeDir]+          (fileInfoIncludeDirs fileInfo)+      _ -> assertBool "expected one selected source file" False++test_resolveIncludeLenientDecode :: Assertion+test_resolveIncludeLenientDecode =+  withTempDir "hackage-tester" $ \root -> do+    let srcDir = root </> "src"+        incDir = root </> "include"+        current = srcDir </> "Main.hs"+        includeFile = incDir </> "bad.inc"+    createDirectory srcDir+    createDirectory incDir+    writeFile current "module Main where\n"+    BS.writeFile includeFile (BS.pack [65, 10, 255, 66, 10]) -- A\n<invalid>B\n+    mText <-+      resolveIncludeBestEffort+        root+        []+        current+        IncludeRequest+          { includePath = "bad.inc",+            includeKind = IncludeSystem,+            includeFrom = current,+            includeLine = 1+          }+    case mText of+      Nothing -> assertBool "expected include bytes to resolve" False+      Just bs ->+        assertBool "expected raw bytes to be preserved" (bs == BS.pack [65, 10, 255, 66, 10])++test_cppMinVersionBaseTrue :: Assertion+test_cppMinVersionBaseTrue = do+  out <- preprocessWithIncludes "A.hs" ["base"] [] source+  assertBool "expected true branch for MIN_VERSION_base" ("hit\n" `T.isInfixOf` out)+  where+    source =+      T.unlines+        [ "{-# LANGUAGE CPP #-}",+          "#if MIN_VERSION_base(4,12,0)",+          "hit",+          "#else",+          "miss",+          "#endif"+        ]++test_cppMinVersionGhcTrue :: Assertion+test_cppMinVersionGhcTrue = do+  out <- preprocessWithIncludes "A.hs" [] [] source+  assertBool "expected true branch for MIN_VERSION_ghc" ("hit\n" `T.isInfixOf` out)+  where+    source =+      T.unlines+        [ "{-# LANGUAGE CPP #-}",+          "#if MIN_VERSION_ghc(8,6,0)",+          "hit",+          "#else",+          "miss",+          "#endif"+        ]++test_cppNegatedMinVersionGhcFalse :: Assertion+test_cppNegatedMinVersionGhcFalse = do+  out <- preprocessWithIncludes "A.hs" [] [] source+  assertBool "expected negated branch to be false for MIN_VERSION_ghc" ("miss\n" `T.isInfixOf` out)+  where+    source =+      T.unlines+        [ "{-# LANGUAGE CPP #-}",+          "#if !MIN_VERSION_ghc(8,8,0)",+          "hit",+          "#else",+          "miss",+          "#endif"+        ]++test_cppMinVersionGlasgowHaskellTrue :: Assertion+test_cppMinVersionGlasgowHaskellTrue = do+  out <- preprocessWithIncludes "A.hs" [] [] source+  assertBool "expected true branch for MIN_VERSION_GLASGOW_HASKELL" ("hit\n" `T.isInfixOf` out)+  where+    source =+      T.unlines+        [ "{-# LANGUAGE CPP #-}",+          "#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)",+          "hit",+          "#else",+          "miss",+          "#endif"+        ]++test_cppUnknownMinVersionFromIncludeTrue :: Assertion+test_cppUnknownMinVersionFromIncludeTrue = do+  out <- preprocessWithIncludes "A.hs" ["custompkg"] includes source+  assertBool "expected true branch for unknown MIN_VERSION in include" ("hit\n" `T.isInfixOf` out)+  where+    source =+      T.unlines+        [ "{-# LANGUAGE CPP #-}",+          "#include \"defs.h\""+        ]+    includes =+      [ ("defs.h", T.unlines ["#if MIN_VERSION_custompkg(1,2,3)", "hit", "#else", "miss", "#endif"])+      ]++test_cppOptionsWithoutCppExtensionDoNotPreprocess :: Assertion+test_cppOptionsWithoutCppExtensionDoNotPreprocess = do+  Result {resultOutput = out} <-+    preprocessForParserIfEnabled [] ["-DTEST=1"] "A.hs" [] (\_ -> pure Nothing) source+  assertEqual "expected source to remain unchanged when CPP extension is not enabled" source out+  where+    source =+      T.unlines+        [ "module A where",+          "#if TEST",+          "x = 1",+          "#else",+          "x = 2",+          "#endif"+        ]++preprocessWithIncludes :: FilePath -> [T.Text] -> [(FilePath, T.Text)] -> T.Text -> IO T.Text+preprocessWithIncludes inputFile deps includeFiles source = do+  Result {resultOutput = out} <-+    preprocessForParserIfEnabled [] [] inputFile deps resolve source+  pure out+  where+    resolve req = pure (TE.encodeUtf8 <$> lookup (includePath req) includeFiles)++sampleCabal :: String+sampleCabal =+  unlines+    [ "cabal-version: 2.4",+      "name: demo",+      "version: 0.1.0.0",+      "",+      "flag build-readme",+      "  default: False",+      "  manual: True",+      "",+      "executable readme",+      "  if !flag(build-readme)",+      "    buildable: False",+      "  main-is: README.lhs",+      "  build-depends: base",+      "  default-language: Haskell2010",+      "",+      "executable cli",+      "  main-is: Main.hs",+      "  hs-source-dirs: src",+      "  build-depends: base",+      "  default-language: Haskell2010"+    ]++nestedFixtureCabal :: String+nestedFixtureCabal =+  unlines+    [ "cabal-version: 2.4",+      "name: fixture",+      "version: 0.1.0.0",+      "executable fixture",+      "  main-is: Fixture.hs",+      "  build-depends: base",+      "  default-language: Haskell2010"+    ]++includeDirCabal :: String+includeDirCabal =+  unlines+    [ "cabal-version: 2.4",+      "name: demo",+      "version: 0.1.0.0",+      "",+      "executable cli",+      "  main-is: Main.hs",+      "  hs-source-dirs: src",+      "  include-dirs: generated/include",+      "  build-depends: base",+      "  default-language: Haskell2010"+    ]++withTempDir :: String -> (FilePath -> IO a) -> IO a+withTempDir prefix action = do+  tempRoot <- getTemporaryDirectory+  (tempFile, tempHandle) <- openTempFile tempRoot (prefix ++ "-XXXXXX")+  hClose tempHandle+  removeFile tempFile+  createDirectory tempFile+  bracket+    (pure tempFile)+    removeDirectoryRecursive+    action++assertLeftContaining :: String -> Either String a -> Assertion+assertLeftContaining needle result =+  case result of+    Left err ->+      assertBool+        ("expected parse error to contain " ++ show needle ++ ", got: " ++ err)+        (needle `contains` err)+    Right _ ->+      assertBool "expected parse failure but got success" False++contains :: String -> String -> Bool+contains needle haystack = any (needle `prefixOf`) (tails haystack)++prefixOf :: String -> String -> Bool+prefixOf [] _ = True+prefixOf _ [] = False+prefixOf (x : xs) (y : ys) = x == y && prefixOf xs ys++tails :: [a] -> [[a]]+tails [] = [[]]+tails xs@(_ : rest) = xs : tails rest
+ test/Test/Lexer/Suite.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Lexer.Suite+  ( lexerTests,+  )+where++import Control.Monad (unless, when)+import Data.Text qualified as T+import LexerGolden qualified as LG+import System.FilePath (takeExtension)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertFailure, testCase, testCaseInfo)++lexerTests :: IO TestTree+lexerTests = do+  cases <- LG.loadLexerCases+  checks <- mapM mkCaseTest cases+  summary <- mkSummaryTest cases+  pure (testGroup "lexer-golden" ([fixtureValidationTests] <> checks <> [summary]))++mkCaseTest :: LG.LexerCase -> IO TestTree+mkCaseTest meta = pure $ case LG.caseStatus meta of+  LG.StatusXFail -> testCaseInfo (LG.caseId meta) (xfailDetails (LG.evaluateLexerCase meta) <* assertCase meta)+  _ -> testCase (LG.caseId meta) (assertCase meta)++xfailDetails :: (LG.Outcome, String) -> IO String+xfailDetails (outcome, details) = do+  case outcome of+    LG.OutcomeXFail -> pure ()+    _ -> assertFailure ("expected xfail outcome, got: " <> show outcome)+  pure details++mkSummaryTest :: [LG.LexerCase] -> IO TestTree+mkSummaryTest cases = do+  let outcomes = map evaluate cases+  pure $+    testCase "summary" $ do+      let (passN, xfailN, xpassN, failN) = LG.progressSummary outcomes+          totalN = passN + xfailN + xpassN + failN+          completion = pct passN totalN+      when (failN > 0 || xpassN > 0) $+        assertFailure+          ( "lexer golden regressions found. "+              <> "pass="+              <> show passN+              <> " xfail="+              <> show xfailN+              <> " xpass="+              <> show xpassN+              <> " fail="+              <> show failN+              <> " completion="+              <> show completion+              <> "%"+          )++assertCase :: LG.LexerCase -> Assertion+assertCase meta =+  case LG.evaluateLexerCase meta of+    (LG.OutcomeFail, details) ->+      assertFailure+        ( "Regression in lexer case "+            <> LG.caseId meta+            <> " ("+            <> LG.caseCategory meta+            <> ") expected "+            <> show (LG.caseStatus meta)+            <> " reason="+            <> LG.caseReason meta+            <> " details="+            <> details+        )+    (LG.OutcomeXPass, details) ->+      assertFailure+        ( "Unexpected pass in xpass lexer case "+            <> LG.caseId meta+            <> " reason="+            <> LG.caseReason meta+            <> " details="+            <> details+        )+    _ -> pure ()++evaluate :: LG.LexerCase -> (LG.LexerCase, LG.Outcome, String)+evaluate meta =+  let (outcome, details) = LG.evaluateLexerCase meta+   in (meta, outcome, details)++pct :: Int -> Int -> Double+pct done totalN+  | totalN <= 0 = 0.0+  | otherwise = fromIntegral (done * 10000 `div` totalN) / 100.0++fixtureValidationTests :: TestTree+fixtureValidationTests =+  testGroup+    "fixture-parse"+    [ testCase "rejects missing required keys" $+        case LG.parseLexerCaseText "missing.yaml" "extensions: []\n" of+          Left _ -> pure ()+          Right _ -> assertFailure "expected parse failure for missing required YAML keys",+      testCase "requires reason for xfail" $+        case LG.parseLexerCaseText "xfail.yaml" validXFailMissingReason of+          Left _ -> pure ()+          Right _ -> assertFailure "expected parse failure when xfail reason is missing",+      testCase "accepts xpass with reason" $+        case LG.parseLexerCaseText "xpass.yaml" validXPassFixture of+          Left err -> assertFailure ("expected parse success, got: " <> err)+          Right parsed ->+            if LG.caseStatus parsed == LG.StatusXPass+              then pure ()+              else assertFailure "expected xpass status",+      testCase "xfail lexer mismatches retain details" $+        case LG.parseLexerCaseText "xfail-details.yaml" validXFailFixture of+          Left err -> assertFailure ("expected parse success, got: " <> err)+          Right parsed ->+            case LG.evaluateLexerCase parsed of+              (LG.OutcomeXFail, details)+                | null details -> assertFailure "expected xfail details to be non-empty"+                | otherwise -> pure ()+              other -> assertFailure ("expected xfail outcome with details, got: " <> show other),+      testCase "only YAML fixtures are loaded" $ do+        cases <- LG.loadLexerCases+        mapM_+          ( \meta ->+              unless (takeExtension (LG.casePath meta) `elem` [".yaml", ".yml"]) $+                assertFailure ("unexpected non-lexer fixture loaded: " <> LG.casePath meta)+          )+          cases+    ]++validXFailMissingReason :: T.Text+validXFailMissingReason =+  T.unlines+    [ "extensions: []",+      "input: bad",+      "tokens:",+      "  - 'TkVarId \"bad\"'",+      "status: xfail"+    ]++validXFailFixture :: T.Text+validXFailFixture =+  T.unlines+    [ "extensions: []",+      "input: \"-10\"",+      "tokens:",+      "  - 'TkVarSym \"-\"'",+      "  - 'TkInteger 10 TInteger'",+      "status: xfail",+      "reason: known bug"+    ]++validXPassFixture :: T.Text+validXPassFixture =+  T.unlines+    [ "extensions: []",+      "input: \"-10\"",+      "tokens:",+      "  - 'TkVarSym \"-\"'",+      "  - 'TkInteger 10 TInteger'",+      "status: xpass",+      "reason: known bug"+    ]
+ test/Test/Oracle/Suite.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Oracle.Suite+  ( oracleTests,+  )+where++import Control.Monad (when)+import Data.Text (Text)+import Data.Text.IO qualified as TIO+import ExtensionSupport+  ( CaseMeta (..),+    Expected (..),+    Outcome (..),+    caseSourcePath,+    evaluateCaseFromFile,+    evaluateCaseText,+    loadOracleCases,+  )+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertFailure, testCase, testCaseInfo)++oracleTests :: IO TestTree+oracleTests = do+  cases <- loadOracleCases+  checks <- mapM mkCaseTest cases+  framework <- frameworkTests+  summary <- mkSummaryTest cases+  pure (testGroup "oracle" (checks <> [framework, summary]))++mkCaseTest :: CaseMeta -> IO TestTree+mkCaseTest meta = do+  source <- TIO.readFile (caseSourcePath meta)+  pure $ case caseExpected meta of+    ExpectXFail -> testCaseInfo (caseId meta) (xfailDetails (evaluateCaseText meta source) <* assertCase meta source)+    _ -> testCase (caseId meta) (assertCase meta source)++xfailDetails :: (CaseMeta, Outcome, String) -> IO String+xfailDetails (_, outcome, details) = do+  case outcome of+    OutcomeXFail -> pure ()+    _ -> assertFailure ("expected xfail outcome, got: " <> show outcome)+  pure details++mkSummaryTest :: [CaseMeta] -> IO TestTree+mkSummaryTest cases = do+  outcomes <- mapM evaluateCaseFromFile cases+  pure $+    testCase "summary" $ do+      let (passN, xfailN, xpassN, failN) = foldr (countOutcome . snd3) (0, 0, 0, 0) outcomes+          totalN = passN + xfailN + xpassN + failN+          completion = pct (passN + xpassN) totalN+      when (failN > 0 || xpassN > 0) $+        assertFailure+          ( "Oracle regressions found. "+              <> "pass="+              <> show passN+              <> " xfail="+              <> show xfailN+              <> " xpass="+              <> show xpassN+              <> " fail="+              <> show failN+              <> " completion="+              <> show completion+              <> "%"+          )+  where+    snd3 (_, b, _) = b++countOutcome :: Outcome -> (Int, Int, Int, Int) -> (Int, Int, Int, Int)+countOutcome outcome (passN, xfailN, xpassN, failN) =+  case outcome of+    OutcomePass -> (passN + 1, xfailN, xpassN, failN)+    OutcomeXFail -> (passN, xfailN + 1, xpassN, failN)+    OutcomeXPass -> (passN, xfailN, xpassN + 1, failN)+    OutcomeFail -> (passN, xfailN, xpassN, failN + 1)++pct :: Int -> Int -> Double+pct done totalN+  | totalN <= 0 = 0.0+  | otherwise = fromIntegral (done * 10000 `div` totalN) / 100.0++assertCase :: CaseMeta -> Text -> Assertion+assertCase meta source = do+  let (_, outcome, details) = evaluateCaseText meta source+  case outcome of+    OutcomeFail ->+      assertFailure+        ( "Regression in case "+            <> caseId meta+            <> " ("+            <> caseCategory meta+            <> ") expected "+            <> show (caseExpected meta)+            <> " reason="+            <> caseReason meta+            <> " details="+            <> details+        )+    OutcomeXPass ->+      assertFailure+        ( "Unexpected pass in xfail case "+            <> caseId meta+            <> " ("+            <> caseCategory meta+            <> ") reason="+            <> caseReason meta+        )+    _ -> pure ()++frameworkTests :: IO TestTree+frameworkTests =+  pure $+    testGroup+      "framework"+      [ testCase "oracle parse failure fails xfail case" $+          let meta =+                CaseMeta+                  { caseId = "framework-invalid-xfail",+                    caseCategory = "framework",+                    casePath = "framework-invalid-xfail.hs",+                    caseExpected = ExpectXFail,+                    caseReason = "regression coverage",+                    caseExtensions = []+                  }+           in do+                let (_, outcome, _) = evaluateCaseText meta "module M where\nx = { y = 1, }\n"+                if outcome == OutcomeFail+                  then pure ()+                  else assertFailure ("expected OutcomeFail when oracle rejects fixture, got " <> show outcome),+        testCase "oracle rejects top-level block-argument lambda" $+          let meta =+                CaseMeta+                  { caseId = "framework-block-argument-lambda",+                    caseCategory = "framework",+                    casePath = "framework-block-argument-lambda.hs",+                    caseExpected = ExpectPass,+                    caseReason = "",+                    caseExtensions = []+                  }+           in do+                let (_, outcome, _) = evaluateCaseText meta "module M where\nf \\x -> x\n"+                if outcome == OutcomeFail+                  then pure ()+                  else assertFailure ("expected OutcomeFail when oracle rejects fixture, got " <> show outcome),+        testCase "oracle parse failure fails pass case" $+          let meta =+                CaseMeta+                  { caseId = "framework-invalid-pass",+                    caseCategory = "framework",+                    casePath = "framework-invalid-pass.hs",+                    caseExpected = ExpectPass,+                    caseReason = "",+                    caseExtensions = []+                  }+           in do+                let (_, outcome, _) = evaluateCaseText meta "module M where\nx = { y = 1, }\n"+                if outcome == OutcomeFail+                  then pure ()+                  else assertFailure ("expected OutcomeFail when oracle rejects fixture, got " <> show outcome)+      ]
+ test/Test/Parser/Suite.hs view
@@ -0,0 +1,478 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Parser.Suite+  ( parserGoldenTests,+  )+where++import Control.Monad (unless, when)+import Data.Text qualified as T+import ParserEquivalent qualified as PE+import ParserGolden qualified as PG+import System.FilePath (takeExtension)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertFailure, testCase, testCaseInfo)++parserGoldenTests :: IO TestTree+parserGoldenTests = do+  goldenTests <- parserGoldenGroup+  equivalentTests <- parserEquivalentGroup+  pure+    ( testGroup+        "parser-fixtures"+        [ goldenTests,+          equivalentTests+        ]+    )++parserGoldenGroup :: IO TestTree+parserGoldenGroup = do+  exprCases <- PG.loadExprCases+  importCases <- PG.loadImportCases+  moduleCases <- PG.loadModuleCases+  patternCases <- PG.loadPatternCases+  pragmaCases <- PG.loadPragmaCases++  exprChecks <- mapM mkExprCaseTest exprCases+  importChecks <- mapM mkModuleCaseTest importCases+  moduleChecks <- mapM mkModuleCaseTest moduleCases+  patternChecks <- mapM mkPatternCaseTest patternCases+  pragmaChecks <- mapM mkModuleCaseTest pragmaCases++  exprSummary <- mkSummaryTest "expr" PG.evaluateExprCase exprCases+  importSummary <- mkSummaryTest "import" PG.evaluateModuleCase importCases+  moduleSummary <- mkSummaryTest "module" PG.evaluateModuleCase moduleCases+  patternSummary <- mkSummaryTest "pattern" PG.evaluatePatternCase patternCases+  pragmaSummary <- mkSummaryTest "pragma" PG.evaluateModuleCase pragmaCases+  combinedSummary <- mkCombinedSummary exprCases importCases moduleCases patternCases pragmaCases++  pure+    ( testGroup+        "parser-golden"+        [ fixtureValidationTests,+          testGroup "expr" (exprChecks <> [exprSummary]),+          testGroup "import" (importChecks <> [importSummary]),+          testGroup "module" (moduleChecks <> [moduleSummary]),+          testGroup "pattern" (patternChecks <> [patternSummary]),+          testGroup "pragma" (pragmaChecks <> [pragmaSummary]),+          combinedSummary+        ]+    )++parserEquivalentGroup :: IO TestTree+parserEquivalentGroup = do+  exprCases <- PE.loadExprCases+  moduleCases <- PE.loadModuleCases+  declCases <- PE.loadDeclCases+  patternCases <- PE.loadPatternCases++  exprChecks <- mapM mkEquivalentExprCaseTest exprCases+  moduleChecks <- mapM mkEquivalentModuleCaseTest moduleCases+  declChecks <- mapM mkEquivalentDeclCaseTest declCases+  patternChecks <- mapM mkEquivalentPatternCaseTest patternCases++  exprSummary <- mkEquivalentSummaryTest "expr" PE.evaluateExprCase exprCases+  moduleSummary <- mkEquivalentSummaryTest "module" PE.evaluateModuleCase moduleCases+  declSummary <- mkEquivalentSummaryTest "decl" PE.evaluateDeclCase declCases+  patternSummary <- mkEquivalentSummaryTest "pattern" PE.evaluatePatternCase patternCases+  combinedSummary <- mkEquivalentCombinedSummary exprCases moduleCases declCases patternCases++  pure+    ( testGroup+        "parser-equivalent"+        [ equivalenceFixtureValidationTests,+          testGroup "expr" (exprChecks <> [exprSummary]),+          testGroup "module" (moduleChecks <> [moduleSummary]),+          testGroup "decl" (declChecks <> [declSummary]),+          testGroup "pattern" (patternChecks <> [patternSummary]),+          combinedSummary+        ]+    )++mkExprCaseTest :: PG.ParserCase -> IO TestTree+mkExprCaseTest meta = pure $ case PG.caseStatus meta of+  PG.StatusXFail -> testCaseInfo (PG.caseId meta) (xfailDetails (PG.evaluateExprCase meta) <* assertExprCase meta)+  _ -> testCase (PG.caseId meta) (assertExprCase meta)++mkModuleCaseTest :: PG.ParserCase -> IO TestTree+mkModuleCaseTest meta = pure $ case PG.caseStatus meta of+  PG.StatusXFail -> testCaseInfo (PG.caseId meta) (xfailDetails (PG.evaluateModuleCase meta) <* assertModuleCase meta)+  _ -> testCase (PG.caseId meta) (assertModuleCase meta)++mkPatternCaseTest :: PG.ParserCase -> IO TestTree+mkPatternCaseTest meta = pure $ case PG.caseStatus meta of+  PG.StatusXFail -> testCaseInfo (PG.caseId meta) (xfailDetails (PG.evaluatePatternCase meta) <* assertPatternCase meta)+  _ -> testCase (PG.caseId meta) (assertPatternCase meta)++xfailDetails :: (PG.Outcome, String) -> IO String+xfailDetails (outcome, details) = do+  case outcome of+    PG.OutcomeXFail -> pure ()+    _ -> assertFailure ("expected xfail outcome, got: " <> show outcome)+  pure details++mkSummaryTest :: String -> (PG.ParserCase -> (PG.Outcome, String)) -> [PG.ParserCase] -> IO TestTree+mkSummaryTest label evaluateCase cases = do+  let outcomes = map (evaluate evaluateCase) cases+  pure $ testCase (label <> " summary") (assertNoRegressions label outcomes)++mkCombinedSummary :: [PG.ParserCase] -> [PG.ParserCase] -> [PG.ParserCase] -> [PG.ParserCase] -> [PG.ParserCase] -> IO TestTree+mkCombinedSummary exprCases importCases moduleCases patternCases pragmaCases = do+  let exprOutcomes = map (evaluate PG.evaluateExprCase) exprCases+      importOutcomes = map (evaluate PG.evaluateModuleCase) importCases+      moduleOutcomes = map (evaluate PG.evaluateModuleCase) moduleCases+      patternOutcomes = map (evaluate PG.evaluatePatternCase) patternCases+      pragmaOutcomes = map (evaluate PG.evaluateModuleCase) pragmaCases+      outcomes = exprOutcomes <> importOutcomes <> moduleOutcomes <> patternOutcomes <> pragmaOutcomes+  pure $ testCase "summary" (assertNoRegressions "parser golden" outcomes)++assertExprCase :: PG.ParserCase -> Assertion+assertExprCase = assertCaseWith PG.evaluateExprCase++assertModuleCase :: PG.ParserCase -> Assertion+assertModuleCase = assertCaseWith PG.evaluateModuleCase++assertPatternCase :: PG.ParserCase -> Assertion+assertPatternCase = assertCaseWith PG.evaluatePatternCase++mkEquivalentExprCaseTest :: PE.EquivalentCase -> IO TestTree+mkEquivalentExprCaseTest meta = pure $ case PE.caseStatus meta of+  PE.StatusXFail -> testCaseInfo (PE.caseId meta) (equivalentXFailDetails (PE.evaluateExprCase meta) <* assertEquivalentExprCase meta)+  _ -> testCase (PE.caseId meta) (assertEquivalentExprCase meta)++mkEquivalentModuleCaseTest :: PE.EquivalentCase -> IO TestTree+mkEquivalentModuleCaseTest meta = pure $ case PE.caseStatus meta of+  PE.StatusXFail -> testCaseInfo (PE.caseId meta) (equivalentXFailDetails (PE.evaluateModuleCase meta) <* assertEquivalentModuleCase meta)+  _ -> testCase (PE.caseId meta) (assertEquivalentModuleCase meta)++mkEquivalentDeclCaseTest :: PE.EquivalentCase -> IO TestTree+mkEquivalentDeclCaseTest meta = pure $ case PE.caseStatus meta of+  PE.StatusXFail -> testCaseInfo (PE.caseId meta) (equivalentXFailDetails (PE.evaluateDeclCase meta) <* assertEquivalentDeclCase meta)+  _ -> testCase (PE.caseId meta) (assertEquivalentDeclCase meta)++mkEquivalentPatternCaseTest :: PE.EquivalentCase -> IO TestTree+mkEquivalentPatternCaseTest meta = pure $ case PE.caseStatus meta of+  PE.StatusXFail -> testCaseInfo (PE.caseId meta) (equivalentXFailDetails (PE.evaluatePatternCase meta) <* assertEquivalentPatternCase meta)+  _ -> testCase (PE.caseId meta) (assertEquivalentPatternCase meta)++equivalentXFailDetails :: (PE.Outcome, String) -> IO String+equivalentXFailDetails (outcome, details) = do+  case outcome of+    PE.OutcomeXFail -> pure ()+    _ -> assertFailure ("expected xfail outcome, got: " <> show outcome)+  pure details++mkEquivalentSummaryTest :: String -> (PE.EquivalentCase -> (PE.Outcome, String)) -> [PE.EquivalentCase] -> IO TestTree+mkEquivalentSummaryTest label evaluateCase cases = do+  let outcomes = map (evaluateEquivalent evaluateCase) cases+  pure $ testCase (label <> " summary") (assertNoEquivalentRegressions label outcomes)++mkEquivalentCombinedSummary :: [PE.EquivalentCase] -> [PE.EquivalentCase] -> [PE.EquivalentCase] -> [PE.EquivalentCase] -> IO TestTree+mkEquivalentCombinedSummary exprCases moduleCases declCases patternCases = do+  let exprOutcomes = map (evaluateEquivalent PE.evaluateExprCase) exprCases+      moduleOutcomes = map (evaluateEquivalent PE.evaluateModuleCase) moduleCases+      declOutcomes = map (evaluateEquivalent PE.evaluateDeclCase) declCases+      patternOutcomes = map (evaluateEquivalent PE.evaluatePatternCase) patternCases+      outcomes = exprOutcomes <> moduleOutcomes <> declOutcomes <> patternOutcomes+  pure $ testCase "summary" (assertNoEquivalentRegressions "parser equivalence" outcomes)++assertEquivalentExprCase :: PE.EquivalentCase -> Assertion+assertEquivalentExprCase = assertEquivalentCaseWith PE.evaluateExprCase++assertEquivalentModuleCase :: PE.EquivalentCase -> Assertion+assertEquivalentModuleCase = assertEquivalentCaseWith PE.evaluateModuleCase++assertEquivalentDeclCase :: PE.EquivalentCase -> Assertion+assertEquivalentDeclCase = assertEquivalentCaseWith PE.evaluateDeclCase++assertEquivalentPatternCase :: PE.EquivalentCase -> Assertion+assertEquivalentPatternCase = assertEquivalentCaseWith PE.evaluatePatternCase++assertCaseWith :: (PG.ParserCase -> (PG.Outcome, String)) -> PG.ParserCase -> Assertion+assertCaseWith evaluateCase meta =+  case evaluateCase meta of+    (PG.OutcomeFail, details) ->+      assertFailure+        ( "Regression in parser case "+            <> PG.caseId meta+            <> " ("+            <> PG.caseCategory meta+            <> ") expected "+            <> show (PG.caseStatus meta)+            <> " reason="+            <> PG.caseReason meta+            <> " details="+            <> details+        )+    (PG.OutcomeXPass, details) ->+      assertFailure+        ( "Unexpected pass in xfail parser case "+            <> PG.caseId meta+            <> " reason="+            <> PG.caseReason meta+            <> " details="+            <> details+        )+    _ -> pure ()++assertEquivalentCaseWith :: (PE.EquivalentCase -> (PE.Outcome, String)) -> PE.EquivalentCase -> Assertion+assertEquivalentCaseWith evaluateCase meta =+  case evaluateCase meta of+    (PE.OutcomeFail, details) ->+      assertFailure+        ( "Regression in parser equivalence case "+            <> PE.caseId meta+            <> " ("+            <> PE.caseCategory meta+            <> ") expected "+            <> show (PE.caseStatus meta)+            <> " reason="+            <> PE.caseReason meta+            <> " details="+            <> details+        )+    (PE.OutcomeXPass, details) ->+      assertFailure+        ( "Unexpected pass in xfail parser equivalence case "+            <> PE.caseId meta+            <> " reason="+            <> PE.caseReason meta+            <> " details="+            <> details+        )+    _ -> pure ()++assertNoRegressions :: String -> [(PG.ParserCase, PG.Outcome, String)] -> Assertion+assertNoRegressions label outcomes = do+  let (passN, xfailN, xpassN, failN) = PG.progressSummary outcomes+      totalN = passN + xfailN + xpassN + failN+      completion = pct passN totalN+  when (failN > 0 || xpassN > 0) $+    assertFailure+      ( label+          <> " regressions found. "+          <> "pass="+          <> show passN+          <> " xfail="+          <> show xfailN+          <> " xpass="+          <> show xpassN+          <> " fail="+          <> show failN+          <> " completion="+          <> show completion+          <> "%"+      )++evaluate :: (PG.ParserCase -> (PG.Outcome, String)) -> PG.ParserCase -> (PG.ParserCase, PG.Outcome, String)+evaluate evaluateCase meta =+  let (outcome, details) = evaluateCase meta+   in (meta, outcome, details)++assertNoEquivalentRegressions :: String -> [(PE.EquivalentCase, PE.Outcome, String)] -> Assertion+assertNoEquivalentRegressions label outcomes = do+  let (passN, xfailN, xpassN, failN) = PE.progressSummary outcomes+      totalN = passN + xfailN + xpassN + failN+      completion = pct passN totalN+  when (failN > 0 || xpassN > 0) $+    assertFailure+      ( label+          <> " regressions found. "+          <> "pass="+          <> show passN+          <> " xfail="+          <> show xfailN+          <> " xpass="+          <> show xpassN+          <> " fail="+          <> show failN+          <> " completion="+          <> show completion+          <> "%"+      )++evaluateEquivalent :: (PE.EquivalentCase -> (PE.Outcome, String)) -> PE.EquivalentCase -> (PE.EquivalentCase, PE.Outcome, String)+evaluateEquivalent evaluateCase meta =+  let (outcome, details) = evaluateCase meta+   in (meta, outcome, details)++pct :: Int -> Int -> Double+pct done totalN+  | totalN <= 0 = 0.0+  | otherwise = fromIntegral (done * 10000 `div` totalN) / 100.0++fixtureValidationTests :: TestTree+fixtureValidationTests =+  testGroup+    "fixture-parse"+    [ testCase "rejects missing required keys" $+        case PG.parseParserCaseText PG.CaseExpr "missing.yaml" "extensions: []\n" of+          Left _ -> pure ()+          Right _ -> assertFailure "expected parse failure for missing required YAML keys",+      testCase "requires reason for xfail" $+        case PG.parseParserCaseText PG.CaseExpr "xfail.yaml" validXFailMissingReason of+          Left _ -> pure ()+          Right _ -> assertFailure "expected parse failure when xfail reason is missing",+      testCase "requires ast for pass" $+        case PG.parseParserCaseText PG.CaseExpr "pass.yaml" validPassMissingAst of+          Left _ -> pure ()+          Right _ -> assertFailure "expected parse failure when pass ast is missing",+      testCase "rejects xpass status" $+        case PG.parseParserCaseText PG.CaseExpr "xpass.yaml" validXPassFixture of+          Left _ -> pure ()+          Right _ -> assertFailure "expected parse failure for xpass status",+      testCase "accepts xfail without ast" $+        case PG.parseParserCaseText PG.CaseExpr "xfail-no-ast.yaml" validXFailNoAst of+          Left err -> assertFailure ("expected parse success, got: " <> err)+          Right parsed ->+            if PG.caseStatus parsed == PG.StatusXFail && null (PG.caseAst parsed)+              then pure ()+              else assertFailure "expected xfail status with empty ast",+      testCase "xfail parse failures retain details" $+        case PG.parseParserCaseText PG.CaseExpr "xfail-details.yaml" validXFailWithParseFailure of+          Left err -> assertFailure ("expected parse success, got: " <> err)+          Right parsed ->+            case PG.evaluateExprCase parsed of+              (PG.OutcomeXFail, details)+                | null details -> assertFailure "expected xfail details to be non-empty"+                | otherwise -> pure ()+              other -> assertFailure ("expected xfail outcome with details, got: " <> show other),+      testCase "only YAML fixtures are loaded" $ do+        exprCases <- PG.loadExprCases+        importCases <- PG.loadImportCases+        moduleCases <- PG.loadModuleCases+        patternCases <- PG.loadPatternCases+        pragmaCases <- PG.loadPragmaCases+        let cases = exprCases <> importCases <> moduleCases <> patternCases <> pragmaCases+        mapM_+          ( \meta ->+              unless (takeExtension (PG.casePath meta) `elem` [".yaml", ".yml"]) $+                assertFailure ("unexpected non-parser fixture loaded: " <> PG.casePath meta)+          )+          cases+    ]++validXFailMissingReason :: T.Text+validXFailMissingReason =+  T.unlines+    [ "extensions: []",+      "input: bad",+      "status: xfail"+    ]++validXFailNoAst :: T.Text+validXFailNoAst =+  T.unlines+    [ "extensions: []",+      "input: bad",+      "status: xfail",+      "reason: known bug"+    ]++validXFailWithParseFailure :: T.Text+validXFailWithParseFailure =+  T.unlines+    [ "extensions: []",+      "input: \"(\"",+      "status: xfail",+      "reason: known bug"+    ]++validPassMissingAst :: T.Text+validPassMissingAst =+  T.unlines+    [ "extensions: []",+      "input: x",+      "status: pass"+    ]++validXPassFixture :: T.Text+validXPassFixture =+  T.unlines+    [ "extensions: []",+      "input: x",+      "ast: EVar \"x\"",+      "status: xpass",+      "reason: known bug"+    ]++equivalenceFixtureValidationTests :: TestTree+equivalenceFixtureValidationTests =+  testGroup+    "equivalence-fixture-parse"+    [ testCase "rejects missing required keys" $+        case PE.parseEquivalentCaseText PE.CaseExpr "missing.yaml" "extensions: []\n" of+          Left _ -> pure ()+          Right _ -> assertFailure "expected parse failure for missing required YAML keys",+      testCase "requires two equivalent inputs" $+        case PE.parseEquivalentCaseText PE.CaseExpr "one-input.yaml" validEquivalentSingleInput of+          Left _ -> pure ()+          Right _ -> assertFailure "expected parse failure for single equivalent input",+      testCase "requires reason for xfail" $+        case PE.parseEquivalentCaseText PE.CaseExpr "xfail.yaml" validEquivalentXFailMissingReason of+          Left _ -> pure ()+          Right _ -> assertFailure "expected parse failure when xfail reason is missing",+      testCase "rejects xpass status" $+        case PE.parseEquivalentCaseText PE.CaseExpr "xpass.yaml" validEquivalentXPassFixture of+          Left _ -> pure ()+          Right _ -> assertFailure "expected parse failure for xpass status",+      testCase "accepts pass fixture" $+        case PE.parseEquivalentCaseText PE.CaseExpr "pass.yaml" validEquivalentPassFixture of+          Left err -> assertFailure ("expected parse success, got: " <> err)+          Right parsed ->+            if PE.caseStatus parsed == PE.StatusPass && length (PE.caseInputs parsed) == 2+              then pure ()+              else assertFailure "expected pass status with two inputs",+      testCase "only YAML fixtures are loaded" $ do+        exprCases <- PE.loadExprCases+        moduleCases <- PE.loadModuleCases+        declCases <- PE.loadDeclCases+        patternCases <- PE.loadPatternCases+        let cases = exprCases <> moduleCases <> declCases <> patternCases+        mapM_+          ( \meta ->+              unless (takeExtension (PE.casePath meta) `elem` [".yaml", ".yml"]) $+                assertFailure ("unexpected non-parser equivalence fixture loaded: " <> PE.casePath meta)+          )+          cases+    ]++validEquivalentSingleInput :: T.Text+validEquivalentSingleInput =+  T.unlines+    [ "extensions: []",+      "equivalent:",+      "  - x",+      "status: pass"+    ]++validEquivalentXFailMissingReason :: T.Text+validEquivalentXFailMissingReason =+  T.unlines+    [ "extensions: []",+      "equivalent:",+      "  - x",+      "  - (x)",+      "status: xfail"+    ]++validEquivalentXPassFixture :: T.Text+validEquivalentXPassFixture =+  T.unlines+    [ "extensions: []",+      "equivalent:",+      "  - x",+      "  - (x)",+      "status: xpass",+      "reason: known bug"+    ]++validEquivalentPassFixture :: T.Text+validEquivalentPassFixture =+  T.unlines+    [ "extensions: []",+      "equivalent:",+      "  - x",+      "  - (x)",+      "status: pass"+    ]
+ test/Test/Performance/Suite.hs view
@@ -0,0 +1,354 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Performance.Suite+  ( parserPerformanceTests,+  )+where++import Aihc.Parser+import Aihc.Parser.Syntax (Extension, parseExtensionName)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Data.Aeson ((.!=), (.:), (.:?))+import Data.Aeson.Types (parseEither, withObject)+import Data.Char (chr, toLower)+import Data.List (sort)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Text.IO qualified as TIO+import Data.Yaml qualified as Y+import ParserGolden (ExpectedStatus (..))+import System.Directory (doesDirectoryExist, listDirectory)+import System.FilePath (takeExtension, (</>))+import System.Timeout (timeout)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertFailure, testCase, testCaseInfo)++data PerfCase = PerfCase+  { perfCaseId :: !String,+    perfCaseSourceName :: !FilePath,+    perfCaseExtensions :: ![Extension],+    perfCaseInput :: !Text,+    perfCaseStatus :: !ExpectedStatus,+    perfCaseReason :: !String+  }++fixtureRoot :: FilePath+fixtureRoot = "test/Test/Fixtures/performance/module"++timeoutMicros :: Int+timeoutMicros = 1000000++generatedCaseSize :: Int+generatedCaseSize = 200++parserPerformanceTests :: IO TestTree+parserPerformanceTests = do+  fixtureCases <- loadPerfCases+  pure $+    testGroup+      "performance"+      [ testGroup+          "parse-under-1s"+          [ testGroup "fixtures" (map mkPerfCaseTest fixtureCases),+            testGroup "generated" (map mkPerfCaseTest generatedPerfCases)+          ]+      ]++mkPerfCaseTest :: PerfCase -> TestTree+mkPerfCaseTest perfCase = case perfCaseStatus perfCase of+  StatusXFail -> testCaseInfo (perfCaseId perfCase) (xfailDetails perfCase <* assertPerfCase perfCase)+  _ -> testCase (perfCaseId perfCase) (assertPerfCase perfCase)++xfailDetails :: PerfCase -> IO String+xfailDetails perfCase = do+  outcome <-+    timeout timeoutMicros $+      evaluate $+        force $+          parseModule+            defaultConfig+              { parserSourceName = perfCaseSourceName perfCase,+                parserExtensions = perfCaseExtensions perfCase+              }+            (perfCaseInput perfCase)+  case outcome of+    Nothing -> pure ("known bug still present: module parse exceeded " <> show timeoutMicros <> "us")+    Just (errs, _)+      | null errs -> assertFailure "expected xfail performance case to still fail"+      | otherwise ->+          pure+            ( "known bug still present: "+                <> formatParseErrors (perfCaseSourceName perfCase) (Just (perfCaseInput perfCase)) errs+            )++assertPerfCase :: PerfCase -> Assertion+assertPerfCase perfCase = do+  outcome <-+    timeout timeoutMicros $+      evaluate $+        force $+          parseModule+            defaultConfig+              { parserSourceName = perfCaseSourceName perfCase,+                parserExtensions = perfCaseExtensions perfCase+              }+            (perfCaseInput perfCase)+  case (perfCaseStatus perfCase, outcome) of+    (StatusPass, Nothing) ->+      assertFailure+        ( "module parse exceeded "+            <> show timeoutMicros+            <> "us for "+            <> perfCaseId perfCase+        )+    (StatusPass, Just (errs, _))+      | not (null errs) ->+          assertFailure+            ( "expected parse success for performance case "+                <> perfCaseId perfCase+                <> ", got parse error: "+                <> formatParseErrors (perfCaseSourceName perfCase) (Just (perfCaseInput perfCase)) errs+            )+    (StatusXFail, Nothing) -> pure ()+    (StatusXFail, Just (errs, _))+      | null errs ->+          assertFailure+            ( "Unexpected pass in xfail performance case "+                <> perfCaseId perfCase+                <> " reason="+                <> perfCaseReason perfCase+            )+    _ -> pure ()++loadPerfCases :: IO [PerfCase]+loadPerfCases = do+  exists <- doesDirectoryExist fixtureRoot+  if not exists+    then pure []+    else do+      paths <- listFixtureFiles fixtureRoot+      mapM loadPerfCase paths++loadPerfCase :: FilePath -> IO PerfCase+loadPerfCase path = do+  source <- TIO.readFile path+  case parsePerfCaseText path source of+    Left err -> fail err+    Right perfCase -> pure perfCase++parsePerfCaseText :: FilePath -> Text -> Either String PerfCase+parsePerfCaseText path source = do+  value <-+    case Y.decodeEither' (TE.encodeUtf8 source) of+      Left err -> Left ("Invalid performance fixture " <> path <> ": " <> Y.prettyPrintParseException err)+      Right parsed -> Right parsed+  (extNames, inputText, statusText, reasonText) <-+    case parseEither+      ( withObject "performance fixture" $ \obj -> do+          exts <- obj .:? "extensions" .!= []+          inputText <- obj .: "input"+          status <- obj .:? "status" .!= "pass"+          reason <- obj .:? "reason" .!= ""+          pure (exts, inputText, status, reason)+      )+      value of+      Left err -> Left ("Invalid performance fixture schema in " <> path <> ": " <> err)+      Right parsed -> Right parsed+  exts <- traverse (parseExtension path) extNames+  status <- parseStatus path statusText+  pure+    PerfCase+      { perfCaseId = dropRootPrefix path,+        perfCaseSourceName = dropRootPrefix path,+        perfCaseExtensions = exts,+        perfCaseInput = inputText,+        perfCaseStatus = status,+        perfCaseReason = T.unpack reasonText+      }+  where+    parseExtension fixturePath raw =+      case parseExtensionName raw of+        Just ext -> Right ext+        Nothing -> Left ("Unknown parser extension " <> show raw <> " in " <> fixturePath)+    parseStatus fixturePath raw =+      case map toLower (T.unpack (T.strip raw)) of+        "pass" -> Right StatusPass+        "xfail" -> Right StatusXFail+        _ -> Left ("Invalid [status] in " <> fixturePath <> ": " <> T.unpack raw)++listFixtureFiles :: FilePath -> IO [FilePath]+listFixtureFiles dir = do+  entries <- sort <$> listDirectory dir+  concat+    <$> mapM+      ( \entry -> do+          let path = dir </> entry+          isDir <- doesDirectoryExist path+          if isDir+            then listFixtureFiles path+            else+              if map toLower (takeExtension path) `elem` [".yaml", ".yml"]+                then pure [path]+                else pure []+      )+      entries++dropRootPrefix :: FilePath -> FilePath+dropRootPrefix path =+  case splitAt (length fixtureRoot + 1) path of+    (prefix, rest)+      | prefix == fixtureRoot <> "/" -> rest+    _ -> path++generatedPerfCases :: [PerfCase]+generatedPerfCases =+  [ mkGeneratedPerfCase "tuple-expression-nested" (mkExprModule (nestedTupleExpr generatedCaseSize)),+    mkGeneratedPerfCase "tuple-expression-wide" (mkExprModule (wideTupleExpr generatedCaseSize)),+    mkGeneratedPerfCase "expression-list" (mkExprModule (longListExpr generatedCaseSize)),+    mkGeneratedPerfCase "tuple-type-nested" (mkTypeModule (nestedTupleType generatedCaseSize)),+    mkGeneratedPerfCase "tuple-type-wide" (mkTypeModule (wideTupleType generatedCaseSize)),+    mkGeneratedPerfCase "tuple-pattern-nested" (mkPatternModule (nestedTuplePattern generatedCaseSize)),+    mkGeneratedPerfCase "tuple-pattern-wide" (mkPatternModule (wideTuplePattern generatedCaseSize)),+    mkGeneratedPerfCase "tuple-pattern-function-nested" (mkTuplePatternFunctionModule (nestedTuplePattern generatedCaseSize)),+    mkGeneratedPerfCase "tuple-pattern-function-wide" (mkTuplePatternFunctionModule (wideTuplePattern generatedCaseSize)),+    mkGeneratedPerfCase "enum-data-constructors" (mkDataModule (enumDataDecl generatedCaseSize)),+    mkGeneratedPerfCase "record-data-fields" (mkDataModule (recordDataDecl generatedCaseSize)),+    mkGeneratedPerfCase "type-right-leaning-terms" (mkTypeModule (rightLeaningType generatedCaseSize)),+    mkGeneratedPerfCase "type-left-leaning-terms" (mkTypeModule (leftLeaningType generatedCaseSize)),+    mkGeneratedPerfCase "type-parameters" (mkTypeModule (typeWithParameters generatedCaseSize)),+    mkGeneratedPerfCase "string-escapes" (mkExprModule (escapedStringExpr (generatedCaseSize * 100))),+    mkGeneratedPerfCase "nested-application" (mkExprModule (nestedAppExpr generatedCaseSize)),+    mkGeneratedPerfCaseWithStatus "xfail-invalid-module" "module Generated where\nvalue = { x = 1, }\n" StatusXFail "regression coverage"+  ]++mkGeneratedPerfCase :: String -> Text -> PerfCase+mkGeneratedPerfCase label inputText =+  mkGeneratedPerfCaseWithStatus label inputText StatusPass ""++mkGeneratedPerfCaseWithStatus :: String -> Text -> ExpectedStatus -> String -> PerfCase+mkGeneratedPerfCaseWithStatus label inputText status reason =+  let caseId = "generated/" <> label <> "-" <> show generatedCaseSize <> ".hs"+   in PerfCase+        { perfCaseId = caseId,+          perfCaseSourceName = caseId,+          perfCaseExtensions = [],+          perfCaseInput = inputText,+          perfCaseStatus = status,+          perfCaseReason = reason+        }++mkExprModule :: Text -> Text+mkExprModule expr = T.unlines ["module Generated where", "value = " <> expr]++mkTypeModule :: Text -> Text+mkTypeModule ty = T.unlines ["module Generated where", "value :: " <> ty, "value = undefined"]++mkPatternModule :: Text -> Text+mkPatternModule pat = T.unlines ["module Generated where", "value " <> pat <> " = x1", "  where", "    x1 = 1"]++mkTuplePatternFunctionModule :: Text -> Text+mkTuplePatternFunctionModule pat = T.unlines ["module Generated where", "fn " <> pat <> " = ()"]++mkDataModule :: Text -> Text+mkDataModule decl = T.unlines ["module Generated where", decl]++nestedTupleExpr :: Int -> Text+nestedTupleExpr n =+  case n of+    0 -> "a"+    _ -> "(" <> "a, " <> nestedTupleExpr (n - 1) <> ")"++wideTupleExpr :: Int -> Text+wideTupleExpr n = tupleText n "a"++longListExpr :: Int -> Text+longListExpr n = "[" <> T.intercalate ", " (replicate n "a") <> "]"++nestedTupleType :: Int -> Text+nestedTupleType n =+  case n of+    0 -> "A"+    _ -> "(" <> "A, " <> nestedTupleType (n - 1) <> ")"++wideTupleType :: Int -> Text+wideTupleType n = tupleText n "A"++nestedTuplePattern :: Int -> Text+nestedTuplePattern n =+  case n of+    0 -> "x1"+    _ -> "(" <> T.pack ("x" <> show (n + 1)) <> ", " <> nestedTuplePattern (n - 1) <> ")"++wideTuplePattern :: Int -> Text+wideTuplePattern n = tupleItemsText (patternVars n)++enumDataDecl :: Int -> Text+enumDataDecl n =+  "data T = "+    <> T.intercalate " | " [T.pack ("C" <> show ix) | ix <- [1 .. n]]++recordDataDecl :: Int -> Text+recordDataDecl n =+  "data T = T\n  { "+    <> T.intercalate "\n  , " [T.pack ("field" <> show ix) <> " :: A" | ix <- [1 .. n]]+    <> "\n  }"++rightLeaningType :: Int -> Text+rightLeaningType n =+  case n of+    0 -> "A"+    1 -> "A"+    _ -> "A -> (" <> rightLeaningType (n - 1) <> ")"++leftLeaningType :: Int -> Text+leftLeaningType n =+  case n of+    0 -> "A"+    1 -> "A"+    _ -> "(" <> leftLeaningType (n - 1) <> " -> A)"++typeWithParameters :: Int -> Text+typeWithParameters n =+  T.unwords ("A" : replicate n "a")++escapedStringExpr :: Int -> Text+escapedStringExpr desiredLength =+  T.concat ["\"", takeEscapedText desiredLength escapedStringFragments, "\""]++escapedStringFragments :: [Text]+escapedStringFragments =+  [shownCharBody (chr n) | n <- [0 .. 255]]+  where+    shownCharBody ch =+      let shown = show [ch]+       in T.pack (take (length shown - 2) (drop 1 shown))++takeEscapedText :: Int -> [Text] -> Text+takeEscapedText desiredLength = go 0+  where+    go accLen (fragment : rest)+      | accLen >= desiredLength = ""+      | otherwise =+          fragment <> go (accLen + T.length fragment) rest+    go _ [] = ""++tupleText :: Int -> Text -> Text+tupleText n atom =+  tupleItemsText (replicate n atom)++tupleItemsText :: [Text] -> Text+tupleItemsText items =+  "(" <> T.intercalate ", " items <> ")"++patternVars :: Int -> [Text]+patternVars n = [T.pack ("x" <> show ix) | ix <- [1 .. n]]++-- | Generate deeply nested constructor application: A(A(A(...A(a)...)))+-- This exercises the paren expression parser's performance under deep nesting.+nestedAppExpr :: Int -> Text+nestedAppExpr n =+  case n of+    0 -> "a"+    _ -> "A(" <> nestedAppExpr (n - 1) <> ")"
+ test/Test/Properties/Arb/Decl.hs view
@@ -0,0 +1,1602 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Properties.Arb.Decl+  ( genDecl,+    genDeclClass,+    genDeclDataFamilyInst,+    genDeclTypeFamilyInst,+    genDeclValue,+    genWhereDecls,+    shrinkDecl,+    shrinkFunctionHeadPats,+  )+where++import Aihc.Parser.Syntax+import Data.Char (isAlpha)+import Data.Maybe (fromMaybe, isJust)+import Data.Text (Text)+import Data.Text qualified as T+import {-# SOURCE #-} Test.Properties.Arb.Expr (genRhs, shrinkExpr, shrinkGuardQualifier)+import Test.Properties.Arb.Identifiers+  ( genConId,+    genConName,+    genConSym,+    genConUnqualifiedName,+    genVarId,+    genVarName,+    genVarSym,+    genVarUnqualifiedName,+    shrinkName,+    shrinkUnqualifiedName,+  )+import Test.Properties.Arb.Pattern (genPattern, shrinkPattern)+import {-# SOURCE #-} Test.Properties.Arb.Type (genType, shrinkForallTelescope, shrinkTyVarBinders, shrinkType)+import Test.Properties.Arb.Utils (optional, smallList0, smallList1)+import Test.QuickCheck++-- | Annotation choices for BangType+data FieldAnnotation = NoAnnotation | StrictAnnotation | LazyAnnotation+  deriving (Eq, Ord, Enum, Bounded)++instance Arbitrary Decl where+  arbitrary = genDecl+  shrink = shrinkDecl++genDecl :: Gen Decl+genDecl =+  scale (`div` 2) $+    oneof+      [ DeclValue <$> genDeclValue,+        genDeclTypeSig,+        genDeclFixity,+        DeclRoleAnnotation <$> genDeclRoleAnnotation,+        DeclTypeSyn <$> genDeclTypeSyn,+        genDeclData,+        genDeclTypeData,+        genDeclNewtype,+        genDeclClass,+        genDeclInstance,+        genDeclStandaloneDeriving,+        genDeclDefault,+        genDeclSplice,+        genDeclForeign,+        genDeclTypeFamilyDecl,+        genDeclTypeFamilyDeclInfix,+        genDeclDataFamilyDecl,+        genDeclTypeFamilyInst,+        genDeclDataFamilyInst,+        genDeclPragma,+        genDeclPatSyn,+        genDeclPatSynSig,+        genDeclStandaloneKindSig+      ]++genDeclValue :: Gen ValueDecl+genDeclValue =+  oneof+    [ genFunctionValueDecl,+      genPatternValueDecl+    ]++genFunctionValueDecl :: Gen ValueDecl+genFunctionValueDecl = do+  name <- genVarUnqualifiedName+  rhs <- genRhs+  oneof+    [ do+        pats <- smallList1 genPattern+        pure+          ( FunctionBind+              name+              [ Match+                  { matchAnns = [],+                    matchHeadForm = MatchHeadPrefix,+                    matchPats = pats,+                    matchRhs = rhs+                  }+              ]+          ),+      do+        lhsPat <- genPattern+        rhsPat <- genPattern+        extraPats <- smallList0 genPattern+        pure+          ( FunctionBind+              name+              [ Match+                  { matchAnns = [],+                    matchHeadForm = MatchHeadInfix,+                    matchPats = [lhsPat, rhsPat] <> extraPats,+                    matchRhs = rhs+                  }+              ]+          )+    ]++genPatternValueDecl :: Gen ValueDecl+genPatternValueDecl =+  PatternBind NoMultiplicityTag <$> genPattern <*> genRhs++genWhereDecls :: Gen (Maybe [Decl])+genWhereDecls = optional $ scale (`div` 2) $ listOf (DeclValue <$> genDeclValue)++genDeclTypeSig :: Gen Decl+genDeclTypeSig = DeclTypeSig <$> smallList1 genVarUnqualifiedName <*> genType++genDeclFixity :: Gen Decl+genDeclFixity = do+  assoc <- elements [Infix, InfixL, InfixR]+  prec <- elements [Nothing, Just 0, Just 6, Just 9]+  ops <- smallList1 genVarUnqualifiedName+  pure $ DeclFixity assoc Nothing prec ops++genDeclRoleAnnotation :: Gen RoleAnnotation+genDeclRoleAnnotation =+  RoleAnnotation+    <$> genConUnqualifiedName+    <*> smallList0 (elements [RoleNominal, RoleRepresentational, RolePhantom, RoleInfer])++genBinderHead :: Gen UnqualifiedName -> Gen (BinderHead UnqualifiedName)+genBinderHead genName =+  oneof+    [ PrefixBinderHead <$> genName <*> genSimpleTyVarBinders,+      InfixBinderHead <$> genSimpleTyVarBinder <*> genName <*> genSimpleTyVarBinder <*> genSimpleTyVarBinders+    ]++genDeclTypeSyn :: Gen TypeSynDecl+genDeclTypeSyn =+  TypeSynDecl+    <$> genBinderHead genConUnqualifiedName+    <*> genType++genDeclData :: Gen Decl+genDeclData =+  oneof+    [ DeclData <$> genSimpleDataDecl,+      DeclData <$> genDeclDataGadt+    ]++genDeclDataGadt :: Gen DataDecl+genDeclDataGadt = do+  name <- genConUnqualifiedName+  params <- genSimpleTyVarBinders+  ctors <- genGadtDataCons+  pure $+    DataDecl+      { dataDeclCTypePragma = Nothing,+        dataDeclHead = PrefixBinderHead name params,+        dataDeclContext = [],+        dataDeclKind = Nothing,+        dataDeclConstructors = ctors,+        dataDeclDeriving = []+      }++genDeclTypeData :: Gen Decl+genDeclTypeData = genDeclTypeDataPrefix++genDeclTypeDataPrefix :: Gen Decl+genDeclTypeDataPrefix = do+  name <- genConUnqualifiedName+  params <- genSimpleTyVarBinders+  ctors <- genTypeDataCons+  pure $+    DeclTypeData $+      DataDecl+        { dataDeclCTypePragma = Nothing,+          dataDeclHead = PrefixBinderHead name params,+          dataDeclContext = [],+          dataDeclKind = Nothing,+          dataDeclConstructors = ctors,+          dataDeclDeriving = []+        }++genTypeDataCons :: Gen [DataConDecl]+genTypeDataCons = smallList0 $ PrefixCon [] [] <$> genConUnqualifiedName <*> smallList0 genNonStrictBangType++-- | Generate a BangType that is never strict (for type data constructors).+-- Type data constructors don't support strictness or lazy annotations.+genNonStrictBangType :: Gen BangType+genNonStrictBangType = do+  ty <- genType+  pure $+    BangType+      { bangAnns = [],+        bangPragmas = [],+        bangStrict = False,+        bangLazy = False,+        bangType = ty+      }++genSimpleDataDecl :: Gen DataDecl+genSimpleDataDecl = do+  head' <- genBinderHead genConUnqualifiedName+  -- GHC does not allow kind annotations (or wildcards) in non-GADT data declarations+  let kind = Nothing+  ctors <- genSimpleDataCons+  deriving' <- genDerivingClauses+  pure $+    DataDecl+      { dataDeclCTypePragma = Nothing,+        dataDeclHead = head',+        dataDeclContext = [],+        dataDeclKind = kind,+        dataDeclConstructors = ctors,+        dataDeclDeriving = deriving'+      }++genSimpleDataCons :: Gen [DataConDecl]+genSimpleDataCons = smallList0 genMixedDataCon++genMixedDataCon :: Gen DataConDecl+genMixedDataCon =+  oneof+    [ genPrefixCon,+      genInfixCon,+      genRecordCon,+      genTupleCon,+      genUnboxedSumCon,+      genListCon+    ]++genPrefixCon :: Gen DataConDecl+genPrefixCon = do+  -- Prefix constructors can be alphabetic (Cons) or symbolic ((:+))+  name <- genConUnqualifiedName+  fields <- smallList0 genSimpleBangType+  pure (PrefixCon [] [] name fields)++genInfixCon :: Gen DataConDecl+genInfixCon = do+  forallVars <- genDataConTyVarBinders+  ctx <- genDataConContext+  InfixCon forallVars ctx <$> genSimpleBangType <*> genConUnqualifiedName <*> genSimpleBangType++genRecordCon :: Gen DataConDecl+genRecordCon = do+  RecordCon [] [] <$> genConUnqualifiedName <*> smallList0 genFieldDecl++genTupleCon :: Gen DataConDecl+genTupleCon = do+  forallVars <- genDataConTyVarBinders+  ctx <- genDataConContext+  flavor <- elements [Boxed, Unboxed]+  fieldCount <-+    case flavor of+      Boxed -> elements [0, 2, 3]+      Unboxed -> elements [0, 1, 2, 3]+  TupleCon forallVars ctx flavor <$> vectorOf fieldCount genSimpleBangType++genUnboxedSumCon :: Gen DataConDecl+genUnboxedSumCon = do+  forallVars <- genDataConTyVarBinders+  ctx <- genDataConContext+  arity <- chooseInt (2, 4)+  pos <- chooseInt (1, arity)+  UnboxedSumCon forallVars ctx pos arity <$> genSimpleBangType++genListCon :: Gen DataConDecl+genListCon = ListCon <$> genDataConTyVarBinders <*> genDataConContext++genDataConTyVarBinders :: Gen [TyVarBinder]+genDataConTyVarBinders = frequency [(4, pure []), (1, smallList1 genSimpleTyVarBinder)]++genDataConContext :: Gen [Type]+genDataConContext = frequency [(4, pure []), (1, smallList1 genSimpleConstraint)]++genFieldDecl :: Gen FieldDecl+genFieldDecl = FieldDecl [] <$> smallList1 genVarUnqualifiedName <*> genFieldMultiplicity <*> genSimpleBangType++genFieldMultiplicity :: Gen (Maybe Type)+genFieldMultiplicity =+  frequency+    [ (4, pure Nothing),+      (1, Just <$> genSimpleMultiplicityType)+    ]++genSimpleMultiplicityType :: Gen Type+genSimpleMultiplicityType =+  oneof+    [ TVar . mkUnqualifiedName NameVarId <$> genVarId,+      TCon <$> genConName <*> pure Unpromoted+    ]++genGadtDataCons :: Gen [DataConDecl]+genGadtDataCons = smallList1 genGadtCon++genGadtCon :: Gen DataConDecl+genGadtCon = do+  names <- smallList1 genConUnqualifiedName+  foralls <- genGadtForalls+  ctx <- genDataConContext+  GadtCon foralls ctx names <$> genGadtBody++genGadtForalls :: Gen [ForallTelescope]+genGadtForalls = pure []++genGadtBody :: Gen GadtBody+genGadtBody =+  oneof+    [ genGadtPrefixBody,+      genGadtRecordBody+    ]++genGadtPrefixBody :: Gen GadtBody+genGadtPrefixBody = GadtPrefixBody <$> smallList0 genGadtArg <*> genType++genGadtArg :: Gen (BangType, ArrowKind)+genGadtArg = (,) <$> genGadtBangType <*> pure ArrowUnrestricted++-- | Generate a BangType for GADT prefix body arg position.+-- Does not generate lazy/strict annotations on types that start with symbolic+-- characters (TStar, TTHSplice, TTuple, etc.) since the lexer treats ~! or !*+-- as single operator tokens.+genGadtBangType :: Gen BangType+genGadtBangType = do+  ty <- scale (min 6) genType+  -- Only generate lazy/strict annotations on types that start with alphabetic characters+  let canAnnotate = typeStartsWithAlpha ty+  annotation <- if canAnnotate then elements [NoAnnotation, StrictAnnotation, LazyAnnotation] else pure NoAnnotation+  case annotation of+    NoAnnotation -> pure $ BangType [] [] False False ty+    StrictAnnotation -> pure $ BangType [] [] True False ty+    LazyAnnotation -> pure $ BangType [] [] False True ty+  where+    typeStartsWithAlpha :: Type -> Bool+    typeStartsWithAlpha (TVar _) = True+    typeStartsWithAlpha (TCon n _) = let txt = nameText n in not (T.null txt) && isAlpha (T.head txt)+    typeStartsWithAlpha (TParen inner) = typeStartsWithAlpha inner+    typeStartsWithAlpha _ = False++-- | Generate a simple type without function types at the top level.+genSimpleTypeWithoutFun :: Gen Type+genSimpleTypeWithoutFun =+  oneof+    [ TVar . mkUnqualifiedName NameVarId <$> genVarId,+      TCon <$> genConName <*> pure Unpromoted+    ]++genGadtRecordBody :: Gen GadtBody+genGadtRecordBody = GadtRecordBody <$> smallList1 genGadtFieldDecl <*> genType++-- | Generate a field declaration for GADT record body position.+-- Uses the full type generator since record field types are parsed by typeParser.+genGadtFieldDecl :: Gen FieldDecl+genGadtFieldDecl = do+  fieldNames <- smallList1 genVarUnqualifiedName+  multiplicity <- genFieldMultiplicity+  FieldDecl [] fieldNames multiplicity . BangType [] [] False False <$> genType++genSimpleBangType :: Gen BangType+genSimpleBangType = do+  annotation <- elements [NoAnnotation, StrictAnnotation, LazyAnnotation]+  (ty, pragmas) <- genBangTypePayload annotation+  case annotation of+    NoAnnotation ->+      pure $+        BangType+          { bangAnns = [],+            bangPragmas = pragmas,+            bangStrict = False,+            bangLazy = False,+            bangType = ty+          }+    StrictAnnotation ->+      pure $+        BangType+          { bangAnns = [],+            bangPragmas = pragmas,+            bangStrict = True,+            bangLazy = False,+            bangType = ty+          }+    LazyAnnotation ->+      pure $+        BangType+          { bangAnns = [],+            bangPragmas = pragmas,+            bangStrict = False,+            bangLazy = True,+            bangType = ty+          }++genBangTypePayload :: FieldAnnotation -> Gen (Type, [Pragma])+genBangTypePayload StrictAnnotation =+  frequency+    [ (4, fmap withNoBangPragmas genType),+      (1, fmap (withBangPragmas [mkPragma (PragmaUnpack UnpackPragma)]) genSimpleTypeWithoutFun),+      (1, fmap (withBangPragmas [mkPragma (PragmaUnpack NoUnpackPragma)]) genSimpleTypeWithoutFun)+    ]+genBangTypePayload _ = fmap withNoBangPragmas genType++withNoBangPragmas :: Type -> (Type, [Pragma])+withNoBangPragmas ty = (ty, [])++withBangPragmas :: [Pragma] -> Type -> (Type, [Pragma])+withBangPragmas pragmas ty = (ty, pragmas)++genDeclNewtype :: Gen Decl+genDeclNewtype = do+  name <- genConUnqualifiedName+  params <- genSimpleTyVarBinders+  ctor <- genNewtypeCon+  deriving' <- genDerivingClauses+  pure $+    DeclNewtype $+      NewtypeDecl+        { newtypeDeclCTypePragma = Nothing,+          newtypeDeclHead = PrefixBinderHead name params,+          newtypeDeclContext = [],+          newtypeDeclKind = Nothing,+          newtypeDeclConstructor = Just ctor,+          newtypeDeclDeriving = deriving'+        }++genNewtypeCon :: Gen DataConDecl+genNewtypeCon =+  oneof+    [ genNewtypePrefixCon,+      genNewtypeRecordCon+    ]++genNewtypePrefixCon :: Gen DataConDecl+genNewtypePrefixCon = do+  conName <- genConUnqualifiedName+  ty <- genType+  pure (PrefixCon [] [] conName [BangType [] [] False False ty])++genNewtypeRecordCon :: Gen DataConDecl+genNewtypeRecordCon = do+  conName <- genConUnqualifiedName+  fieldName <- genVarUnqualifiedName+  ty <- genType+  pure (RecordCon [] [] conName [FieldDecl [] [fieldName] Nothing (BangType [] [] False False ty)])++genDeclClass :: Gen Decl+genDeclClass = do+  name <- genConUnqualifiedName+  params <- genSimpleTyVarBinders+  ctx <- genOptionalSimpleContext+  items <- genClassDeclItems params+  declHead <-+    oneof+      [ pure $ PrefixBinderHead name params,+        InfixBinderHead <$> genSimpleTyVarBinder <*> pure name <*> genSimpleTyVarBinder <*> genSimpleTyVarBinders+      ]+  pure $+    DeclClass $+      ClassDecl+        { classDeclContext = ctx,+          classDeclHead = declHead,+          classDeclFundeps = genClassFundepsFromHead declHead,+          classDeclItems = items+        }++genClassFundepsFromHead :: BinderHead UnqualifiedName -> [FunctionalDependency]+genClassFundepsFromHead head' =+  case binderHeadTyVarNames head' of+    determiner : determined : _ -> [FunctionalDependency [] [determiner] [determined]]+    _ -> []++binderHeadTyVarNames :: BinderHead UnqualifiedName -> [Text]+binderHeadTyVarNames head' =+  case head' of+    PrefixBinderHead _ params -> map tyVarBinderName params+    InfixBinderHead lhs _ rhs tailParams -> map tyVarBinderName (lhs : rhs : tailParams)++genClassDeclItems :: [TyVarBinder] -> Gen [ClassDeclItem]+genClassDeclItems params =+  smallList0 $+    oneof+      [ genClassTypeSigItem,+        genClassDefaultSigItem,+        genClassFixityItem,+        genClassDefaultItem,+        genClassAssociatedTypeDeclItem,+        genClassAssociatedDataDeclItem params,+        ClassItemDefaultTypeInst <$> genAssociatedTypeDefaultInst,+        genClassPragmaItem+      ]++genClassTypeSigItem :: Gen ClassDeclItem+genClassTypeSigItem = ClassItemTypeSig <$> smallList1 genVarUnqualifiedName <*> genType++genClassDefaultSigItem :: Gen ClassDeclItem+genClassDefaultSigItem = do+  name <- genVarUnqualifiedName+  ClassItemDefaultSig name <$> genType++genClassFixityItem :: Gen ClassDeclItem+genClassFixityItem = do+  assoc <- elements [Infix, InfixL, InfixR]+  prec <- elements [Nothing, Just 0, Just 6, Just 9]+  namespace <- elements [Nothing, Just IEEntityNamespaceType, Just IEEntityNamespaceData]+  ops <- smallList1 genVarUnqualifiedName+  pure (ClassItemFixity assoc namespace prec ops)++genClassDefaultItem :: Gen ClassDeclItem+genClassDefaultItem = ClassItemDefault <$> genFunctionValueDecl++genClassAssociatedTypeDeclItem :: Gen ClassDeclItem+genClassAssociatedTypeDeclItem = do+  ClassItemTypeFamilyDecl <$> genAssociatedTypeFamilyDecl++genClassAssociatedDataDeclItem :: [TyVarBinder] -> Gen ClassDeclItem+genClassAssociatedDataDeclItem params = do+  df <- genAssociatedDataFamilyDecl params+  pure $ ClassItemDataFamilyDecl df++genClassPragmaItem :: Gen ClassDeclItem+genClassPragmaItem = do+  kind <- elements ["INLINE", "NOINLINE", "INLINABLE"]+  ClassItemPragma . mkPragma . PragmaInline kind <$> genVarId++genAssociatedTypeFamilyDecl :: Gen TypeFamilyDecl+genAssociatedTypeFamilyDecl = do+  name <- genConUnqualifiedName+  params <- smallList0 genSimpleTyVarBinder+  explicitFamilyKeyword <- arbitrary+  let headType = TCon (qualifyName Nothing name) Unpromoted+  resultSig <- genAssociatedTypeFamilyResultSig params+  pure $+    TypeFamilyDecl+      { typeFamilyDeclHeadForm = TypeHeadPrefix,+        typeFamilyDeclExplicitFamilyKeyword = explicitFamilyKeyword,+        typeFamilyDeclHead = headType,+        typeFamilyDeclParams = params,+        typeFamilyDeclResultSig = resultSig,+        typeFamilyDeclEquations = Nothing+      }++genAssociatedDataFamilyDecl :: [TyVarBinder] -> Gen DataFamilyDecl+genAssociatedDataFamilyDecl classParams = do+  let canUseInfixHead = length classParams >= 2+  infixHead <- if canUseInfixHead then elements [False, True] else pure False+  head' <-+    if infixHead+      then do+        name <- genConUnqualifiedName+        shuffled <- shuffle classParams+        case shuffled of+          lhs : rhs : _ -> pure (InfixBinderHead lhs name rhs [])+          _ -> error "genAssociatedDataFamilyDecl: expected at least two class params"+      else do+        name <- genConUnqualifiedName+        paramCount <- chooseInt (0, min 2 (length classParams))+        params <- take paramCount <$> shuffle classParams+        pure (PrefixBinderHead name params)+  kind <- optional genType+  pure $+    DataFamilyDecl+      { dataFamilyDeclHead = head',+        dataFamilyDeclKind = kind+      }++genAssociatedTypeDefaultInst :: Gen TypeFamilyInst+genAssociatedTypeDefaultInst = do+  lhs <- TCon <$> genConName <*> pure Unpromoted+  rhs <- genType+  pure $+    TypeFamilyInst+      { typeFamilyInstForall = [],+        typeFamilyInstHeadForm = TypeHeadPrefix,+        typeFamilyInstLhs = lhs,+        typeFamilyInstRhs = rhs+      }++genTypeFamilyResultSig :: Bool -> [TyVarBinder] -> Gen (Maybe TypeFamilyResultSig)+genTypeFamilyResultSig explicitFamily params =+  frequency $+    [(4, pure Nothing), (1, Just . TypeFamilyKindSig <$> genType)]+      <> [(1, Just <$> genTypeFamilyTyVarSig) | explicitFamily]+      <> [(1, Just <$> genTypeFamilyInjectiveSig params) | not (null params)]++genAssociatedTypeFamilyResultSig :: [TyVarBinder] -> Gen (Maybe TypeFamilyResultSig)+genAssociatedTypeFamilyResultSig params =+  frequency $+    [(4, pure Nothing), (1, Just . TypeFamilyKindSig <$> genType)]+      <> [(1, Just <$> genTypeFamilyInjectiveSig params) | not (null params)]++genTypeFamilyTyVarSig :: Gen TypeFamilyResultSig+genTypeFamilyTyVarSig = TypeFamilyTyVarSig <$> genResultTyVarBinder++genTypeFamilyInjectiveSig :: [TyVarBinder] -> Gen TypeFamilyResultSig+genTypeFamilyInjectiveSig params = do+  result <- genResultTyVarBinder+  let resultName = tyVarBinderName result+      determined = map tyVarBinderName params+  pure $+    TypeFamilyInjectiveSig+      result+      TypeFamilyInjectivity+        { typeFamilyInjectivityAnns = [],+          typeFamilyInjectivityResult = resultName,+          typeFamilyInjectivityDetermined = determined+        }++genResultTyVarBinder :: Gen TyVarBinder+genResultTyVarBinder =+  pure (TyVarBinder [] "r" Nothing TyVarBSpecified TyVarBVisible)++genTypeFamilyEquations :: TypeHeadForm -> Type -> [TyVarBinder] -> Gen (Maybe [TypeFamilyEq])+genTypeFamilyEquations headForm headType params =+  frequency+    [ (4, pure Nothing),+      (1, Just <$> smallList1 (genTypeFamilyEq headForm headType params))+    ]++genTypeFamilyEq :: TypeHeadForm -> Type -> [TyVarBinder] -> Gen TypeFamilyEq+genTypeFamilyEq headForm headType params = do+  lhs <- genTypeFamilyEqLhs headForm headType params+  rhs <- genType+  forallVars <- frequency [(4, pure []), (1, smallList1 genSimpleTyVarBinder)]+  pure $+    TypeFamilyEq+      { typeFamilyEqAnns = [],+        typeFamilyEqForall = forallVars,+        typeFamilyEqHeadForm = headForm,+        typeFamilyEqLhs = lhs,+        typeFamilyEqRhs = rhs+      }++genTypeFamilyEqLhs :: TypeHeadForm -> Type -> [TyVarBinder] -> Gen Type+genTypeFamilyEqLhs headForm headType params =+  case headForm of+    TypeHeadPrefix -> do+      args <- vectorOf (length params) genFamilyLhsArg+      pure (foldl TApp headType args)+    TypeHeadInfix ->+      case headType of+        TInfix _ op promoted _ -> TInfix <$> genFamilyInfixOperand <*> pure op <*> pure promoted <*> genFamilyInfixOperand+        _ -> pure headType++genDeclInstance :: Gen Decl+genDeclInstance = oneof [genDeclInstancePrefix, genDeclInstanceInfix, genDeclInstanceParenInfix]++genInstanceDeclItems :: Gen [InstanceDeclItem]+genInstanceDeclItems =+  smallList0 $+    oneof+      [ InstanceItemBind <$> genFunctionValueDecl,+        InstanceItemTypeSig <$> smallList1 genVarUnqualifiedName <*> genType,+        genInstanceFixityItem,+        InstanceItemTypeFamilyInst <$> genAssociatedTypeDefaultInst,+        genInstanceAssociatedDataFamilyInstItem,+        InstanceItemPragma <$> genInstancePragma+      ]++genInstanceFixityItem :: Gen InstanceDeclItem+genInstanceFixityItem = do+  assoc <- elements [Infix, InfixL, InfixR]+  prec <- elements [Nothing, Just 0, Just 6, Just 9]+  namespace <- elements [Nothing, Just IEEntityNamespaceType, Just IEEntityNamespaceData]+  ops <- smallList1 genVarUnqualifiedName+  pure (InstanceItemFixity assoc namespace prec ops)++genInstancePragma :: Gen Pragma+genInstancePragma = mkPragma . PragmaInline "INLINE" <$> genVarId++genInstanceAssociatedDataFamilyInstItem :: Gen InstanceDeclItem+genInstanceAssociatedDataFamilyInstItem = do+  inst <- genDataFamilyInstWith (pure Nothing) genFamilyInfixHead genSimpleDataCons+  pure (InstanceItemDataFamilyInst inst)++genDeclInstancePrefix :: Gen Decl+genDeclInstancePrefix = do+  className <- genConName+  types <- smallList0 genInstanceHeadType+  ctx <- genSimpleContext+  items <- if null types then pure [] else genInstanceDeclItems+  pure $+    DeclInstance $+      InstanceDecl+        { instanceDeclPragmas = [],+          instanceDeclWarning = Nothing,+          instanceDeclForall = [],+          instanceDeclContext = ctx,+          instanceDeclHead = foldl TApp (TCon className Unpromoted) types,+          instanceDeclItems = items+        }++genDeclInstanceInfix :: Gen Decl+genDeclInstanceInfix = do+  className <- genConName+  lhs <- genInfixInstanceHeadType+  rhs <- genInfixInstanceHeadType+  ctx <- genSimpleContext+  items <- genInstanceDeclItems+  pure $+    DeclInstance $+      InstanceDecl+        { instanceDeclPragmas = [],+          instanceDeclWarning = Nothing,+          instanceDeclForall = [],+          instanceDeclContext = ctx,+          instanceDeclHead = TInfix lhs className Unpromoted rhs,+          instanceDeclItems = items+        }++-- | Generate a parenthesized infix instance head with trailing type arguments.+-- Covers syntax like @instance (f \`C\` g) x@ and @instance (c & d) a@.+genDeclInstanceParenInfix :: Gen Decl+genDeclInstanceParenInfix = do+  className <- genConName+  lhs <- genInfixInstanceHeadType+  rhs <- genInfixInstanceHeadType+  tailTypes <- smallList1 genInstanceHeadType+  ctx <- genSimpleContext+  items <- genInstanceDeclItems+  pure $+    DeclInstance $+      InstanceDecl+        { instanceDeclPragmas = [],+          instanceDeclWarning = Nothing,+          instanceDeclForall = [],+          instanceDeclContext = ctx,+          instanceDeclHead = foldl TApp (TParen (TInfix lhs className Unpromoted rhs)) tailTypes,+          instanceDeclItems = items+        }++genDeclStandaloneDeriving :: Gen Decl+genDeclStandaloneDeriving = oneof [genDeclStandaloneDerivingPrefix, genDeclStandaloneDerivingInfix, genDeclStandaloneDerivingParenInfix]++genDeclStandaloneDerivingPrefix :: Gen Decl+genDeclStandaloneDerivingPrefix = do+  className <- genConName+  types <- smallList0 genInstanceHeadType+  strategy <- optional genDerivingStrategy+  ctx <- genSimpleContext+  pure $+    DeclStandaloneDeriving $+      StandaloneDerivingDecl+        { standaloneDerivingStrategy = strategy,+          standaloneDerivingPragmas = [],+          standaloneDerivingWarning = Nothing,+          standaloneDerivingForall = [],+          standaloneDerivingContext = ctx,+          standaloneDerivingHead = foldl TApp (TCon className Unpromoted) types+        }++genDeclStandaloneDerivingInfix :: Gen Decl+genDeclStandaloneDerivingInfix = do+  className <- genConName+  lhs <- genInfixInstanceHeadType+  rhs <- genInfixInstanceHeadType+  strategy <- optional genDerivingStrategy+  ctx <- genSimpleContext+  pure $+    DeclStandaloneDeriving $+      StandaloneDerivingDecl+        { standaloneDerivingStrategy = strategy,+          standaloneDerivingPragmas = [],+          standaloneDerivingWarning = Nothing,+          standaloneDerivingForall = [],+          standaloneDerivingContext = ctx,+          standaloneDerivingHead = TInfix lhs className Unpromoted rhs+        }++-- | Generate a parenthesized infix standalone deriving head with trailing type arguments.+-- Covers syntax like @deriving instance (f \`C\` g) x@.+genDeclStandaloneDerivingParenInfix :: Gen Decl+genDeclStandaloneDerivingParenInfix = do+  className <- genConName+  lhs <- genInfixInstanceHeadType+  rhs <- genInfixInstanceHeadType+  tailTypes <- smallList1 genInstanceHeadType+  strategy <- optional genDerivingStrategy+  ctx <- genSimpleContext+  pure $+    DeclStandaloneDeriving $+      StandaloneDerivingDecl+        { standaloneDerivingStrategy = strategy,+          standaloneDerivingPragmas = [],+          standaloneDerivingWarning = Nothing,+          standaloneDerivingForall = [],+          standaloneDerivingContext = ctx,+          standaloneDerivingHead = foldl TApp (TParen (TInfix lhs className Unpromoted rhs)) tailTypes+        }++genInstanceHeadType :: Gen Type+genInstanceHeadType = suchThat (scale (min 4) genType) isValidInstanceHeadType++isValidInstanceHeadType :: Type -> Bool+isValidInstanceHeadType ty =+  case ty of+    TStar {} -> False+    TForall {} -> False+    TContext {} -> False+    TImplicitParam {} -> False+    TTypeApp {} -> False+    TAnn _ inner -> isValidInstanceHeadType inner+    _ -> True++isInfixInstanceHeadType :: Type -> Bool+isInfixInstanceHeadType ty =+  case ty of+    TVar {} -> True+    TCon {} -> True+    TTypeLit {} -> True+    TStar {} -> True+    TTuple {} -> True+    TList {} -> True+    TApp fn arg -> isInfixInstanceHeadType fn && isInfixInstanceHeadType arg+    TTypeApp inner _ -> isInfixInstanceHeadType inner+    TParen inner -> isInfixInstanceHeadType inner+    _ -> False++genInfixInstanceHeadType :: Gen Type+genInfixInstanceHeadType = suchThat genInstanceHeadType isInfixInstanceHeadType++genDeclDefault :: Gen Decl+genDeclDefault = DeclDefault <$> smallList0 genType++genDeclSplice :: Gen Decl+genDeclSplice = do+  DeclSplice . EVar <$> genVarName++genDeclForeign :: Gen Decl+genDeclForeign = do+  direction <- elements [ForeignImport, ForeignExport]+  entity <- genForeignEntity direction+  callConv <-+    case (direction, entity) of+      (ForeignImport, ForeignEntityDynamic) -> pure CCall+      (ForeignImport, ForeignEntityWrapper) -> pure CCall+      (ForeignImport, ForeignEntityAddress {}) -> pure CCall+      (ForeignImport, _) -> elements [CCall, StdCall, CApi, JavaScript]+      (ForeignExport, _) -> elements [CCall, StdCall, CApi, JavaScript]+  -- Safety is only valid for imports, not exports+  safety <- case (direction, entity) of+    (ForeignImport, ForeignEntityDynamic) -> pure Nothing+    (ForeignImport, ForeignEntityWrapper) -> pure Nothing+    (ForeignImport, ForeignEntityStatic {}) -> pure Nothing+    (ForeignImport, ForeignEntityAddress {}) -> pure Nothing+    (ForeignImport, ForeignEntityOmitted) -> optional $ elements [Safe, Unsafe]+    (ForeignImport, ForeignEntityNamed _)+      | callConv == CCall -> optional $ elements [Safe, Unsafe, Interruptible]+      | otherwise -> optional $ elements [Safe, Unsafe]+    (ForeignExport, _) -> pure Nothing+  name <- genVarUnqualifiedName+  ty <- genType+  pure $+    DeclForeign $+      ForeignDecl+        { foreignDirection = direction,+          foreignCallConv = callConv,+          foreignSafety = safety,+          foreignEntity = entity,+          foreignName = name,+          foreignType = ty+        }++genForeignEntity :: ForeignDirection -> Gen ForeignEntitySpec+genForeignEntity direction =+  case direction of+    ForeignImport ->+      oneof+        [ pure ForeignEntityDynamic,+          pure ForeignEntityWrapper,+          ForeignEntityStatic . Just <$> genForeignSymbol,+          ForeignEntityAddress . Just <$> genForeignSymbol,+          ForeignEntityNamed <$> genForeignSymbol,+          pure ForeignEntityOmitted+        ]+    ForeignExport ->+      oneof+        [ ForeignEntityNamed <$> genForeignSymbol,+          pure ForeignEntityOmitted+        ]++genForeignSymbol :: Gen Text+genForeignSymbol = elements ["foreign_symbol", "static_name", "js_name"]++genDeclTypeFamilyDecl :: Gen Decl+genDeclTypeFamilyDecl = do+  name <- genConId+  let headType = TCon (qualifyName Nothing (mkUnqualifiedName NameConId name)) Unpromoted+  params <- genSimpleTyVarBinders+  resultSig <- genTypeFamilyResultSig True params+  equations <- genTypeFamilyEquations TypeHeadPrefix headType params+  pure $+    DeclTypeFamilyDecl $+      TypeFamilyDecl+        { typeFamilyDeclHeadForm = TypeHeadPrefix,+          typeFamilyDeclExplicitFamilyKeyword = True,+          typeFamilyDeclHead = headType,+          typeFamilyDeclParams = params,+          typeFamilyDeclResultSig = resultSig,+          typeFamilyDeclEquations = equations+        }++-- | Generate an infix type family declaration, covering both symbolic operators+-- (e.g. @type family a ** b@) and backtick-wrapped identifiers+-- (e.g. @type family a \`And\` b@).+genDeclTypeFamilyDeclInfix :: Gen Decl+genDeclTypeFamilyDeclInfix = do+  name <- genConUnqualifiedName+  lhsName <- genVarId+  rhsName <- genVarId+  let lhs = TyVarBinder [] lhsName Nothing TyVarBSpecified TyVarBVisible+      rhs = TyVarBinder [] rhsName Nothing TyVarBSpecified TyVarBVisible+      lhsType = TVar (mkUnqualifiedName NameVarId lhsName)+      rhsType = TVar (mkUnqualifiedName NameVarId rhsName)+      headType = TInfix lhsType (qualifyName Nothing name) Unpromoted rhsType+      params = [lhs, rhs]+  resultSig <- genTypeFamilyResultSig True params+  equations <- genTypeFamilyEquations TypeHeadInfix headType params+  pure $+    DeclTypeFamilyDecl $+      TypeFamilyDecl+        { typeFamilyDeclHeadForm = TypeHeadInfix,+          typeFamilyDeclExplicitFamilyKeyword = True,+          typeFamilyDeclHead = headType,+          typeFamilyDeclParams = params,+          typeFamilyDeclResultSig = resultSig,+          typeFamilyDeclEquations = equations+        }++genDeclDataFamilyDecl :: Gen Decl+genDeclDataFamilyDecl = do+  head' <-+    oneof+      [ InfixBinderHead <$> genSimpleTyVarBinder <*> genConUnqualifiedName <*> genSimpleTyVarBinder <*> genSimpleTyVarBinders,+        PrefixBinderHead <$> genConUnqualifiedName <*> genSimpleTyVarBinders+      ]+  kind <- optional genType+  pure $+    DeclDataFamilyDecl $+      DataFamilyDecl+        { dataFamilyDeclHead = head',+          dataFamilyDeclKind = kind+        }++genDeclTypeFamilyInst :: Gen Decl+genDeclTypeFamilyInst =+  oneof+    [ genDeclTypeFamilyInstPrefix,+      genDeclTypeFamilyInstInfix+    ]++genDeclTypeFamilyInstPrefix :: Gen Decl+genDeclTypeFamilyInstPrefix = do+  lhs <- genFamilyLhsType+  rhs <- genType+  pure $+    DeclTypeFamilyInst $+      TypeFamilyInst+        { typeFamilyInstForall = [],+          typeFamilyInstHeadForm = TypeHeadPrefix,+          typeFamilyInstLhs = lhs,+          typeFamilyInstRhs = rhs+        }++genDeclTypeFamilyInstInfix :: Gen Decl+genDeclTypeFamilyInstInfix = do+  op <- genTypeFamilyInstOperator+  lhsArg <- genFamilyInfixOperand+  rhsArg <- genFamilyInfixOperand+  rhs <- genType+  pure $+    DeclTypeFamilyInst $+      TypeFamilyInst+        { typeFamilyInstForall = [],+          typeFamilyInstHeadForm = TypeHeadInfix,+          typeFamilyInstLhs = TInfix lhsArg op Unpromoted rhsArg,+          typeFamilyInstRhs = rhs+        }++genDeclDataFamilyInst :: Gen Decl+genDeclDataFamilyInst =+  oneof+    [ genDeclDataFamilyInstPrefix,+      genDeclDataFamilyInstInfix,+      genDeclDataFamilyInstGadt+    ]++genDataFamilyInstWith :: Gen (Maybe Type) -> Gen Type -> Gen [DataConDecl] -> Gen DataFamilyInst+genDataFamilyInstWith genKind genHead genConstructors = do+  head' <- genHead+  kind <- genKind+  ctors <- genConstructors+  derivingClauses <- genDerivingClauses+  pure $+    DataFamilyInst+      { dataFamilyInstIsNewtype = False,+        dataFamilyInstForall = [],+        dataFamilyInstHead = head',+        dataFamilyInstKind = kind,+        dataFamilyInstConstructors = ctors,+        dataFamilyInstDeriving = derivingClauses+      }++genDeclDataFamilyInstPrefix :: Gen Decl+genDeclDataFamilyInstPrefix = do+  -- Kind annotations are not valid in non-GADT data instance declarations+  DeclDataFamilyInst <$> genDataFamilyInstWith (pure Nothing) genFamilyLhsType genSimpleDataCons++genDeclDataFamilyInstInfix :: Gen Decl+genDeclDataFamilyInstInfix =+  -- Kind annotations are not valid in non-GADT data instance declarations+  DeclDataFamilyInst <$> genDataFamilyInstWith (pure Nothing) genFamilyInfixHead genSimpleDataCons++genDeclDataFamilyInstGadt :: Gen Decl+genDeclDataFamilyInstGadt = do+  DeclDataFamilyInst <$> genDataFamilyInstWith genOptionalDataFamilyInstKind genFamilyLhsType genGadtDataCons++genOptionalDataFamilyInstKind :: Gen (Maybe Type)+genOptionalDataFamilyInstKind = optional genType++-- | Generate a type family LHS: a type constructor applied to an arbitrary type argument.+genFamilyLhsType :: Gen Type+genFamilyLhsType = do+  familyName <- genConId+  let familyCon = TCon (qualifyName Nothing (mkUnqualifiedName NameConId familyName)) Unpromoted+  TApp familyCon <$> genFamilyLhsArg++genTypeFamilyInstOperator :: Gen Name+genTypeFamilyInstOperator =+  oneof+    [ qualifyName Nothing . mkUnqualifiedName NameVarSym <$> genFamilyInstVarOperator,+      qualifyName Nothing . mkUnqualifiedName NameConSym <$> genFamilyInstConOperator,+      qualifyName Nothing . mkUnqualifiedName NameConId <$> genConId+    ]++genFamilyInstVarOperator :: Gen Text+genFamilyInstVarOperator =+  suchThat genVarSym (`notElem` ["*", ".", "!", "'"])++genFamilyInstConOperator :: Gen Text+genFamilyInstConOperator =+  suchThat genConSym (`notElem` ["!"])++genFamilyInfixOperand :: Gen Type+genFamilyInfixOperand =+  frequency+    [ (1, genFamilyTypeAtom),+      (3, genFamilyTypeApp)+    ]++genFamilyInfixHead :: Gen Type+genFamilyInfixHead = do+  op <- genTypeFamilyInstOperator+  lhs <- genFamilyInfixOperand+  TInfix lhs op Unpromoted <$> genFamilyInfixOperand++genFamilyTypeApp :: Gen Type+genFamilyTypeApp = do+  f <- genFamilyTypeAtom+  args <- smallList1 genFamilyTypeAtom+  pure (foldl TApp f args)++genFamilyTypeAtom :: Gen Type+genFamilyTypeAtom = genSimpleTypeWithoutFun++genFamilyLhsArg :: Gen Type+genFamilyLhsArg = suchThat (scale (min 4) genType) (not . isStarType)++isStarType :: Type -> Bool+isStarType TStar {} = True+isStarType _ = False++genDeclPragma :: Gen Decl+genDeclPragma = do+  kind <- elements ["INLINE", "NOINLINE", "INLINABLE"]+  DeclPragma . mkPragma . PragmaInline kind <$> genVarId++mkPragma :: PragmaType -> Pragma+mkPragma pt = Pragma {pragmaType = pt, pragmaRawText = ""}++genDeclPatSyn :: Gen Decl+genDeclPatSyn = do+  synName <- genConUnqualifiedName+  argName <- genVarId+  conName <- qualifyName Nothing . mkUnqualifiedName NameConId <$> genConId+  let args = PatSynPrefixArgs [argName]+      pat = PCon conName [] [PVar (mkUnqualifiedName NameVarId argName)]+  dir <- elements [PatSynBidirectional, PatSynUnidirectional]+  pure $ DeclPatSyn (PatSynDecl synName args pat dir)++genDeclPatSynSig :: Gen Decl+genDeclPatSynSig = DeclPatSynSig <$> smallList1 genConUnqualifiedName <*> genType++genDeclStandaloneKindSig :: Gen Decl+genDeclStandaloneKindSig = DeclStandaloneKindSig <$> genConUnqualifiedName <*> genType++genSimpleTyVarBinder :: Gen TyVarBinder+genSimpleTyVarBinder = TyVarBinder [] <$> genVarId <*> pure Nothing <*> pure TyVarBSpecified <*> pure TyVarBVisible++-- | Generate simple type variable binders (0-2 params).+genSimpleTyVarBinders :: Gen [TyVarBinder]+genSimpleTyVarBinders =+  smallList0 genSimpleTyVarBinder++-- | Generate deriving clauses (0-2).+genDerivingClauses :: Gen [DerivingClause]+genDerivingClauses = smallList0 genDerivingClause++genDerivingClause :: Gen DerivingClause+genDerivingClause = do+  strategy <- optional genDerivingStrategy+  classes <- oneof [Left <$> genSimpleConName, Right <$> smallList0 genType]+  pure $+    DerivingClause+      { derivingStrategy = strategy,+        derivingClasses = classes+      }++genDerivingStrategy :: Gen DerivingStrategy+genDerivingStrategy =+  oneof [pure DerivingStock, pure DerivingNewtype, pure DerivingAnyclass, DerivingVia <$> genType]++-- GHC does not allow singleton symbolic class names in deriving clauses.+genSimpleConName :: Gen Name+genSimpleConName =+  qualifyName Nothing . mkUnqualifiedName NameConId <$> genConId++-- | Generate a simple constructor type (used in deriving/context).+genSimpleConType :: Gen Type+genSimpleConType =+  (\n -> TCon (qualifyName Nothing (mkUnqualifiedName NameConId n)) Unpromoted) <$> genConId++-- | Generate a simple constraint context (0-2 constraints).+-- For instance contexts, 0 constraints means no context at all.+genSimpleContext :: Gen [Type]+genSimpleContext = smallList0 genSimpleConstraint++-- | Generate an optional context (Nothing or Just [constraints]).+-- Never generates Just [] since that prints as () => which roundtrips+-- to a unit tuple in the constraint list.+genOptionalSimpleContext :: Gen (Maybe [Type])+genOptionalSimpleContext = optional $ smallList1 genSimpleConstraint++-- | Generate a simple constraint: ClassName tyvar+genSimpleConstraint :: Gen Type+genSimpleConstraint =+  TApp+    <$> genSimpleConType+    <*> (TVar . mkUnqualifiedName NameVarId <$> genVarId)++-- ---------------------------------------------------------------------------+-- Shrinking declarations+-- ---------------------------------------------------------------------------++shrinkDecl :: Decl -> [Decl]+shrinkDecl decl =+  case decl of+    DeclAnn _ inner -> inner : shrinkDecl inner+    DeclValue vd -> map DeclValue (shrinkValueDecl vd)+    DeclTypeSig names ty ->+      [DeclTypeSig names' ty | names' <- shrinkList shrinkBinderName names, not (null names')]+        <> [DeclTypeSig names ty' | ty' <- shrinkType ty]+    DeclPatSyn ps ->+      [DeclPatSyn ps' | ps' <- shrinkPatSynDecl ps]+    DeclPatSynSig names ty ->+      [DeclPatSynSig names' ty | names' <- shrinkList shrinkConName names, not (null names')]+        <> [DeclPatSynSig names ty' | ty' <- shrinkType ty]+    DeclStandaloneKindSig name ty ->+      [DeclStandaloneKindSig name' ty | name' <- shrinkConName name]+        <> [DeclStandaloneKindSig name ty' | ty' <- shrinkType ty]+    DeclFixity assoc ns prec ops ->+      [DeclFixity assoc ns prec ops' | ops' <- shrinkList shrinkBinderName ops, not (null ops')]+    DeclRoleAnnotation ra ->+      [DeclRoleAnnotation ra' | ra' <- shrinkRoleAnnotation ra]+    DeclTypeSyn ts ->+      [DeclTypeSyn ts' | ts' <- shrinkTypeSynDecl ts]+    DeclData dd ->+      [DeclData dd' | dd' <- shrinkDataDecl dd]+    DeclTypeData dd ->+      [DeclTypeData dd' | dd' <- shrinkDataDecl dd]+    DeclNewtype nd ->+      [DeclNewtype nd' | nd' <- shrinkNewtypeDecl nd]+    DeclClass cd ->+      [DeclClass cd' | cd' <- shrinkClassDecl cd]+    DeclInstance inst ->+      [DeclInstance inst' | inst' <- shrinkInstanceDecl inst]+    DeclStandaloneDeriving sd ->+      [DeclStandaloneDeriving sd' | sd' <- shrinkStandaloneDerivingDecl sd]+    DeclDefault types ->+      [DeclDefault types' | types' <- shrinkList shrinkType types]+    DeclSplice expr ->+      [DeclSplice expr' | expr' <- shrinkExpr expr]+    DeclForeign fd ->+      [DeclForeign fd' | fd' <- shrinkForeignDecl fd]+    DeclTypeFamilyDecl tf ->+      [DeclTypeFamilyDecl tf' | tf' <- shrinkTypeFamilyDecl tf]+    DeclDataFamilyDecl df ->+      [DeclDataFamilyDecl df' | df' <- shrinkDataFamilyDecl df]+    DeclTypeFamilyInst tfi ->+      [DeclTypeFamilyInst tfi' | tfi' <- shrinkTypeFamilyInst tfi]+    DeclDataFamilyInst dfi ->+      [DeclDataFamilyInst dfi' | dfi' <- shrinkDataFamilyInst dfi]+    DeclPragma _ -> []++-- ---------------------------------------------------------------------------+-- Value declarations (function binds and pattern binds)+-- ---------------------------------------------------------------------------++shrinkValueDecl :: ValueDecl -> [ValueDecl]+shrinkValueDecl vd =+  case vd of+    PatternBind multTag pat rhs ->+      [PatternBind multTag simpleVarPattern rhs | pat /= PWildcard && not (isSimpleVarPattern pat)]+        <> [PatternBind multTag pat rhs' | rhs' <- shrinkRhs rhs]+        <> [PatternBind multTag pat' rhs | pat' <- shrinkPattern pat]+    FunctionBind name matches ->+      [ PatternBind NoMultiplicityTag (PVar name) (matchRhs match)+      | match <- matches+      ]+        <>+        -- Shrink multiple matches to a single match+        [FunctionBind name [m {matchAnns = []}] | length matches > 1, m <- matches]+        -- Shrink the list of matches+        <> [FunctionBind name ms' | ms' <- shrinkList shrinkMatch matches, not (null ms')]+        -- Shrink the function name+        <> [FunctionBind name' matches | name' <- shrinkBinderName name]++-- | Shrink an individual match clause.+shrinkMatch :: Match -> [Match]+shrinkMatch match =+  -- Shrink the RHS+  [match {matchAnns = [], matchRhs = rhs'} | rhs' <- shrinkRhs (matchRhs match)]+    -- Shrink the patterns+    <> [match {matchAnns = [], matchPats = pats'} | pats' <- shrinkFunctionHeadPats (matchHeadForm match) (matchPats match)]++-- ---------------------------------------------------------------------------+-- Right-hand sides+-- ---------------------------------------------------------------------------++-- | Shrink an RHS: try removing the where clause, simplifying guards to+-- unguarded, and recursively shrinking sub-expressions.+shrinkRhs :: Rhs Expr -> [Rhs Expr]+shrinkRhs rhs =+  case rhs of+    UnguardedRhs _ expr mWhere ->+      -- Hoist failing where-bound RHSs before shrinking the surrounding layout.+      whereValueRhss (fromMaybe [] mWhere)+        <> [UnguardedRhs [] expr Nothing | isJust mWhere]+        -- Shrink the expression+        <> [UnguardedRhs [] expr' mWhere | expr' <- shrinkExpr expr]+        -- Shrink the where clause+        <> [UnguardedRhs [] expr (Just ds') | Just ds <- [mWhere], ds' <- shrinkWhereDecls ds]+    GuardedRhss _ grhss mWhere ->+      -- Collapse to unguarded keeping the where clause (try both with and without)+      [UnguardedRhs [] (guardedRhsBody firstGrhs) mWhere | firstGrhs : _ <- [grhss]]+        <> [UnguardedRhs [] (guardedRhsBody firstGrhs) Nothing | firstGrhs : _ <- [grhss]]+        -- Drop the where clause+        <> [GuardedRhss [] grhss Nothing | isJust mWhere]+        -- Shrink the guard list (keep at least one)+        <> [GuardedRhss [] grhss' mWhere | grhss' <- shrinkList shrinkGuardedRhs grhss, not (null grhss')]+        -- Shrink the where clause+        <> [GuardedRhss [] grhss (Just ds') | Just ds <- [mWhere], ds' <- shrinkWhereDecls ds]++isSimpleVarPattern :: Pattern -> Bool+isSimpleVarPattern pat =+  case pat of+    PVar name -> unqualifiedNameType name == NameVarId && unqualifiedNameText name == "a"+    _ -> False++simpleVarPattern :: Pattern+simpleVarPattern = PVar (mkUnqualifiedName NameVarId "a")++-- | Shrink a where-clause declaration list (keep at least one decl).+shrinkWhereDecls :: [Decl] -> [[Decl]]+shrinkWhereDecls ds =+  [ds' | ds' <- shrinkList shrinkDecl ds, not (null ds')]++whereValueRhss :: [Decl] -> [Rhs Expr]+whereValueRhss decls =+  [ rhs+  | DeclValue valueDecl <- decls,+    rhs <- case valueDecl of+      PatternBind _ _ patternRhs -> [patternRhs]+      FunctionBind _ matches -> map matchRhs matches+  ]++-- | Shrink a guarded RHS: shrink the body and the guards.+shrinkGuardedRhs :: GuardedRhs Expr -> [GuardedRhs Expr]+shrinkGuardedRhs grhs =+  [grhs {guardedRhsBody = body'} | body' <- shrinkExpr (guardedRhsBody grhs)]+    <> [grhs {guardedRhsGuards = gs'} | gs' <- shrinkList shrinkGuardQualifier (guardedRhsGuards grhs), not (null gs')]++-- ---------------------------------------------------------------------------+-- Pattern synonyms+-- ---------------------------------------------------------------------------++shrinkPatSynDecl :: PatSynDecl -> [PatSynDecl]+shrinkPatSynDecl ps =+  [ps {patSynDeclPat = pat'} | pat' <- shrinkPattern (patSynDeclPat ps)]+    <> [ps {patSynDeclName = name'} | name' <- shrinkConName (patSynDeclName ps)]++-- ---------------------------------------------------------------------------+-- Type synonyms+-- ---------------------------------------------------------------------------++shrinkTypeSynDecl :: TypeSynDecl -> [TypeSynDecl]+shrinkTypeSynDecl ts =+  [ts {typeSynHead = head'} | head' <- shrinkBinderHeadName shrinkUnqualifiedName (typeSynHead ts)]+    <> [ts {typeSynBody = ty'} | ty' <- shrinkType (typeSynBody ts)]+    <> [ts {typeSynHead = head'} | head' <- shrinkBinderHeadParams (typeSynHead ts)]++-- ---------------------------------------------------------------------------+-- Data declarations+-- ---------------------------------------------------------------------------++shrinkDataDecl :: DataDecl -> [DataDecl]+shrinkDataDecl dd =+  -- Shrink constructors+  [dd {dataDeclConstructors = cs'} | cs' <- shrinkList shrinkDataConDecl (dataDeclConstructors dd)]+    -- Shrink kind+    <> [dd {dataDeclKind = Just ty'} | Just ty <- [dataDeclKind dd], ty' <- shrinkType ty]+    -- Shrink head+    <> [dd {dataDeclHead = head'} | head' <- shrinkBinderHeadName shrinkUnqualifiedName (dataDeclHead dd)]+    -- Shrink deriving clauses+    <> [dd {dataDeclDeriving = ds'} | ds' <- shrinkList shrinkDerivingClause (dataDeclDeriving dd)]+    -- Shrink type parameters+    <> [dd {dataDeclHead = head'} | head' <- shrinkBinderHeadParams (dataDeclHead dd)]+    -- Shrink context+    <> [dd {dataDeclContext = ctx'} | ctx' <- shrinkList shrinkType (dataDeclContext dd)]++shrinkNewtypeDecl :: NewtypeDecl -> [NewtypeDecl]+shrinkNewtypeDecl nd =+  -- Shrink deriving+  [nd {newtypeDeclDeriving = ds'} | ds' <- shrinkList shrinkDerivingClause (newtypeDeclDeriving nd)]+    -- Shrink type parameters+    <> [nd {newtypeDeclHead = head'} | head' <- shrinkBinderHeadParams (newtypeDeclHead nd)]+    -- Shrink context+    <> [nd {newtypeDeclContext = ctx'} | ctx' <- shrinkList shrinkType (newtypeDeclContext nd)]+    -- Shrink constructor+    <> [nd {newtypeDeclConstructor = Just ctor'} | Just ctor <- [newtypeDeclConstructor nd], ctor' <- shrinkDataConDecl ctor]+    -- Shrink deriving clauses+    <> [nd {newtypeDeclDeriving = ds'} | ds' <- shrinkList shrinkDerivingClause (newtypeDeclDeriving nd)]++shrinkDataConDecl :: DataConDecl -> [DataConDecl]+shrinkDataConDecl con =+  case con of+    DataConAnn _ inner -> inner : shrinkDataConDecl inner+    PrefixCon forall' ctx name fields ->+      [PrefixCon forall' ctx name fields' | fields' <- shrinkList shrinkBangType fields]+        <> [PrefixCon forall' ctx name' fields | name' <- shrinkUnqualifiedName name]+        <> [PrefixCon forall' ctx' name fields | ctx' <- shrinkList shrinkType ctx]+    InfixCon forall' ctx lhs name rhs ->+      [InfixCon forall' ctx lhs' name rhs | lhs' <- shrinkBangType lhs]+        <> [InfixCon forall' ctx lhs name rhs' | rhs' <- shrinkBangType rhs]+        <> [InfixCon forall' ctx lhs name' rhs | name' <- shrinkUnqualifiedName name]+        <> [InfixCon forall' ctx' lhs name rhs | ctx' <- shrinkList shrinkType ctx]+    RecordCon forall' ctx name fields ->+      [RecordCon forall' ctx name' fields | name' <- shrinkUnqualifiedName name]+        <> [RecordCon forall' ctx name fields' | fields' <- shrinkList shrinkFieldDecl fields]+        <> [RecordCon forall' ctx' name fields | ctx' <- shrinkList shrinkType ctx]+    GadtCon forall' ctx names body ->+      [GadtCon forall' ctx names' body | names' <- shrinkList shrinkUnqualifiedName names, not (null names')]+        <> [GadtCon forall' ctx names body' | body' <- shrinkGadtBody body]+        <> [GadtCon forall' ctx' names body | ctx' <- shrinkList shrinkType ctx]+        <> [GadtCon forall'' ctx names body | forall'' <- shrinkForallTelescopes forall']+    TupleCon forall' ctx flavor fields ->+      [TupleCon forall' ctx flavor fields' | fields' <- shrinkList shrinkBangType fields]+        <> [TupleCon forall' ctx' flavor fields | ctx' <- shrinkList shrinkType ctx]+    UnboxedSumCon forall' ctx pos arity field ->+      [UnboxedSumCon forall' ctx pos arity field' | field' <- shrinkBangType field]+        <> [UnboxedSumCon forall' ctx' pos arity field | ctx' <- shrinkList shrinkType ctx]+    ListCon forall' ctx ->+      [ListCon forall' ctx' | ctx' <- shrinkList shrinkType ctx]++shrinkGadtBody :: GadtBody -> [GadtBody]+shrinkGadtBody body =+  case body of+    GadtPrefixBody args result ->+      [GadtPrefixBody args' result | args' <- shrinkList (\(bt, ak) -> map (,ak) (shrinkBangType bt)) args]+        <> [GadtPrefixBody args result' | result' <- shrinkType result]+    GadtRecordBody fields result ->+      [GadtRecordBody fields' result | fields' <- shrinkList shrinkFieldDecl fields, not (null fields')]+        <> [GadtRecordBody fields result' | result' <- shrinkType result]++shrinkBangType :: BangType -> [BangType]+shrinkBangType bt =+  [bt {bangType = ty'} | ty' <- shrinkType (bangType bt)]++shrinkFieldDecl :: FieldDecl -> [FieldDecl]+shrinkFieldDecl fd =+  [fd {fieldNames = ns'} | ns' <- shrinkList shrinkBinderName (fieldNames fd), not (null ns')]+    <> [fd {fieldType = bt'} | bt' <- shrinkBangType (fieldType fd)]++shrinkDerivingClause :: DerivingClause -> [DerivingClause]+shrinkDerivingClause dc =+  [dc {derivingStrategy = Just strategy'} | Just strategy <- [derivingStrategy dc], strategy' <- shrinkDerivingStrategy strategy]+    <> case derivingClasses dc of+      Left name -> [dc {derivingClasses = Left name'} | name' <- shrinkName name]+      Right classes -> [dc {derivingClasses = Right cs'} | cs' <- shrinkList shrinkType classes]++shrinkDerivingStrategy :: DerivingStrategy -> [DerivingStrategy]+shrinkDerivingStrategy strategy =+  case strategy of+    DerivingStock -> []+    DerivingNewtype -> []+    DerivingAnyclass -> []+    DerivingVia ty -> [DerivingVia ty' | ty' <- shrinkType ty]++-- ---------------------------------------------------------------------------+-- Class and instance declarations+-- ---------------------------------------------------------------------------++shrinkClassDecl :: ClassDecl -> [ClassDecl]+shrinkClassDecl cd =+  [cd {classDeclHead = head', classDeclFundeps = genClassFundepsFromHead head'} | head' <- shrinkBinderHeadName shrinkConName (classDeclHead cd)]+    <> [cd {classDeclItems = is'} | is' <- shrinkList shrinkClassDeclItem (classDeclItems cd)]+    <> [cd {classDeclHead = head', classDeclFundeps = genClassFundepsFromHead head'} | head' <- shrinkBinderHeadParams (classDeclHead cd)]+    <> [cd {classDeclContext = ctx'} | Just ctx <- [classDeclContext cd], ctx' <- Nothing : [Just ctx'' | ctx'' <- shrinkList shrinkType ctx]]+    <> [cd {classDeclFundeps = []} | not (null (classDeclFundeps cd))]++shrinkClassDeclItem :: ClassDeclItem -> [ClassDeclItem]+shrinkClassDeclItem item =+  case item of+    ClassItemAnn _ inner -> inner : shrinkClassDeclItem inner+    ClassItemTypeSig names ty ->+      [ClassItemTypeSig names' ty | names' <- shrinkList shrinkBinderName names, not (null names')]+        <> [ClassItemTypeSig names ty' | ty' <- shrinkType ty]+    ClassItemDefaultSig name ty ->+      [ClassItemDefaultSig name' ty | name' <- shrinkBinderName name]+        <> [ClassItemDefaultSig name ty' | ty' <- shrinkType ty]+    ClassItemFixity assoc ns prec ops ->+      [ClassItemFixity assoc ns prec ops' | ops' <- shrinkList shrinkBinderName ops, not (null ops')]+        <> [ClassItemFixity assoc Nothing prec ops | isJust ns]+        <> [ClassItemFixity assoc ns Nothing ops | isJust prec]+    ClassItemDefault vd ->+      [ClassItemDefault vd' | vd' <- shrinkClassDefaultDecl vd]+    ClassItemTypeFamilyDecl tf ->+      [ClassItemTypeFamilyDecl tf' | tf' <- shrinkTypeFamilyDecl tf]+    ClassItemDataFamilyDecl df ->+      [ClassItemDataFamilyDecl df' | df' <- shrinkDataFamilyDecl df]+    ClassItemDefaultTypeInst tfi ->+      [ClassItemDefaultTypeInst tfi' | tfi' <- shrinkTypeFamilyInst tfi]+    ClassItemPragma _ -> []++shrinkClassDefaultDecl :: ValueDecl -> [ValueDecl]+shrinkClassDefaultDecl vd =+  case vd of+    PatternBind multTag pat rhs ->+      [PatternBind multTag simpleClassDefaultPattern rhs | pat /= PWildcard && pat /= simpleClassDefaultPattern]+        <> [PatternBind multTag pat rhs' | rhs' <- shrinkRhs rhs]+        <> [PatternBind multTag pat' rhs | pat' <- shrinkPattern pat]+    FunctionBind name matches ->+      [FunctionBind name [m {matchAnns = []}] | length matches > 1, m <- matches]+        <> [FunctionBind name ms' | ms' <- shrinkList shrinkMatch matches, not (null ms')]+        <> [FunctionBind name' matches | name' <- shrinkBinderName name]++simpleClassDefaultPattern :: Pattern+simpleClassDefaultPattern = PVar (mkUnqualifiedName NameVarId "x")++shrinkInstanceDecl :: InstanceDecl -> [InstanceDecl]+shrinkInstanceDecl inst =+  [inst {instanceDeclItems = is'} | is' <- shrinkList (const []) (instanceDeclItems inst)]+    <> [inst {instanceDeclHead = head'} | head' <- shrinkType (instanceDeclHead inst)]+    <> [inst {instanceDeclContext = ctx'} | ctx' <- shrinkList shrinkType (instanceDeclContext inst)]++-- ---------------------------------------------------------------------------+-- Standalone deriving+-- ---------------------------------------------------------------------------++shrinkStandaloneDerivingDecl :: StandaloneDerivingDecl -> [StandaloneDerivingDecl]+shrinkStandaloneDerivingDecl sd =+  [sd {standaloneDerivingHead = head'} | head' <- shrinkType (standaloneDerivingHead sd)]+    <> [sd {standaloneDerivingContext = ctx'} | ctx' <- shrinkList shrinkType (standaloneDerivingContext sd)]++-- ---------------------------------------------------------------------------+-- Foreign declarations+-- ---------------------------------------------------------------------------++shrinkForeignDecl :: ForeignDecl -> [ForeignDecl]+shrinkForeignDecl fd =+  [fd {foreignType = ty'} | ty' <- shrinkType (foreignType fd)]+    <> [fd {foreignName = n'} | n' <- shrinkUnqualifiedName (foreignName fd)]++-- ---------------------------------------------------------------------------+-- Type/data families+-- ---------------------------------------------------------------------------++shrinkTypeFamilyDecl :: TypeFamilyDecl -> [TypeFamilyDecl]+shrinkTypeFamilyDecl tf =+  [tf {typeFamilyDeclParams = ps'} | ps' <- shrinkTypeHeadParams (typeFamilyDeclHeadForm tf) (typeFamilyDeclParams tf)]+    <> [tf {typeFamilyDeclExplicitFamilyKeyword = False} | typeFamilyDeclExplicitFamilyKeyword tf]++shrinkDataFamilyDecl :: DataFamilyDecl -> [DataFamilyDecl]+shrinkDataFamilyDecl df =+  [df {dataFamilyDeclHead = head'} | head' <- shrinkBinderHeadParams (dataFamilyDeclHead df)]++shrinkTypeFamilyInst :: TypeFamilyInst -> [TypeFamilyInst]+shrinkTypeFamilyInst tfi =+  [tfi {typeFamilyInstLhs = lhs'} | lhs' <- shrinkTypeFamilyInstLhs (typeFamilyInstHeadForm tfi) (typeFamilyInstLhs tfi)]+    <> [tfi {typeFamilyInstRhs = rhs'} | rhs' <- shrinkType (typeFamilyInstRhs tfi)]++shrinkTypeFamilyInstLhs :: TypeHeadForm -> Type -> [Type]+shrinkTypeFamilyInstLhs headForm lhs =+  case headForm of+    TypeHeadPrefix -> shrinkType lhs+    TypeHeadInfix ->+      case lhs of+        TApp (TApp op lhsArg) rhsArg ->+          [TApp (TApp op lhsArg') rhsArg | lhsArg' <- shrinkType lhsArg]+            <> [TApp (TApp op lhsArg) rhsArg' | rhsArg' <- shrinkType rhsArg]+        _ -> []++shrinkDataFamilyInst :: DataFamilyInst -> [DataFamilyInst]+shrinkDataFamilyInst dfi =+  [dfi {dataFamilyInstConstructors = cs'} | cs' <- shrinkList shrinkDataConDecl (dataFamilyInstConstructors dfi)]+    <> [dfi {dataFamilyInstHead = h'} | h' <- shrinkType (dataFamilyInstHead dfi)]+    <> [dfi {dataFamilyInstDeriving = ds'} | ds' <- shrinkList shrinkDerivingClause (dataFamilyInstDeriving dfi)]++-- ---------------------------------------------------------------------------+-- Role annotations+-- ---------------------------------------------------------------------------++shrinkRoleAnnotation :: RoleAnnotation -> [RoleAnnotation]+shrinkRoleAnnotation ra =+  [ra {roleAnnotationRoles = rs'} | rs' <- shrinkList (const []) (roleAnnotationRoles ra)]+    <> [ra {roleAnnotationName = n'} | n' <- shrinkConName (roleAnnotationName ra)]++-- ---------------------------------------------------------------------------+-- Name shrinking helpers+-- ---------------------------------------------------------------------------++shrinkConName :: UnqualifiedName -> [UnqualifiedName]+shrinkConName = shrinkUnqualifiedName++shrinkBinderName :: BinderName -> [BinderName]+shrinkBinderName = shrinkUnqualifiedName++-- ---------------------------------------------------------------------------+-- Shared helpers+-- ---------------------------------------------------------------------------++shrinkForallTelescopes :: [ForallTelescope] -> [[ForallTelescope]]+shrinkForallTelescopes = shrinkList shrinkForallTelescope++shrinkTypeHeadParams :: TypeHeadForm -> [TyVarBinder] -> [[TyVarBinder]]+shrinkTypeHeadParams headForm params =+  case headForm of+    TypeHeadPrefix -> shrinkTyVarBinders params+    TypeHeadInfix -> [ps' | ps' <- shrinkTyVarBinders params, length ps' >= 2]++shrinkBinderHeadName :: (name -> [name]) -> BinderHead name -> [BinderHead name]+shrinkBinderHeadName shrinkNameFn head' =+  case head' of+    PrefixBinderHead name params -> [PrefixBinderHead name' params | name' <- shrinkNameFn name]+    InfixBinderHead lhs name rhs tailParams ->+      [InfixBinderHead lhs name' rhs tailParams | name' <- shrinkNameFn name]++shrinkBinderHeadParams :: BinderHead UnqualifiedName -> [BinderHead UnqualifiedName]+shrinkBinderHeadParams head' =+  case head' of+    PrefixBinderHead name params ->+      [PrefixBinderHead name' params | name' <- shrinkUnqualifiedName name]+        <> [PrefixBinderHead name params' | params' <- shrinkTyVarBinders params]+    InfixBinderHead lhs name rhs tailParams ->+      [InfixBinderHead lhs name' rhs tailParams | name' <- shrinkUnqualifiedName name]+        <> [ head''+           | params' <- shrinkTypeHeadParams TypeHeadInfix (lhs : rhs : tailParams),+             head'' <- case params' of+               lhs' : rhs' : tailParams' -> [InfixBinderHead lhs' name rhs' tailParams']+               _ -> []+           ]++shrinkFunctionHeadPats :: MatchHeadForm -> [Pattern] -> [[Pattern]]+shrinkFunctionHeadPats headForm pats =+  case headForm of+    MatchHeadPrefix ->+      [ shrunk+      | shrunk <- shrinkList shrinkPattern pats,+        not (null shrunk)+      ]+    MatchHeadInfix ->+      [ lhs' : rhs : tailPats+      | lhs : rhs : tailPats <- [pats],+        lhs' <- shrinkPattern lhs+      ]+        <> [ lhs : rhs' : tailPats+           | lhs : rhs : tailPats <- [pats],+             rhs' <- shrinkPattern rhs+           ]+        <> [ lhs : rhs : shrunkTail+           | lhs : rhs : tailPats <- [pats],+             shrunkTail <- shrinkList shrinkPattern tailPats+           ]
+ test/Test/Properties/Arb/Expr.hs view
@@ -0,0 +1,939 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Properties.Arb.Expr+  ( genExpr,+    genRhs,+    mkIntExpr,+    mkStringExpr,+    shrinkExpr,+    shrinkGuardQualifier,+  )+where++import Aihc.Parser.Syntax+import Data.Char (isSpace)+import Data.Maybe (isJust, isNothing)+import Data.Text (Text)+import Data.Text qualified as T+import Test.Properties.Arb.Decl (genDeclValue, genWhereDecls, shrinkFunctionHeadPats)+import Test.Properties.Arb.Identifiers+  ( genCharValue,+    genConName,+    genFieldName,+    genModuleQualifier,+    genStringValue,+    genTenths,+    genVarId,+    genVarName,+    showHex,+    shrinkFloat,+    shrinkName,+    shrinkQualifier,+    shrinkUnqualifiedName,+  )+import Test.Properties.Arb.Pattern (genPattern, shrinkPattern)+import {-# SOURCE #-} Test.Properties.Arb.Type (genType, shrinkType)+import Test.Properties.Arb.Utils+import Test.QuickCheck++-- | Generate a random expression. Uses QuickCheck's size parameter+-- to control recursion depth.+genExpr :: Gen Expr+genExpr = scale (`div` 2) $ do+  n <- getSize+  if n <= 0 then genExprLeaf else oneof (baseGenerators <> quoteGenerators)+  where+    baseGenerators =+      [ -- Leaf expressions+        genExprLeaf,+        -- Recursive expressions (reduce size for subexpressions)+        EApp <$> genExpr <*> genExpr,+        EInfix <$> genExpr <*> genVarName <*> genExpr,+        ENegate <$> genExpr,+        ESectionL <$> genExpr <*> genVarName,+        ESectionR <$> genRightSectionOpName <*> genExpr,+        EIf <$> genExpr <*> genExpr <*> genExpr,+        EMultiWayIf <$> genGuardedRhsListWith,+        ECase <$> genExpr <*> genCaseAltsWith,+        ELambdaPats <$> genPatterns <*> genExpr,+        ELambdaCase <$> genCaseAltsWith,+        ELambdaCases <$> genLambdaCaseAltsWith,+        ELetDecls <$> smallList0 (DeclValue <$> genDeclValue) <*> genExpr,+        EDo <$> genDoStmtsWith <*> genDoFlavor,+        EListComp <$> genExpr <*> genCompStmtsWith,+        EListCompParallel <$> genExpr <*> genParallelCompStmtsWith,+        EList <$> genListElemsWith,+        ETuple Boxed . map Just <$> genTupleElemsWith,+        ETuple Unboxed . map Just <$> genUnboxedTupleElemsWith,+        ETuple Boxed <$> genTupleSectionElemsWith,+        ETuple Unboxed <$> genTupleSectionElemsWith,+        genUnboxedSumExprWith,+        EArithSeq <$> genArithSeqWith,+        ERecordCon <$> genConName <*> genRecordFieldsWith <*> pure False,+        ERecordUpd <$> genExpr <*> genRecordFieldsWith,+        ETypeSig <$> genExpr <*> genType,+        ETypeApp <$> genExpr <*> genType,+        EParen . ETypeSyntax TypeSyntaxExplicitNamespace <$> genTypeSyntaxType,+        EParen <$> genExpr,+        EProc <$> genPattern <*> genCmdWith,+        EParen <$> (EPragma <$> genSccPragma <*> genPragmaExpr),+        -- OverloadedRecordDot+        EGetField <$> genExpr <*> genRecordFieldName,+        EGetFieldProjection <$> smallList1 genRecordFieldName,+        -- Template Haskell splices are valid inside quote bodies.+        ETHSplice <$> genSpliceBody,+        ETHTypedSplice <$> genTypedSpliceBody+      ]+    quoteGenerators =+      [ ETHExpQuote <$> genExpr,+        ETHTypedQuote <$> genExpr,+        ETHDeclQuote <$> smallList0 (DeclValue <$> genDeclValue),+        ETHPatQuote <$> genPattern,+        ETHTypeQuote <$> genType,+        ETHNameQuote <$> genNameQuoteExpr,+        ETHTypeNameQuote <$> genTypeNameQuoteType+      ]++-- | Generate a leaf (non-recursive) expression.+genExprLeaf :: Gen Expr+genExprLeaf =+  oneof+    [ EVar <$> genVarName,+      genOverloadedLabel,+      mkIntExpr <$> chooseInteger (0, 999),+      mkHexExpr <$> chooseInteger (0, 255),+      mkFloatExpr <$> genTenths,+      mkCharExpr <$> genCharValue,+      mkStringExpr <$> genStringValue,+      -- MagicHash literals+      (\v -> EInt v TIntHash (T.pack (show v) <> "#")) <$> chooseInteger (0, 999),+      (\v -> ECharHash v (T.pack (show v) <> "#")) <$> genCharValue,+      (\v -> EStringHash v (T.pack (show (T.unpack v)) <> "#")) <$> genStringValue,+      EQuasiQuote <$> genQuasiQuoteName <*> genStringValue,+      pure (EList []),+      pure (ETuple Boxed []),+      pure (ETuple Unboxed []),+      (\n -> ETuple Boxed (replicate n Nothing)) <$> chooseInt (2, 5),+      (\n -> ETuple Unboxed (replicate n Nothing)) <$> chooseInt (2, 5)+    ]++genOverloadedLabel :: Gen Expr+genOverloadedLabel = do+  labelName <- suchThat genVarId (not . T.isSuffixOf "#")+  pure (EOverloadedLabel labelName ("#" <> labelName))++genSccPragma :: Gen Pragma+genSccPragma = do+  sccLabel <- suchThat genVarId (not . T.isSuffixOf "#")+  pure Pragma {pragmaType = PragmaSCC sccLabel, pragmaRawText = ""}++genPragmaExpr :: Gen Expr+genPragmaExpr = EVar <$> genVarName++genTypeSyntaxType :: Gen Type+genTypeSyntaxType =+  oneof+    [ TVar . mkUnqualifiedName NameVarId <$> genVarId,+      (`TCon` Unpromoted) <$> genConName+    ]++-- | Generate a quasi-quote name, excluding TH bracket names (e, d, p, t) which+-- would collide with Template Haskell bracket syntax ([e|...|], [d|...|], etc.).+genQuasiQuoteName :: Gen Text+genQuasiQuoteName = suchThat genVarId isValidQuasiQuoteName++isValidQuasiQuoteName :: Text -> Bool+isValidQuasiQuoteName name = name `notElem` ["e", "d", "p", "t", ""] && not (T.isSuffixOf "#" name)++-- | Generate the body of a TH splice: either a bare variable or a parenthesized expression.+-- Bare variables produce $name syntax; parenthesized produce $(expr) syntax.+genSpliceBody :: Gen Expr+genSpliceBody =+  oneof+    [ EVar <$> genVarName,+      EParen <$> scale (`div` 2) genExpr+    ]++-- | Generate the body of a TH typed splice: always parenthesized.+-- Typed splices require parentheses: $$(expr) is valid, $$expr is invalid.+genTypedSpliceBody :: Gen Expr+genTypedSpliceBody =+  EParen <$> scale (`div` 2) genExpr++-- | Generate a TH value name quote target.+-- Produces unqualified identifiers plus qualified identifiers and operators+-- such as @M.v@ and @M.+@.+genNameQuoteExpr :: Gen Expr+genNameQuoteExpr =+  oneof+    [ EVar <$> genVarName,+      pure (EList []),+      pure (ETuple Boxed []),+      pure (ETuple Unboxed []),+      (\n -> ETuple Boxed (replicate n Nothing))+        <$> chooseInt (2, 5),+      (\n -> ETuple Unboxed (replicate n Nothing))+        <$> chooseInt (2, 5)+    ]++genTypeNameQuoteType :: Gen Type+genTypeNameQuoteType =+  oneof+    [ TCon <$> genConName <*> pure Unpromoted,+      pure (TBuiltinCon TBuiltinList),+      pure (TTuple Boxed Unpromoted []),+      pure (TTuple Unboxed Unpromoted [])+    ]++-- | Generate simple patterns for lambdas+genPatterns :: Gen [Pattern]+genPatterns = smallList1 genPattern++genCmdWith :: Gen Cmd+genCmdWith = scale (`div` 2) $ do+  n <- getSize+  if n <= 0 then genCmdLeafWith else oneof (genCmdLeafWith : genCmdRecursiveWith)++genCmdLeafWith :: Gen Cmd+genCmdLeafWith =+  CmdArrApp <$> genExpr <*> genArrAppType <*> genExpr++genCmdRecursiveWith :: [Gen Cmd]+genCmdRecursiveWith =+  [ CmdInfix <$> genCmdWith <*> genVarName <*> genCmdWith,+    CmdDo <$> genCmdDoStmtsWith,+    CmdIf <$> genExpr <*> genCmdWith <*> genCmdWith,+    CmdCase <$> genExpr <*> genCmdCaseAltsWith,+    CmdLet <$> smallList0 (DeclValue <$> genDeclValue) <*> genCmdWith,+    CmdLam <$> genPatterns <*> genCmdWith,+    CmdPar <$> genCmdWith+  ]++genArrAppType :: Gen ArrAppType+genArrAppType = elements [HsFirstOrderApp, HsHigherOrderApp]++genCmdCaseAltsWith :: Gen [CaseAlt Cmd]+genCmdCaseAltsWith = smallList1 genCmdCaseAltWith++genCmdCaseAltWith :: Gen (CaseAlt Cmd)+genCmdCaseAltWith = scale (`div` 2) $ do+  CaseAlt [] <$> genPattern <*> genCmdRhsWith++genCmdDoStmtsWith :: Gen [DoStmt Cmd]+genCmdDoStmtsWith = smallList1 genCmdDoStmtWith++genCmdDoStmtWith :: Gen (DoStmt Cmd)+genCmdDoStmtWith =+  scale (`div` 2) . oneof $+    [ DoBind <$> genPattern <*> genCmdWith,+      DoLetDecls <$> smallList0 (DeclValue <$> genDeclValue),+      DoExpr <$> genCmdWith,+      DoRecStmt <$> genCmdRecDoStmtsWith+    ]++genCmdRecDoStmtsWith :: Gen [DoStmt Cmd]+genCmdRecDoStmtsWith =+  scale (`div` 2) . smallList1 $+    oneof+      [ DoBind <$> genPattern <*> genCmdWith,+        DoLetDecls <$> smallList0 (DeclValue <$> genDeclValue),+        DoExpr <$> genCmdWith+      ]++genCaseAltsWith :: Gen [CaseAlt Expr]+genCaseAltsWith = smallList0 genCaseAltWith++genCaseAltWith :: Gen (CaseAlt Expr)+genCaseAltWith = CaseAlt [] <$> genPattern <*> genRhs++genLambdaCaseAltsWith :: Gen [LambdaCaseAlt]+genLambdaCaseAltsWith = smallList0 genLambdaCaseAltWith++genLambdaCaseAltWith :: Gen LambdaCaseAlt+genLambdaCaseAltWith = scale (`div` 2) $ do+  LambdaCaseAlt [] <$> genPatterns <*> genRhs++genRhs :: Gen (Rhs Expr)+genRhs =+  oneof+    [ UnguardedRhs [] <$> genExpr <*> genWhereDecls,+      GuardedRhss [] <$> genGuardedRhsListWith <*> genWhereDecls+    ]++genCmdRhsWith :: Gen (Rhs Cmd)+genCmdRhsWith =+  oneof+    [ UnguardedRhs [] <$> genCmdWith <*> genWhereDecls,+      GuardedRhss [] <$> genCmdGuardedRhsListWith <*> genWhereDecls+    ]++genGuardedRhsListWith :: Gen [GuardedRhs Expr]+genGuardedRhsListWith = smallList1 genGuardedRhsWith++genGuardedRhsWith :: Gen (GuardedRhs Expr)+genGuardedRhsWith = GuardedRhs [] <$> smallList1 genGuardQualifierWith <*> genExpr++genCmdGuardedRhsListWith :: Gen [GuardedRhs Cmd]+genCmdGuardedRhsListWith = smallList1 genCmdGuardedRhsWith++genCmdGuardedRhsWith :: Gen (GuardedRhs Cmd)+genCmdGuardedRhsWith = GuardedRhs [] <$> smallList1 genGuardQualifierWith <*> genCmdWith++-- | Generate a guard qualifier.+genGuardQualifierWith :: Gen GuardQualifier+genGuardQualifierWith =+  oneof+    [ -- Boolean guard: | expr = ...+      GuardExpr <$> genExpr,+      -- Pattern guard: | pat <- expr = ...+      -- The guarded-qualifier parser now accepts the full pattern generator,+      -- which includes parenthesized view patterns such as `(view -> pat)`.+      scale (`div` 2) (GuardPat <$> genPattern <*> genExpr),+      -- Let guard: | let decls = ...+      GuardLet <$> smallList0 (DeclValue <$> genDeclValue)+    ]++genDoFlavor :: Gen DoFlavor+genDoFlavor =+  oneof+    [ pure DoPlain,+      pure DoMdo,+      DoQualified <$> genModuleQualifier,+      DoQualifiedMdo <$> genModuleQualifier+    ]++genDoStmtsWith :: Gen [DoStmt Expr]+genDoStmtsWith = do+  stmts <- smallList0 genDoStmtWith+  -- Last statement must be DoExpr+  lastExpr <- genExpr+  pure (stmts <> [DoExpr lastExpr])++genDoStmtWith :: Gen (DoStmt Expr)+genDoStmtWith =+  scale (`div` 2) $+    oneof+      [ DoBind <$> genPattern <*> genExpr,+        DoLetDecls <$> smallList0 (DeclValue <$> genDeclValue),+        DoExpr <$> genExpr,+        DoRecStmt <$> genRecDoStmtsWith+      ]++-- | Generate statements for a @rec@ block inside @mdo@/@do@.+-- At least one statement is required.+genRecDoStmtsWith :: Gen [DoStmt Expr]+genRecDoStmtsWith =+  scale (`div` 2) $+    smallList1 $+      oneof+        [ DoBind <$> genPattern <*> genExpr,+          DoLetDecls <$> smallList0 (DeclValue <$> genDeclValue),+          DoExpr <$> genExpr+        ]++genCompStmtsWith :: Gen [CompStmt]+genCompStmtsWith = do+  firstStmt <- genCompStmtInitialWith+  restStmts <- smallList0 genCompStmtWith+  pure (firstStmt : restStmts)++genCompStmtInitialWith :: Gen CompStmt+genCompStmtInitialWith =+  scale (`div` 2) $+    oneof+      [ CompGen <$> genPattern <*> genExpr,+        CompGuard <$> genExpr,+        CompLetDecls <$> smallList0 (DeclValue <$> genDeclValue)+      ]++genCompStmtWith :: Gen CompStmt+genCompStmtWith =+  scale (`div` 2) $+    oneof+      [ CompGen <$> genPattern <*> genExpr,+        CompGuard <$> genExpr,+        CompLetDecls <$> smallList0 (DeclValue <$> genDeclValue),+        CompThen <$> genExpr,+        CompThenBy <$> genExpr <*> genExpr,+        CompGroupUsing <$> genExpr,+        CompGroupByUsing <$> genExpr <*> genExpr+      ]++genParallelCompStmtsWith :: Gen [[CompStmt]]+genParallelCompStmtsWith = smallList2 genCompStmtsWith++genListElemsWith :: Gen [Expr]+genListElemsWith = smallList0 genExpr++-- | Generate tuple elements+genTupleElemsWith :: Gen [Expr]+genTupleElemsWith = smallList2 genExpr++-- | Generate elements for an unboxed tuple (0-4 elements).+-- Unlike boxed tuples, unboxed tuples with 0 elements are valid Haskell.+-- Sometimes generates layout-sensitive expressions (case, do, if, let, lambda)+-- to ensure proper implicit layout handling with unboxed tuple delimiters.+genUnboxedTupleElemsWith :: Gen [Expr]+genUnboxedTupleElemsWith =+  smallList0 genExpr++genUnboxedSumExprWith :: Gen Expr+genUnboxedSumExprWith = do+  arity <- chooseInt (2, 4)+  altIdx <- chooseInt (0, arity - 1)+  EUnboxedSum altIdx arity <$> genExpr++genTupleSectionElemsWith :: Gen [Maybe Expr]+genTupleSectionElemsWith = do+  elems <- smallList2 genMaybeExprWith+  -- Ensure at least one Nothing (otherwise it's just a tuple)+  if Nothing `notElem` elems+    then do+      idx <- chooseInt (0, length elems - 1)+      pure (take idx elems <> [Nothing] <> drop (idx + 1) elems)+    else pure elems++genMaybeExprWith :: Gen (Maybe Expr)+genMaybeExprWith =+  optional genExpr++genArithSeqWith :: Gen ArithSeq+genArithSeqWith =+  scale (`div` 2) $+    oneof+      [ ArithSeqFrom <$> genExpr,+        ArithSeqFromThen <$> genExpr <*> genExpr,+        ArithSeqFromTo <$> genExpr <*> genExpr,+        ArithSeqFromThenTo <$> genExpr <*> genExpr <*> genExpr+      ]++genRecordFieldsWith :: Gen [RecordField Expr]+genRecordFieldsWith =+  smallList0 $+    RecordField <$> genVarName <*> genExpr <*> pure False++-- | Generate a field name for OverloadedRecordDot.+-- Uses an unqualified variable name (field names are always unqualified).+genRecordFieldName :: Gen Name+genRecordFieldName = qualifyName Nothing . mkUnqualifiedName NameVarId <$> genFieldName++-- | Literal expression constructors+mkHexExpr :: Integer -> Expr+mkHexExpr value = EInt value TInteger ("0x" <> T.pack (showHex value))++mkFloatExpr :: Rational -> Expr+mkFloatExpr value = EFloat value TFractional (renderFloat value)++mkCharExpr :: Char -> Expr+mkCharExpr value = EChar value (T.pack (show value))++mkCharHashExpr :: Char -> Expr+mkCharHashExpr value = ECharHash value (T.pack (show value) <> "#")++mkStringExpr :: Text -> Expr+mkStringExpr value = EString value (T.pack (show (T.unpack value)))++mkStringHashExpr :: Text -> Expr+mkStringHashExpr value = EStringHash value (T.pack (show (T.unpack value)) <> "#")++-- | Create an integer expression with canonical representation.+mkIntExpr :: Integer -> Expr+mkIntExpr value = EInt value TInteger (T.pack (show value))++renderFloat :: Rational -> T.Text+renderFloat value = T.pack (show (fromRational value :: Double))++shrinkOverloadedLabel :: Text -> Text -> [String]+shrinkOverloadedLabel value raw+  | Just unquoted <- T.stripPrefix "#" raw,+    not ("\"" `T.isPrefixOf` unquoted) =+      [ T.unpack candidate+      | candidate <-+          ["a"]+            <> [T.map replaceUnicode value | T.any (> '\x7f') value]+            <> map T.pack (shrink (T.unpack value)),+        candidate /= value,+        isValidLabelName candidate+      ]+  | otherwise = []+  where+    replaceUnicode c = if c > '\x7f' then 'a' else c+    isValidLabelName name =+      case T.uncons name of+        Just (first, rest) ->+          (first `elem` (['a' .. 'z'] <> ['A' .. 'Z'] <> ['_']))+            && T.all isUnquotedLabelChar rest+        Nothing -> False+    isUnquotedLabelChar c =+      not (isSpace c) && c `notElem` ("()[]{},;`#\"" :: String)++-- | Shrink an expression for QuickCheck counterexample minimization.+shrinkExpr :: Expr -> [Expr]+shrinkExpr expr =+  [EList [] | expr /= EList []]+    ++ case expr of+      EVar name -> [EVar name' | name' <- shrinkName name]+      ETypeSyntax form ty -> [ETypeSyntax form ty' | ty' <- shrinkType ty]+      EInt value _ _ -> simpleVarExpr : [mkIntExpr shrunk | shrunk <- shrinkIntegral value]+      EFloat value _ _ -> simpleVarExpr : [mkFloatExpr shrunk | shrunk <- shrinkFloat value]+      EChar value _ ->+        simpleVarExpr+          : [mkCharExpr 'a' | value /= 'a']+      ECharHash value _ ->+        simpleVarExpr+          : [mkCharHashExpr 'a' | value /= 'a']+      EString value _ -> simpleVarExpr : [mkStringExpr (T.pack shrunk) | shrunk <- shrink (T.unpack value)]+      EStringHash value _ -> simpleVarExpr : [mkStringHashExpr (T.pack shrunk) | shrunk <- shrink (T.unpack value)]+      EOverloadedLabel value raw ->+        [EOverloadedLabel (T.pack shrunk) ("#" <> T.pack shrunk) | shrunk <- shrinkOverloadedLabel value raw]+      EPragma pragma inner -> inner : [EPragma pragma inner' | inner' <- shrinkExpr inner]+      EQuasiQuote quoter body ->+        [EVar (qualifyName Nothing (mkUnqualifiedName NameVarId "a"))]+          <> [EQuasiQuote quoter' body | quoter' <- "q" : T.inits quoter, isValidQuasiQuoteName quoter', quoter' /= quoter]+          <> [EQuasiQuote quoter (T.pack shrunk) | shrunk <- shrink (T.unpack body)]+      EApp fn arg ->+        [fn, arg]+          <> [EApp fn' arg | fn' <- shrinkExpr fn]+          <> [EApp fn arg' | arg' <- shrinkExpr arg]+      EInfix lhs op rhs ->+        [lhs, rhs]+          <> [EInfix lhs op' rhs | op' <- shrinkName op]+          <> [EInfix simpleVarExpr op rhs | lhs /= EList [] && not (isSimpleVarExpr lhs)]+          <> [EInfix lhs op rhs' | rhs' <- shrinkExpr rhs]+          <> [EInfix lhs' op rhs | lhs' <- shrinkExpr lhs]+      ENegate inner -> inner : [ENegate inner' | inner' <- shrinkExpr inner]+      ESectionL inner op ->+        inner+          : [ESectionL inner' op | inner' <- shrinkExpr inner]+            <> [ESectionL inner op' | op' <- shrinkName op]+      ESectionR op inner ->+        inner+          : [ESectionR op inner' | isValidRightSectionOpName op, inner' <- shrinkExpr inner]+            <> [ESectionR op' inner | op' <- shrinkName op, isValidRightSectionOpName op']+      EIf cond thenE elseE ->+        [thenE, elseE]+          <> [EIf cond' thenE elseE | cond' <- shrinkExpr cond]+          <> [EIf cond thenE' elseE | thenE' <- shrinkExpr thenE]+          <> [EIf cond thenE elseE' | elseE' <- shrinkExpr elseE]+      EMultiWayIf rhss ->+        [guardedRhsBody grhs | grhs : _ <- [rhss]]+          <> [EMultiWayIf rhss' | rhss' <- shrinkList shrinkGuardedRhs rhss, not (null rhss')]+      ECase scrutinee alts ->+        scrutinee+          : [ECase scrutinee' alts | scrutinee' <- shrinkExpr scrutinee]+            <> [ECase scrutinee alts' | alts' <- shrinkCaseAlts alts, not (null alts')]+      ELambdaPats pats body ->+        body+          : [ELambdaPats pats body' | body' <- shrinkExpr body]+            <> [ELambdaPats pats' body | pats' <- shrinkList shrinkPattern pats, not (null pats')]+      ELambdaCase alts ->+        [body | CaseAlt {caseAltRhs = UnguardedRhs _ body _} <- alts]+          <> [ELambdaCase alts' | alts' <- shrinkCaseAlts alts, not (null alts')]+      ELambdaCases alts ->+        [body | LambdaCaseAlt {lambdaCaseAltRhs = UnguardedRhs _ body _} <- alts]+          <> [ELambdaCases alts' | alts' <- shrinkLambdaCaseAlts alts, not (null alts')]+      ELetDecls decls body ->+        [ELetDecls [simpleLetDecl] simpleUnitExpr | not (isSimpleLetTarget decls body)]+          <> ( body+                 : [ELetDecls decls body' | body' <- shrinkExpr body]+                   <> [ELetDecls decls' body | decls' <- shrinkDecls decls, not (null decls')]+             )+      EDo stmts flavor ->+        [body | [DoExpr body] <- [stmts]]+          <> [EDo stmts flavor' | flavor' <- shrinkDoFlavor flavor]+          <> [EDo stmts' flavor | stmts' <- shrinkDoStmts stmts, not (null stmts')]+      EListComp body stmts ->+        body+          : [EListComp body' stmts | body' <- shrinkExpr body]+            <> [EListComp body stmts' | stmts' <- shrinkCompStmts stmts, not (null stmts')]+      EListCompParallel body stmtss ->+        body+          : [EListCompParallel body' stmtss | body' <- shrinkExpr body]+            -- Each branch needs at least one statement, so filter out empty branches+            <> [EListCompParallel body stmtss' | stmtss' <- shrinkParallelCompStmts stmtss, length stmtss' >= 2]+      EList elems ->+        [EList elems' | elems' <- shrinkList shrinkExpr elems]+      ETuple tupleFlavor elems ->+        [ETuple Boxed elems | tupleFlavor == Unboxed, length elems /= 1]+          <> [ETuple tupleFlavor elems' | elems' <- shrinkTupleMaybeElems shrinkMaybeExpr elems]+      EArithSeq seq' ->+        [EArithSeq seq'' | seq'' <- shrinkArithSeq seq']+      ERecordCon con fields _ ->+        [simpleVarExpr]+          <> [ERecordCon con' fields False | con' <- shrinkName con]+          <> [ERecordCon con fields' False | fields' <- shrinkRecordFields fields]+      ERecordUpd target fields ->+        target+          : [ERecordUpd target' fields | target' <- shrinkExpr target]+            <> [ERecordUpd target fields' | fields' <- shrinkRecordFields fields]+      EGetField base fieldName ->+        base+          : [EGetField base' fieldName | base' <- shrinkExpr base]+            <> [EGetField base fieldName' | fieldName' <- shrinkName fieldName]+      EGetFieldProjection fields ->+        [EGetFieldProjection fields' | fields' <- shrinkList shrinkName fields, not (null fields')]+      ETypeSig inner ty ->+        inner+          : [ETypeSig inner ty' | ty' <- shrinkType ty]+            <> [ETypeSig inner' ty | inner' <- shrinkExpr inner]+      ETypeApp inner ty ->+        inner+          : [ETypeApp inner ty' | ty' <- shrinkType ty]+            <> [ETypeApp inner' ty | inner' <- shrinkExpr inner]+      EUnboxedSum altIdx arity inner ->+        [EUnboxedSum altIdx arity inner' | inner' <- shrinkExpr inner]+      EParen inner -> inner : [EParen inner' | inner' <- shrinkExpr inner]+      ETHExpQuote body -> body : [ETHExpQuote body' | body' <- shrinkExpr body]+      ETHTypedQuote body -> body : [ETHTypedQuote body' | body' <- shrinkExpr body]+      ETHDeclQuote decls ->+        [ETHDeclQuote decls' | decls' <- shrinkDecls decls, not (null decls')]+      ETHTypeQuote ty -> [ETHTypeQuote ty' | ty' <- shrinkType ty]+      ETHPatQuote pat -> [ETHPatQuote pat' | pat' <- shrinkPattern pat]+      ETHNameQuote e -> e : [ETHNameQuote e' | e' <- shrinkExpr e]+      ETHTypeNameQuote ty -> [ETHTypeNameQuote ty' | ty' <- shrinkType ty]+      ETHSplice body -> body : [ETHSplice body' | body' <- shrinkExpr body]+      ETHTypedSplice body -> body : [ETHTypedSplice body' | body' <- shrinkExpr body]+      EProc pat body ->+        [EProc pat' body | pat' <- shrinkPattern pat]+          <> [EProc pat body' | body' <- shrinkCmd body]+      EAnn _ sub -> shrinkExpr sub++shrinkCmd :: Cmd -> [Cmd]+shrinkCmd cmd =+  case peelCmdAnn cmd of+    CmdAnn _ inner -> shrinkCmd inner+    CmdArrApp lhs appTy rhs ->+      [CmdArrApp lhs' appTy rhs | lhs' <- shrinkExpr lhs]+        <> [CmdArrApp lhs appTy rhs' | rhs' <- shrinkExpr rhs]+    CmdInfix lhs op rhs ->+      [lhs, rhs]+        <> [CmdInfix lhs op' rhs | op' <- shrinkName op]+        <> [CmdInfix lhs' op rhs | lhs' <- shrinkCmd lhs]+        <> [CmdInfix lhs op rhs' | rhs' <- shrinkCmd rhs]+    CmdDo stmts -> [CmdDo stmts' | stmts' <- shrinkCmdDoStmts stmts, not (null stmts')]+    CmdIf cond yes no ->+      [yes, no]+        <> [CmdIf cond' yes no | cond' <- shrinkExpr cond]+        <> [CmdIf cond yes' no | yes' <- shrinkCmd yes]+        <> [CmdIf cond yes no' | no' <- shrinkCmd no]+    CmdCase scrut alts ->+      [CmdCase scrut' alts | scrut' <- shrinkExpr scrut]+        <> [CmdCase scrut alts' | alts' <- shrinkCmdCaseAlts alts, not (null alts')]+    CmdLet decls body ->+      body+        : [CmdLet decls' body | decls' <- shrinkDecls decls, not (null decls')]+          <> [CmdLet decls body' | body' <- shrinkCmd body]+    CmdLam pats body ->+      body+        : [CmdLam pats' body | pats' <- shrinkList shrinkPattern pats, not (null pats')]+          <> [CmdLam pats body' | body' <- shrinkCmd body]+    CmdApp cmd' expr ->+      cmd'+        : [CmdApp cmd'' expr | cmd'' <- shrinkCmd cmd']+          <> [CmdApp cmd' expr' | expr' <- shrinkExpr expr]+    CmdPar inner -> inner : [CmdPar inner' | inner' <- shrinkCmd inner]++shrinkCmdDoStmts :: [DoStmt Cmd] -> [[DoStmt Cmd]]+shrinkCmdDoStmts = shrinkList shrinkCmdDoStmt++shrinkCmdDoStmt :: DoStmt Cmd -> [DoStmt Cmd]+shrinkCmdDoStmt stmt =+  case peelDoStmtAnn stmt of+    DoBind pat cmd ->+      [DoBind pat' cmd | pat' <- shrinkPattern pat]+        <> [DoBind pat cmd' | cmd' <- shrinkCmd cmd]+    DoLetDecls decls -> [DoLetDecls decls' | decls' <- shrinkDecls decls, not (null decls')]+    DoExpr cmd -> [DoExpr cmd' | cmd' <- shrinkCmd cmd]+    DoRecStmt stmts -> [DoRecStmt stmts' | stmts' <- shrinkCmdDoStmts stmts, not (null stmts')]+    DoAnn _ _ -> []++shrinkCmdCaseAlts :: [CaseAlt Cmd] -> [[CaseAlt Cmd]]+shrinkCmdCaseAlts = shrinkList shrinkCmdCaseAlt++shrinkCmdCaseAlt :: CaseAlt Cmd -> [CaseAlt Cmd]+shrinkCmdCaseAlt alt =+  [alt {caseAltPattern = pat'} | pat' <- shrinkPattern (caseAltPattern alt)]+    <> [alt {caseAltRhs = rhs'} | rhs' <- shrinkCmdRhs (caseAltRhs alt)]++shrinkCaseAlts :: [CaseAlt Expr] -> [[CaseAlt Expr]]+shrinkCaseAlts = shrinkList shrinkCaseAlt++shrinkLambdaCaseAlts :: [LambdaCaseAlt] -> [[LambdaCaseAlt]]+shrinkLambdaCaseAlts = shrinkList shrinkLambdaCaseAlt++shrinkCaseAlt :: CaseAlt Expr -> [CaseAlt Expr]+shrinkCaseAlt alt =+  [alt {caseAltPattern = pat'} | pat' <- shrinkPattern (caseAltPattern alt)]+    <> [alt {caseAltRhs = rhs'} | rhs' <- shrinkLetRhs (caseAltRhs alt)]++shrinkLambdaCaseAlt :: LambdaCaseAlt -> [LambdaCaseAlt]+shrinkLambdaCaseAlt alt =+  [alt {lambdaCaseAltPats = pats'} | pats' <- shrinkList shrinkPattern (lambdaCaseAltPats alt), not (null pats')]+    <> [alt {lambdaCaseAltRhs = rhs'} | rhs' <- shrinkLetRhs (lambdaCaseAltRhs alt)]++shrinkGuardedRhs :: GuardedRhs Expr -> [GuardedRhs Expr]+shrinkGuardedRhs grhs =+  [grhs {guardedRhsBody = body'} | body' <- shrinkExpr (guardedRhsBody grhs)]+    <> [grhs {guardedRhsGuards = gs'} | gs' <- shrinkList shrinkGuardQualifier (guardedRhsGuards grhs), not (null gs')]++shrinkCmdGuardedRhs :: GuardedRhs Cmd -> [GuardedRhs Cmd]+shrinkCmdGuardedRhs grhs =+  [grhs {guardedRhsBody = body'} | body' <- shrinkCmd (guardedRhsBody grhs)]+    <> [grhs {guardedRhsGuards = gs'} | gs' <- shrinkList shrinkGuardQualifier (guardedRhsGuards grhs), not (null gs')]++-- | Shrink a guard qualifier.+shrinkGuardQualifier :: GuardQualifier -> [GuardQualifier]+shrinkGuardQualifier gq =+  case gq of+    GuardAnn _ inner -> inner : shrinkGuardQualifier inner+    GuardExpr expr -> [GuardExpr expr' | expr' <- shrinkExpr expr]+    GuardPat pat expr ->+      [GuardExpr expr]+        <> [GuardPat pat' expr | pat' <- shrinkPattern pat]+        <> [GuardPat pat expr' | expr' <- shrinkExpr expr]+    GuardLet decls -> [GuardLet decls' | decls' <- shrinkDecls decls, not (null decls')]++shrinkDecls :: [Decl] -> [[Decl]]+shrinkDecls = shrinkList shrinkLetDecl++shrinkLetDecl :: Decl -> [Decl]+shrinkLetDecl decl =+  case decl of+    DeclAnn _ inner -> inner : shrinkLetDecl inner+    DeclValue (PatternBind multTag pat rhs) ->+      [DeclValue (PatternBind multTag pat rhs') | rhs' <- shrinkLetRhs rhs]+        <> [DeclValue (PatternBind multTag pat' rhs) | pat' <- shrinkPattern pat]+    DeclValue (FunctionBind name matches) ->+      [ DeclValue (PatternBind NoMultiplicityTag (PVar name) (matchRhs match))+      | match <- matches+      ]+        <>+        -- Shrink multiple matches to a single match+        [DeclValue (FunctionBind name [m {matchAnns = []}]) | length matches > 1, m <- matches]+        -- Shrink individual matches+        <> [DeclValue (FunctionBind name ms') | ms' <- shrinkList shrinkLetMatch matches, not (null ms')]+        <> [DeclValue (FunctionBind name' matches) | name' <- shrinkUnqualifiedName name]+    DeclTypeSig names ty ->+      [DeclTypeSig names ty' | ty' <- shrinkType ty]+    _ -> []++-- | Shrink a match clause within let/where/TH contexts.+shrinkLetMatch :: Match -> [Match]+shrinkLetMatch match =+  [match {matchAnns = [], matchRhs = rhs'} | rhs' <- shrinkLetRhs (matchRhs match)]+    <> [match {matchAnns = [], matchPats = pats'} | pats' <- shrinkFunctionHeadPats (matchHeadForm match) (matchPats match)]++-- | Shrink an RHS within let/where/TH contexts.+shrinkLetRhs :: Rhs Expr -> [Rhs Expr]+shrinkLetRhs rhs =+  case rhs of+    UnguardedRhs _ expr mWhere ->+      [rhs' | ds <- maybe [] pure mWhere, rhs' <- whereValueRhss ds]+        <> [UnguardedRhs [] expr Nothing | isJust mWhere]+        <> [UnguardedRhs [] expr' mWhere | expr' <- shrinkExpr expr]+        <> [UnguardedRhs [] expr (Just ds') | Just ds <- [mWhere], ds' <- shrinkDecls ds, not (null ds')]+    GuardedRhss _ rhss mWhere ->+      -- Collapse to unguarded using the first guard's body+      [UnguardedRhs [] (guardedRhsBody firstRhs) Nothing | firstRhs : _ <- [rhss]]+        <> [GuardedRhss [] rhss Nothing | isJust mWhere]+        <> [GuardedRhss [] rhss' mWhere | rhss' <- shrinkList shrinkGuardedRhs rhss, not (null rhss')]+        <> [GuardedRhss [] rhss (Just ds') | Just ds <- [mWhere], ds' <- shrinkDecls ds, not (null ds')]++shrinkCmdRhs :: Rhs Cmd -> [Rhs Cmd]+shrinkCmdRhs rhs =+  case rhs of+    UnguardedRhs _ body mWhere ->+      [UnguardedRhs [] body Nothing | isJust mWhere]+        <> [UnguardedRhs [] body' mWhere | body' <- shrinkCmd body]+        <> [UnguardedRhs [] body (Just ds') | Just ds <- [mWhere], ds' <- shrinkDecls ds, not (null ds')]+    GuardedRhss _ rhss mWhere ->+      [UnguardedRhs [] (guardedRhsBody firstRhs) Nothing | firstRhs : _ <- [rhss]]+        <> [GuardedRhss [] rhss Nothing | isJust mWhere]+        <> [GuardedRhss [] rhss' mWhere | rhss' <- shrinkList shrinkCmdGuardedRhs rhss, not (null rhss')]+        <> [GuardedRhss [] rhss (Just ds') | Just ds <- [mWhere], ds' <- shrinkDecls ds, not (null ds')]++whereValueRhss :: [Decl] -> [Rhs Expr]+whereValueRhss decls =+  [ rhs+  | DeclValue valueDecl <- decls,+    rhs <- case valueDecl of+      PatternBind _ _ patternRhs -> [patternRhs]+      FunctionBind _ matches -> map matchRhs matches+  ]++shrinkDoStmts :: [DoStmt Expr] -> [[DoStmt Expr]]+shrinkDoStmts stmts =+  case stmts of+    [stmt] -> [[stmt'] | stmt' <- shrinkDoStmt stmt, isDoExprStmt stmt']+    _ -> [stmts' | stmts' <- shrinkList shrinkDoStmt stmts, doStmtsEndInExpr stmts']++doStmtsEndInExpr :: [DoStmt Expr] -> Bool+doStmtsEndInExpr stmts =+  case reverse stmts of+    stmt : _ -> isDoExprStmt stmt+    [] -> False++isDoExprStmt :: DoStmt Expr -> Bool+isDoExprStmt stmt =+  case peelDoStmtAnn stmt of+    DoExpr {} -> True+    _ -> False++shrinkDoFlavor :: DoFlavor -> [DoFlavor]+shrinkDoFlavor flavor =+  case flavor of+    DoPlain -> []+    DoMdo -> [DoPlain]+    DoQualified name ->+      DoPlain : [DoQualified name' | name' <- shrinkQualifier name]+    DoQualifiedMdo name ->+      DoMdo+        : DoQualified name+        : [DoQualifiedMdo name' | name' <- shrinkQualifier name]++shrinkDoStmt :: DoStmt Expr -> [DoStmt Expr]+shrinkDoStmt stmt =+  case peelDoStmtAnn stmt of+    DoBind pat expr ->+      [DoBind pat' expr | pat' <- shrinkPattern pat]+        <> [DoBind pat expr' | expr' <- shrinkExpr expr]+    DoLetDecls decls -> [DoLetDecls decls' | decls' <- shrinkDecls decls, not (null decls')]+    DoExpr expr -> [DoExpr expr' | expr' <- shrinkExpr expr]+    DoRecStmt stmts -> [DoRecStmt stmts' | stmts' <- shrinkDoStmts stmts, not (null stmts')]+    DoAnn _ _ -> []++shrinkCompStmts :: [CompStmt] -> [[CompStmt]]+shrinkCompStmts =+  filter compStmtsCanStart . shrinkList shrinkCompStmt++compStmtsCanStart :: [CompStmt] -> Bool+compStmtsCanStart (stmt : _) = not (isTransformCompStmt stmt)+compStmtsCanStart [] = True++isTransformCompStmt :: CompStmt -> Bool+isTransformCompStmt stmt =+  case peelCompStmtAnn stmt of+    CompThen {} -> True+    CompThenBy {} -> True+    CompGroupUsing {} -> True+    CompGroupByUsing {} -> True+    _ -> False++-- | Shrink parallel comprehension branches, ensuring each branch has at least one statement+shrinkParallelCompStmts :: [[CompStmt]] -> [[[CompStmt]]]+shrinkParallelCompStmts =+  -- Each branch must have at least one statement+  shrinkList shrinkCompStmtsNonEmpty+  where+    shrinkCompStmtsNonEmpty stmts =+      [stmts' | stmts' <- shrinkCompStmts stmts, not (null stmts'), compStmtsCanStart stmts']++shrinkCompStmt :: CompStmt -> [CompStmt]+shrinkCompStmt stmt =+  case peelCompStmtAnn stmt of+    CompGen pat expr ->+      [CompGen pat' expr | pat' <- shrinkPattern pat]+        <> [CompGen pat expr' | expr' <- shrinkExpr expr]+    CompGuard expr -> [CompGuard expr' | expr' <- shrinkExpr expr]+    CompLetDecls decls -> [CompLetDecls decls' | decls' <- shrinkDecls decls, not (null decls')]+    CompThen f -> [CompThen f' | f' <- shrinkExpr f]+    CompThenBy f e -> [CompThenBy f' e | f' <- shrinkExpr f] <> [CompThenBy f e' | e' <- shrinkExpr e]+    CompGroupUsing f -> [CompGroupUsing f' | f' <- shrinkExpr f]+    CompGroupByUsing e f -> [CompGroupByUsing e' f | e' <- shrinkExpr e] <> [CompGroupByUsing e f' | f' <- shrinkExpr f]+    CompAnn _ _ -> []++shrinkTupleMaybeElems :: (a -> [a]) -> [a] -> [[a]]+shrinkTupleMaybeElems shrinkElem elems =+  case elems of+    [] -> [] -- Unit can't shrink+    _ ->+      [elems' | elems' <- shrinkList shrinkElem elems, length elems' /= 1]++shrinkMaybeExpr :: Maybe Expr -> [Maybe Expr]+shrinkMaybeExpr mExpr =+  case mExpr of+    Nothing -> []+    Just expr -> Nothing : [Just expr' | expr' <- shrinkExpr expr]++shrinkArithSeq :: ArithSeq -> [ArithSeq]+shrinkArithSeq seq' =+  case peelArithSeqAnn seq' of+    ArithSeqFrom from ->+      [ArithSeqFrom from' | from' <- shrinkExpr from]+    ArithSeqFromThen from thenE ->+      ArithSeqFrom from+        : [ArithSeqFromThen from' thenE | from' <- shrinkExpr from]+          <> [ArithSeqFromThen from thenE' | thenE' <- shrinkExpr thenE]+    ArithSeqFromTo from to ->+      ArithSeqFrom from+        : [ArithSeqFromTo from' to | from' <- shrinkExpr from]+          <> [ArithSeqFromTo from to' | to' <- shrinkExpr to]+    ArithSeqFromThenTo from thenE to ->+      ArithSeqFromTo from to+        : [ArithSeqFromThenTo from' thenE to | from' <- shrinkExpr from]+          <> [ArithSeqFromThenTo from thenE' to | thenE' <- shrinkExpr thenE]+          <> [ArithSeqFromThenTo from thenE to' | to' <- shrinkExpr to]+    ArithSeqAnn _ _ -> []++shrinkRecordFields :: [RecordField Expr] -> [[RecordField Expr]]+shrinkRecordFields = shrinkList shrinkRecordField++shrinkRecordField :: RecordField Expr -> [RecordField Expr]+shrinkRecordField field =+  [field {recordFieldName = name'} | name' <- shrinkName (recordFieldName field)]+    <> [field {recordFieldValue = expr'} | expr' <- shrinkExpr (recordFieldValue field)]++instance Arbitrary Expr where+  arbitrary = resize 5 genExpr+  shrink = shrinkExpr++simpleVarExpr :: Expr+simpleVarExpr = EVar simpleVarName++simpleVarName :: Name+simpleVarName = qualifyName Nothing (mkUnqualifiedName NameVarId "a")++genRightSectionOpName :: Gen Name+genRightSectionOpName =+  genVarName `suchThat` isValidRightSectionOpName++isValidRightSectionOpName :: Name -> Bool+isValidRightSectionOpName name =+  not $+    isNothing (nameQualifier name)+      && nameType name == NameVarSym+      && nameText name == "-"++isSimpleVarExpr :: Expr -> Bool+isSimpleVarExpr expr =+  case expr of+    EVar name -> name == simpleVarName+    _ -> False++simpleUnitExpr :: Expr+simpleUnitExpr = EList []++simpleLetDecl :: Decl+simpleLetDecl =+  DeclValue+    ( PatternBind+        NoMultiplicityTag+        (PVar (mkUnqualifiedName NameVarId "a"))+        (UnguardedRhs [] simpleUnitExpr Nothing)+    )++isSimpleLetTarget :: [Decl] -> Expr -> Bool+isSimpleLetTarget decls body =+  body == simpleUnitExpr+    && case decls of+      [DeclValue (PatternBind NoMultiplicityTag pat (UnguardedRhs [] expr Nothing))] ->+        expr == simpleUnitExpr && isSimpleLetPattern pat+      _ -> False++isSimpleLetPattern :: Pattern -> Bool+isSimpleLetPattern pat =+  case pat of+    PVar name -> unqualifiedNameType name == NameVarId && unqualifiedNameText name == "a"+    PWildcard -> True+    _ -> False
+ test/Test/Properties/Arb/Expr.hs-boot view
@@ -0,0 +1,15 @@+{-# LANGUAGE Haskell2010 #-}++-- | Boot file for Test.Properties.Arb.Expr+-- This breaks the circular dependency between Expr.hs and Pattern.hs.+-- Pattern.hs needs genExpr/shrinkExpr for view patterns and splices,+-- while Expr.hs needs genPattern from Pattern.hs.+module Test.Properties.Arb.Expr where++import Aihc.Parser.Syntax (Expr, GuardQualifier, Rhs)+import Test.QuickCheck (Gen)++genExpr :: Gen Expr+genRhs :: Gen (Rhs Expr)+shrinkExpr :: Expr -> [Expr]+shrinkGuardQualifier :: GuardQualifier -> [GuardQualifier]
+ test/Test/Properties/Arb/Identifiers.hs view
@@ -0,0 +1,521 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Shared generators and helpers used by Expr.hs, Pattern.hs, Type.hs, and Decl.hs.+-- This module breaks import cycles because it doesn't depend on any of those modules.+module Test.Properties.Arb.Identifiers+  ( -- * Variable identifiers+    genVarId,+    genVarIdNoHash,+    genVarUnqualifiedName,+    genVarUnqualifiedNameNoHash,+    genVarName,+    shrinkIdent,+    isValidGeneratedIdent,+    genVarSym,+    isValidGeneratedVarSym,+    shrinkVarSym,++    -- * Constructor identifiers+    genConId,+    genConUnqualifiedName,+    genConName,+    shrinkConIdent,+    isValidConIdent,++    -- * Constructor operator symbols+    genConSym,+    isValidGeneratedConSym,+    shrinkConSym,++    -- * Name shrinkers+    shrinkName,+    shrinkUnqualifiedName,++    -- * Module qualifiers+    genOptionalQualifier,+    genModuleQualifier,+    genModuleSegment,+    shrinkQualifier,++    -- * Field names+    genFieldName,++    -- * Quasi-quotation helpers+    genQuoterName,+    isValidQuoterName,+    genQuasiBody,++    -- * Character and string generators+    genCharValue,+    genStringValue,++    -- * Numeric helpers+    genTenths,+    showHex,+    shrinkFloat,+  )+where++import Aihc.Parser.Syntax (Name (..), NameType (..), UnqualifiedName (..), allKnownExtensions, mkUnqualifiedName, qualifyName)+import Aihc.Parser.Token (LexToken (..), LexTokenKind (..), lexTokensWithExtensions)+import Data.Char (GeneralCategory (..), generalCategory)+import Data.Maybe (isJust)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Test.QuickCheck (Gen, chooseInt, chooseInteger, elements, oneof, shrink, shrinkIntegral, shrinkList, vectorOf)++allChars :: [Char]+allChars = [minBound .. maxBound]++varIdentStartChars :: [Char]+varIdentStartChars = filter isValidGeneratedIdentStartChar allChars++conIdentStartChars :: [Char]+conIdentStartChars = filter isValidConIdentStartChar allChars++varIdentTailChars :: [Char]+varIdentTailChars = filter isValidGeneratedIdentTailChar allChars++conIdentTailChars :: [Char]+conIdentTailChars = filter isValidConIdentTailChar allChars++symbolChars :: [Char]+symbolChars = filter isValidSymbolChar allChars++-- Symbols starting with ':' are constructors, symbols starting with '|' collide+-- with guard/alternative syntax in expression positions.+varSymStartChars :: [Char]+varSymStartChars = filter (\c -> c /= ':' && c /= '|') symbolChars++reservedOperators :: Set.Set Text+reservedOperators =+  Set.fromList+    [ "..",+      ":",+      "::",+      "=",+      "\\",+      "|",+      "<-",+      "->",+      "~",+      "=>",+      "-<",+      ">-",+      "-<<",+      ">>-",+      "→",+      "←",+      "⇒",+      "∷",+      "∀",+      "⤙",+      "⤚",+      "⤛",+      "⤜",+      "⦇",+      "⦈",+      "⟦",+      "⟧",+      "⊸",+      "★"+    ]++-------------------------------------------------------------------------------+-- Variable identifiers+-------------------------------------------------------------------------------++genVarId :: Gen Text+genVarId = do+  first <- elements varIdentStartChars+  restLen <- chooseInt (0, 8)+  rest <- vectorOf restLen (elements varIdentTailChars)+  hashCount <- chooseInt (0, 4)+  let candidate = T.pack (first : rest) <> T.replicate hashCount "#"+  if isValidGeneratedIdent candidate+    then pure candidate+    else genVarId++genVarIdNoHash :: Gen Text+genVarIdNoHash = do+  first <- elements varIdentStartChars+  restLen <- chooseInt (0, 8)+  rest <- vectorOf restLen (elements varIdentTailChars)+  let candidate = T.pack (first : rest)+  if isValidGeneratedIdent candidate+    then pure candidate+    else genVarIdNoHash++genVarUnqualifiedName :: Gen UnqualifiedName+genVarUnqualifiedName = oneof [mkUnqualifiedName NameVarId <$> genVarId, mkUnqualifiedName NameVarSym <$> genVarSym]++-- For silly reasons, as-patterns don't support magic hashes in var-ids, but it's fine in var-syms.+genVarUnqualifiedNameNoHash :: Gen UnqualifiedName+genVarUnqualifiedNameNoHash = oneof [mkUnqualifiedName NameVarId <$> genVarIdNoHash, mkUnqualifiedName NameVarSym <$> genVarSym]++genVarName :: Gen Name+genVarName = do+  qual <- genOptionalQualifier+  qualifyName qual <$> genVarUnqualifiedName++shrinkIdent :: Text -> [Text]+shrinkIdent "a" = []+shrinkIdent ident = "a" : shrinkWithPreservedFirstChar isValidGeneratedIdent ident++isValidGeneratedIdent :: Text -> Bool+isValidGeneratedIdent ident =+  case unsnocMagicHash ident of+    Just (baseIdent, _magicHashes) ->+      case T.uncons baseIdent of+        Just (first, rest) ->+          baseIdent /= "_"+            && isValidGeneratedIdentStartChar first+            && T.all isValidGeneratedIdentTailChar rest+            && lexesAsVariableIdentifier ident+        Nothing -> False+    Nothing -> False++lexesAsVariableIdentifier :: Text -> Bool+lexesAsVariableIdentifier ident =+  case lexTokensWithExtensions allKnownExtensions ident of+    [LexToken {lexTokenKind = TkVarId tokIdent}, LexToken {lexTokenKind = TkEOF}] -> tokIdent == ident+    _ -> False++unsnocMagicHash :: Text -> Maybe (Text, Text)+unsnocMagicHash ident =+  let magicHashes = T.takeWhileEnd (== '#') ident+      baseIdent = T.dropEnd (T.length magicHashes) ident+   in if T.null ident || T.null baseIdent then Nothing else Just (baseIdent, magicHashes)++-------------------------------------------------------------------------------+-- Constructor identifiers (uppercase-starting names)+-------------------------------------------------------------------------------++-- | Generate a constructor/type constructor name starting with uppercase.+-- Produces names like @Foo@, @A1@, @T'x@, etc.+genConId :: Gen Text+genConId = do+  first <- elements conIdentStartChars+  restLen <- chooseInt (0, 5)+  rest <- vectorOf restLen (elements conIdentTailChars)+  hashCount <- chooseInt (0, 4)+  pure (T.pack (first : rest) <> T.replicate hashCount "#")++genConUnqualifiedName :: Gen UnqualifiedName+genConUnqualifiedName = oneof [mkUnqualifiedName NameConId <$> genConId, mkUnqualifiedName NameConSym <$> genConSym]++genConName :: Gen Name+genConName = do+  qual <- genOptionalQualifier+  qualifyName qual <$> genConUnqualifiedName++shrinkConIdent :: Text -> [Text]+shrinkConIdent ident =+  filter (\candidate -> candidate /= ident && isValidConIdent candidate) $+    ["C"]+      <> [asciiConIdent ident | T.any (> '\x7f') ident]+      <> shrinkWithPreservedFirstChar isValidConIdent ident+  where+    asciiConIdent name =+      case T.uncons name of+        Just (_, rest) -> "A" <> T.map replaceTailUnicode rest+        Nothing -> "A"+    replaceTailUnicode c = if c > '\x7f' then 'a' else c++isValidConIdent :: Text -> Bool+isValidConIdent ident =+  case unsnocMagicHash ident of+    Just (baseIdent, _magicHashes) ->+      case T.uncons baseIdent of+        Just (first, rest) ->+          isValidConIdentStartChar first+            && T.all isValidConIdentTailChar rest+        Nothing -> False+    Nothing -> False++-------------------------------------------------------------------------------+-- Constructor operator symbols+-------------------------------------------------------------------------------++-- | Generate a constructor operator symbol (starting with @:@).+-- Examples: @:+@, @:*@, @:==@, @:+:@+-- Rejects @:@ (built-in list cons) and @::@ (type signature operator).+genConSym :: Gen Text+genConSym = do+  restLen <- chooseInt (1, 3)+  rest <- vectorOf restLen (elements symbolChars)+  let op = T.pack (':' : rest)+  if isValidGeneratedConSym op then pure op else genConSym++isValidGeneratedConSym :: Text -> Bool+isValidGeneratedConSym op =+  case T.uncons op of+    Just (':', rest) -> not (T.null rest) && T.all isValidSymbolChar rest && op `Set.notMember` reservedOperators+    _ -> False++genVarSym :: Gen Text+genVarSym = do+  first <- elements varSymStartChars+  restLen <- chooseInt (0, 3)+  rest <- vectorOf restLen (elements symbolChars)+  let op = T.pack (first : rest)+  if isValidGeneratedVarSym op then pure op else genVarSym++isValidGeneratedVarSym :: Text -> Bool+isValidGeneratedVarSym op =+  case T.uncons op of+    Just (first, rest) ->+      first /= ':'+        && first /= '|'+        && isValidSymbolChar first+        && T.all (/= '`') op+        && T.all isValidSymbolChar rest+        && op `Set.notMember` reservedOperators+        && not (isDashRun op)+        && not (isOverloadedLabelPrefix op)+    Nothing -> False++-- | '#' followed by an identifier-start char is an overloaded label, not a symbol.+isOverloadedLabelPrefix :: Text -> Bool+isOverloadedLabelPrefix op =+  case T.uncons op of+    Just ('#', rest) -> case T.uncons rest of+      Just (c, _) -> isValidGeneratedIdentStartChar c || isValidConIdentStartChar c+      Nothing -> False+    _ -> False++-------------------------------------------------------------------------------+-- Module qualifiers+-------------------------------------------------------------------------------++-- | Generate an optional module qualifier (e.g., Nothing or Just "Data.List").+-- Biased towards Nothing to keep most names unqualified.+genOptionalQualifier :: Gen (Maybe Text)+genOptionalQualifier =+  oneof+    [ pure Nothing,+      Just <$> genModuleQualifier+    ]++-- | Generate a module qualifier like "Data.List" or "Prelude".+genModuleQualifier :: Gen Text+genModuleQualifier = do+  segCount <- chooseInt (1, 3)+  segs <- vectorOf segCount genModuleSegment+  pure (T.intercalate "." segs)++-- | Generate a single module name segment (starts with uppercase). Contrary to conids, module segments may not contain magic hashes.+genModuleSegment :: Gen Text+genModuleSegment = T.filter (/= '#') <$> genConId++-------------------------------------------------------------------------------+-- Field names+-------------------------------------------------------------------------------++-- | Generate a record field name (lowercase-starting identifier).+-- Rejects reserved identifiers and extension-reserved identifiers.+genFieldName :: Gen Text+genFieldName = do+  first <- elements (['a' .. 'z'] <> ['_'])+  restLen <- chooseInt (0, 5)+  rest <- vectorOf restLen (elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> "_'"))+  let candidate = T.pack (first : rest)+  if lexesAsVariableIdentifier candidate+    then pure candidate+    else genFieldName++-------------------------------------------------------------------------------+-- Quasi-quotation helpers+-------------------------------------------------------------------------------++-- | Generate a quasi-quoter name, excluding TH bracket names (e, d, p, t).+genQuoterName :: Gen Text+genQuoterName = do+  first <- elements (['a' .. 'z'] <> ['_'])+  restLen <- chooseInt (0, 4)+  rest <- vectorOf restLen (elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> "_'"))+  let candidate = T.pack (first : rest)+  if isValidQuoterName candidate+    then pure candidate+    else genQuoterName++isValidQuoterName :: Text -> Bool+isValidQuoterName name =+  case T.uncons name of+    Just (first, rest) ->+      (first `elem` (['a' .. 'z'] <> ['_']))+        && T.all (`elem` (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> "_'.")) rest+        -- Exclude names that clash with TH quote brackets+        && name `notElem` ["e", "t", "d", "p"]+    Nothing -> False++-- | Generate a quasi-quotation body (safe characters only).+genQuasiBody :: Gen Text+genQuasiBody = do+  len <- chooseInt (0, 10)+  chars <- vectorOf len (elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> " +-*/_()"))+  pure (T.pack chars)++-------------------------------------------------------------------------------+-- Character and string generators+-------------------------------------------------------------------------------++-- | Generate a printable character safe for use in literals.+genCharValue :: Gen Char+genCharValue = elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> " _")++-- | Generate a string value for use in string literals.+genStringValue :: Gen Text+genStringValue = do+  len <- chooseInt (0, 8)+  T.pack <$> vectorOf len genCharValue++-------------------------------------------------------------------------------+-- Numeric helpers+-------------------------------------------------------------------------------++-- | Generate a decimal value with one decimal digit of precision.+genTenths :: Gen Rational+genTenths = do+  whole <- chooseInteger (0, 99)+  frac <- chooseInteger (0, 9)+  pure (fromInteger whole + fromInteger frac / 10)++-- | Show an integer as a hexadecimal string (without prefix).+showHex :: Integer -> String+showHex value+  | value < 16 = [hexDigit value]+  | otherwise = showHex (value `div` 16) <> [hexDigit (value `mod` 16)]+  where+    hexDigit x = "0123456789abcdef" !! fromInteger x++-- | Shrink a floating-point value, maintaining one decimal digit of precision.+shrinkFloat :: Rational -> [Rational]+shrinkFloat value =+  [fromInteger shrunk / 10 | shrunk <- shrinkIntegral (round (value * 10) :: Integer), shrunk >= 0]++isValidGeneratedIdentStartChar :: Char -> Bool+isValidGeneratedIdentStartChar c = c == '_' || generalCategory c == LowercaseLetter++isValidConIdentStartChar :: Char -> Bool+isValidConIdentStartChar c = generalCategory c `elem` [UppercaseLetter, TitlecaseLetter]++isValidIdentNumberChar :: Char -> Bool+isValidIdentNumberChar c =+  case generalCategory c of+    DecimalNumber -> True+    OtherNumber -> True+    _ -> False++isValidGeneratedIdentTailChar :: Char -> Bool+isValidGeneratedIdentTailChar c = c == '\'' || isValidGeneratedIdentStartChar c || isValidConIdentStartChar c || isValidIdentContinueChar c++isValidConIdentTailChar :: Char -> Bool+isValidConIdentTailChar c = c == '\'' || isValidGeneratedIdentStartChar c || isValidConIdentStartChar c || isValidConIdentContinueChar c++isValidIdentContinueChar :: Char -> Bool+isValidIdentContinueChar c =+  case generalCategory c of+    LetterNumber -> True+    ModifierLetter -> True+    _ -> isValidIdentNumberChar c++isValidConIdentContinueChar :: Char -> Bool+isValidConIdentContinueChar c =+  case generalCategory c of+    DecimalNumber -> True+    ModifierLetter -> True+    NonSpacingMark -> True+    _ -> False++isValidSymbolChar :: Char -> Bool+isValidSymbolChar c = c `elem` (":!#$%&*+./<=>?@\\^|-~" :: String) || isValidUnicodeSymbolChar c && c /= '`'++isValidUnicodeSymbolChar :: Char -> Bool+isValidUnicodeSymbolChar c =+  case generalCategory c of+    MathSymbol -> True+    CurrencySymbol -> True+    ModifierSymbol -> True+    OtherSymbol -> True+    ConnectorPunctuation -> c > '\x7f'+    DashPunctuation -> c > '\x7f'+    OtherPunctuation -> c > '\x7f'+    _ -> False++isDashRun :: Text -> Bool+isDashRun op = T.length op >= 2 && T.all (== '-') op++shrinkWithPreservedFirstChar :: (Text -> Bool) -> Text -> [Text]+shrinkWithPreservedFirstChar isValid name =+  case T.uncons name of+    Just (first, rest) ->+      [ candidate+      | shrunkRest <- shrink (T.unpack rest),+        let candidate = T.pack (first : shrunkRest),+        isValid candidate+      ]+    Nothing -> []++-- | Shrink a variable symbol, preferring shorter and ASCII-only operators.+-- Always tries @+@ as the minimal candidate, replaces unicode chars with @+@,+-- and tries shorter prefixes.+shrinkVarSym :: Text -> [Text]+shrinkVarSym sym =+  filter (\s -> s /= sym && isValidGeneratedVarSym s) $+    ["+"]+      <> [T.map replaceUnicode sym | T.any (> '\x7f') sym]+      <> [T.take n sym | n <- [1 .. T.length sym - 1]]+  where+    replaceUnicode c = if c > '\x7f' then '+' else c++-- | Shrink a constructor symbol, preferring shorter and ASCII-only operators.+-- Always tries @:+@ as the minimal candidate, replaces unicode chars in the+-- tail with @+@, and tries shorter prefixes.+shrinkConSym :: Text -> [Text]+shrinkConSym sym =+  filter (\s -> s /= sym && isValidGeneratedConSym s) $+    [":+"]+      <> [ T.cons ':' (T.map (\c -> if c > '\x7f' then '+' else c) rest)+         | Just (':', rest) <- [T.uncons sym],+           T.any (> '\x7f') rest+         ]+      <> [T.take n sym | n <- [1 .. T.length sym - 1]]++shrinkNameText :: NameType -> Text -> [Text]+shrinkNameText nt txt = case nt of+  NameVarId -> shrinkIdent txt+  NameConId -> shrinkConIdent txt+  NameVarSym -> shrinkVarSym txt+  NameConSym -> shrinkConSym txt++-- | Shrink a module segment: try "A" as the minimal, replace unicode with+-- ASCII where possible, then try dropping tail characters.+shrinkModuleSegment :: Text -> [Text]+shrinkModuleSegment "A" = []+shrinkModuleSegment seg =+  filter (\s -> s /= seg && isValidConIdent s) $+    ["A"]+      <> [T.map (\c -> if c > '\x7f' then 'A' else c) seg | T.any (> '\x7f') seg]+      <> shrinkWithPreservedFirstChar isValidConIdent seg++-- | Shrink a module qualifier by trying fewer or shorter segments.+shrinkQualifier :: Text -> [Text]+shrinkQualifier q =+  let segs = T.splitOn "." q+   in filter (/= q) $+        ["A"]+          <> [T.intercalate "." segs' | segs' <- shrinkList shrinkModuleSegment segs, not (null segs')]++-- | Shrink a 'Name': try removing the module qualifier, shrink the qualifier+-- itself, then shrink the local name text (replacing unicode symbols with ASCII where possible).+shrinkName :: Name -> [Name]+shrinkName name =+  [name {nameQualifier = Nothing} | isJust (nameQualifier name)]+    <> [name {nameQualifier = Just q'} | Just q <- [nameQualifier name], q' <- shrinkQualifier q]+    <> [name {nameText = t} | t <- shrinkNameText (nameType name) (nameText name)]++shrinkUnqualifiedName :: UnqualifiedName -> [UnqualifiedName]+shrinkUnqualifiedName name =+  [name {unqualifiedNameText = t} | t <- shrinkNameText (unqualifiedNameType name) (unqualifiedNameText name)]
+ test/Test/Properties/Arb/Module.hs view
@@ -0,0 +1,423 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Properties.Arb.Module+  ( genModuleName,+    shrinkModuleName,+    genUnqualifiedVarName,+    genTypeName,+    shrinkTypeName,+  )+where++import Aihc.Parser.Syntax+import Data.Text (Text)+import Data.Text qualified as T+import Test.Properties.Arb.Decl ()+import Test.Properties.Arb.Identifiers (genVarId, genVarSym, shrinkName, shrinkUnqualifiedName)+import Test.QuickCheck++instance Arbitrary Module where+  arbitrary = do+    n <- chooseInt (0, 6)+    imports <- genImportDecls+    mHead <- genMaybeModuleHead+    decls <- vectorOf n arbitrary+    pure $+      Module+        { moduleAnns = [],+          moduleHead = mHead,+          moduleLanguagePragmas = [],+          moduleImports = imports,+          moduleDecls = decls+        }++  shrink modu =+    [modu {moduleHead = Nothing} | Just _ <- [moduleHead modu]]+      <> [modu {moduleImports = []} | not (null (moduleImports modu))]+      <> [modu {moduleDecls = []} | not (null (moduleDecls modu))]+      <> [ modu {moduleDecls = shrunk}+         | shrunk <- shrinkList shrink (moduleDecls modu),+           not (null shrunk)+         ]+      <> [ modu {moduleImports = shrunk}+         | shrunk <- shrinkList shrinkImportDecl (moduleImports modu)+         ]+      <> [ modu {moduleHead = shrunk}+         | shrunk <- shrinkMaybeModuleHead (moduleHead modu)+         ]++-- | Generate an optional module head.+-- Most modules have explicit headers, but implicit modules (Nothing) are also valid.+genMaybeModuleHead :: Gen (Maybe ModuleHead)+genMaybeModuleHead =+  frequency+    [ (9, Just <$> genModuleHead), -- 90% explicit module header+      (1, pure Nothing) -- 10% implicit module (no module declaration)+    ]++genModuleHead :: Gen ModuleHead+genModuleHead = do+  name <- genModuleName+  exports <- genMaybeExportSpecs+  warningText <- frequency [(4, pure Nothing), (1, Just <$> genWarningPragma)]+  pure $+    ModuleHead+      { moduleHeadAnns = [],+        moduleHeadName = name,+        moduleHeadWarningPragma = warningText,+        moduleHeadExports = exports+      }++-- | Shrink an optional module head.+shrinkMaybeModuleHead :: Maybe ModuleHead -> [Maybe ModuleHead]+shrinkMaybeModuleHead mHead =+  case mHead of+    Nothing -> []+    Just head' ->+      Nothing : [Just shrunk | shrunk <- shrinkModuleHead head']++shrinkModuleHead :: ModuleHead -> [ModuleHead]+shrinkModuleHead head' =+  [ head' {moduleHeadName = shrunk}+  | shrunk <- shrinkModuleName (moduleHeadName head')+  ]+    <> [ head' {moduleHeadExports = shrunk}+       | shrunk <- shrinkMaybeExportSpecs (moduleHeadExports head')+       ]+    <> [ head' {moduleHeadWarningPragma = shrunk}+       | Just warning <- [moduleHeadWarningPragma head'],+         shrunk <- Nothing : map Just (shrinkWarningPragma warning)+       ]++genMaybeExportSpecs :: Gen (Maybe [ExportSpec])+genMaybeExportSpecs =+  frequency+    [ (3, pure Nothing),+      (2, Just <$> genExportSpecs)+    ]++shrinkMaybeExportSpecs :: Maybe [ExportSpec] -> [Maybe [ExportSpec]]+shrinkMaybeExportSpecs mSpecs =+  case mSpecs of+    Nothing -> []+    Just specs ->+      Nothing : [Just shrunk | shrunk <- shrinkList shrink specs]++genExportSpecs :: Gen [ExportSpec]+genExportSpecs = do+  n <- chooseInt (0, 3)+  vectorOf n arbitrary++genExportVarName :: Gen Name+genExportVarName = qualifyName Nothing <$> genUnqualifiedVarName++genExportTypeName :: Gen Name+genExportTypeName = qualifyName Nothing <$> genTypeName++genWarningMessage :: Gen Text+genWarningMessage = do+  n <- chooseInt (1, 8)+  chars <- vectorOf n (elements (['a' .. 'z'] <> ['A' .. 'Z'] <> [' ']))+  pure (T.pack chars)++shrinkWarningMessage :: Text -> [Text]+shrinkWarningMessage msg =+  [T.pack candidate | candidate <- shrink (T.unpack msg), not (null candidate)]++genMaybeWarningPragma :: Gen (Maybe Pragma)+genMaybeWarningPragma = frequency [(4, pure Nothing), (1, Just <$> genWarningPragma)]++genWarningPragma :: Gen Pragma+genWarningPragma = do+  msg <- genWarningMessage+  pt <- elements [PragmaWarning msg, PragmaDeprecated msg]+  pure Pragma {pragmaType = pt, pragmaRawText = ""}++shrinkWarningPragma :: Pragma -> [Pragma]+shrinkWarningPragma p = case pragmaType p of+  PragmaWarning msg -> [p {pragmaType = PragmaWarning msg'} | msg' <- shrinkWarningMessage msg]+  PragmaDeprecated msg -> [p {pragmaType = PragmaDeprecated msg'} | msg' <- shrinkWarningMessage msg]+  _ -> []++instance Arbitrary ExportSpec where+  arbitrary =+    oneof+      [ ExportModule <$> genMaybeWarningPragma <*> genModuleName,+        ExportVar <$> genMaybeWarningPragma <*> pure Nothing <*> genExportVarName,+        ExportAbs <$> genMaybeWarningPragma <*> arbitrary <*> genExportTypeName,+        -- Namespace keywords (pattern/type/data) before T(..) are not valid GHC syntax+        ExportAll <$> genMaybeWarningPragma <*> pure Nothing <*> genExportTypeName,+        -- Namespace keywords (pattern/type/data) are not valid in ExportWith/ExportWithAll+        ExportWith <$> genMaybeWarningPragma <*> pure Nothing <*> genExportTypeName <*> genExportMembers,+        genExportWithAll+      ]++  shrink spec =+    case spec of+      ExportAnn _ sub -> sub : shrink sub+      ExportModule _ modName ->+        [ExportModule Nothing shrunk | shrunk <- shrinkModuleName modName]+      ExportVar mWarning namespace name ->+        [ExportVar Nothing namespace name | Just _ <- [mWarning]]+          <> [ExportVar mWarning namespace shrunk | shrunk <- shrinkName name]+      ExportAbs mWarning namespace name ->+        [ExportAbs Nothing namespace name | Just _ <- [mWarning]]+          <> [ExportAbs mWarning namespace shrunk | shrunk <- shrinkName name]+      ExportAll mWarning namespace name ->+        [ExportAbs mWarning namespace name]+          <> [ExportAll Nothing namespace name | Just _ <- [mWarning]]+          <> [ExportAll mWarning namespace shrunk | shrunk <- shrinkName name]+      ExportWith mWarning _namespace name members ->+        -- Always use Nothing namespace (pattern/type/data not valid in ExportWith)+        [ExportAbs mWarning Nothing name | not (null members)]+          <> [ExportWith Nothing Nothing name members | Just _ <- [mWarning]]+          <> [ExportWith mWarning Nothing shrunk members | shrunk <- shrinkName name]+          <> [ExportWith mWarning Nothing name shrunk | shrunk <- shrinkList shrink members, not (null shrunk)]+      ExportWithAll mWarning _namespace name wildcardIndex members ->+        -- Always use Nothing namespace (pattern/type/data not valid in ExportWithAll)+        [ExportWith mWarning Nothing name members]+          <> [ExportWithAll Nothing Nothing name wildcardIndex members | Just _ <- [mWarning]]+          <> [ExportWithAll mWarning Nothing shrunk wildcardIndex members | shrunk <- shrinkName name]+          <> [ExportWithAll mWarning Nothing name shrunkIndex members | shrunkIndex <- shrinkWildcardIndex wildcardIndex members]+          <> [ExportWithAll mWarning Nothing name (min wildcardIndex (length shrunk)) shrunk | shrunk <- shrinkList shrink members, not (null shrunk)]++instance Arbitrary IEEntityNamespace where+  arbitrary = elements [IEEntityNamespaceType, IEEntityNamespacePattern, IEEntityNamespaceData]++  shrink namespace =+    case namespace of+      IEEntityNamespaceType -> []+      IEEntityNamespacePattern -> [IEEntityNamespaceType]+      IEEntityNamespaceData -> [IEEntityNamespaceType]++instance Arbitrary IEBundledNamespace where+  arbitrary = elements [IEBundledNamespaceType, IEBundledNamespaceData]++  shrink namespace =+    case namespace of+      IEBundledNamespaceType -> []+      IEBundledNamespaceData -> [IEBundledNamespaceType]++instance Arbitrary ImportSpec where+  arbitrary =+    ImportSpec []+      <$> arbitrary+      <*> genImportItems++  shrink spec =+    [spec {importSpecHiding = shrunk} | shrunk <- shrink (importSpecHiding spec)]+      <> [spec {importSpecItems = shrunk} | shrunk <- shrinkList shrink (importSpecItems spec)]++instance Arbitrary ImportItem where+  arbitrary =+    oneof+      [ ImportItemVar Nothing <$> genUnqualifiedVarName,+        ImportItemAbs <$> genTypeNamespace <*> genTypeName,+        ImportItemAll <$> genTypeNamespace <*> genTypeName,+        ImportItemWith <$> genBundledNamespace <*> genTypeName <*> genImportMembers+      ]++  shrink item =+    case item of+      ImportAnn _ sub -> sub : shrink sub+      ImportItemVar namespace name ->+        [ImportItemVar namespace shrunk | shrunk <- shrinkUnqualifiedName name]+      ImportItemAbs namespace name ->+        [ImportItemAbs namespace shrunk | shrunk <- shrinkTypeName name]+      ImportItemAll namespace name ->+        [ImportItemAbs namespace name]+          <> [ImportItemAll namespace shrunk | shrunk <- shrinkTypeName name]+      ImportItemWith namespace name members ->+        [ImportItemAbs namespace name | not (null members)]+          <> [ImportItemWith namespace shrunk members | shrunk <- shrinkTypeName name]+          <> [ImportItemWith namespace name shrunk | shrunk <- shrinkList shrink members, not (null shrunk)]+      ImportItemAllWith namespace name _wildcardIndex members ->+        [ImportItemWith namespace name members]++instance Arbitrary IEBundledMember where+  arbitrary = do+    namespace <- genMemberNamespace+    name <- genMemberNameFor namespace+    pure (IEBundledMember namespace name)++  shrink (IEBundledMember namespace name) =+    [IEBundledMember shrunkNamespace name | shrunkNamespace <- shrink namespace]+      <> [IEBundledMember namespace shrunkName | shrunkName <- shrinkMemberNameFor namespace name]++genMemberName :: Gen Name+genMemberName =+  frequency+    [ (3, qualifyName Nothing <$> genUnqualifiedMemberName),+      (1, genQualifiedMemberName)+    ]++genUnqualifiedMemberName :: Gen UnqualifiedName+genUnqualifiedMemberName =+  oneof [mkUnqualifiedName NameVarId <$> genVarId, genTypeName]++genQualifiedMemberName :: Gen Name+genQualifiedMemberName = do+  modName <- genModuleName+  qualifyName (Just modName) <$> oneof [mkUnqualifiedName NameVarId <$> genVarId, genTypeName]++genMemberNameFor :: Maybe IEBundledNamespace -> Gen Name+genMemberNameFor namespace =+  case namespace of+    Nothing -> genMemberName+    Just _ -> qualifyName Nothing <$> genTypeName++genExportWithAll :: Gen ExportSpec+genExportWithAll = do+  mWarning <- genMaybeWarningPragma+  -- Namespace keywords (pattern/type/data) are not valid before T(..) in exports+  let namespace = Nothing+  name <- genExportTypeName+  members <- listOf1 arbitrary+  wildcardIndex <- chooseInt (0, length members)+  pure (ExportWithAll mWarning namespace name wildcardIndex members)++genImportMembers :: Gen [IEBundledMember]+genImportMembers =+  frequency+    [ (1, pure []),+      (4, genExportMembers)+    ]++shrinkWildcardIndex :: Int -> [a] -> [Int]+shrinkWildcardIndex wildcardIndex members =+  [shrunk | shrunk <- shrink wildcardIndex, shrunk >= 0, shrunk <= length members]++shrinkMemberNameFor :: Maybe IEBundledNamespace -> Name -> [Name]+shrinkMemberNameFor _namespace = shrinkName++instance Arbitrary ImportDecl where+  arbitrary = do+    modName <- genModuleName+    spec <- genMaybeImportSpec+    pure $+      ImportDecl+        { importDeclAnns = [],+          importDeclLevel = Nothing,+          importDeclPackage = Nothing,+          importDeclSourcePragma = Nothing,+          importDeclSafe = False,+          importDeclQualified = False,+          importDeclQualifiedPost = False,+          importDeclModule = modName,+          importDeclAs = Nothing,+          importDeclSpec = spec+        }++  shrink decl =+    [ decl {importDeclModule = shrunk}+    | shrunk <- shrinkModuleName (importDeclModule decl)+    ]+      <> [ decl {importDeclSpec = shrunk}+         | shrunk <- shrinkMaybeImportSpec (importDeclSpec decl)+         ]++genImportDecls :: Gen [ImportDecl]+genImportDecls = do+  n <- chooseInt (0, 3)+  vectorOf n arbitrary++shrinkImportDecl :: ImportDecl -> [ImportDecl]+shrinkImportDecl = shrink++genModuleName :: Gen Text+genModuleName = do+  first <- elements ['A' .. 'Z']+  restLen <- chooseInt (0, 5)+  rest <- vectorOf restLen (elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> "_'"))+  pure (T.pack (first : rest))++shrinkModuleName :: Text -> [Text]+shrinkModuleName name =+  [ candidate+  | candidate <- map T.pack (shrink (T.unpack name)),+    isValidModuleName candidate+  ]++isValidModuleName :: Text -> Bool+isValidModuleName name =+  case T.uncons name of+    Just (first, rest) ->+      (first `elem` ['A' .. 'Z'])+        && T.all (`elem` (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> "_'")) rest+    Nothing -> False++genTypeName :: Gen UnqualifiedName+genTypeName = do+  first <- elements ['A' .. 'Z']+  restLen <- chooseInt (0, 5)+  rest <- vectorOf restLen (elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> "_'"))+  pure (mkUnqualifiedName NameConId (T.pack (first : rest)))++shrinkTypeName :: UnqualifiedName -> [UnqualifiedName]+shrinkTypeName name =+  [ mkUnqualifiedName NameConId candidate+  | candidate <- map T.pack (shrink (T.unpack (renderUnqualifiedName name))),+    isValidTypeName candidate+  ]++isValidTypeName :: Text -> Bool+isValidTypeName name =+  case T.uncons name of+    Just (first, rest) ->+      (first `elem` ['A' .. 'Z'])+        && T.all (`elem` (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> "_'")) rest+    Nothing -> False++genExportMembers :: Gen [IEBundledMember]+genExportMembers = do+  n <- chooseInt (0, 3)+  vectorOf n arbitrary++genTypeNamespace :: Gen (Maybe IEEntityNamespace)+genTypeNamespace =+  frequency+    [ (3, pure Nothing),+      (1, pure (Just IEEntityNamespaceType)),+      (1, pure (Just IEEntityNamespaceData))+    ]++genBundledNamespace :: Gen (Maybe IEEntityNamespace)+genBundledNamespace =+  frequency+    [ (5, pure Nothing),+      (1, pure (Just IEEntityNamespaceData))+    ]++genMemberNamespace :: Gen (Maybe IEBundledNamespace)+genMemberNamespace =+  frequency+    [ (4, pure Nothing),+      (1, pure (Just IEBundledNamespaceData)),+      (1, pure (Just IEBundledNamespaceType))+    ]++genUnqualifiedVarName :: Gen UnqualifiedName+genUnqualifiedVarName =+  oneof+    [ mkUnqualifiedName NameVarId <$> genVarId,+      mkUnqualifiedName NameVarSym <$> genVarSym+    ]++genImportItems :: Gen [ImportItem]+genImportItems = do+  n <- chooseInt (0, 3)+  vectorOf n arbitrary++genMaybeImportSpec :: Gen (Maybe ImportSpec)+genMaybeImportSpec =+  frequency+    [ (3, pure Nothing),+      (2, Just <$> arbitrary)+    ]++shrinkMaybeImportSpec :: Maybe ImportSpec -> [Maybe ImportSpec]+shrinkMaybeImportSpec mSpec =+  case mSpec of+    Nothing -> []+    Just spec -> Nothing : [Just shrunk | shrunk <- shrink spec]
+ test/Test/Properties/Arb/Pattern.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Properties.Arb.Pattern+  ( genPattern,+    shrinkPattern,+  )+where++import Aihc.Parser.Syntax+import Data.Text (Text)+import Data.Text qualified as T+import {-# SOURCE #-} Test.Properties.Arb.Expr (genExpr, shrinkExpr)+import Test.Properties.Arb.Identifiers+  ( genCharValue,+    genConName,+    genFieldName,+    genOptionalQualifier,+    genQuasiBody,+    genQuoterName,+    genStringValue,+    genTenths,+    genVarId,+    genVarName,+    genVarUnqualifiedName,+    genVarUnqualifiedNameNoHash,+    isValidQuoterName,+    showHex,+    shrinkFloat,+    shrinkIdent,+    shrinkName,+    shrinkUnqualifiedName,+  )+import {-# SOURCE #-} Test.Properties.Arb.Type (shrinkType)+import Test.Properties.Arb.Utils (smallList0, smallList2)+import Test.QuickCheck++instance Arbitrary Pattern where+  arbitrary = genPattern+  shrink = shrinkPattern++genPattern :: Gen Pattern+genPattern = scale (`div` 2) $ do+  n <- getSize+  if n <= 0+    then oneof leafGenerators+    else oneof (leafGenerators <> recursiveGenerators)+  where+    leafGenerators =+      [ PVar <$> genVarUnqualifiedName,+        pure PWildcard,+        PLit <$> genLiteral,+        PQuasiQuote <$> genQuoterName <*> genQuasiBody,+        PNegLit <$> genNumericLiteral,+        PSplice <$> genPatSpliceBody,+        PTuple Boxed <$> elements [[], [PVar (mkUnqualifiedName NameVarId "x"), PWildcard]],+        PTuple Unboxed <$> elements [[], [PVar (mkUnqualifiedName NameVarId "x")], [PVar (mkUnqualifiedName NameVarId "x"), PWildcard]],+        pure (PList []),+        PCon <$> genConName <*> pure [] <*> pure []+      ]+    recursiveGenerators =+      [ PTuple Boxed <$> genTupleElemsWith,+        PTuple Unboxed <$> genUnboxedTupleElemsWith,+        PList <$> genListElemsWith,+        genPatternConWith,+        genPatternInfixWith,+        PParen <$> genPattern,+        genRecordPatternWith,+        genPatternTypeSigWith,+        genUnboxedSumPatternWith,+        genViewPatternWith,+        PAs <$> genVarUnqualifiedNameNoHash <*> genPattern,+        PStrict <$> genPattern,+        PIrrefutable <$> genPattern+      ]++genViewPatternWith :: Gen Pattern+genViewPatternWith =+  PView <$> genExpr <*> genPattern++genPatternConWith :: Gen Pattern+genPatternConWith = PCon <$> genConName <*> pure [] <*> smallList0 genPattern++genPatternTypeSigWith :: Gen Pattern+genPatternTypeSigWith = PTypeSig <$> genPattern <*> genPatternType++-- | Generate a simple type for use in pattern type signatures.+genPatternType :: Gen Type+genPatternType =+  oneof+    [ TVar . mkUnqualifiedName NameVarId <$> genVarId,+      (`TCon` Unpromoted) <$> genConName+    ]++genPatternInfixWith :: Gen Pattern+genPatternInfixWith = PInfix <$> genPattern <*> genConName <*> genPattern++genTupleElemsWith :: Gen [Pattern]+genTupleElemsWith = oneof [pure [], smallList2 genPattern]++-- | Generate elements for an unboxed tuple pattern (0-4 elements).+-- Unlike boxed tuples, unboxed tuples with 0 elements are valid Haskell.+genUnboxedTupleElemsWith :: Gen [Pattern]+genUnboxedTupleElemsWith = smallList0 genPattern++genUnboxedSumPatternWith :: Gen Pattern+genUnboxedSumPatternWith = do+  arity <- chooseInt (2, 4)+  altIdx <- chooseInt (0, arity - 1)+  PUnboxedSum altIdx arity <$> genPattern++genListElemsWith :: Gen [Pattern]+genListElemsWith = smallList0 genPattern++genRecordPatternWith :: Gen Pattern+genRecordPatternWith = PRecord <$> genConName <*> genRecordFieldsWith <*> pure False++genRecordFieldsWith :: Gen [RecordField Pattern]+genRecordFieldsWith = do+  n <- chooseInt (0, 3)+  names <- vectorOf n genFieldName+  pats <- vectorOf n genPattern+  quals <- vectorOf n genOptionalQualifier+  let qualifiedNames = zipWith (\q name -> qualifyName q (mkUnqualifiedName NameVarId name)) quals names+  pure [RecordField fieldName fieldPat False | (fieldName, fieldPat) <- zip qualifiedNames pats]++genLiteral :: Gen Literal+genLiteral =+  oneof+    [ mkIntLiteral <$> chooseInteger (0, 999),+      mkHexLiteral <$> chooseInteger (0, 255),+      mkFloatLiteral <$> genTenths,+      mkCharLiteral <$> genCharValue,+      mkStringLiteral <$> genStringValue+    ]++genNumericLiteral :: Gen Literal+genNumericLiteral =+  oneof+    [ mkIntLiteral <$> chooseInteger (0, 999),+      mkHexLiteral <$> chooseInteger (0, 255),+      mkFloatLiteral <$> genTenths+    ]++-- | Generate the body of a TH pattern splice: either a bare variable or a parenthesized expression.+genPatSpliceBody :: Gen Expr+genPatSpliceBody =+  oneof+    [ EVar <$> genVarName,+      EParen . EVar <$> genVarName+    ]++mkIntLiteral :: Integer -> Literal+mkIntLiteral value = LitInt value TInteger (T.pack (show value))++mkHexLiteral :: Integer -> Literal+mkHexLiteral value = LitInt value TInteger ("0x" <> T.pack (showHex value))++mkFloatLiteral :: Rational -> Literal+mkFloatLiteral value = LitFloat value TFractional (renderFloat value)++mkCharLiteral :: Char -> Literal+mkCharLiteral value = LitChar value (T.pack (show value))++mkStringLiteral :: Text -> Literal+mkStringLiteral value = LitString value (T.pack (show (T.unpack value)))++renderFloat :: Rational -> T.Text+renderFloat value = T.pack (show (fromRational value :: Double))++shrinkPattern :: Pattern -> [Pattern]+shrinkPattern pat =+  [PWildcard | pat /= PWildcard]+    <> case pat of+      PAnn _ sub -> shrinkPattern sub+      PVar name ->+        [PVar shrunk | shrunk <- shrinkUnqualifiedName name]+      PTypeBinder binder -> [PTypeBinder binder' | binder' <- shrinkTyVarBinder binder]+      PTypeSyntax form ty -> [PTypeSyntax form ty' | ty' <- shrinkType ty]+      PWildcard -> []+      PLit lit ->+        [PLit shrunk | shrunk <- shrinkLiteral lit]+      PQuasiQuote quoter body ->+        [PQuasiQuote q body | q <- shrinkQuoterName quoter]+          <> [PQuasiQuote quoter b | b <- map T.pack (shrink (T.unpack body))]+      PTuple tupleFlavor elems ->+        shrinkPatternTupleElems tupleFlavor elems+      PList elems ->+        [PList elems' | elems' <- shrinkList shrinkPattern elems]+      PCon con typeArgs args ->+        [PCon con' typeArgs args | con' <- shrinkName con]+          <> [PCon con typeArgs [] | not (null args)]+          <> [PCon con typeArgs args' | args' <- shrinkList shrinkPattern args]+      PInfix lhs op rhs ->+        [lhs, rhs]+          <> [PInfix lhs' op rhs | lhs' <- shrinkPattern lhs]+          <> [PInfix lhs op' rhs | op' <- shrinkName op]+          <> [PInfix lhs op rhs' | rhs' <- shrinkPattern rhs]+      PView expr inner ->+        [inner]+          <> [PView expr' inner | expr' <- shrinkExpr expr]+          <> [PView expr inner' | inner' <- shrinkPattern inner]+      PAs name inner ->+        [inner]+          <> [PAs name' inner | name' <- shrinkUnqualifiedName name]+          <> [PAs name inner' | inner' <- shrinkPattern inner]+      PStrict inner ->+        [inner]+          <> [PStrict inner' | inner' <- shrinkPattern inner]+      PIrrefutable inner ->+        [inner]+          <> [PIrrefutable inner' | inner' <- shrinkPattern inner]+      PNegLit lit ->+        [PLit lit]+          <> [PNegLit shrunk | shrunk <- shrinkNumericLiteral lit]+      PParen inner ->+        [inner] <> [PParen inner' | inner' <- shrinkPattern inner]+      PUnboxedSum altIdx arity inner ->+        [inner]+          <> [PUnboxedSum (max 0 (altIdx - 1)) (arity - 1) inner | arity > 2]+          <> [PUnboxedSum altIdx arity inner' | inner' <- shrinkPattern inner]+      PRecord con fields _ ->+        [PRecord con' fields False | con' <- shrinkName con]+          <> [PRecord con [] False | not (null fields)]+          <> [PRecord con fields' False | fields' <- shrinkList shrinkField fields]+      PTypeSig inner ty ->+        [inner]+          <> [PTypeSig inner' ty | inner' <- shrinkPattern inner]+          <> [PTypeSig inner ty' | ty' <- shrinkType ty]+      PSplice expr ->+        [PSplice expr' | expr' <- shrinkExpr expr]++shrinkTyVarBinder :: TyVarBinder -> [TyVarBinder]+shrinkTyVarBinder tvb =+  [tvb {tyVarBinderName = name'} | name' <- shrinkIdent (tyVarBinderName tvb)]++shrinkPatternTupleElems :: TupleFlavor -> [Pattern] -> [Pattern]+shrinkPatternTupleElems tupleFlavor elems =+  -- For a unit boxed tuple (), try a simple variable as a simpler outer pattern+  ( case (tupleFlavor, elems) of+      (Boxed, []) -> [PVar (mkUnqualifiedName NameVarId "x")]+      _ -> []+  )+    -- For a single-element unboxed tuple, try extracting the element directly+    <> ( case (tupleFlavor, elems) of+           (Unboxed, [e]) -> [e]+           _ -> []+       )+    <> [ candidate+       | shrunk <- shrinkList shrinkPattern elems,+         candidate <- case shrunk of+           [] -> [PTuple tupleFlavor []]+           [_] -> [PTuple tupleFlavor shrunk | tupleFlavor == Unboxed]+           _ -> [PTuple tupleFlavor shrunk]+       ]++shrinkField :: RecordField Pattern -> [RecordField Pattern]+shrinkField field =+  [field {recordFieldName = fieldName'} | fieldName' <- shrinkName (recordFieldName field)]+    <> [field {recordFieldValue = shrunk} | shrunk <- shrinkPattern (recordFieldValue field)]++shrinkLiteral :: Literal -> [Literal]+shrinkLiteral lit =+  case peelLiteralAnn lit of+    LitInt value _ _ -> [mkIntLiteral shrunk | shrunk <- shrinkIntegral value]+    LitFloat value _ _ -> [mkFloatLiteral shrunk | shrunk <- shrinkFloat value, shrunk >= 0]+    LitChar c _ -> [mkCharLiteral shrunk | shrunk <- shrink c]+    LitCharHash c _ -> [LitCharHash shrunk (T.pack (show shrunk) <> "#") | shrunk <- shrink c]+    LitString txt _ -> [mkStringLiteral (T.pack shrunk) | shrunk <- shrink (T.unpack txt)]+    LitStringHash txt _ -> [LitStringHash (T.pack shrunk) (T.pack (show shrunk) <> "#") | shrunk <- shrink (T.unpack txt)]+    LitAnn {} -> error "unreachable"++shrinkNumericLiteral :: Literal -> [Literal]+shrinkNumericLiteral lit =+  case lit of+    LitInt {} -> shrinkLiteral lit+    LitFloat {} -> shrinkLiteral lit+    _ -> []++shrinkQuoterName :: Text -> [Text]+shrinkQuoterName name =+  [ candidate+  | candidate <- map T.pack (shrink (T.unpack name)),+    isValidQuoterName candidate+  ]
+ test/Test/Properties/Arb/Type.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Properties.Arb.Type+  ( genType,+    shrinkType,+    shrinkTyVarBinders,+    shrinkForallTelescope,+  )+where++import Aihc.Parser.Syntax+import Data.Text (Text)+import Data.Text qualified as T+import Test.Properties.Arb.Expr (shrinkExpr)+import Test.Properties.Arb.Identifiers+  ( genCharValue,+    genConName,+    genQuasiBody,+    genQuoterName,+    genVarId,+    genVarIdNoHash,+    shrinkIdent,+    shrinkName,+  )+import Test.Properties.Arb.Utils (smallList0)+import Test.QuickCheck++instance Arbitrary Type where+  arbitrary = genType+  shrink = shrinkType++-- | Generate a random type. Uses QuickCheck's size parameter to control+-- recursion depth.+genType :: Gen Type+genType = scale (`div` 2) $ do+  n <- getSize+  if n <= 0+    then+      oneof+        [ TVar <$> genTypeVarName,+          (`TCon` Unpromoted) <$> genConName,+          (`TCon` Promoted) <$> genConName,+          TBuiltinCon <$> genTypeBuiltinCon,+          TTypeLit <$> genTypeLiteral,+          pure (TStar "*"),+          pure TWildcard,+          TQuasiQuote <$> genQuoterName <*> genQuasiBody,+          TTuple Boxed Unpromoted <$> elements [[], [TVar "a", TCon (qualifyName Nothing (mkUnqualifiedName NameConId "B")) Unpromoted]],+          TTuple Unboxed Unpromoted <$> elements [[], [TVar "a", TCon (qualifyName Nothing (mkUnqualifiedName NameConId "B")) Unpromoted]],+          TList Unpromoted <$> genTypeListElems,+          TUnboxedSum <$> genUnboxedSumElems+        ]+    else+      oneof+        [ TVar <$> genTypeVarName,+          (`TCon` Unpromoted) <$> genConName,+          (`TCon` Promoted) <$> genConName,+          TBuiltinCon <$> genTypeBuiltinCon,+          TTypeLit <$> genTypeLiteral,+          pure (TStar "*"),+          pure TWildcard,+          TQuasiQuote <$> genQuoterName <*> genQuasiBody,+          TForall <$> genForallTelescope <*> genType,+          genTypeApp,+          genTypeTypeApp,+          genTypeInfix,+          genTypeFun,+          TTuple Boxed Unpromoted <$> genTypeTupleElems,+          TTuple Boxed Promoted <$> genPromotedTupleElems,+          TTuple Unboxed Unpromoted <$> genTypeTupleElems,+          TUnboxedSum <$> genUnboxedSumElems,+          TList Unpromoted <$> genTypeListElems,+          TList Promoted <$> genPromotedListElems,+          TParen <$> genType,+          TSplice <$> genTypeSpliceBody,+          genTypeContext,+          genTypeImplicitParam,+          TKindSig <$> genKindSigSubject <*> genKindSigKind+        ]++genTypeApp :: Gen Type+genTypeApp = TApp <$> genType <*> genType++genTypeTypeApp :: Gen Type+genTypeTypeApp = TTypeApp <$> genType <*> genType++genTypeInfix :: Gen Type+genTypeInfix = do+  lhs <- genType+  rhs <- genType+  op <- genConName+  pure (TInfix lhs op Unpromoted rhs)++genTypeFun :: Gen Type+genTypeFun =+  oneof+    [ TFun ArrowUnrestricted <$> genType <*> genType,+      TFun ArrowLinear <$> genType <*> genType,+      (TFun . ArrowExplicit <$> genMultiplicityType) <*> genType <*> genType+    ]++-- | Generate a multiplicity type for explicit multiplicity annotations.+-- Keep it simple to avoid overly complex nesting.+genMultiplicityType :: Gen Type+genMultiplicityType =+  oneof+    [ TVar <$> genTypeVarName,+      (`TCon` Unpromoted) <$> genConName+    ]++-- | Generate the body of a TH type splice: either a bare variable or a parenthesized expression.+genTypeSpliceBody :: Gen Expr+genTypeSpliceBody =+  oneof+    [ EVar <$> genTypeVarExprName,+      EParen . EVar <$> genTypeVarExprName+    ]++genTypeContext :: Gen Type+genTypeContext = do+  n <- chooseInt (1, 3)+  constraints <- vectorOf n genConstraintType+  TContext constraints <$> genType++-- | Generate a constraint type (used in contexts).+-- Typically a type constructor applied to some arguments.+genConstraintType :: Gen Type+genConstraintType = do+  s <- getSize+  className <- (`TCon` Unpromoted) <$> genConName+  oneof+    [ -- Simple constraint: ClassName tyvar+      TApp className . TVar <$> genTypeVarName,+      -- Applied constraint: ClassName (Type)+      TApp className . TParen <$> resize s genType+    ]++genTypeImplicitParam :: Gen Type+genTypeImplicitParam = do+  name <- ("?" <>) <$> genVarIdNoHash+  TImplicitParam name <$> genType++genTypeTupleElems :: Gen [Type]+genTypeTupleElems = do+  isUnit <- arbitrary+  if isUnit+    then pure []+    else do+      n <- chooseInt (2, 4)+      scale (`div` n) $ vectorOf n genType++genTypeListElems :: Gen [Type]+genTypeListElems = do+  n <- chooseInt (1, 4)+  scale (`div` n) $ vectorOf n genType++genUnboxedSumElems :: Gen [Type]+genUnboxedSumElems = do+  n <- chooseInt (2, 4)+  scale (`div` n) $ vectorOf n genType++-- | Generate elements for a promoted tuple or list. Uses simple types only+-- to avoid nesting ambiguities with kind signatures and unboxed tuples+-- inside promoted containers.+genPromotedTupleElems :: Gen [Type]+genPromotedTupleElems = do+  isUnit <- arbitrary+  if isUnit+    then pure []+    else do+      n <- chooseInt (2, 3)+      vectorOf n genPromotedElem++genPromotedListElems :: Gen [Type]+genPromotedListElems = do+  n <- chooseInt (1, 3)+  vectorOf n genPromotedElem++-- | Generate a simple type suitable for use inside promoted tuples/lists.+-- Avoids character type literals since 'c' conflicts with the promotion tick.+genPromotedElem :: Gen Type+genPromotedElem =+  oneof+    [ TVar <$> genTypeVarName,+      (`TCon` Unpromoted) <$> genConName,+      genPromotedSafeTypeLiteral,+      pure (TStar "*")+    ]++-- | Generate type literals safe for use in promoted contexts (no char literals).+genPromotedSafeTypeLiteral :: Gen Type+genPromotedSafeTypeLiteral =+  TTypeLit+    <$> oneof+      [ do+          n <- chooseInteger (0, 1000)+          pure (TypeLitInteger n (T.pack (show n))),+        do+          txt <- genSymbolText+          pure (TypeLitSymbol txt (T.pack (show (T.unpack txt))))+      ]++genSimpleTypeAtom :: Gen Type+genSimpleTypeAtom =+  oneof+    [ TVar <$> genTypeVarName,+      (`TCon` Unpromoted) <$> genConName,+      TTypeLit <$> genTypeLiteral,+      pure (TStar "*"),+      pure TWildcard,+      TQuasiQuote <$> genQuoterName <*> genQuasiBody,+      TTuple Boxed Unpromoted <$> genTypeTupleElems,+      TTuple Unboxed Unpromoted <$> smallList0 genType,+      TUnboxedSum <$> genUnboxedSumElems,+      TList Unpromoted <$> genTypeListElems,+      TParen <$> genType+    ]++genKindSigSubject :: Gen Type+genKindSigSubject = genSimpleTypeAtom++genKindSigKind :: Gen Type+genKindSigKind =+  frequency+    [ (3, genSimpleTypeAtom),+      (1, TFun ArrowUnrestricted <$> genSimpleTypeAtom <*> genSimpleTypeAtom)+    ]++genForallTelescope :: Gen ForallTelescope+genForallTelescope = do+  vis <- elements [ForallInvisible, ForallVisible]+  -- Visible foralls (forall a -> T) require specified binders; inferred ({a}) are only valid in invisible foralls+  binders <- genTypeBindersFor vis+  pure (ForallTelescope vis binders)++genTypeBindersFor :: ForallVis -> Gen [TyVarBinder]+genTypeBindersFor vis = do+  n <- chooseInt (1, 3)+  vectorOf n (genTyVarBinderFor vis)++genTyVarBinderFor :: ForallVis -> Gen TyVarBinder+genTyVarBinderFor vis = do+  name <- genTypeVarName+  case vis of+    ForallVisible ->+      oneof+        [ -- Plain specified binder: a+          pure (TyVarBinder [] (renderUnqualifiedName name) Nothing TyVarBSpecified TyVarBVisible),+          -- Kinded specified binder: (a :: Kind)+          do+            kind <- resize 0 genSimpleTypeAtom+            pure (TyVarBinder [] (renderUnqualifiedName name) (Just kind) TyVarBSpecified TyVarBVisible)+        ]+    ForallInvisible ->+      oneof+        [ -- Plain specified binder: a+          pure (TyVarBinder [] (renderUnqualifiedName name) Nothing TyVarBSpecified TyVarBVisible),+          -- Plain inferred binder: {a}+          pure (TyVarBinder [] (renderUnqualifiedName name) Nothing TyVarBInferred TyVarBVisible),+          -- Kinded inferred binder: {a :: Kind}+          do+            kind <- resize 0 genSimpleTypeAtom+            pure (TyVarBinder [] (renderUnqualifiedName name) (Just kind) TyVarBInferred TyVarBVisible),+          -- Kinded specified binder: (a :: Kind)+          do+            kind <- resize 0 genSimpleTypeAtom+            pure (TyVarBinder [] (renderUnqualifiedName name) (Just kind) TyVarBSpecified TyVarBVisible)+        ]++genTypeVarName :: Gen UnqualifiedName+genTypeVarName = mkUnqualifiedName NameVarId <$> genVarId++genTypeVarExprName :: Gen Name+genTypeVarExprName = qualifyName Nothing . mkUnqualifiedName NameVarId <$> genVarId++genTypeLiteral :: Gen TypeLiteral+genTypeLiteral =+  oneof+    [ do+        n <- chooseInteger (0, 1000)+        pure (TypeLitInteger n (T.pack (show n))),+      do+        txt <- genSymbolText+        pure (TypeLitSymbol txt (T.pack (show (T.unpack txt)))),+      do+        c <- genCharValue+        pure (TypeLitChar c (T.pack (show c)))+    ]++genTypeBuiltinCon :: Gen TypeBuiltinCon+genTypeBuiltinCon =+  elements+    [ TBuiltinTuple 2,+      TBuiltinTuple 3,+      TBuiltinArrow,+      TBuiltinList,+      TBuiltinCons+    ]++genSymbolText :: Gen Text+genSymbolText = do+  len <- chooseInt (0, 8)+  chars <- vectorOf len genCharValue+  pure (T.pack chars)++shrinkType :: Type -> [Type]+shrinkType ty =+  [TWildcard | ty /= TWildcard]+    ++ case ty of+      TVar name ->+        [TVar $ unqualifiedNameFromText "a" | renderUnqualifiedName name /= "a"]+          <> [TVar (mkUnqualifiedName NameVarId shrunk) | shrunk <- shrinkIdent (renderUnqualifiedName name)]+      TCon name promoted ->+        [ TCon shrunk promoted+        | shrunk <- shrinkName name+        ]+      TBuiltinCon {} ->+        []+      TImplicitParam name inner ->+        [inner]+          <> [TImplicitParam name' inner | name' <- shrinkImplicitParamName name]+          <> [TImplicitParam name inner' | inner' <- shrinkType inner]+      TTypeLit {} ->+        []+      TStar {} ->+        []+      TQuasiQuote quoter body ->+        [TQuasiQuote q body | q <- shrinkIdent quoter]+          <> [TQuasiQuote quoter b | b <- map T.pack (shrink (T.unpack body))]+      TForall telescope inner ->+        [inner]+          <> [TForall telescope' inner | telescope' <- shrinkForallTelescope telescope]+          <> [TForall telescope inner' | inner' <- shrinkType inner]+      TApp fn arg ->+        [fn, arg]+          <> [TApp fn' arg | fn' <- shrinkType fn]+          <> [TApp fn arg' | arg' <- shrinkType arg]+      TTypeApp fn arg ->+        [fn, arg]+          <> [TTypeApp fn' arg | fn' <- shrinkType fn]+          <> [TTypeApp fn arg' | arg' <- shrinkType arg]+      TFun arrowKind lhs rhs ->+        [lhs, rhs]+          <> [TFun arrowKind lhs' rhs | lhs' <- shrinkType lhs]+          <> [TFun arrowKind lhs rhs' | rhs' <- shrinkType rhs]+      TInfix lhs op promoted rhs ->+        [lhs, rhs]+          <> [TInfix lhs' op promoted rhs | lhs' <- shrinkType lhs]+          <> [TInfix lhs op promoted rhs' | rhs' <- shrinkType rhs]+      TTuple tupleFlavor _ elems ->+        shrinkTypeTupleElems tupleFlavor elems+      TList _ elems ->+        [TList Unpromoted elems' | elems' <- shrinkList shrinkType elems, not (null elems')]+          <> elems+      TParen inner ->+        [inner]+          <> [TParen inner' | inner' <- shrinkType inner]+      TKindSig ty' kind ->+        [ty', kind]+          <> [TKindSig ty'' kind | ty'' <- shrinkType ty']+          <> [TKindSig ty' kind' | kind' <- shrinkType kind]+      TUnboxedSum elems ->+        [TUnboxedSum elems' | elems' <- shrinkList shrinkType elems, length elems' >= 2]+      TContext constraints inner ->+        [inner]+          <> [TContext constraints' inner | constraints' <- shrinkList shrinkType constraints, not (null constraints')]+          <> [TContext constraints inner' | inner' <- shrinkType inner]+      TSplice e ->+        [TSplice e' | e' <- shrinkExpr e]+      TWildcard ->+        []+      TAnn _ sub -> shrinkType sub++shrinkTyVarBinders :: [TyVarBinder] -> [[TyVarBinder]]+shrinkTyVarBinders binders =+  [ shrunk+  | shrunk <- shrinkList shrinkTyVarBinder binders,+    not (null shrunk)+  ]++shrinkTyVarBinder :: TyVarBinder -> [TyVarBinder]+shrinkTyVarBinder tvb =+  [tvb {tyVarBinderName = name'} | name' <- shrinkIdent (tyVarBinderName tvb)]+    <> [tvb {tyVarBinderKind = Just kind'} | Just kind <- [tyVarBinderKind tvb], kind' <- shrinkType kind]++shrinkForallTelescope :: ForallTelescope -> [ForallTelescope]+shrinkForallTelescope telescope =+  [ telescope {forallTelescopeBinders = binders'}+  | binders' <- shrinkTyVarBinders (forallTelescopeBinders telescope)+  ]+    <> [ telescope {forallTelescopeVisibility = ForallInvisible}+       | forallTelescopeVisibility telescope == ForallVisible+       ]++shrinkTypeTupleElems :: TupleFlavor -> [Type] -> [Type]+shrinkTypeTupleElems tupleFlavor elems =+  elems+    <> [TTuple Boxed Unpromoted elems | tupleFlavor == Unboxed, length elems /= 1]+    <> [ candidate+       | shrunk <- shrinkList shrinkType elems,+         candidate <- case shrunk of+           [] -> [TTuple tupleFlavor Unpromoted []]+           [_] | tupleFlavor == Boxed -> []+           _ -> [TTuple tupleFlavor Unpromoted shrunk]+       ]++shrinkImplicitParamName :: Text -> [Text]+shrinkImplicitParamName name =+  case T.stripPrefix "?" name of+    Nothing -> []+    Just inner -> ["?" <> candidate | candidate <- shrinkIdent inner]
+ test/Test/Properties/Arb/Type.hs-boot view
@@ -0,0 +1,11 @@+{-# LANGUAGE Haskell2010 #-}++module Test.Properties.Arb.Type where++import Aihc.Parser.Syntax (ForallTelescope, TyVarBinder, Type)+import Test.QuickCheck (Gen)++genType :: Gen Type+shrinkType :: Type -> [Type]+shrinkTyVarBinders :: [TyVarBinder] -> [[TyVarBinder]]+shrinkForallTelescope :: ForallTelescope -> [ForallTelescope]
+ test/Test/Properties/Arb/Utils.hs view
@@ -0,0 +1,76 @@+module Test.Properties.Arb.Utils+  ( optional,+    smallList0,+    smallList1,+    smallList2,+    requiredExtensions,+  )+where++import Aihc.Parser.Syntax+import Control.Monad (replicateM)+import Test.QuickCheck++-- | Optionally generate a value, or Nothing.+optional :: Gen a -> Gen (Maybe a)+optional gen = do+  n <- getSize+  if n <= 0 then pure Nothing else oneof [pure Nothing, Just <$> gen]++-- | Generate a list of 0 to 3 elements.+smallList0 :: Gen a -> Gen [a]+smallList0 gen = do+  limit <- getSize+  n <- chooseInt (0, min 3 (max 0 limit))+  replicateM n (scale (`div` n) gen)++-- | Generate a list of 1 to 3 elements.+smallList1 :: Gen a -> Gen [a]+smallList1 gen = do+  limit <- getSize+  n <- chooseInt (1, min 3 (max 1 limit))+  replicateM n (scale (`div` n) gen)++-- | Generate a list of 2 to 3 elements.+smallList2 :: Gen a -> Gen [a]+smallList2 gen = do+  limit <- getSize+  n <- chooseInt (2, min 3 (max 2 limit))+  replicateM n (scale (`div` n) gen)++requiredExtensions :: [Extension]+requiredExtensions = effectiveExtensions GHC2024Edition moduleExtensionSettings+  where+    moduleExtensionSettings :: [ExtensionSetting]+    moduleExtensionSettings =+      map+        EnableExtension+        [ Arrows,+          BlockArguments,+          CApiFFI,+          ExplicitNamespaces,+          ImplicitParams,+          InterruptibleFFI,+          JavaScriptFFI,+          LambdaCase,+          LinearTypes,+          MagicHash,+          MultiWayIf,+          OverloadedLabels,+          OverloadedRecordDot,+          ParallelListComp,+          PatternSynonyms,+          QualifiedDo,+          QuasiQuotes,+          RecursiveDo,+          RequiredTypeArguments,+          TemplateHaskell,+          TransformListComp,+          TupleSections,+          TypeAbstractions,+          TypeApplications,+          UnboxedSums,+          UnboxedTuples,+          UnicodeSyntax,+          ViewPatterns+        ]
+ test/Test/Properties/Coverage.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Properties.Coverage (assertAnyCtorCoverage, assertCtorCoverage) where++import Data.Data (Data, dataTypeConstrs, dataTypeOf, gmapQl, isAlgType, showConstr, toConstr)+import Data.Set qualified as Set+import Test.QuickCheck (Property, cover)++assertCtorCoverage :: forall a. (Data a) => [String] -> a -> (Property -> Property)+assertCtorCoverage excluded x prop =+  let allCtors = filter (`notElem` excluded) (map showConstr (dataTypeConstrs (dataTypeOf (undefined :: a))))+      coverableCtors = allCtors+      seenCtors = usedCtors x+   in foldr ($) prop [cover 1 (ctor `Set.member` seenCtors) ctor | ctor <- coverableCtors]++assertAnyCtorCoverage :: forall a. (Data a) => [String] -> [a] -> (Property -> Property)+assertAnyCtorCoverage excluded xs prop =+  let allCtors = filter (`notElem` excluded) (map showConstr (dataTypeConstrs (dataTypeOf (undefined :: a))))+      seenCtors = Set.fromList (map (showConstr . toConstr) xs)+   in foldr ($) prop [cover 1 (ctor `Set.member` seenCtors) ctor | ctor <- allCtors]++usedCtors :: (Data a) => a -> Set.Set String+usedCtors x =+  let here+        | isAlgType (dataTypeOf x) = Set.singleton (showConstr (toConstr x))+        | otherwise = Set.empty+   in here <> gmapQl (<>) Set.empty usedCtors x
+ test/Test/Properties/DeclRoundTrip.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Properties.DeclRoundTrip+  ( prop_declPrettyRoundTrip,+  )+where++import Aihc.Parser (ParseResult (..), ParserConfig (..), defaultConfig, formatParseErrors, parseDecl)+import Aihc.Parser.Parens (addDeclParens)+import Aihc.Parser.Pretty ()+import Aihc.Parser.Shorthand (Shorthand (shorthand))+import Aihc.Parser.Syntax+import Data.Text qualified as T+import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.Text (renderStrict)+import Test.Properties.Arb.Utils (requiredExtensions)+import Test.Properties.Coverage (assertCtorCoverage)+import Test.QuickCheck++declConfig :: ParserConfig+declConfig =+  defaultConfig+    { parserExtensions = requiredExtensions+    }++prop_declPrettyRoundTrip :: Decl -> Property+prop_declPrettyRoundTrip decl =+  let parenthesized = addDeclParens decl+      source = renderStrict (layoutPretty defaultLayoutOptions (pretty parenthesized))+      expected = stripAnnotations parenthesized+      addValueDeclCoverage prop =+        case decl of+          DeclValue valueDecl -> assertCtorCoverage [] valueDecl prop+          _ -> prop+   in checkCoverage $+        addValueDeclCoverage $+          assertCtorCoverage ["DeclAnn"] decl $+            counterexample (T.unpack source) $+              case parseDecl declConfig source of+                ParseErr err ->+                  counterexample (formatParseErrors (parserSourceName declConfig) (Just source) err) False+                ParseOk parsed ->+                  let actual = stripAnnotations parsed+                   in counterexample ("expected:\n" <> show (shorthand expected) <> "\nactual:\n" <> show (shorthand actual)) (expected == actual)
+ test/Test/Properties/ExprRoundTrip.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Properties.ExprRoundTrip+  ( prop_exprPrettyRoundTrip,+  )+where++import Aihc.Parser+import Aihc.Parser.Parens (addExprParens)+import Aihc.Parser.Pretty ()+import Aihc.Parser.Syntax+import Data.Text qualified as T+import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.Text (renderStrict)+import Test.Properties.Arb.Expr ()+import Test.Properties.Arb.Utils (requiredExtensions)+import Test.Properties.Coverage (assertCtorCoverage)+import Test.QuickCheck++exprConfig :: ParserConfig+exprConfig =+  defaultConfig+    { parserExtensions = requiredExtensions+    }++prop_exprPrettyRoundTrip :: Expr -> Property+prop_exprPrettyRoundTrip expr =+  let parenthesized = addExprParens expr+      source = renderStrict (layoutPretty defaultLayoutOptions (pretty parenthesized))+      expected = stripAnnotations parenthesized+   in assertCtorCoverage ["EAnn"] expr $+        counterexample (T.unpack source) $+          case parseExpr exprConfig source of+            ParseErr err ->+              counterexample (formatParseErrors (parserSourceName exprConfig) (Just source) err) False+            ParseOk parsed ->+              let actual = stripAnnotations parsed+               in counterexample ("expected: " <> show expected <> "\nactual: " <> show actual) (expected == actual)
+ test/Test/Properties/MinimalParentheses.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Properties.MinimalParentheses+  ( prop_minimalParenthesesExpr,+    prop_minimalParenthesesPattern,+    prop_minimalParenthesesType,+    prop_minimalParenthesesSignatureType,+  )+where++import Aihc.Parser (ParseResult (..), ParserConfig (..), defaultConfig, parseExpr, parsePattern, parseSignatureType, parseType)+import Aihc.Parser.Parens (addExprParens, addPatternParens, addSignatureTypeParens, addTypeParens)+import Aihc.Parser.Pretty (prettyExpr, prettyPattern, prettyType)+import Aihc.Parser.Shorthand (Shorthand (shorthand))+import Aihc.Parser.Syntax+import Data.Text qualified as T+import ParserValidation (stripParens)+import Prettyprinter (defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.Text (renderStrict)+import Test.Properties.Arb.Utils (requiredExtensions)+import Test.QuickCheck++config :: ParserConfig+config =+  defaultConfig+    { parserExtensions = requiredExtensions+    }++prop_minimalParenthesesExpr :: Expr -> Property+prop_minimalParenthesesExpr expr = do+  counterexample+    ( "Found smaller, valid expression. "+        ++ "Original:\n"+        ++ show (shorthand parenthesized)+        ++ "\n"+        ++ T.unpack (renderStrict (layoutPretty defaultLayoutOptions (prettyExpr parenthesized)))+        ++ "\nSmaller:\n"+        ++ show (shorthand noParens)+        ++ "\n"+        ++ T.unpack (renderStrict (layoutPretty defaultLayoutOptions (prettyExpr noParens)))+    )+    (isMinimal || not exprIsValid)+  where+    noParens = stripParens expr+    parenthesized = addExprParens noParens+    source = renderStrict (layoutPretty defaultLayoutOptions (prettyExpr noParens))+    isMinimal = parenthesized == noParens+    exprIsValid = case parseExpr config source of ParseOk parsed -> stripAnnotations parsed == stripAnnotations noParens; ParseErr {} -> False++prop_minimalParenthesesPattern :: Pattern -> Property+prop_minimalParenthesesPattern pat = do+  counterexample+    ( "Found smaller, valid pattern. "+        ++ "Original:\n"+        ++ show (shorthand parenthesized)+        ++ "\n"+        ++ T.unpack (renderStrict (layoutPretty defaultLayoutOptions (prettyPattern parenthesized)))+        ++ "\nSmaller:\n"+        ++ show (shorthand noParens)+        ++ "\n"+        ++ T.unpack (renderStrict (layoutPretty defaultLayoutOptions (prettyPattern noParens)))+    )+    (isMinimal || not patternIsValid)+  where+    noParens = stripParens pat+    parenthesized = addPatternParens noParens+    source = renderStrict (layoutPretty defaultLayoutOptions (prettyPattern noParens))+    isMinimal = parenthesized == noParens+    patternIsValid = case parsePattern config source of ParseOk parsed -> stripAnnotations parsed == stripAnnotations noParens; ParseErr {} -> False++prop_minimalParenthesesSignatureType :: Type -> Property+prop_minimalParenthesesSignatureType ty = do+  counterexample+    ( "Found smaller, valid signature type. "+        ++ "Original:\n"+        ++ show (shorthand parenthesized)+        ++ "\n"+        ++ T.unpack (renderStrict (layoutPretty defaultLayoutOptions (prettyType parenthesized)))+        ++ "\nSmaller:\n"+        ++ show (shorthand noParens)+        ++ "\n"+        ++ T.unpack (renderStrict (layoutPretty defaultLayoutOptions (prettyType noParens)))+    )+    (isMinimal || not typeIsValid)+  where+    noParens = stripParens ty+    parenthesized = addSignatureTypeParens noParens+    source = renderStrict (layoutPretty defaultLayoutOptions (prettyType noParens))+    isMinimal = parenthesized == noParens+    typeIsValid = case parseSignatureType config source of ParseOk parsed -> stripAnnotations parsed == stripAnnotations noParens; ParseErr {} -> False++prop_minimalParenthesesType :: Type -> Property+prop_minimalParenthesesType ty = do+  counterexample+    ( "Found smaller, valid type. "+        ++ "Original:\n"+        ++ show (shorthand parenthesized)+        ++ "\n"+        ++ T.unpack (renderStrict (layoutPretty defaultLayoutOptions (prettyType parenthesized)))+        ++ "\nSmaller:\n"+        ++ show (shorthand noParens)+        ++ "\n"+        ++ T.unpack (renderStrict (layoutPretty defaultLayoutOptions (prettyType noParens)))+    )+    (isMinimal || not typeIsValid)+  where+    noParens = stripParens ty+    parenthesized = addTypeParens noParens+    source = renderStrict (layoutPretty defaultLayoutOptions (prettyType noParens))+    isMinimal = parenthesized == noParens+    typeIsValid = case parseType config source of ParseOk parsed -> stripAnnotations parsed == stripAnnotations noParens; ParseErr {} -> False
+ test/Test/Properties/ModuleRoundTrip.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Properties.ModuleRoundTrip+  ( prop_modulePrettyRoundTrip,+    prop_moduleValidator,+  )+where++import Aihc.Parser+import Aihc.Parser.Parens (addModuleParens)+import Aihc.Parser.Shorthand (Shorthand (shorthand))+import Aihc.Parser.Syntax+import Data.Text qualified as T+import ParserValidation (validateParser)+import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.Text (renderStrict)+import Test.Properties.Arb.Module ()+import Test.Properties.Arb.Utils (requiredExtensions)+import Test.QuickCheck++prop_modulePrettyRoundTrip :: Module -> Property+prop_modulePrettyRoundTrip modu =+  let source = renderStrict (layoutPretty defaultLayoutOptions (pretty modu))+      (errs, reparsed) = parseModule moduleConfig source+      reparsedSource = renderStrict (layoutPretty defaultLayoutOptions (pretty reparsed))+   in counterexample ("Original source:\n" <> T.unpack source) $+        case errs of+          [] ->+            counterexample ("Reparsed source:\n" <> T.unpack reparsedSource) $+              let expected = stripAnnotations (addModuleParens modu)+                  actual = stripAnnotations reparsed+               in counterexample ("Original AST:\n" <> show (shorthand expected) <> "\nActual AST:\n" <> show (shorthand actual)) (expected == actual)+          _ ->+            counterexample (formatParseErrors "<quickcheck>" (Just source) errs) False++prop_moduleValidator :: Module -> Property+prop_moduleValidator modu =+  let source = renderStrict (layoutPretty defaultLayoutOptions (pretty modu))+      mbErr = validateParser "<quickcheck>" GHC2024Edition (map EnableExtension requiredExtensions) source+   in counterexample ("Original source:\n" <> T.unpack source) $+        case mbErr of+          Nothing -> property True+          Just errs ->+            counterexample (show errs) False++moduleConfig :: ParserConfig+moduleConfig =+  defaultConfig+    { parserExtensions = requiredExtensions+    }
+ test/Test/Properties/NoExceptions.hs view
@@ -0,0 +1,363 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Properties.NoExceptions+  ( prop_preprocessorArbitraryTextNoExceptions,+    prop_lexerArbitraryTextNoExceptions,+    prop_moduleParserArbitraryTokensNoExceptions,+    prop_exprParserArbitraryTokensNoExceptions,+    prop_typeParserArbitraryTokensNoExceptions,+    prop_patternParserArbitraryTokensNoExceptions,+    prop_declParserArbitraryTokensNoExceptions,+    prop_importDeclParserArbitraryTokensNoExceptions,+    prop_moduleHeaderParserArbitraryTokensNoExceptions,+    prop_genLexTokenKindConstructorCoverage,+    genLexToken,+    shrinkLexToken,+  )+where++import Aihc.Parser.Internal.FromTokens+  ( parseDeclFromTokens,+    parseExprFromTokens,+    parseImportDeclFromTokens,+    parseModuleFromTokens,+    parseModuleHeaderFromTokens,+    parsePatternFromTokens,+    parseTypeFromTokens,+  )+import Aihc.Parser.Lex+  ( LexToken (..),+    LexTokenKind (..),+    TokenOrigin (..),+    lexModuleTokens,+    lexTokens,+  )+import Aihc.Parser.Syntax (ExtensionSetting (..), FloatType (..), NumericType (..), SourceSpan (..))+import Aihc.Parser.Syntax qualified as Syntax+import Control.DeepSeq (NFData (..), force)+import Control.Exception (SomeException, evaluate, try)+import CppSupport (preprocessForParserWithoutIncludes)+import Data.Text (Text)+import Data.Text qualified as T+import Test.Properties.Coverage (assertAnyCtorCoverage)+import Test.QuickCheck++prop_preprocessorArbitraryTextNoExceptions :: Property+prop_preprocessorArbitraryTextNoExceptions =+  forAll genArbitraryText $ \source ->+    ioProperty $+      noExceptionProperty+        "preprocessForParserWithoutIncludes"+        (preprocessForParserWithoutIncludes "QuickCheck.hs" [] source)++prop_lexerArbitraryTextNoExceptions :: Property+prop_lexerArbitraryTextNoExceptions =+  forAll genArbitraryText $ \source ->+    ioProperty $ do+      lexTokensProp <- noExceptionProperty "lexTokens" (lexTokens source)+      lexModuleTokensProp <- noExceptionProperty "lexModuleTokens" (lexModuleTokens source)+      pure (lexTokensProp .&&. lexModuleTokensProp)++prop_moduleParserArbitraryTokensNoExceptions :: Property+prop_moduleParserArbitraryTokensNoExceptions =+  forAllShrink genTokenStream shrinkTokenStream $ \tokens ->+    ioProperty (noExceptionProperty "parseModuleFromTokens" (parseModuleFromTokens "<quickcheck>" tokens))++prop_exprParserArbitraryTokensNoExceptions :: Property+prop_exprParserArbitraryTokensNoExceptions =+  forAllShrink genTokenStream shrinkTokenStream $ \tokens ->+    ioProperty (noExceptionProperty "parseExprFromTokens" (parseExprFromTokens "<quickcheck>" tokens))++prop_typeParserArbitraryTokensNoExceptions :: Property+prop_typeParserArbitraryTokensNoExceptions =+  forAllShrink genTokenStream shrinkTokenStream $ \tokens ->+    ioProperty (noExceptionProperty "parseTypeFromTokens" (parseTypeFromTokens "<quickcheck>" tokens))++prop_patternParserArbitraryTokensNoExceptions :: Property+prop_patternParserArbitraryTokensNoExceptions =+  forAllShrink genTokenStream shrinkTokenStream $ \tokens ->+    ioProperty (noExceptionProperty "parsePatternFromTokens" (parsePatternFromTokens "<quickcheck>" tokens))++prop_declParserArbitraryTokensNoExceptions :: Property+prop_declParserArbitraryTokensNoExceptions =+  forAllShrink genTokenStream shrinkTokenStream $ \tokens ->+    ioProperty (noExceptionProperty "parseDeclFromTokens" (parseDeclFromTokens "<quickcheck>" tokens))++prop_importDeclParserArbitraryTokensNoExceptions :: Property+prop_importDeclParserArbitraryTokensNoExceptions =+  forAllShrink genTokenStream shrinkTokenStream $ \tokens ->+    ioProperty (noExceptionProperty "parseImportDeclFromTokens" (parseImportDeclFromTokens "<quickcheck>" tokens))++prop_moduleHeaderParserArbitraryTokensNoExceptions :: Property+prop_moduleHeaderParserArbitraryTokensNoExceptions =+  forAllShrink genTokenStream shrinkTokenStream $ \tokens ->+    ioProperty (noExceptionProperty "parseModuleHeaderFromTokens" (parseModuleHeaderFromTokens "<quickcheck>" tokens))++prop_genLexTokenKindConstructorCoverage :: Property+prop_genLexTokenKindConstructorCoverage =+  checkCoverage $+    forAll (vectorOf 512 genLexTokenKind) $ \kinds ->+      assertAnyCtorCoverage [] kinds (property True)++noExceptionProperty :: forall a. (NFData a) => String -> a -> IO Property+noExceptionProperty operation value = do+  outcome <- (try (evaluate (force value)) :: IO (Either SomeException a))+  pure $+    case outcome of+      Left err -> counterexample (operation <> " threw exception: " <> show err) False+      Right _ -> property True++genArbitraryText :: Gen Text+genArbitraryText = T.pack <$> sized (\size -> do n <- chooseInt (0, min 256 (size * 8 + 8)); vectorOf n arbitrary)++genTokenStream :: Gen [LexToken]+genTokenStream = sized $ \size -> do+  n <- chooseInt (0, min 80 (size * 4 + 4))+  vectorOf n genLexToken++shrinkTokenStream :: [LexToken] -> [[LexToken]]+shrinkTokenStream = shrinkList shrinkLexToken++genLexToken :: Gen LexToken+genLexToken = do+  kind <- genLexTokenKind+  tokenText <- genTokenText+  span' <- genSourceSpan+  tokenOrigin <- elements [FromSource, InsertedLayout]+  atLineStart <- arbitrary+  pure LexToken {lexTokenKind = kind, lexTokenText = tokenText, lexTokenSpan = span', lexTokenOrigin = tokenOrigin, lexTokenAtLineStart = atLineStart}++shrinkLexToken :: LexToken -> [LexToken]+shrinkLexToken token =+  [token {lexTokenText = shrunkText} | shrunkText <- shrinkText (lexTokenText token)]+    <> [token {lexTokenSpan = shrunkSpan} | shrunkSpan <- shrinkSourceSpan (lexTokenSpan token)]++genLexTokenKind :: Gen LexTokenKind+genLexTokenKind =+  oneof+    [ pure TkKeywordModule,+      pure TkKeywordWhere,+      pure TkKeywordDo,+      pure TkKeywordClass,+      pure TkKeywordData,+      pure TkKeywordDefault,+      pure TkKeywordDeriving,+      pure TkKeywordImport,+      pure TkKeywordCase,+      pure TkKeywordForall,+      pure TkKeywordForeign,+      pure TkKeywordOf,+      pure TkKeywordLet,+      pure TkKeywordIn,+      pure TkKeywordIf,+      pure TkKeywordThen,+      pure TkKeywordElse,+      pure TkKeywordInfix,+      pure TkKeywordInfixl,+      pure TkKeywordInfixr,+      pure TkKeywordInstance,+      pure TkKeywordNewtype,+      pure TkKeywordType,+      pure TkKeywordUnderscore,+      pure TkKeywordProc,+      pure TkKeywordRec,+      pure TkKeywordMdo,+      pure TkKeywordPattern,+      pure TkKeywordBy,+      pure TkKeywordUsing,+      TkQualifiedDo <$> genModuleText,+      TkQualifiedMdo <$> genModuleText,+      pure TkReservedDotDot,+      pure TkReservedColon,+      pure TkReservedDoubleColon,+      pure TkReservedEquals,+      pure TkReservedBackslash,+      pure TkReservedPipe,+      pure TkReservedLeftArrow,+      pure TkReservedRightArrow,+      pure TkReservedAt,+      pure TkReservedDoubleArrow,+      pure TkPrefixPercent,+      pure TkLinearArrow,+      pure TkArrowTail,+      pure TkArrowTailReverse,+      pure TkDoubleArrowTail,+      pure TkDoubleArrowTailReverse,+      pure TkBananaOpen,+      pure TkBananaClose,+      TkPragma . (\pt -> Syntax.Pragma {Syntax.pragmaType = pt, Syntax.pragmaRawText = ""}) . Syntax.PragmaLanguage <$> genExtensionSettings,+      TkPragma . (\pt -> Syntax.Pragma {Syntax.pragmaType = pt, Syntax.pragmaRawText = ""}) . Syntax.PragmaInstanceOverlap <$> genInstanceOverlapPragma,+      TkPragma . (\pt -> Syntax.Pragma {Syntax.pragmaType = pt, Syntax.pragmaRawText = ""}) . Syntax.PragmaWarning <$> genTokenText,+      TkPragma . (\pt -> Syntax.Pragma {Syntax.pragmaType = pt, Syntax.pragmaRawText = ""}) . Syntax.PragmaDeprecated <$> genTokenText,+      TkPragma . (\pt -> Syntax.Pragma {Syntax.pragmaType = pt, Syntax.pragmaRawText = ""}) <$> (Syntax.PragmaInline <$> genTokenText <*> genTokenText),+      TkPragma . (\pt -> Syntax.Pragma {Syntax.pragmaType = pt, Syntax.pragmaRawText = ""}) . Syntax.PragmaUnpack <$> genPragmaUnpackKind,+      TkPragma . (\pt -> Syntax.Pragma {Syntax.pragmaType = pt, Syntax.pragmaRawText = ""}) <$> (Syntax.PragmaSource <$> genTokenText <*> genTokenText),+      TkPragma . (\pt -> Syntax.Pragma {Syntax.pragmaType = pt, Syntax.pragmaRawText = ""}) . Syntax.PragmaSCC <$> genTokenText,+      TkPragma . (\pt -> Syntax.Pragma {Syntax.pragmaType = pt, Syntax.pragmaRawText = ""}) . Syntax.PragmaUnknown <$> genTokenText,+      TkVarId <$> genIdentifierText,+      TkConId <$> genConstructorText,+      TkQVarId <$> genModuleText <*> genIdentifierText,+      TkQConId <$> genModuleText <*> genConstructorText,+      TkImplicitParam <$> genIdentifierText,+      TkVarSym <$> genOperatorText,+      TkConSym <$> genConOperatorText,+      TkQVarSym <$> genModuleText <*> genOperatorText,+      TkQConSym <$> genModuleText <*> genConOperatorText,+      TkInteger <$> arbitrary <*> genNumericType,+      TkFloat <$> arbitrary <*> genFloatType,+      TkChar <$> arbitrary,+      TkCharHash <$> arbitrary <*> genTokenText,+      TkString <$> genTokenText,+      TkStringHash <$> genTokenText <*> genTokenText,+      TkOverloadedLabel <$> genIdentifierText <*> genTokenText,+      pure TkSpecialLParen,+      pure TkSpecialRParen,+      pure TkSpecialUnboxedLParen,+      pure TkSpecialUnboxedRParen,+      pure TkSpecialComma,+      pure TkSpecialSemicolon,+      pure TkSpecialLBracket,+      pure TkSpecialRBracket,+      pure TkSpecialBacktick,+      pure TkSpecialLBrace,+      pure TkSpecialRBrace,+      pure TkMinusOperator,+      pure TkPrefixMinus,+      pure TkPrefixBang,+      pure TkPrefixTilde,+      pure TkRecordDot,+      pure TkTypeApp,+      pure TkTHExpQuoteOpen,+      pure TkTHExpQuoteClose,+      pure TkTHTypedQuoteOpen,+      pure TkTHTypedQuoteClose,+      pure TkTHDeclQuoteOpen,+      pure TkTHTypeQuoteOpen,+      pure TkTHPatQuoteOpen,+      pure TkTHQuoteTick,+      pure TkTHTypeQuoteTick,+      pure TkTHSplice,+      pure TkTHTypedSplice,+      TkQuasiQuote <$> genQuoterText <*> genTokenText,+      pure TkLineComment,+      pure TkBlockComment,+      TkError <$> genTokenText,+      pure TkEOF+    ]++genConstructorText :: Gen Text+genConstructorText =+  oneof+    [ pure "Foo",+      pure "Bar",+      pure "Just",+      pure "Nothing"+    ]++genConOperatorText :: Gen Text+genConOperatorText =+  oneof+    [ pure ":",+      pure ":+:",+      pure ":-:"+    ]++genExtensionSettings :: Gen [ExtensionSetting]+genExtensionSettings = do+  n <- chooseInt (0, 8)+  vectorOf n genExtensionSetting++genExtensionSetting :: Gen ExtensionSetting+genExtensionSetting = do+  extension <- elements Syntax.allKnownExtensions+  oneof [pure (EnableExtension extension), pure (DisableExtension extension)]++genInstanceOverlapPragma :: Gen Syntax.InstanceOverlapPragma+genInstanceOverlapPragma =+  elements [Syntax.Overlapping, Syntax.Overlappable, Syntax.Overlaps, Syntax.Incoherent]++genPragmaUnpackKind :: Gen Syntax.PragmaUnpackKind+genPragmaUnpackKind =+  elements [Syntax.UnpackPragma, Syntax.NoUnpackPragma]++genNumericType :: Gen NumericType+genNumericType =+  elements [TInteger, TIntHash, TWordHash, TInt8Hash, TInt16Hash, TInt32Hash, TInt64Hash, TWord8Hash, TWord16Hash, TWord32Hash, TWord64Hash]++genFloatType :: Gen FloatType+genFloatType =+  elements [TFractional, TFloatHash, TDoubleHash]++genTokenText :: Gen Text+genTokenText = T.pack <$> sized (\size -> do n <- chooseInt (0, min 32 (size + 4)); vectorOf n arbitrary)++shrinkText :: Text -> [Text]+shrinkText txt = map T.pack (shrink (T.unpack txt))++genIdentifierText :: Gen Text+genIdentifierText =+  oneof+    [ pure "x",+      pure "M.x",+      pure "_",+      pure "forall",+      genTokenText+    ]++genModuleText :: Gen Text+genModuleText =+  oneof+    [ pure "M",+      pure "Data.List",+      genConstructorText+    ]++genOperatorText :: Gen Text+genOperatorText =+  oneof+    [ elements ["+", "-", "*", "->", "=>", "::", "=", "|", ":", ".."],+      genTokenText+    ]++genQuoterText :: Gen Text+genQuoterText =+  oneof+    [ elements ["qq", "M.qq", "x", "_"],+      genTokenText+    ]++genSourceSpan :: Gen SourceSpan+genSourceSpan =+  oneof+    [ pure NoSourceSpan,+      do+        sourceName <- elements ["<input>", "source", "generated.h"]+        startLine <- chooseInt (1, 200)+        startCol <- chooseInt (1, 200)+        endLine <- chooseInt (startLine, startLine + 5)+        endCol <-+          if endLine == startLine+            then chooseInt (startCol, startCol + 10)+            else chooseInt (1, 200)+        startOffset <- chooseInt (0, 4000)+        endOffset <- chooseInt (startOffset, startOffset + 200)+        pure (SourceSpan sourceName startLine startCol endLine endCol startOffset endOffset)+    ]++shrinkSourceSpan :: SourceSpan -> [SourceSpan]+shrinkSourceSpan span' =+  case span' of+    NoSourceSpan -> []+    SourceSpan sourceName sl sc el ec startOffset endOffset ->+      [NoSourceSpan]+        <> [ SourceSpan sourceName sl' sc' el' ec' startOffset' endOffset'+           | (sl', sc', el', ec', startOffset', endOffset') <- shrink (sl, sc, el, ec, startOffset, endOffset),+             sl' >= 1,+             sc' >= 1,+             el' >= sl',+             ec' >= 1,+             el' > sl' || ec' >= sc',+             startOffset' >= 0,+             endOffset' >= startOffset'+           ]
+ test/Test/Properties/ParensIdempotency.hs view
@@ -0,0 +1,45 @@+module Test.Properties.ParensIdempotency+  ( prop_declParensIdempotent,+    prop_exprParensIdempotent,+    prop_moduleParensIdempotent,+    prop_patternParensIdempotent,+    prop_typeParensIdempotent,+  )+where++import Aihc.Parser.Parens+  ( addDeclParens,+    addExprParens,+    addModuleParens,+    addPatternParens,+    addTypeParens,+  )+import Aihc.Parser.Syntax+import Data.Data (Data)+import Test.Properties.Arb.Decl ()+import Test.Properties.Arb.Expr ()+import Test.Properties.Arb.Module ()+import Test.Properties.Arb.Pattern ()+import Test.Properties.Arb.Type ()+import Test.QuickCheck++prop_moduleParensIdempotent :: Module -> Property+prop_moduleParensIdempotent = parensIdempotent addModuleParens++prop_declParensIdempotent :: Decl -> Property+prop_declParensIdempotent = parensIdempotent addDeclParens++prop_exprParensIdempotent :: Expr -> Property+prop_exprParensIdempotent = parensIdempotent addExprParens++prop_patternParensIdempotent :: Pattern -> Property+prop_patternParensIdempotent = parensIdempotent addPatternParens++prop_typeParensIdempotent :: Type -> Property+prop_typeParensIdempotent = parensIdempotent addTypeParens++parensIdempotent :: (Data a, Eq a, Show a) => (a -> a) -> a -> Property+parensIdempotent addParens value =+  let onceParenthesized = stripAnnotations (addParens value)+      twice = stripAnnotations (addParens (addParens value))+   in counterexample ("once:\n" <> show onceParenthesized <> "\n\ntwice:\n" <> show twice) (twice == onceParenthesized)
+ test/Test/Properties/PatternRoundTrip.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Properties.PatternRoundTrip+  ( prop_patternPrettyRoundTrip,+  )+where++import Aihc.Parser (ParseResult (..), ParserConfig (..), defaultConfig, formatParseErrors, parsePattern)+import Aihc.Parser.Parens (addPatternParens)+import Aihc.Parser.Syntax+import Data.Text qualified as T+import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.Text (renderStrict)+import Test.Properties.Arb.Pattern ()+import Test.Properties.Arb.Utils (requiredExtensions)+import Test.Properties.Coverage (assertCtorCoverage)+import Test.QuickCheck++patternConfig :: ParserConfig+patternConfig =+  defaultConfig+    { parserExtensions = requiredExtensions+    }++prop_patternPrettyRoundTrip :: Pattern -> Property+prop_patternPrettyRoundTrip pat =+  let source = renderStrict (layoutPretty defaultLayoutOptions (pretty pat))+      expected = stripAnnotations (addPatternParens pat)+   in checkCoverage $+        assertCtorCoverage ["PAnn", "PTypeBinder", "PTypeSyntax"] pat $+          counterexample (T.unpack source) $+            case parsePattern patternConfig source of+              ParseErr err ->+                counterexample (formatParseErrors (parserSourceName patternConfig) (Just source) err) False+              ParseOk parsed ->+                let actual = stripAnnotations parsed+                 in counterexample ("expected: " <> show expected <> "\nactual: " <> show actual) (expected == actual)
+ test/Test/Properties/ShorthandSubset.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Properties.ShorthandSubset+  ( prop_shorthandDeclSubsetOfShow,+    prop_shorthandExprSubsetOfShow,+    prop_shorthandLexTokenSubsetOfShow,+    prop_shorthandModuleSubsetOfShow,+    prop_shorthandTypeSubsetOfShow,+  )+where++import Aihc.Parser.Lex (LexToken)+import Aihc.Parser.Shorthand (Shorthand (shorthand))+import Aihc.Parser.Syntax+import Data.Char (isAlphaNum, isSpace)+import Data.List (isSubsequenceOf)+import Test.Properties.Arb.Decl ()+import Test.Properties.Arb.Expr ()+import Test.Properties.Arb.Module ()+import Test.Properties.Arb.Type ()+import Test.Properties.NoExceptions (genLexToken, shrinkLexToken)+import Test.QuickCheck++prop_shorthandModuleSubsetOfShow :: Module -> Property+prop_shorthandModuleSubsetOfShow = shorthandSubsetOfShow++prop_shorthandDeclSubsetOfShow :: Decl -> Property+prop_shorthandDeclSubsetOfShow = shorthandSubsetOfShow++prop_shorthandExprSubsetOfShow :: Expr -> Property+prop_shorthandExprSubsetOfShow = shorthandSubsetOfShow++prop_shorthandTypeSubsetOfShow :: Type -> Property+prop_shorthandTypeSubsetOfShow = shorthandSubsetOfShow++prop_shorthandLexTokenSubsetOfShow :: Property+prop_shorthandLexTokenSubsetOfShow =+  forAllShrink genLexToken shrinkLexToken (shorthandSubsetOfShow :: LexToken -> Property)++shorthandSubsetOfShow :: (Shorthand a, Show a) => a -> Property+shorthandSubsetOfShow value =+  counterexample+    ( "Show:\n"+        <> shown+        <> "\n\nShorthand:\n"+        <> short+        <> "\n\nShow tokens:\n"+        <> show shownTokens+        <> "\n\nShorthand tokens:\n"+        <> show shortTokens+    )+    (shortTokens `isSubsequenceOf` shownTokens)+  where+    shown = show value+    short = show (shorthand value)+    shownTokens = normalizeTokens (tokens shown)+    shortTokens = normalizeTokens (tokens short)++normalizeTokens :: [String] -> [String]+normalizeTokens = map normalizeToken++normalizeToken :: String -> String+normalizeToken "Prefix" = "PrefixBinderHead"+normalizeToken "Infix" = "InfixBinderHead"+normalizeToken "DerivingVia" = "DerivingViaExtension"+normalizeToken "Safe" = "SafeHaskell"+normalizeToken "Unsafe" = "UnsafeHaskell"+normalizeToken tok = tok++tokens :: String -> [String]+tokens [] = []+tokens input@(c : cs)+  | isSpace c = tokens cs+  | isIdentStart c =+      let (tok, rest) = span isIdentChar input+       in tok : tokens rest+  | c == '"' || c == '\'' =+      let (tok, rest) = stringToken c input+       in tok : tokens rest+  | otherwise = tokens cs++isIdentStart :: Char -> Bool+isIdentStart c = isAlphaNum c || c == '_'++isIdentChar :: Char -> Bool+isIdentChar c = isAlphaNum c || c == '_' || c == '#'++stringToken :: Char -> String -> (String, String)+stringToken quote (_ : rest) = go False [quote] rest+  where+    go _ acc [] = (reverse acc, [])+    go True acc (c : cs) = go False (c : acc) cs+    go False acc (c : cs)+      | c == '\\' = go True (c : acc) cs+      | c == quote = (reverse (c : acc), cs)+      | otherwise = go False (c : acc) cs+stringToken _ [] = ([], [])
+ test/Test/Properties/TypeRoundTrip.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Properties.TypeRoundTrip+  ( prop_typePrettyRoundTrip,+  )+where++import Aihc.Parser+import Aihc.Parser.Parens (addTypeParens)+import Aihc.Parser.Syntax+import Data.Text qualified as T+import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.Text (renderStrict)+import Test.Properties.Arb.Utils (requiredExtensions)+import Test.Properties.Coverage (assertCtorCoverage)+import Test.QuickCheck++typeConfig :: ParserConfig+typeConfig =+  defaultConfig+    { parserExtensions = requiredExtensions+    }++prop_typePrettyRoundTrip :: Type -> Property+prop_typePrettyRoundTrip ty =+  let source = renderStrict (layoutPretty defaultLayoutOptions (pretty ty))+      expected = stripAnnotations (addTypeParens ty)+   in checkCoverage $+        withMaxShrinks 100 $+          assertCtorCoverage ["TAnn"] ty $+            counterexample (T.unpack source) $+              case parseType typeConfig source of+                ParseErr err ->+                  counterexample (formatParseErrors (parserSourceName typeConfig) (Just source) err) False+                ParseOk parsed ->+                  let actual = stripAnnotations parsed+                   in counterexample ("expected: " <> show expected <> "\nactual: " <> show actual) (expected == actual)
+ test/Test/StackageProgress/Summary.hs view
@@ -0,0 +1,149 @@+module Test.StackageProgress.Summary (stackageProgressSummaryTests) where++import Data.List (isInfixOf)+import StackageProgress.Summary+import Test.Tasty+import Test.Tasty.HUnit++stackageProgressSummaryTests :: TestTree+stackageProgressSummaryTests =+  testGroup+    "stackage progress summary"+    [ testCase "tracks counts without retaining optional output" test_countsOnly,+      testCase "preserves succeeded and failed package output" test_keptOutputs,+      testCase "limits ghc errors and falls back to package reason" test_ghcErrors,+      testCase "extracts prompt candidates from parser failures" test_promptCandidate,+      testCase "extracts prompt candidates from any parser failure" test_promptCandidateIncludesAnyFailure,+      testCase "renders prompt text and deterministic candidate selection" test_promptRendering+    ]++test_countsOnly :: Assertion+test_countsOnly = do+  let summary =+        finalizeSummary $+          addPackageResults+            (SummaryOptions False False 0)+            [ packageResult "alpha" True True True "" Nothing 0,+              packageResult "beta" False True False "parser failed" Nothing 128+            ]+            emptySummary+  assertEqual "ours count" 1 (summarySuccessOursN summary)+  assertEqual "hse count" 2 (summarySuccessHseN summary)+  assertEqual "ghc count" 1 (summarySuccessGhcN summary)+  assertEqual "succeeded packages omitted" [] (summarySucceededPackages summary)+  assertEqual "failed packages omitted" [] (summaryFailedPackages summary)+  assertEqual "ghc errors omitted" [] (summaryGhcErrors summary)++test_keptOutputs :: Assertion+test_keptOutputs = do+  let summary =+        finalizeSummary $+          addPackageResults+            (SummaryOptions True True 0)+            [ packageResult "alpha" True True True "" Nothing 0,+              packageResult "beta" False True True "parser failed" Nothing 256,+              packageResult "gamma" True False True "" Nothing 0+            ]+            emptySummary+  assertEqual "succeeded packages keep encounter order" ["alpha-1.0.0", "gamma-1.0.0"] (summarySucceededPackages summary)+  assertEqual+    "failed table keeps parser failures only"+    [FailedPackage "beta-1.0.0" 256 []]+    (summaryFailedPackages summary)++test_ghcErrors :: Assertion+test_ghcErrors = do+  let summary =+        finalizeSummary $+          addPackageResults+            (SummaryOptions False False 2)+            [ packageResult "alpha" True True False "" (Just "ghc exploded") 0,+              packageResult "beta" False True False "  parser failed early  " Nothing 64,+              packageResult "gamma" False True False "should be truncated" (Just "ignored") 32+            ]+            emptySummary+  assertEqual+    "ghc errors are limited and use fallback reason text"+    [ ("alpha-1.0.0", "ghc exploded"),+      ("beta-1.0.0", "No direct GHC diagnostic; package failed before/around GHC check: parser failed early")+    ]+    (summaryGhcErrors summary)++test_promptCandidate :: Assertion+test_promptCandidate = do+  let result =+        packageResult+          "monad-st"+          False+          True+          True+          "parse failed in /tmp/Control/Monad/ST/Class.hs: Parse failed: unexpected {'"+          Nothing+          1024+  assertEqual+    "extracts prompt candidate preserving original error text"+    ( Just+        PromptCandidate+          { promptPackageName = "monad-st",+            promptErrorMessage = "parse failed in /tmp/Control/Monad/ST/Class.hs: Parse failed: unexpected {'"+          }+    )+    (promptCandidateFromResult result)++test_promptCandidateIncludesAnyFailure :: Assertion+test_promptCandidateIncludesAnyFailure = do+  let roundtripOnly = packageResult "roundtrip-only" False True True "roundtrip mismatch in /tmp/Foo.hs" Nothing 1024+      parseSucceeded = packageResult "parse-success" True True True "parse failed in /tmp/Bar.hs" Nothing 1024+  assertEqual+    "non-parse failure text is still treated as a parser failure"+    ( Just+        PromptCandidate+          { promptPackageName = "roundtrip-only",+            promptErrorMessage = "roundtrip mismatch in /tmp/Foo.hs"+          }+    )+    (promptCandidateFromResult roundtripOnly)+  assertEqual "successful parser result should be ignored" Nothing (promptCandidateFromResult parseSucceeded)++test_promptRendering :: Assertion+test_promptRendering = do+  let candidates =+        [ PromptCandidate "a" "PARSE_ERROR: a",+          PromptCandidate "b" "PARSE_ERROR: b",+          PromptCandidate "c" "PARSE_ERROR: c"+        ]+  assertEqual "seed 0 chooses first" (Just (PromptCandidate "a" "PARSE_ERROR: a")) (selectPromptCandidate 0 candidates)+  assertEqual "seed 1 chooses second" (Just (PromptCandidate "b" "PARSE_ERROR: b")) (selectPromptCandidate 1 candidates)+  assertEqual "seed wraps by modulo" (Just (PromptCandidate "c" "PARSE_ERROR: c")) (selectPromptCandidate 5 candidates)+  let template =+        unlines+          [ "# Error messages:",+            "{{ERROR_MESSAGES}}",+            "",+            "Re-test by running: nix run .#aihc-dev -- hackage-tester {{PACKAGE_NAME}}",+            "",+            "Fix '{{PACKAGE_NAME}}'"+          ]+      rendered =+        renderPrompt+          template+          PromptCandidate+            { promptPackageName = "monad-st",+              promptErrorMessage = "parse failed in /tmp/Control/Monad/ST/Class.hs"+            }+  assertBool "prompt includes heading" ("# Error messages:" `isInfixOf` rendered)+  assertBool "prompt includes re-test command" ("nix run .#aihc-dev -- hackage-tester monad-st" `isInfixOf` rendered)+  assertBool "prompt includes package replacement" ("Fix 'monad-st'" `isInfixOf` rendered)++packageResult :: String -> Bool -> Bool -> Bool -> String -> Maybe String -> Integer -> PackageResult+packageResult name oursOk hseOk ghcOk reason ghcError size =+  PackageResult+    { package = PackageSpec name "1.0.0",+      packageOursOk = oursOk,+      packageHseOk = hseOk,+      packageGhcOk = ghcOk,+      packageReason = reason,+      packageGhcError = ghcError,+      packageSourceSize = size,+      packageFileErrors = []+    }