diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/aihc-parser.cabal b/aihc-parser.cabal new file mode 100644 --- /dev/null +++ b/aihc-parser.cabal @@ -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 diff --git a/common/CppSupport.hs b/common/CppSupport.hs new file mode 100644 --- /dev/null +++ b/common/CppSupport.hs @@ -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 diff --git a/common/ExtensionSupport.hs b/common/ExtensionSupport.hs new file mode 100644 --- /dev/null +++ b/common/ExtensionSupport.hs @@ -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 `): " + <> 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) diff --git a/common/GhcOracle.hs b/common/GhcOracle.hs new file mode 100644 --- /dev/null +++ b/common/GhcOracle.hs @@ -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) diff --git a/common/HackageSupport.hs b/common/HackageSupport.hs new file mode 100644 --- /dev/null +++ b/common/HackageSupport.hs @@ -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 diff --git a/common/HackageTester/CLI.hs b/common/HackageTester/CLI.hs new file mode 100644 --- /dev/null +++ b/common/HackageTester/CLI.hs @@ -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" diff --git a/common/HackageTester/Model.hs b/common/HackageTester/Model.hs new file mode 100644 --- /dev/null +++ b/common/HackageTester/Model.hs @@ -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" diff --git a/common/HseExtensions.hs b/common/HseExtensions.hs new file mode 100644 --- /dev/null +++ b/common/HseExtensions.hs @@ -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)] diff --git a/common/LexerGolden.hs b/common/LexerGolden.hs new file mode 100644 --- /dev/null +++ b/common/LexerGolden.hs @@ -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 diff --git a/common/ParserEquivalent.hs b/common/ParserEquivalent.hs new file mode 100644 --- /dev/null +++ b/common/ParserEquivalent.hs @@ -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 diff --git a/common/ParserErrorGolden.hs b/common/ParserErrorGolden.hs new file mode 100644 --- /dev/null +++ b/common/ParserErrorGolden.hs @@ -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) diff --git a/common/ParserGolden.hs b/common/ParserGolden.hs new file mode 100644 --- /dev/null +++ b/common/ParserGolden.hs @@ -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 diff --git a/common/ParserValidation.hs b/common/ParserValidation.hs new file mode 100644 --- /dev/null +++ b/common/ParserValidation.hs @@ -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) diff --git a/common/ShrinkUtils.hs b/common/ShrinkUtils.hs new file mode 100644 --- /dev/null +++ b/common/ShrinkUtils.hs @@ -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 == '_' diff --git a/common/StackageProgress/Summary.hs b/common/StackageProgress/Summary.hs new file mode 100644 --- /dev/null +++ b/common/StackageProgress/Summary.hs @@ -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 diff --git a/src/Aihc/Parser.hs b/src/Aihc/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser.hs @@ -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 @\"\\"@ +-- * 'parserExtensions' is empty (no extensions enabled by default) +-- +-- >>> parserSourceName defaultConfig +-- "" +-- +-- >>> parserExtensions defaultConfig +-- [] +defaultConfig :: ParserConfig +defaultConfig = + ParserConfig + { parserSourceName = "", + 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 "" "x = 1" (SourceSpan 1 5 1 6) = """ +-- :1:5: +-- 1 | x = 1 +-- | ^ +-- """ +-- renderSourceReference "" "module where" (SourceSpan 1 8 1 13) = """ +-- :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 diff --git a/src/Aihc/Parser/Internal/CheckPattern.hs b/src/Aihc/Parser/Internal/CheckPattern.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Internal/CheckPattern.hs @@ -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 diff --git a/src/Aihc/Parser/Internal/Cmd.hs b/src/Aihc/Parser/Internal/Cmd.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Internal/Cmd.hs @@ -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 diff --git a/src/Aihc/Parser/Internal/Common.hs b/src/Aihc/Parser/Internal/Common.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Internal/Common.hs @@ -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) diff --git a/src/Aihc/Parser/Internal/Decl.hs b/src/Aihc/Parser/Internal/Decl.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Internal/Decl.hs @@ -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) diff --git a/src/Aihc/Parser/Internal/Errors.hs b/src/Aihc/Parser/Internal/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Internal/Errors.hs @@ -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) <> "'" diff --git a/src/Aihc/Parser/Internal/Expr.hs b/src/Aihc/Parser/Internal/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Internal/Expr.hs @@ -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 { 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 '{' 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 diff --git a/src/Aihc/Parser/Internal/Expr.hs-boot b/src/Aihc/Parser/Internal/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Internal/Expr.hs-boot @@ -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] diff --git a/src/Aihc/Parser/Internal/FromTokens.hs b/src/Aihc/Parser/Internal/FromTokens.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Internal/FromTokens.hs @@ -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 diff --git a/src/Aihc/Parser/Internal/Import.hs b/src/Aihc/Parser/Internal/Import.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Internal/Import.hs @@ -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) diff --git a/src/Aihc/Parser/Internal/Module.hs b/src/Aihc/Parser/Internal/Module.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Internal/Module.hs @@ -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)) diff --git a/src/Aihc/Parser/Internal/Pattern.hs b/src/Aihc/Parser/Internal/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Internal/Pattern.hs @@ -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 diff --git a/src/Aihc/Parser/Internal/Type.hs b/src/Aihc/Parser/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Internal/Type.hs @@ -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 @% ->@, 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 diff --git a/src/Aihc/Parser/Lex.hs b/src/Aihc/Parser/Lex.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Lex.hs @@ -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 "" [] + +lexModuleTokens :: Text -> [LexToken] +lexModuleTokens = lexModuleTokensWithSourceNameAndExtensions "" [] + +lexTokensWithExtensions :: [Extension] -> Text -> [LexToken] +lexTokensWithExtensions = lexTokensWithSourceNameAndExtensions "" + +lexModuleTokensWithExtensions :: [Extension] -> Text -> [LexToken] +lexModuleTokensWithExtensions = lexModuleTokensWithSourceNameAndExtensions "" + +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 + +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 + _ -> "" + st' = if T.null rawTxt || rawTxt == "" 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 diff --git a/src/Aihc/Parser/Lex/Header.hs b/src/Aihc/Parser/Lex/Header.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Lex/Header.hs @@ -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 diff --git a/src/Aihc/Parser/Lex/Layout.hs b/src/Aihc/Parser/Lex/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Lex/Layout.hs @@ -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 + } diff --git a/src/Aihc/Parser/Lex/Numbers.hs b/src/Aihc/Parser/Lex/Numbers.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Lex/Numbers.hs @@ -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') diff --git a/src/Aihc/Parser/Lex/Pragmas.hs b/src/Aihc/Parser/Lex/Pragmas.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Lex/Pragmas.hs @@ -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 diff --git a/src/Aihc/Parser/Lex/Quoted.hs b/src/Aihc/Parser/Lex/Quoted.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Lex/Quoted.hs @@ -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 diff --git a/src/Aihc/Parser/Lex/Trivia.hs b/src/Aihc/Parser/Lex/Trivia.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Lex/Trivia.hs @@ -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 diff --git a/src/Aihc/Parser/Lex/Types.hs b/src/Aihc/Parser/Lex/Types.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Lex/Types.hs @@ -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 diff --git a/src/Aihc/Parser/Parens.hs b/src/Aihc/Parser/Parens.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Parens.hs @@ -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) + } diff --git a/src/Aihc/Parser/Pretty.hs b/src/Aihc/Parser/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Pretty.hs @@ -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))] diff --git a/src/Aihc/Parser/Shorthand.hs b/src/Aihc/Parser/Shorthand.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Shorthand.hs @@ -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) diff --git a/src/Aihc/Parser/Syntax.hs b/src/Aihc/Parser/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Syntax.hs @@ -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 = ""} diff --git a/src/Aihc/Parser/Token.hs b/src/Aihc/Parser/Token.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Token.hs @@ -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 @""@. +-- +-- '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 diff --git a/src/Aihc/Parser/Types.hs b/src/Aihc/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Types.hs @@ -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 "" [] "" + 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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 "" Nothing bundle) + ParseErr bundle -> + assertFailure ("expected parse success for:\n" <> T.unpack source <> "\n" <> formatParseErrors "" 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 "" Nothing bundle) + ParseErr bundle -> + assertFailure ("expected parse success for " <> T.unpack source <> "\n" <> formatParseErrors "" 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 "" Nothing bundle) + ParseErr bundle -> + assertFailure ("expected parse success for " <> T.unpack source <> "\n" <> formatParseErrors "" 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 "" 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 "" 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 "" 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 "" 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 "" 1 1 1 2 0 1 xSpan + assertSourceSpan "" 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 "" 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 "" 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 "" 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 "" 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 "" 1 1 1 2 0 1 xSpan + assertSourceSpan "" 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 "" (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 "" 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 "" 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 "" 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 "" 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 "" 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 "" 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 "" 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 "" 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 "" 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) diff --git a/test/Test/ErrorMessages/Suite.hs b/test/Test/ErrorMessages/Suite.hs new file mode 100644 --- /dev/null +++ b/test/Test/ErrorMessages/Suite.hs @@ -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" + ] diff --git a/test/Test/ExtensionMapping/Suite.hs b/test/Test/ExtensionMapping/Suite.hs new file mode 100644 --- /dev/null +++ b/test/Test/ExtensionMapping/Suite.hs @@ -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 diff --git a/test/Test/Fixtures/ViewPatterns/do-tuple-view-pattern.hs b/test/Test/Fixtures/ViewPatterns/do-tuple-view-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/ViewPatterns/do-tuple-view-pattern.hs @@ -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 diff --git a/test/Test/Fixtures/corpus/regressions/regression-001.hs b/test/Test/Fixtures/corpus/regressions/regression-001.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/corpus/regressions/regression-001.hs @@ -0,0 +1,2 @@ +module R where +apply = f (g h) diff --git a/test/Test/Fixtures/equivalent/decl/context-kindsig-rhs.yaml b/test/Test/Fixtures/equivalent/decl/context-kindsig-rhs.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/decl/context-kindsig-rhs.yaml @@ -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. diff --git a/test/Test/Fixtures/equivalent/decl/delimited-context-kindsig-rhs.yaml b/test/Test/Fixtures/equivalent/decl/delimited-context-kindsig-rhs.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/decl/delimited-context-kindsig-rhs.yaml @@ -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. diff --git a/test/Test/Fixtures/equivalent/decl/paren-rhs.yaml b/test/Test/Fixtures/equivalent/decl/paren-rhs.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/decl/paren-rhs.yaml @@ -0,0 +1,5 @@ +extensions: [] +equivalent: + - x = 10 + - x = (10) +status: pass diff --git a/test/Test/Fixtures/equivalent/expr/infix-left-assoc.yaml b/test/Test/Fixtures/equivalent/expr/infix-left-assoc.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/expr/infix-left-assoc.yaml @@ -0,0 +1,6 @@ +extensions: [] +equivalent: + - a + b + c + - (a + b) + c +status: pass +reason: parser matches GHC's left-associated parsed infix tree diff --git a/test/Test/Fixtures/equivalent/expr/multi-way-if-branch-infix.yaml b/test/Test/Fixtures/equivalent/expr/multi-way-if-branch-infix.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/expr/multi-way-if-branch-infix.yaml @@ -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. diff --git a/test/Test/Fixtures/equivalent/expr/multi-way-if-indented.yaml b/test/Test/Fixtures/equivalent/expr/multi-way-if-indented.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/expr/multi-way-if-indented.yaml @@ -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. diff --git a/test/Test/Fixtures/equivalent/expr/multi-way-if-infix.yaml b/test/Test/Fixtures/equivalent/expr/multi-way-if-infix.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/expr/multi-way-if-infix.yaml @@ -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. diff --git a/test/Test/Fixtures/equivalent/expr/multi-way-if-outside-infix.yaml b/test/Test/Fixtures/equivalent/expr/multi-way-if-outside-infix.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/expr/multi-way-if-outside-infix.yaml @@ -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. diff --git a/test/Test/Fixtures/equivalent/module/braced-decls.yaml b/test/Test/Fixtures/equivalent/module/braced-decls.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/module/braced-decls.yaml @@ -0,0 +1,8 @@ +extensions: [] +equivalent: + - | + module X where + x = 10 + - | + module X where { x = 10 } +status: pass diff --git a/test/Test/Fixtures/equivalent/module/th-name-quote-record-dot.yaml b/test/Test/Fixtures/equivalent/module/th-name-quote-record-dot.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/module/th-name-quote-record-dot.yaml @@ -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 diff --git a/test/Test/Fixtures/equivalent/module/th-type-name-quote-record-dot.yaml b/test/Test/Fixtures/equivalent/module/th-type-name-quote-record-dot.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/module/th-type-name-quote-record-dot.yaml @@ -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 diff --git a/test/Test/Fixtures/equivalent/pattern/paren-con-arg.yaml b/test/Test/Fixtures/equivalent/pattern/paren-con-arg.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/pattern/paren-con-arg.yaml @@ -0,0 +1,5 @@ +extensions: [] +equivalent: + - Just x + - Just (x) +status: pass diff --git a/test/Test/Fixtures/equivalent/pattern/view-block-app-arg.yaml b/test/Test/Fixtures/equivalent/pattern/view-block-app-arg.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/pattern/view-block-app-arg.yaml @@ -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. diff --git a/test/Test/Fixtures/equivalent/pattern/view-nonfinal-let-block-app-arg.yaml b/test/Test/Fixtures/equivalent/pattern/view-nonfinal-let-block-app-arg.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/equivalent/pattern/view-nonfinal-let-block-app-arg.yaml @@ -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. diff --git a/test/Test/Fixtures/error-messages/module/arrow-pattern.yaml b/test/Test/Fixtures/error-messages/module/arrow-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/arrow-pattern.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/case-missing-of.yaml b/test/Test/Fixtures/error-messages/module/case-missing-of.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/case-missing-of.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/cpp-bad-macro.yaml b/test/Test/Fixtures/error-messages/module/cpp-bad-macro.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/cpp-bad-macro.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/cpp-directive-missing-rhs.yaml b/test/Test/Fixtures/error-messages/module/cpp-directive-missing-rhs.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/cpp-directive-missing-rhs.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/do-bind-missing-rhs.yaml b/test/Test/Fixtures/error-messages/module/do-bind-missing-rhs.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/do-bind-missing-rhs.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/hash-line-missing-rhs.yaml b/test/Test/Fixtures/error-messages/module/hash-line-missing-rhs.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/hash-line-missing-rhs.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/if-missing-condition-keyword.yaml b/test/Test/Fixtures/error-messages/module/if-missing-condition-keyword.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/if-missing-condition-keyword.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/import-prelude-lowercase.yaml b/test/Test/Fixtures/error-messages/module/import-prelude-lowercase.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/import-prelude-lowercase.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/import-qualified-qualified.yaml b/test/Test/Fixtures/error-messages/module/import-qualified-qualified.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/import-qualified-qualified.yaml @@ -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' diff --git a/test/Test/Fixtures/error-messages/module/import-then-let-missing-rhs.yaml b/test/Test/Fixtures/error-messages/module/import-then-let-missing-rhs.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/import-then-let-missing-rhs.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/import-where.yaml b/test/Test/Fixtures/error-messages/module/import-where.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/import-where.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/lambda-in-case-branch.yaml b/test/Test/Fixtures/error-messages/module/lambda-in-case-branch.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/lambda-in-case-branch.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/lambda-missing-body.yaml b/test/Test/Fixtures/error-messages/module/lambda-missing-body.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/lambda-missing-body.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/let-expression-in-pattern.yaml b/test/Test/Fixtures/error-messages/module/let-expression-in-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/let-expression-in-pattern.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/list-pattern-in-equation.yaml b/test/Test/Fixtures/error-messages/module/list-pattern-in-equation.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/list-pattern-in-equation.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/missing-class-item-separator.yaml b/test/Test/Fixtures/error-messages/module/missing-class-item-separator.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/missing-class-item-separator.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/missing-import-name.yaml b/test/Test/Fixtures/error-messages/module/missing-import-name.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/missing-import-name.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/missing-module-name.yaml b/test/Test/Fixtures/error-messages/module/missing-module-name.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/missing-module-name.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/missing-rhs.yaml b/test/Test/Fixtures/error-messages/module/missing-rhs.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/missing-rhs.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/multiple-decl-errors.yaml b/test/Test/Fixtures/error-messages/module/multiple-decl-errors.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/multiple-decl-errors.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/multiple-import-errors-braced.yaml b/test/Test/Fixtures/error-messages/module/multiple-import-errors-braced.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/multiple-import-errors-braced.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/multiple-import-errors.yaml b/test/Test/Fixtures/error-messages/module/multiple-import-errors.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/multiple-import-errors.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/nested-case-in-equation.yaml b/test/Test/Fixtures/error-messages/module/nested-case-in-equation.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/nested-case-in-equation.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/pattern-as-non-constructor.yaml b/test/Test/Fixtures/error-messages/module/pattern-as-non-constructor.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/pattern-as-non-constructor.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/pattern-list-vs-recursive-function.yaml b/test/Test/Fixtures/error-messages/module/pattern-list-vs-recursive-function.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/pattern-list-vs-recursive-function.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/pattern-reserved-with-patternsynonyms.yaml b/test/Test/Fixtures/error-messages/module/pattern-reserved-with-patternsynonyms.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/pattern-reserved-with-patternsynonyms.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/record-update-with-wildcard.yaml b/test/Test/Fixtures/error-messages/module/record-update-with-wildcard.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/record-update-with-wildcard.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/transform-list-comp-by-binder.yaml b/test/Test/Fixtures/error-messages/module/transform-list-comp-by-binder.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/transform-list-comp-by-binder.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/transform-list-comp-using-binder.yaml b/test/Test/Fixtures/error-messages/module/transform-list-comp-using-binder.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/transform-list-comp-using-binder.yaml @@ -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 diff --git a/test/Test/Fixtures/error-messages/module/tuple-or-pattern-merge.yaml b/test/Test/Fixtures/error-messages/module/tuple-or-pattern-merge.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/error-messages/module/tuple-or-pattern-merge.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/block-args-case-simple.yaml b/test/Test/Fixtures/golden/expr/block-args-case-simple.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/block-args-case-simple.yaml @@ -0,0 +1,7 @@ +extensions: [BlockArguments] +input: | + id case x of + _ -> () +ast: |- + EApp (EVar "id") (ECase (EVar "x") [CaseAlt (PWildcard) (ETuple [])]) +status: pass diff --git a/test/Test/Fixtures/golden/expr/block-args-case-trailing-arg.yaml b/test/Test/Fixtures/golden/expr/block-args-case-trailing-arg.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/block-args-case-trailing-arg.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/block-args-do-bind.yaml b/test/Test/Fixtures/golden/expr/block-args-do-bind.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/block-args-do-bind.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/block-args-do-disabled.yaml b/test/Test/Fixtures/golden/expr/block-args-do-disabled.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/block-args-do-disabled.yaml @@ -0,0 +1,7 @@ +extensions: [] +input: | + id do + pure () +ast: |- +status: fail +reason: BlockArguments extension not enabled diff --git a/test/Test/Fixtures/golden/expr/block-args-do-multiple.yaml b/test/Test/Fixtures/golden/expr/block-args-do-multiple.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/block-args-do-multiple.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/block-args-do-simple.yaml b/test/Test/Fixtures/golden/expr/block-args-do-simple.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/block-args-do-simple.yaml @@ -0,0 +1,7 @@ +extensions: [BlockArguments] +input: | + id do + pure () +ast: |- + EApp (EVar "id") (EDo [DoExpr (EApp (EVar "pure") (ETuple []))]) +status: pass diff --git a/test/Test/Fixtures/golden/expr/block-args-if-explicit-paren.yaml b/test/Test/Fixtures/golden/expr/block-args-if-explicit-paren.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/block-args-if-explicit-paren.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/block-args-if-nested.yaml b/test/Test/Fixtures/golden/expr/block-args-if-nested.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/block-args-if-nested.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/block-args-if-simple.yaml b/test/Test/Fixtures/golden/expr/block-args-if-simple.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/block-args-if-simple.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/block-args-if-trailing-arg.yaml b/test/Test/Fixtures/golden/expr/block-args-if-trailing-arg.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/block-args-if-trailing-arg.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/block-args-lambda-simple.yaml b/test/Test/Fixtures/golden/expr/block-args-lambda-simple.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/block-args-lambda-simple.yaml @@ -0,0 +1,6 @@ +extensions: [BlockArguments] +input: | + id \x -> x +ast: |- + EApp (EVar "id") (ELambdaPats [PVar "x"] (EVar "x")) +status: pass diff --git a/test/Test/Fixtures/golden/expr/block-args-lambda-trailing-arg.yaml b/test/Test/Fixtures/golden/expr/block-args-lambda-trailing-arg.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/block-args-lambda-trailing-arg.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/case-record-pattern.yaml b/test/Test/Fixtures/golden/expr/case-record-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/case-record-pattern.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/cases-no-extension.yaml b/test/Test/Fixtures/golden/expr/cases-no-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/cases-no-extension.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + \cases -> () +ast: |- + ELambdaPats [PVar "cases"] (ETuple []) +status: pass diff --git a/test/Test/Fixtures/golden/expr/cases-with-extension.yaml b/test/Test/Fixtures/golden/expr/cases-with-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/cases-with-extension.yaml @@ -0,0 +1,6 @@ +extensions: [LambdaCase] +input: | + \cases -> () +ast: |- + ELambdaCases [LambdaCaseAlt [] (ETuple [])] +status: pass diff --git a/test/Test/Fixtures/golden/expr/do-explicit-braces-empty.yaml b/test/Test/Fixtures/golden/expr/do-explicit-braces-empty.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/do-explicit-braces-empty.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + do {} +ast: |- +status: fail +reason: empty do blocks are invalid diff --git a/test/Test/Fixtures/golden/expr/do-explicit-braces.yaml b/test/Test/Fixtures/golden/expr/do-explicit-braces.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/do-explicit-braces.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + do { x; y } +ast: |- + EDo [DoExpr (EVar "x"), DoExpr (EVar "y")] +status: pass diff --git a/test/Test/Fixtures/golden/expr/do-layout-bad-dedent.yaml b/test/Test/Fixtures/golden/expr/do-layout-bad-dedent.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/do-layout-bad-dedent.yaml @@ -0,0 +1,8 @@ +extensions: [] +input: | + do + x + y +ast: |- +status: fail +reason: invalid do-notation dedent diff --git a/test/Test/Fixtures/golden/expr/do-layout-basic.yaml b/test/Test/Fixtures/golden/expr/do-layout-basic.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/do-layout-basic.yaml @@ -0,0 +1,8 @@ +extensions: [] +input: | + do + x + y +ast: |- + EDo [DoExpr (EVar "x"), DoExpr (EVar "y")] +status: pass diff --git a/test/Test/Fixtures/golden/expr/do-layout-bind.yaml b/test/Test/Fixtures/golden/expr/do-layout-bind.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/do-layout-bind.yaml @@ -0,0 +1,8 @@ +extensions: [] +input: | + do + x <- y + x +ast: |- + EDo [DoBind (PVar "x") (EVar "y"), DoExpr (EVar "x")] +status: pass diff --git a/test/Test/Fixtures/golden/expr/do-layout-continuation.yaml b/test/Test/Fixtures/golden/expr/do-layout-continuation.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/do-layout-continuation.yaml @@ -0,0 +1,8 @@ +extensions: [] +input: | + do + x + y +ast: |- + EDo [DoExpr (EApp (EVar "x") (EVar "y"))] +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-binary-int8.yaml b/test/Test/Fixtures/golden/expr/extended-literals-binary-int8.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-binary-int8.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals] +input: | + 0b1010#Int8 +ast: |- + EInt 10 TInt8Hash +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-double-hash.yaml b/test/Test/Fixtures/golden/expr/extended-literals-double-hash.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-double-hash.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals, MagicHash] +input: | + 10.3## +ast: |- + EFloat 103 % 10 TDoubleHash +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-float-hash.yaml b/test/Test/Fixtures/golden/expr/extended-literals-float-hash.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-float-hash.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals, MagicHash] +input: | + 10.3# +ast: |- + EFloat 103 % 10 TFloatHash +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-fractional.yaml b/test/Test/Fixtures/golden/expr/extended-literals-fractional.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-fractional.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals, MagicHash] +input: | + 10.3 +ast: |- + EFloat 103 % 10 TFractional +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-hex-word8.yaml b/test/Test/Fixtures/golden/expr/extended-literals-hex-word8.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-hex-word8.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals] +input: | + 0xFF#Word8 +ast: |- + EInt 255 TWord8Hash +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-int-hash.yaml b/test/Test/Fixtures/golden/expr/extended-literals-int-hash.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-int-hash.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals, MagicHash] +input: | + 1# +ast: |- + EInt 1 TIntHash +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-int16.yaml b/test/Test/Fixtures/golden/expr/extended-literals-int16.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-int16.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals, MagicHash] +input: | + 123#Int16 +ast: |- + EInt 123 TInt16Hash +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-int32.yaml b/test/Test/Fixtures/golden/expr/extended-literals-int32.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-int32.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals, MagicHash] +input: | + 123#Int32 +ast: |- + EInt 123 TInt32Hash +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-int64.yaml b/test/Test/Fixtures/golden/expr/extended-literals-int64.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-int64.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals, MagicHash] +input: | + 123#Int64 +ast: |- + EInt 123 TInt64Hash +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-int8.yaml b/test/Test/Fixtures/golden/expr/extended-literals-int8.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-int8.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals, MagicHash] +input: | + 123#Int8 +ast: |- + EInt 123 TInt8Hash +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-word-hash.yaml b/test/Test/Fixtures/golden/expr/extended-literals-word-hash.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-word-hash.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals, MagicHash] +input: | + 1## +ast: |- + EInt 1 TWordHash +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-word16.yaml b/test/Test/Fixtures/golden/expr/extended-literals-word16.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-word16.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals, MagicHash] +input: | + 123#Word16 +ast: |- + EInt 123 TWord16Hash +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-word32.yaml b/test/Test/Fixtures/golden/expr/extended-literals-word32.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-word32.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals, MagicHash] +input: | + 123#Word32 +ast: |- + EInt 123 TWord32Hash +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-word64.yaml b/test/Test/Fixtures/golden/expr/extended-literals-word64.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-word64.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals, MagicHash] +input: | + 123#Word64 +ast: |- + EInt 123 TWord64Hash +status: pass diff --git a/test/Test/Fixtures/golden/expr/extended-literals-word8.yaml b/test/Test/Fixtures/golden/expr/extended-literals-word8.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/extended-literals-word8.yaml @@ -0,0 +1,6 @@ +extensions: [ExtendedLiterals, MagicHash] +input: | + 123#Word8 +ast: |- + EInt 123 TWord8Hash +status: pass diff --git a/test/Test/Fixtures/golden/expr/foo-hash-bar-magic-hash.yaml b/test/Test/Fixtures/golden/expr/foo-hash-bar-magic-hash.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/foo-hash-bar-magic-hash.yaml @@ -0,0 +1,6 @@ +extensions: [MagicHash] +input: | + foo#bar +ast: |- + EApp (EVar "foo#") (EVar "bar") +status: pass diff --git a/test/Test/Fixtures/golden/expr/foo-hash-bar-no-magic-hash.yaml b/test/Test/Fixtures/golden/expr/foo-hash-bar-no-magic-hash.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/foo-hash-bar-no-magic-hash.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + foo#bar +ast: |- + EInfix (EVar "foo") "#" (EVar "bar") +status: pass diff --git a/test/Test/Fixtures/golden/expr/hex-fractional-no-exponent.yaml b/test/Test/Fixtures/golden/expr/hex-fractional-no-exponent.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/hex-fractional-no-exponent.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + 0x5e.a +ast: |- + EFloat 757 % 8 TFractional +status: pass diff --git a/test/Test/Fixtures/golden/expr/if-both-branches-type-sig.yaml b/test/Test/Fixtures/golden/expr/if-both-branches-type-sig.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/if-both-branches-type-sig.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/if-else-type-sig.yaml b/test/Test/Fixtures/golden/expr/if-else-type-sig.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/if-else-type-sig.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/if-then-type-sig-arrow.yaml b/test/Test/Fixtures/golden/expr/if-then-type-sig-arrow.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/if-then-type-sig-arrow.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/if-then-type-sig.yaml b/test/Test/Fixtures/golden/expr/if-then-type-sig.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/if-then-type-sig.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/invalid-token.yaml b/test/Test/Fixtures/golden/expr/invalid-token.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/invalid-token.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + f @ +ast: |- +status: fail +reason: invalid token diff --git a/test/Test/Fixtures/golden/expr/lambda-case-empty.yaml b/test/Test/Fixtures/golden/expr/lambda-case-empty.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/lambda-case-empty.yaml @@ -0,0 +1,7 @@ +extensions: + - LambdaCase +input: | + \case {} +ast: |- + ELambdaCase [] +status: pass diff --git a/test/Test/Fixtures/golden/expr/lambda-case-multiline-application.yaml b/test/Test/Fixtures/golden/expr/lambda-case-multiline-application.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/lambda-case-multiline-application.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/lexneg-after-infix-dollar.yaml b/test/Test/Fixtures/golden/expr/lexneg-after-infix-dollar.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/lexneg-after-infix-dollar.yaml @@ -0,0 +1,6 @@ +extensions: [LexicalNegation] +input: | + f $ -x +ast: |- + EInfix (EVar "f") "$" (ENegate (EVar "x")) +status: pass diff --git a/test/Test/Fixtures/golden/expr/lexneg-app-space-var.yaml b/test/Test/Fixtures/golden/expr/lexneg-app-space-var.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/lexneg-app-space-var.yaml @@ -0,0 +1,6 @@ +extensions: [LexicalNegation] +input: | + f -x +ast: |- + EApp (EVar "f") (ENegate (EVar "x")) +status: pass diff --git a/test/Test/Fixtures/golden/expr/lexneg-paren-minus-spaced.yaml b/test/Test/Fixtures/golden/expr/lexneg-paren-minus-spaced.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/lexneg-paren-minus-spaced.yaml @@ -0,0 +1,6 @@ +extensions: [LexicalNegation] +input: | + (- x) +ast: |- + EParen (ESectionR "-" (EVar "x")) +status: pass diff --git a/test/Test/Fixtures/golden/expr/lexneg-precedence-infix.yaml b/test/Test/Fixtures/golden/expr/lexneg-precedence-infix.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/lexneg-precedence-infix.yaml @@ -0,0 +1,6 @@ +extensions: [LexicalNegation] +input: | + -a % b +ast: |- + EInfix (ENegate (EVar "a")) "%" (EVar "b") +status: pass diff --git a/test/Test/Fixtures/golden/expr/magic-hash-ident.yaml b/test/Test/Fixtures/golden/expr/magic-hash-ident.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/magic-hash-ident.yaml @@ -0,0 +1,6 @@ +extensions: [MagicHash] +input: | + x# +ast: |- + EVar "x#" +status: pass diff --git a/test/Test/Fixtures/golden/expr/magic-hash-int-literal.yaml b/test/Test/Fixtures/golden/expr/magic-hash-int-literal.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/magic-hash-int-literal.yaml @@ -0,0 +1,6 @@ +extensions: [MagicHash] +input: | + 42# +ast: |- + EInt 42 TIntHash +status: pass diff --git a/test/Test/Fixtures/golden/expr/magic-hash-word-float-literal.yaml b/test/Test/Fixtures/golden/expr/magic-hash-word-float-literal.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/magic-hash-word-float-literal.yaml @@ -0,0 +1,6 @@ +extensions: [MagicHash] +input: | + 0.0## +ast: |- + EFloat 0 % 1 TDoubleHash +status: pass diff --git a/test/Test/Fixtures/golden/expr/magic-hash-word-literal.yaml b/test/Test/Fixtures/golden/expr/magic-hash-word-literal.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/magic-hash-word-literal.yaml @@ -0,0 +1,6 @@ +extensions: [MagicHash] +input: | + 0## +ast: |- + EInt 0 TWordHash +status: pass diff --git a/test/Test/Fixtures/golden/expr/mdo-explicit-braces.yaml b/test/Test/Fixtures/golden/expr/mdo-explicit-braces.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/mdo-explicit-braces.yaml @@ -0,0 +1,6 @@ +extensions: [RecursiveDo] +input: | + mdo { pure x } +ast: |- + EDo [DoExpr (EApp (EVar "pure") (EVar "x"))] (DoMdo) +status: pass diff --git a/test/Test/Fixtures/golden/expr/missing-rparen.yaml b/test/Test/Fixtures/golden/expr/missing-rparen.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/missing-rparen.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (f x +ast: |- +status: fail +reason: missing right parenthesis diff --git a/test/Test/Fixtures/golden/expr/multiline-application.yaml b/test/Test/Fixtures/golden/expr/multiline-application.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-application.yaml @@ -0,0 +1,8 @@ +extensions: [] +input: | + f + x + y +ast: |- + EApp (EApp (EVar "f") (EVar "x")) (EVar "y") +status: pass diff --git a/test/Test/Fixtures/golden/expr/multiline-basic.yaml b/test/Test/Fixtures/golden/expr/multiline-basic.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-basic.yaml @@ -0,0 +1,7 @@ +extensions: [MultilineStrings] +input: | + """Hello, World!""" +ast: |- + EString "Hello, World!" +status: pass +comment: Single line without leading/trailing newlines diff --git a/test/Test/Fixtures/golden/expr/multiline-blank-line.yaml b/test/Test/Fixtures/golden/expr/multiline-blank-line.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-blank-line.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/expr/multiline-embedded-tab.yaml b/test/Test/Fixtures/golden/expr/multiline-embedded-tab.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-embedded-tab.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/expr/multiline-empty.yaml b/test/Test/Fixtures/golden/expr/multiline-empty.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-empty.yaml @@ -0,0 +1,7 @@ +extensions: [MultilineStrings] +input: | + """""" +ast: |- + EString "" +status: pass +comment: Empty multiline string diff --git a/test/Test/Fixtures/golden/expr/multiline-escape.yaml b/test/Test/Fixtures/golden/expr/multiline-escape.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-escape.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/expr/multiline-indent.yaml b/test/Test/Fixtures/golden/expr/multiline-indent.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-indent.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/expr/multiline-leading-trailing-newlines.yaml b/test/Test/Fixtures/golden/expr/multiline-leading-trailing-newlines.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-leading-trailing-newlines.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/expr/multiline-newlines.yaml b/test/Test/Fixtures/golden/expr/multiline-newlines.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-newlines.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/expr/multiline-single-line.yaml b/test/Test/Fixtures/golden/expr/multiline-single-line.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-single-line.yaml @@ -0,0 +1,7 @@ +extensions: [MultilineStrings] +input: | + """single line""" +ast: |- + EString "single line" +status: pass +comment: Triple-quoted string on single line (no newlines) diff --git a/test/Test/Fixtures/golden/expr/multiline-string-gap.yaml b/test/Test/Fixtures/golden/expr/multiline-string-gap.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-string-gap.yaml @@ -0,0 +1,12 @@ +extensions: [MultilineStrings] +input: | + """ + Line 1\ + \continues here + """ +ast: |- + EString "Line 1continues here" +status: pass +comment: | + String gap (\\) is collapsed before multiline processing. + The backslash-whitespace-backslash sequence is removed entirely. diff --git a/test/Test/Fixtures/golden/expr/multiline-tabs.yaml b/test/Test/Fixtures/golden/expr/multiline-tabs.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-tabs.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/expr/multiline-trailing-gap-before-close.yaml b/test/Test/Fixtures/golden/expr/multiline-trailing-gap-before-close.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-trailing-gap-before-close.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/expr/multiline-unescaped-quotes.yaml b/test/Test/Fixtures/golden/expr/multiline-unescaped-quotes.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-unescaped-quotes.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/expr/multiline-varying-indent.yaml b/test/Test/Fixtures/golden/expr/multiline-varying-indent.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiline-varying-indent.yaml @@ -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). diff --git a/test/Test/Fixtures/golden/expr/multiway-if-infix-branch-body.yaml b/test/Test/Fixtures/golden/expr/multiway-if-infix-branch-body.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiway-if-infix-branch-body.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/multiway-if-offside-infix-lhs.yaml b/test/Test/Fixtures/golden/expr/multiway-if-offside-infix-lhs.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/multiway-if-offside-infix-lhs.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/expr/negate-after-infix-plus.yaml b/test/Test/Fixtures/golden/expr/negate-after-infix-plus.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/negate-after-infix-plus.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + a + - 1 +ast: |- + EInfix (EVar "a") "+" (ENegate (EInt 1 TInteger)) +status: pass diff --git a/test/Test/Fixtures/golden/expr/negate-after-infix-var.yaml b/test/Test/Fixtures/golden/expr/negate-after-infix-var.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/negate-after-infix-var.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + f $ - x +ast: |- + EInfix (EVar "f") "$" (ENegate (EVar "x")) +status: pass diff --git a/test/Test/Fixtures/golden/expr/negate-application.yaml b/test/Test/Fixtures/golden/expr/negate-application.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/negate-application.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + -f x +ast: |- + ENegate (EApp (EVar "f") (EVar "x")) +status: pass diff --git a/test/Test/Fixtures/golden/expr/negate-infix-chain.yaml b/test/Test/Fixtures/golden/expr/negate-infix-chain.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/negate-infix-chain.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + -1 + 2 +ast: |- + EInfix (ENegate (EInt 1 TInteger)) "+" (EInt 2 TInteger) +status: pass diff --git a/test/Test/Fixtures/golden/expr/negate-int-default.yaml b/test/Test/Fixtures/golden/expr/negate-int-default.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/negate-int-default.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + -1 +ast: |- + ENegate (EInt 1 TInteger) +status: pass diff --git a/test/Test/Fixtures/golden/expr/negate-int-lexical-negation.yaml b/test/Test/Fixtures/golden/expr/negate-int-lexical-negation.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/negate-int-lexical-negation.yaml @@ -0,0 +1,6 @@ +extensions: [NegativeLiterals] +input: | + -1 +ast: |- + EInt -1 TInteger +status: pass diff --git a/test/Test/Fixtures/golden/expr/negate-paren-int-hash.yaml b/test/Test/Fixtures/golden/expr/negate-paren-int-hash.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/negate-paren-int-hash.yaml @@ -0,0 +1,6 @@ +extensions: [MagicHash] +input: | + -(95#) +ast: |- + ENegate (EParen (EInt 95 TIntHash)) +status: pass diff --git a/test/Test/Fixtures/golden/expr/negative-literal-extension.yaml b/test/Test/Fixtures/golden/expr/negative-literal-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/negative-literal-extension.yaml @@ -0,0 +1,7 @@ +extensions: + - NegativeLiterals +input: | + -1 +ast: |- + EInt -1 TInteger +status: pass diff --git a/test/Test/Fixtures/golden/expr/neglit-app-space-int.yaml b/test/Test/Fixtures/golden/expr/neglit-app-space-int.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/neglit-app-space-int.yaml @@ -0,0 +1,6 @@ +extensions: [NegativeLiterals] +input: | + f -5 +ast: |- + EApp (EVar "f") (EInt -5 TInteger) +status: pass diff --git a/test/Test/Fixtures/golden/expr/neglit-infix-minus-paren.yaml b/test/Test/Fixtures/golden/expr/neglit-infix-minus-paren.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/neglit-infix-minus-paren.yaml @@ -0,0 +1,6 @@ +extensions: [NegativeLiterals] +input: | + f -(x*2) +ast: |- + EInfix (EVar "f") "-" (EParen (EInfix (EVar "x") "*" (EInt 2 TInteger))) +status: pass diff --git a/test/Test/Fixtures/golden/expr/neglit-infix-minus-var.yaml b/test/Test/Fixtures/golden/expr/neglit-infix-minus-var.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/neglit-infix-minus-var.yaml @@ -0,0 +1,6 @@ +extensions: [NegativeLiterals] +input: | + f -x +ast: |- + EInfix (EVar "f") "-" (EVar "x") +status: pass diff --git a/test/Test/Fixtures/golden/expr/neglit-infix-tight-int.yaml b/test/Test/Fixtures/golden/expr/neglit-infix-tight-int.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/neglit-infix-tight-int.yaml @@ -0,0 +1,6 @@ +extensions: [NegativeLiterals] +input: | + f-5 +ast: |- + EInfix (EVar "f") "-" (EInt 5 TInteger) +status: pass diff --git a/test/Test/Fixtures/golden/expr/neglit-unary-int.yaml b/test/Test/Fixtures/golden/expr/neglit-unary-int.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/neglit-unary-int.yaml @@ -0,0 +1,6 @@ +extensions: [NegativeLiterals] +input: | + -10 +ast: |- + EInt -10 TInteger +status: pass diff --git a/test/Test/Fixtures/golden/expr/nested-app.yaml b/test/Test/Fixtures/golden/expr/nested-app.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/nested-app.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + f (g 1) +ast: |- + EApp (EVar "f") (EParen (EApp (EVar "g") (EInt 1 TInteger))) +status: pass diff --git a/test/Test/Fixtures/golden/expr/noext-infix-minus-int.yaml b/test/Test/Fixtures/golden/expr/noext-infix-minus-int.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/noext-infix-minus-int.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + f -5 +ast: |- + EInfix (EVar "f") "-" (EInt 5 TInteger) +status: pass diff --git a/test/Test/Fixtures/golden/expr/noext-infix-minus-var.yaml b/test/Test/Fixtures/golden/expr/noext-infix-minus-var.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/noext-infix-minus-var.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + f -x +ast: |- + EInfix (EVar "f") "-" (EVar "x") +status: pass diff --git a/test/Test/Fixtures/golden/expr/operator-section-trailing-minus.yaml b/test/Test/Fixtures/golden/expr/operator-section-trailing-minus.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/operator-section-trailing-minus.yaml @@ -0,0 +1,6 @@ +extensions: [GHC2021] +input: | + (n-1-) +ast: |- + EParen (ESectionL (EInfix (EVar "n") "-" (EInt 1 TInteger)) "-") +status: pass diff --git a/test/Test/Fixtures/golden/expr/overloaded-label-basic.yaml b/test/Test/Fixtures/golden/expr/overloaded-label-basic.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/overloaded-label-basic.yaml @@ -0,0 +1,6 @@ +extensions: [OverloadedLabels] +input: | + #typeUrl +ast: |- + EOverloadedLabel "typeUrl" "#typeUrl" +status: pass diff --git a/test/Test/Fixtures/golden/expr/overloaded-label-quoted.yaml b/test/Test/Fixtures/golden/expr/overloaded-label-quoted.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/overloaded-label-quoted.yaml @@ -0,0 +1,6 @@ +extensions: [OverloadedLabels] +input: | + #"The quick brown fox" +ast: |- + EOverloadedLabel "The quick brown fox" "#\"The quick brown fox\"" +status: pass diff --git a/test/Test/Fixtures/golden/expr/paren-negate-spaced.yaml b/test/Test/Fixtures/golden/expr/paren-negate-spaced.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/paren-negate-spaced.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (- x) +ast: |- + EParen (ENegate (EVar "x")) +status: pass diff --git a/test/Test/Fixtures/golden/expr/paren-negate-tight.yaml b/test/Test/Fixtures/golden/expr/paren-negate-tight.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/paren-negate-tight.yaml @@ -0,0 +1,6 @@ +extensions: [LexicalNegation] +input: | + (-x) +ast: |- + ENegate (EVar "x") +status: pass diff --git a/test/Test/Fixtures/golden/expr/paren-section-infix-fmap.yaml b/test/Test/Fixtures/golden/expr/paren-section-infix-fmap.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/paren-section-infix-fmap.yaml @@ -0,0 +1,6 @@ +extensions: [GHC2021] +input: | + (a . b <$>) +ast: |- + EParen (ESectionL (EInfix (EVar "a") "." (EVar "b")) "<$>") +status: pass diff --git a/test/Test/Fixtures/golden/expr/paren-section-left-plus.yaml b/test/Test/Fixtures/golden/expr/paren-section-left-plus.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/paren-section-left-plus.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (x+) +ast: |- + EParen (ESectionL (EVar "x") "+") +status: pass diff --git a/test/Test/Fixtures/golden/expr/paren-section-right-plus.yaml b/test/Test/Fixtures/golden/expr/paren-section-right-plus.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/paren-section-right-plus.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (+x) +ast: |- + EParen (ESectionR "+" (EVar "x")) +status: pass diff --git a/test/Test/Fixtures/golden/expr/proc-notation.yaml b/test/Test/Fixtures/golden/expr/proc-notation.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/proc-notation.yaml @@ -0,0 +1,6 @@ +extensions: [Arrows] +input: | + proc x -> returnA -< x +ast: |- + EProc (PVar "x") (CmdArrApp (EVar "returnA") HsFirstOrderApp (EVar "x")) +status: pass diff --git a/test/Test/Fixtures/golden/expr/qualified-conop-infix.yaml b/test/Test/Fixtures/golden/expr/qualified-conop-infix.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/qualified-conop-infix.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + x Data.List.:++ y +ast: |- + EInfix (EVar "x") "Data.List" ":++" (EVar "y") +status: pass diff --git a/test/Test/Fixtures/golden/expr/qualified-dot-section-right.yaml b/test/Test/Fixtures/golden/expr/qualified-dot-section-right.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/qualified-dot-section-right.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (Foo.. x) +ast: |- + EParen (ESectionR "Foo" "." (EVar "x")) +status: pass diff --git a/test/Test/Fixtures/golden/expr/qualified-op-deep.yaml b/test/Test/Fixtures/golden/expr/qualified-op-deep.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/qualified-op-deep.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (A.B.C.+) +ast: |- + EVar "A.B.C" "+" +status: pass diff --git a/test/Test/Fixtures/golden/expr/qualified-op-infix.yaml b/test/Test/Fixtures/golden/expr/qualified-op-infix.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/qualified-op-infix.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + x Prelude.+ y +ast: |- + EInfix (EVar "x") "Prelude" "+" (EVar "y") +status: pass diff --git a/test/Test/Fixtures/golden/expr/qualified-op-paren.yaml b/test/Test/Fixtures/golden/expr/qualified-op-paren.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/qualified-op-paren.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (Prelude.+) +ast: |- + EVar "Prelude" "+" +status: pass diff --git a/test/Test/Fixtures/golden/expr/qualified-op-section-left.yaml b/test/Test/Fixtures/golden/expr/qualified-op-section-left.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/qualified-op-section-left.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (x Prelude.+) +ast: |- + EParen (ESectionL (EVar "x") "Prelude" "+") +status: pass diff --git a/test/Test/Fixtures/golden/expr/qualified-op-section-right.yaml b/test/Test/Fixtures/golden/expr/qualified-op-section-right.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/qualified-op-section-right.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (Prelude.+ x) +ast: |- + EParen (ESectionR "Prelude" "+" (EVar "x")) +status: pass diff --git a/test/Test/Fixtures/golden/expr/record-dot-chained.yaml b/test/Test/Fixtures/golden/expr/record-dot-chained.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/record-dot-chained.yaml @@ -0,0 +1,6 @@ +extensions: [OverloadedRecordDot] +input: | + a.b.c +ast: |- + EGetField (EGetField (EVar "a") "b") "c" +status: pass diff --git a/test/Test/Fixtures/golden/expr/record-dot-composition-unaffected.yaml b/test/Test/Fixtures/golden/expr/record-dot-composition-unaffected.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/record-dot-composition-unaffected.yaml @@ -0,0 +1,6 @@ +extensions: [OverloadedRecordDot] +input: | + f . g +ast: |- + EInfix (EVar "f") "." (EVar "g") +status: pass diff --git a/test/Test/Fixtures/golden/expr/record-dot-disabled.yaml b/test/Test/Fixtures/golden/expr/record-dot-disabled.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/record-dot-disabled.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + record.field +ast: |- + EInfix (EVar "record") "." (EVar "field") +status: pass diff --git a/test/Test/Fixtures/golden/expr/record-dot-in-app.yaml b/test/Test/Fixtures/golden/expr/record-dot-in-app.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/record-dot-in-app.yaml @@ -0,0 +1,6 @@ +extensions: [OverloadedRecordDot] +input: | + f record.field +ast: |- + EApp (EVar "f") (EGetField (EVar "record") "field") +status: pass diff --git a/test/Test/Fixtures/golden/expr/record-dot-paren-base.yaml b/test/Test/Fixtures/golden/expr/record-dot-paren-base.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/record-dot-paren-base.yaml @@ -0,0 +1,6 @@ +extensions: [OverloadedRecordDot] +input: | + (f x).field +ast: |- + EGetField (EParen (EApp (EVar "f") (EVar "x"))) "field" +status: pass diff --git a/test/Test/Fixtures/golden/expr/record-dot-projection-chained.yaml b/test/Test/Fixtures/golden/expr/record-dot-projection-chained.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/record-dot-projection-chained.yaml @@ -0,0 +1,6 @@ +extensions: [OverloadedRecordDot] +input: | + (.f.g) +ast: |- + EParen (EGetFieldProjection ["f", "g"]) +status: pass diff --git a/test/Test/Fixtures/golden/expr/record-dot-projection-simple.yaml b/test/Test/Fixtures/golden/expr/record-dot-projection-simple.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/record-dot-projection-simple.yaml @@ -0,0 +1,6 @@ +extensions: [OverloadedRecordDot] +input: | + (.field) +ast: |- + EParen (EGetFieldProjection ["field"]) +status: pass diff --git a/test/Test/Fixtures/golden/expr/record-dot-simple.yaml b/test/Test/Fixtures/golden/expr/record-dot-simple.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/record-dot-simple.yaml @@ -0,0 +1,6 @@ +extensions: [OverloadedRecordDot] +input: | + record.field +ast: |- + EGetField (EVar "record") "field" +status: pass diff --git a/test/Test/Fixtures/golden/expr/record-dot-then-update.yaml b/test/Test/Fixtures/golden/expr/record-dot-then-update.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/record-dot-then-update.yaml @@ -0,0 +1,6 @@ +extensions: [OverloadedRecordDot] +input: | + r.field { x = 1 } +ast: |- + ERecordUpd (EGetField (EVar "r") "field") {"x" = EInt 1 TInteger} +status: pass diff --git a/test/Test/Fixtures/golden/expr/simple-app.yaml b/test/Test/Fixtures/golden/expr/simple-app.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/simple-app.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + f x +ast: |- + EApp (EVar "f") (EVar "x") +status: pass diff --git a/test/Test/Fixtures/golden/expr/simple-int.yaml b/test/Test/Fixtures/golden/expr/simple-int.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/simple-int.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + 42 +ast: |- + EInt 42 TInteger +status: pass diff --git a/test/Test/Fixtures/golden/expr/th-qualified-name-quotes.yaml b/test/Test/Fixtures/golden/expr/th-qualified-name-quotes.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/th-qualified-name-quotes.yaml @@ -0,0 +1,7 @@ +extensions: + - TemplateHaskell +input: | + ('M.v, '(M.+)) +ast: |- + ETuple [ETHNameQuote (EVar "M" "v"), ETHNameQuote (EVar "M" "+")] +status: pass diff --git a/test/Test/Fixtures/golden/expr/tuple-constructor-3.yaml b/test/Test/Fixtures/golden/expr/tuple-constructor-3.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/tuple-constructor-3.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (,,) +ast: |- + ETuple [Nothing, Nothing, Nothing] +status: pass diff --git a/test/Test/Fixtures/golden/expr/tuple-pair.yaml b/test/Test/Fixtures/golden/expr/tuple-pair.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/tuple-pair.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (a,b) +ast: |- + ETuple [EVar "a", EVar "b"] +status: pass diff --git a/test/Test/Fixtures/golden/expr/tuple-section-left.yaml b/test/Test/Fixtures/golden/expr/tuple-section-left.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/tuple-section-left.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (a,) +ast: |- + ETuple [EVar "a", Nothing] +status: pass diff --git a/test/Test/Fixtures/golden/expr/tuple-section-middle.yaml b/test/Test/Fixtures/golden/expr/tuple-section-middle.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/tuple-section-middle.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (a,,b) +ast: |- + ETuple [EVar "a", Nothing, EVar "b"] +status: pass diff --git a/test/Test/Fixtures/golden/expr/tuple-section-nested-left.yaml b/test/Test/Fixtures/golden/expr/tuple-section-nested-left.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/tuple-section-nested-left.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + ((,a),) +ast: |- + ETuple [ETuple [Nothing, EVar "a"], Nothing] +status: pass diff --git a/test/Test/Fixtures/golden/expr/tuple-section-nested-unit.yaml b/test/Test/Fixtures/golden/expr/tuple-section-nested-unit.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/tuple-section-nested-unit.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + ((),,) +ast: |- + ETuple [ETuple [], Nothing, Nothing] +status: pass diff --git a/test/Test/Fixtures/golden/expr/tuple-section-right.yaml b/test/Test/Fixtures/golden/expr/tuple-section-right.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/tuple-section-right.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (,a) +ast: |- + ETuple [Nothing, EVar "a"] +status: pass diff --git a/test/Test/Fixtures/golden/expr/tuple-unit.yaml b/test/Test/Fixtures/golden/expr/tuple-unit.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/tuple-unit.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + () +ast: |- + ETuple [] +status: pass diff --git a/test/Test/Fixtures/golden/expr/type-app-loose.yaml b/test/Test/Fixtures/golden/expr/type-app-loose.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/type-app-loose.yaml @@ -0,0 +1,6 @@ +extensions: [TypeApplications] +input: | + f @ a +ast: |- + EInfix (EVar "f") "@" (EVar "a") +status: pass diff --git a/test/Test/Fixtures/golden/expr/type-app-no-space.yaml b/test/Test/Fixtures/golden/expr/type-app-no-space.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/type-app-no-space.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + read@Int 5 +ast: |- +status: fail +reason: type application requires space before @ diff --git a/test/Test/Fixtures/golden/expr/type-app-tight-no-space-chain.yaml b/test/Test/Fixtures/golden/expr/type-app-tight-no-space-chain.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/type-app-tight-no-space-chain.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + f @Int@Bool +ast: |- +status: fail +reason: type application chain requires spaces before @ diff --git a/test/Test/Fixtures/golden/expr/type-app-tight.yaml b/test/Test/Fixtures/golden/expr/type-app-tight.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/type-app-tight.yaml @@ -0,0 +1,6 @@ +extensions: [TypeApplications] +input: | + f @a +ast: |- + ETypeApp (EVar "f") (TVar "a") +status: pass diff --git a/test/Test/Fixtures/golden/expr/unboxed-tuple-basic.yaml b/test/Test/Fixtures/golden/expr/unboxed-tuple-basic.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/unboxed-tuple-basic.yaml @@ -0,0 +1,6 @@ +extensions: [UnboxedTuples] +input: | + (# 1, 2 #) +ast: |- + ETuple Unboxed [EInt 1 TInteger, EInt 2 TInteger] +status: pass diff --git a/test/Test/Fixtures/golden/expr/unboxed-tuple-constructor-3.yaml b/test/Test/Fixtures/golden/expr/unboxed-tuple-constructor-3.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/unboxed-tuple-constructor-3.yaml @@ -0,0 +1,6 @@ +extensions: [UnboxedTuples] +input: | + (#,,#) +ast: |- + ETuple Unboxed [Nothing, Nothing, Nothing] +status: pass diff --git a/test/Test/Fixtures/golden/expr/unboxed-tuple-section.yaml b/test/Test/Fixtures/golden/expr/unboxed-tuple-section.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/expr/unboxed-tuple-section.yaml @@ -0,0 +1,6 @@ +extensions: [UnboxedTuples] +input: | + (# 1, #) +ast: |- + ETuple Unboxed [EInt 1 TInteger, Nothing] +status: pass diff --git a/test/Test/Fixtures/golden/import/operator-import.yaml b/test/Test/Fixtures/golden/import/operator-import.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/import/operator-import.yaml @@ -0,0 +1,7 @@ +extensions: + - TypeOperators +input: | + import Data.Type.Equality ((:~~:)(..)) +ast: |- + Module {[ImportDecl {"Data.Type.Equality", ImportSpec {[ImportItemAll{UnqualifiedName {":~~:"}}]}}]} +status: pass diff --git a/test/Test/Fixtures/golden/module/FlexibleInstances/instance-unit.yaml b/test/Test/Fixtures/golden/module/FlexibleInstances/instance-unit.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/FlexibleInstances/instance-unit.yaml @@ -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")})]} diff --git a/test/Test/Fixtures/golden/module/app.yaml b/test/Test/Fixtures/golden/module/app.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/app.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/arrow-command-infix-bare-case-arrapp.yaml b/test/Test/Fixtures/golden/module/arrow-command-infix-bare-case-arrapp.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/arrow-command-infix-bare-case-arrapp.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/arrow-proc-lhs-needs-parens.yaml b/test/Test/Fixtures/golden/module/arrow-proc-lhs-needs-parens.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/arrow-proc-lhs-needs-parens.yaml @@ -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 -<< diff --git a/test/Test/Fixtures/golden/module/associated-type-default-shorthand.yaml b/test/Test/Fixtures/golden/module/associated-type-default-shorthand.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/associated-type-default-shorthand.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/bad-head.yaml b/test/Test/Fixtures/golden/module/bad-head.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/bad-head.yaml @@ -0,0 +1,7 @@ +extensions: [] +input: | + module where + x = 1 +ast: |- +status: fail +reason: invalid module header diff --git a/test/Test/Fixtures/golden/module/block-args-lambda-as-pattern.yaml b/test/Test/Fixtures/golden/module/block-args-lambda-as-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/block-args-lambda-as-pattern.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/case-guarded-in-record-field.yaml b/test/Test/Fixtures/golden/module/case-guarded-in-record-field.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/case-guarded-in-record-field.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/case-in-record-field.yaml b/test/Test/Fixtures/golden/module/case-in-record-field.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/case-in-record-field.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/class-infix-identifier-head.yaml b/test/Test/Fixtures/golden/module/class-infix-identifier-head.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/class-infix-identifier-head.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/class-infix-kinded-head.yaml b/test/Test/Fixtures/golden/module/class-infix-kinded-head.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/class-infix-kinded-head.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/data-bool-core-lib.yaml b/test/Test/Fixtures/golden/module/data-bool-core-lib.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/data-bool-core-lib.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/data-con-infix-parenthesized-function-type.yaml b/test/Test/Fixtures/golden/module/data-con-infix-parenthesized-function-type.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/data-con-infix-parenthesized-function-type.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/data-con-infix-parenthesized-infix-type.yaml b/test/Test/Fixtures/golden/module/data-con-infix-parenthesized-infix-type.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/data-con-infix-parenthesized-infix-type.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/data-con-infix-simple-type.yaml b/test/Test/Fixtures/golden/module/data-con-infix-simple-type.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/data-con-infix-simple-type.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/data-con-infix-tuple-constructor-application.yaml b/test/Test/Fixtures/golden/module/data-con-infix-tuple-constructor-application.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/data-con-infix-tuple-constructor-application.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/data-con-infix-type-app-rhs.yaml b/test/Test/Fixtures/golden/module/data-con-infix-type-app-rhs.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/data-con-infix-type-app-rhs.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/data-deriving-complex-types.yaml b/test/Test/Fixtures/golden/module/data-deriving-complex-types.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/data-deriving-complex-types.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/data-deriving-qualified-bare.yaml b/test/Test/Fixtures/golden/module/data-deriving-qualified-bare.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/data-deriving-qualified-bare.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/data-mixed-operator-and-normal-fields.yaml b/test/Test/Fixtures/golden/module/data-mixed-operator-and-normal-fields.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/data-mixed-operator-and-normal-fields.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/data-record-bang-star.yaml b/test/Test/Fixtures/golden/module/data-record-bang-star.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/data-record-bang-star.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/dataset-prefix.yaml b/test/Test/Fixtures/golden/module/dataset-prefix.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/dataset-prefix.yaml @@ -0,0 +1,7 @@ +extensions: [] +input: | + module DatasetPrefix where + dataset = 5 +ast: |- + Module {ModuleHead {"DatasetPrefix"}, [DeclValue (PatternBind (PVar "dataset") (EInt 5 TInteger))]} +status: pass diff --git a/test/Test/Fixtures/golden/module/default-decl-empty.yaml b/test/Test/Fixtures/golden/module/default-decl-empty.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/default-decl-empty.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + default () +ast: |- + Module {[DeclDefault []]} +status: pass diff --git a/test/Test/Fixtures/golden/module/default-decl.yaml b/test/Test/Fixtures/golden/module/default-decl.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/default-decl.yaml @@ -0,0 +1,7 @@ +extensions: [] +input: | + module D10 where + default (Integer, Double) +ast: |- + Module {ModuleHead {"D10"}, [DeclDefault [TCon "Integer", TCon "Double"]]} +status: pass diff --git a/test/Test/Fixtures/golden/module/do-if-then-else-case-layout.yaml b/test/Test/Fixtures/golden/module/do-if-then-else-case-layout.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/do-if-then-else-case-layout.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/do-if-then-else-let-layout.yaml b/test/Test/Fixtures/golden/module/do-if-then-else-let-layout.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/do-if-then-else-let-layout.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/do-where-layout-multi.yaml b/test/Test/Fixtures/golden/module/do-where-layout-multi.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/do-where-layout-multi.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/do-where-layout.yaml b/test/Test/Fixtures/golden/module/do-where-layout.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/do-where-layout.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/explicit-namespace-app-arg-bare.yaml b/test/Test/Fixtures/golden/module/explicit-namespace-app-arg-bare.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/explicit-namespace-app-arg-bare.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/explicit-namespace-record-dot-bare.yaml b/test/Test/Fixtures/golden/module/explicit-namespace-record-dot-bare.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/explicit-namespace-record-dot-bare.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/explicit-namespace-record-update-bare.yaml b/test/Test/Fixtures/golden/module/explicit-namespace-record-update-bare.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/explicit-namespace-record-update-bare.yaml @@ -0,0 +1,5 @@ +extensions: [ExplicitNamespaces] +input: | + x = type (:+) {} +status: fail +reason: GHC rejects record construction/update directly after an explicit namespace expression diff --git a/test/Test/Fixtures/golden/module/export-spec-bundled-data-members.yaml b/test/Test/Fixtures/golden/module/export-spec-bundled-data-members.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/export-spec-bundled-data-members.yaml @@ -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))]} diff --git a/test/Test/Fixtures/golden/module/export-spec-data-namespace.yaml b/test/Test/Fixtures/golden/module/export-spec-data-namespace.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/export-spec-data-namespace.yaml @@ -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))]} diff --git a/test/Test/Fixtures/golden/module/expr-type-sig-kind-sig-bare.yaml b/test/Test/Fixtures/golden/module/expr-type-sig-kind-sig-bare.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/expr-type-sig-kind-sig-bare.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/fixity-multi-operator.yaml b/test/Test/Fixtures/golden/module/fixity-multi-operator.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/fixity-multi-operator.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + infix ^, + +ast: |- + Module {[DeclFixity Infix Nothing Nothing [UnqualifiedName {"^"}, UnqualifiedName {"+"}]]} +status: pass diff --git a/test/Test/Fixtures/golden/module/fixity-operator-backtick.yaml b/test/Test/Fixtures/golden/module/fixity-operator-backtick.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/fixity-operator-backtick.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/fixity-operator.yaml b/test/Test/Fixtures/golden/module/fixity-operator.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/fixity-operator.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/forall-kinded-inferred-binder.yaml b/test/Test/Fixtures/golden/module/forall-kinded-inferred-binder.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/forall-kinded-inferred-binder.yaml @@ -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"}])]} diff --git a/test/Test/Fixtures/golden/module/gadt-promoted-cons-operator.yaml b/test/Test/Fixtures/golden/module/gadt-promoted-cons-operator.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/gadt-promoted-cons-operator.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/guard-expression-type-signature.yaml b/test/Test/Fixtures/golden/module/guard-expression-type-signature.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/guard-expression-type-signature.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/guard-view-pattern.yaml b/test/Test/Fixtures/golden/module/guard-view-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/guard-view-pattern.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/implicit-module.yaml b/test/Test/Fixtures/golden/module/implicit-module.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/implicit-module.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/import-spec-bundled-data-members.yaml b/test/Test/Fixtures/golden/module/import-spec-bundled-data-members.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/import-spec-bundled-data-members.yaml @@ -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))]} diff --git a/test/Test/Fixtures/golden/module/import-spec-data-namespace.yaml b/test/Test/Fixtures/golden/module/import-spec-data-namespace.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/import-spec-data-namespace.yaml @@ -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))]} diff --git a/test/Test/Fixtures/golden/module/infix-app-prefix-minus.yaml b/test/Test/Fixtures/golden/module/infix-app-prefix-minus.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/infix-app-prefix-minus.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/infix-funlhs-minus-int-pattern.yaml b/test/Test/Fixtures/golden/module/infix-funlhs-minus-int-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/infix-funlhs-minus-int-pattern.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/infix-funlhs-minus-string-pattern.yaml b/test/Test/Fixtures/golden/module/infix-funlhs-minus-string-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/infix-funlhs-minus-string-pattern.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + M.H - "" = x +ast: |- + Module {[DeclValue (FunctionBind "-" [Match {MatchHeadInfix, [PCon "M" "H" [], PLit (LitString "")], EVar "x"}])]} +status: pass diff --git a/test/Test/Fixtures/golden/module/infix-funlhs-th-splice-pattern.yaml b/test/Test/Fixtures/golden/module/infix-funlhs-th-splice-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/infix-funlhs-th-splice-pattern.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/inlinable-pragma.yaml b/test/Test/Fixtures/golden/module/inlinable-pragma.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/inlinable-pragma.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + {-# INLINABLE w #-} +ast: |- + Module {[DeclPragma PragmaInline "INLINABLE" "w"]} +status: pass diff --git a/test/Test/Fixtures/golden/module/instance-infix-identifier-head.yaml b/test/Test/Fixtures/golden/module/instance-infix-identifier-head.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/instance-infix-identifier-head.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/instance-no-args.yaml b/test/Test/Fixtures/golden/module/instance-no-args.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/instance-no-args.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/instance-parenthesized-head-multiline.yaml b/test/Test/Fixtures/golden/module/instance-parenthesized-head-multiline.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/instance-parenthesized-head-multiline.yaml @@ -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"])}])]})]} diff --git a/test/Test/Fixtures/golden/module/instance-promoted-unit-infix-head.yaml b/test/Test/Fixtures/golden/module/instance-promoted-unit-infix-head.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/instance-promoted-unit-infix-head.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/javascript-ffi-imports.yaml b/test/Test/Fixtures/golden/module/javascript-ffi-imports.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/javascript-ffi-imports.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/lambda-case-unparenthesized-type-pattern.yaml b/test/Test/Fixtures/golden/module/lambda-case-unparenthesized-type-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/lambda-case-unparenthesized-type-pattern.yaml @@ -0,0 +1,5 @@ +extensions: [LambdaCase] +input: | + x = \case _ :: T -> () +status: fail +reason: GHC rejects unparenthesized pattern type signatures in case alternatives diff --git a/test/Test/Fixtures/golden/module/linear-types.yaml b/test/Test/Fixtures/golden/module/linear-types.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/linear-types.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/literate/bird-style-indented.yaml b/test/Test/Fixtures/golden/module/literate/bird-style-indented.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/literate/bird-style-indented.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/module/literate/bird-style-interleaved.yaml b/test/Test/Fixtures/golden/module/literate/bird-style-interleaved.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/literate/bird-style-interleaved.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/module/literate/bird-style.yaml b/test/Test/Fixtures/golden/module/literate/bird-style.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/literate/bird-style.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/module/literate/latex-style-interleaved.yaml b/test/Test/Fixtures/golden/module/literate/latex-style-interleaved.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/literate/latex-style-interleaved.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/module/literate/latex-style-with-other-envs.yaml b/test/Test/Fixtures/golden/module/literate/latex-style-with-other-envs.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/literate/latex-style-with-other-envs.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/module/literate/latex-style.yaml b/test/Test/Fixtures/golden/module/literate/latex-style.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/literate/latex-style.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/module/magic-hash-basic.yaml b/test/Test/Fixtures/golden/module/magic-hash-basic.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/magic-hash-basic.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/magichash-record-dot-bare.yaml b/test/Test/Fixtures/golden/module/magichash-record-dot-bare.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/magichash-record-dot-bare.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/minimal.yaml b/test/Test/Fixtures/golden/module/minimal.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/minimal.yaml @@ -0,0 +1,7 @@ +extensions: [] +input: | + module Demo where + x = 1 +ast: |- + Module {ModuleHead {"Demo"}, [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]} +status: pass diff --git a/test/Test/Fixtures/golden/module/missing-equals.yaml b/test/Test/Fixtures/golden/module/missing-equals.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/missing-equals.yaml @@ -0,0 +1,7 @@ +extensions: [] +input: | + module Demo where + x 1 +ast: |- +status: fail +reason: missing equals in declaration diff --git a/test/Test/Fixtures/golden/module/multiway-if-guard-bare-type-sig.yaml b/test/Test/Fixtures/golden/module/multiway-if-guard-bare-type-sig.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/multiway-if-guard-bare-type-sig.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/newtype-operator-field-polymorphic.yaml b/test/Test/Fixtures/golden/module/newtype-operator-field-polymorphic.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/newtype-operator-field-polymorphic.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/newtype-operator-field.yaml b/test/Test/Fixtures/golden/module/newtype-operator-field.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/newtype-operator-field.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + newtype T = MkT { ($$) :: Int } +ast: |- + Module {[DeclNewtype (NewtypeDecl {Prefix "T", RecordCon "MkT" [FieldDecl ["$$"] (TCon "Int")]})]} +status: pass diff --git a/test/Test/Fixtures/golden/module/parser-fuzz-data-deriving-empty.yaml b/test/Test/Fixtures/golden/module/parser-fuzz-data-deriving-empty.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/parser-fuzz-data-deriving-empty.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + data A deriving () +ast: |- + Module {[DeclData (DataDecl {Prefix "A", [DerivingClause {[]}]})]} +status: pass diff --git a/test/Test/Fixtures/golden/module/pattern-synonym-basic.yaml b/test/Test/Fixtures/golden/module/pattern-synonym-basic.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/pattern-synonym-basic.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/pragma/empty-pragma.yaml b/test/Test/Fixtures/golden/module/pragma/empty-pragma.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/pragma/empty-pragma.yaml @@ -0,0 +1,8 @@ +extensions: [] +input: | + {-##-} + module EmptyPragma where + x = 1 +ast: |- + Module {ModuleHead {"EmptyPragma"}, [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]} +status: pass diff --git a/test/Test/Fixtures/golden/module/pragma/language-no-cpp.yaml b/test/Test/Fixtures/golden/module/pragma/language-no-cpp.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/pragma/language-no-cpp.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/pragma/options-glasgow-exts-magic-hash.yaml b/test/Test/Fixtures/golden/module/pragma/options-glasgow-exts-magic-hash.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/pragma/options-glasgow-exts-magic-hash.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/prefix-pattern-qualifiers.yaml b/test/Test/Fixtures/golden/module/prefix-pattern-qualifiers.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/prefix-pattern-qualifiers.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/prelude-bool-reexports.yaml b/test/Test/Fixtures/golden/module/prelude-bool-reexports.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/prelude-bool-reexports.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/proc-arrow-simple.yaml b/test/Test/Fixtures/golden/module/proc-arrow-simple.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/proc-arrow-simple.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/proc-pattern-negative-literal.yaml b/test/Test/Fixtures/golden/module/proc-pattern-negative-literal.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/proc-pattern-negative-literal.yaml @@ -0,0 +1,5 @@ +extensions: [Arrows] +input: | + x = proc -0 -> a -<< a +status: fail +reason: unparenthesized proc binders must be atomic patterns diff --git a/test/Test/Fixtures/golden/module/promoted-parenthesized-qualified-name.yaml b/test/Test/Fixtures/golden/module/promoted-parenthesized-qualified-name.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/promoted-parenthesized-qualified-name.yaml @@ -0,0 +1,5 @@ +extensions: [DataKinds] +input: | + type T = '(M.A) +status: fail +reason: GHC rejects parenthesized promoted constructor names diff --git a/test/Test/Fixtures/golden/module/standalone-deriving-infix-paren-lhs.yaml b/test/Test/Fixtures/golden/module/standalone-deriving-infix-paren-lhs.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/standalone-deriving-infix-paren-lhs.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + deriving instance ((C) '()) :+ () +ast: |- + Module {[DeclStandaloneDeriving (StandaloneDerivingDecl {TInfix (TParen (TApp (TParen (TCon "C")) (TTuple Promoted []))) ":+" (TTuple [])})]} +status: pass diff --git a/test/Test/Fixtures/golden/module/standalone-deriving-no-args.yaml b/test/Test/Fixtures/golden/module/standalone-deriving-no-args.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/standalone-deriving-no-args.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + deriving instance Foo +ast: |- + Module {[DeclStandaloneDeriving (StandaloneDerivingDecl {TCon "Foo"})]} +status: pass diff --git a/test/Test/Fixtures/golden/module/string-gap-operator-continuation.yaml b/test/Test/Fixtures/golden/module/string-gap-operator-continuation.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/string-gap-operator-continuation.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/module/string-gap-where-layout.yaml b/test/Test/Fixtures/golden/module/string-gap-where-layout.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/string-gap-where-layout.yaml @@ -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. diff --git a/test/Test/Fixtures/golden/module/template-haskell-implicit-decl-splice.yaml b/test/Test/Fixtures/golden/module/template-haskell-implicit-decl-splice.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/template-haskell-implicit-decl-splice.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/template-haskell-operator-splice.yaml b/test/Test/Fixtures/golden/module/template-haskell-operator-splice.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/template-haskell-operator-splice.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/th-decl-quote-infix-head-bare-type-sig.yaml b/test/Test/Fixtures/golden/module/th-decl-quote-infix-head-bare-type-sig.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/th-decl-quote-infix-head-bare-type-sig.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/th-decl-quote-multi-decl.yaml b/test/Test/Fixtures/golden/module/th-decl-quote-multi-decl.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/th-decl-quote-multi-decl.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/th-name-quote-tuple-expression.yaml b/test/Test/Fixtures/golden/module/th-name-quote-tuple-expression.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/th-name-quote-tuple-expression.yaml @@ -0,0 +1,5 @@ +extensions: [TemplateHaskell] +input: | + x = '(A,B) +status: fail +reason: GHC rejects tuple expressions as Template Haskell name quote bodies diff --git a/test/Test/Fixtures/golden/module/th-pattern-quote-bare-type-sig.yaml b/test/Test/Fixtures/golden/module/th-pattern-quote-bare-type-sig.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/th-pattern-quote-bare-type-sig.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/th-splice-bare-block.yaml b/test/Test/Fixtures/golden/module/th-splice-bare-block.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/th-splice-bare-block.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/th-type-name-quote-wildcard.yaml b/test/Test/Fixtures/golden/module/th-type-name-quote-wildcard.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/th-type-name-quote-wildcard.yaml @@ -0,0 +1,5 @@ +extensions: [TemplateHaskell, PartialTypeSignatures] +input: | + x = '' _ +status: fail +reason: GHC rejects wildcard syntax as a TH type-name quote body diff --git a/test/Test/Fixtures/golden/module/th-typed-splice-bare-block.yaml b/test/Test/Fixtures/golden/module/th-typed-splice-bare-block.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/th-typed-splice-bare-block.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/type-equality-family-application.yaml b/test/Test/Fixtures/golden/module/type-equality-family-application.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/type-equality-family-application.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/type-family-instance-promoted-unit.yaml b/test/Test/Fixtures/golden/module/type-family-instance-promoted-unit.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/type-family-instance-promoted-unit.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/type-role-no-roles.yaml b/test/Test/Fixtures/golden/module/type-role-no-roles.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/type-role-no-roles.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + type role M +ast: |- + Module {[DeclRoleAnnotation (RoleAnnotation {UnqualifiedName {"M"}, []})]} +status: pass diff --git a/test/Test/Fixtures/golden/module/type-role-parenthesized-operator.yaml b/test/Test/Fixtures/golden/module/type-role-parenthesized-operator.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/type-role-parenthesized-operator.yaml @@ -0,0 +1,6 @@ +extensions: [GHC2021, RoleAnnotations] +input: | + type role (:=) nominal nominal +status: pass +ast: |- + Module {[DeclRoleAnnotation (RoleAnnotation {UnqualifiedName {":="}, [RoleNominal, RoleNominal]})]} diff --git a/test/Test/Fixtures/golden/module/type-sig-infix-star-no-star-is-type.yaml b/test/Test/Fixtures/golden/module/type-sig-infix-star-no-star-is-type.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/type-sig-infix-star-no-star-is-type.yaml @@ -0,0 +1,6 @@ +extensions: [NoStarIsType] +input: | + fn :: a * b +ast: |- + Module {[DeclTypeSig ["fn"] (TInfix (TVar "a") "*" (TVar "b"))]} +status: pass diff --git a/test/Test/Fixtures/golden/module/type-synonym-implicit-param.yaml b/test/Test/Fixtures/golden/module/type-synonym-implicit-param.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/type-synonym-implicit-param.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/type-synonym-star-no-star-is-type.yaml b/test/Test/Fixtures/golden/module/type-synonym-star-no-star-is-type.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/type-synonym-star-no-star-is-type.yaml @@ -0,0 +1,6 @@ +extensions: [NoStarIsType] +input: | + type X = (*) +ast: |- + Module {[DeclTypeSyn (TypeSynDecl {Prefix "X", TCon "*"})]} +status: pass diff --git a/test/Test/Fixtures/golden/module/type-synonym.yaml b/test/Test/Fixtures/golden/module/type-synonym.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/type-synonym.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/type-tuple-shorthand-defaults.yaml b/test/Test/Fixtures/golden/module/type-tuple-shorthand-defaults.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/type-tuple-shorthand-defaults.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/unboxed-tuples-basic.yaml b/test/Test/Fixtures/golden/module/unboxed-tuples-basic.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/unboxed-tuples-basic.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/unboxed-tuples-singleton.yaml b/test/Test/Fixtures/golden/module/unboxed-tuples-singleton.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/unboxed-tuples-singleton.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/module/warning-pragma.yaml b/test/Test/Fixtures/golden/module/warning-pragma.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/module/warning-pragma.yaml @@ -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))]} diff --git a/test/Test/Fixtures/golden/pattern/deep-view-pattern.yaml b/test/Test/Fixtures/golden/pattern/deep-view-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/deep-view-pattern.yaml @@ -0,0 +1,6 @@ +extensions: [ViewPatterns] +input: | + (a -> b -> c) +ast: |- + PParen (PView (EVar "a") (PView (EVar "b") (PVar "c"))) +status: pass diff --git a/test/Test/Fixtures/golden/pattern/list-deep-view-pattern.yaml b/test/Test/Fixtures/golden/pattern/list-deep-view-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/list-deep-view-pattern.yaml @@ -0,0 +1,6 @@ +extensions: [ViewPatterns] +input: | + [a -> b -> c] +ast: |- + PList [PView (EVar "a") (PView (EVar "b") (PVar "c"))] +status: pass diff --git a/test/Test/Fixtures/golden/pattern/mdo-view-pattern.yaml b/test/Test/Fixtures/golden/pattern/mdo-view-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/mdo-view-pattern.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/pattern/paren-backtick-con-infix.yaml b/test/Test/Fixtures/golden/pattern/paren-backtick-con-infix.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/paren-backtick-con-infix.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (x `Cons` xs) +ast: |- + PParen (PInfix (PVar "x") "Cons" (PVar "xs")) +status: pass diff --git a/test/Test/Fixtures/golden/pattern/paren-con-infix.yaml b/test/Test/Fixtures/golden/pattern/paren-con-infix.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/paren-con-infix.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (a :+: b) +ast: |- + PParen (PInfix (PVar "a") ":+:" (PVar "b")) +status: pass diff --git a/test/Test/Fixtures/golden/pattern/paren-consym-double.yaml b/test/Test/Fixtures/golden/pattern/paren-consym-double.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/paren-consym-double.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + ((:+)) +ast: |- + PParen (PCon ":+" []) +status: pass diff --git a/test/Test/Fixtures/golden/pattern/paren-neg-literal.yaml b/test/Test/Fixtures/golden/pattern/paren-neg-literal.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/paren-neg-literal.yaml @@ -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". diff --git a/test/Test/Fixtures/golden/pattern/paren-nested-as.yaml b/test/Test/Fixtures/golden/pattern/paren-nested-as.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/paren-nested-as.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/pattern/paren-single.yaml b/test/Test/Fixtures/golden/pattern/paren-single.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/paren-single.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (a) +ast: |- + PParen (PVar "a") +status: pass diff --git a/test/Test/Fixtures/golden/pattern/paren-varsym-single.yaml b/test/Test/Fixtures/golden/pattern/paren-varsym-single.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/paren-varsym-single.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (+) +ast: |- + PVar "+" +status: pass diff --git a/test/Test/Fixtures/golden/pattern/record-field-view-pattern.yaml b/test/Test/Fixtures/golden/pattern/record-field-view-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/record-field-view-pattern.yaml @@ -0,0 +1,6 @@ +extensions: [ViewPatterns] +input: | + Box {field = id -> x} +ast: |- + PRecord "Box" {"field" = PView (EVar "id") (PVar "x")} +status: pass diff --git a/test/Test/Fixtures/golden/pattern/tuple-nested-view-patterns.yaml b/test/Test/Fixtures/golden/pattern/tuple-nested-view-patterns.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/tuple-nested-view-patterns.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/pattern/tuple-pair.yaml b/test/Test/Fixtures/golden/pattern/tuple-pair.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/tuple-pair.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (a,b) +ast: |- + PTuple [PVar "a", PVar "b"] +status: pass diff --git a/test/Test/Fixtures/golden/pattern/tuple-strict-irrefutable.yaml b/test/Test/Fixtures/golden/pattern/tuple-strict-irrefutable.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/tuple-strict-irrefutable.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: | + (!a, ~b) +ast: |- + PTuple [PStrict (PVar "a"), PIrrefutable (PVar "b")] +status: pass diff --git a/test/Test/Fixtures/golden/pattern/unboxed-sum-first.yaml b/test/Test/Fixtures/golden/pattern/unboxed-sum-first.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/unboxed-sum-first.yaml @@ -0,0 +1,6 @@ +extensions: [UnboxedSums] +input: | + (# a | #) +ast: |- + PUnboxedSum 0 2 PVar "a" +status: pass diff --git a/test/Test/Fixtures/golden/pattern/unboxed-sum-second.yaml b/test/Test/Fixtures/golden/pattern/unboxed-sum-second.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/unboxed-sum-second.yaml @@ -0,0 +1,6 @@ +extensions: [UnboxedSums] +input: | + (# | a #) +ast: |- + PUnboxedSum 1 2 PVar "a" +status: pass diff --git a/test/Test/Fixtures/golden/pattern/unboxed-sum-view-as.yaml b/test/Test/Fixtures/golden/pattern/unboxed-sum-view-as.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/unboxed-sum-view-as.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/pattern/unboxed-sum-wildcard-middle.yaml b/test/Test/Fixtures/golden/pattern/unboxed-sum-wildcard-middle.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/unboxed-sum-wildcard-middle.yaml @@ -0,0 +1,6 @@ +extensions: [UnboxedSums] +input: | + (# | _ | #) +ast: |- + PUnboxedSum 1 3 PWildcard +status: pass diff --git a/test/Test/Fixtures/golden/pattern/unboxed-tuple-pair.yaml b/test/Test/Fixtures/golden/pattern/unboxed-tuple-pair.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/unboxed-tuple-pair.yaml @@ -0,0 +1,6 @@ +extensions: [UnboxedTuples] +input: | + (# a, b #) +ast: |- + PTuple Unboxed [PVar "a", PVar "b"] +status: pass diff --git a/test/Test/Fixtures/golden/pattern/unboxed-tuple-singleton.yaml b/test/Test/Fixtures/golden/pattern/unboxed-tuple-singleton.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/unboxed-tuple-singleton.yaml @@ -0,0 +1,6 @@ +extensions: [UnboxedTuples] +input: | + (# x #) +ast: |- + PTuple Unboxed [PVar "x"] +status: pass diff --git a/test/Test/Fixtures/golden/pattern/unboxed-tuple-view-wildcard.yaml b/test/Test/Fixtures/golden/pattern/unboxed-tuple-view-wildcard.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/unboxed-tuple-view-wildcard.yaml @@ -0,0 +1,6 @@ +extensions: [UnboxedTuples, ViewPatterns] +input: | + (# (== 0) -> True, _ #) +ast: |- + PTuple Unboxed [PView (EParen (ESectionR "==" (EInt 0 TInteger))) (PCon "True" []), PWildcard] +status: pass diff --git a/test/Test/Fixtures/golden/pattern/view-infix-function.yaml b/test/Test/Fixtures/golden/pattern/view-infix-function.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/view-infix-function.yaml @@ -0,0 +1,6 @@ +extensions: [ViewPatterns] +input: | + (f . g -> x) +ast: |- + PParen (PView (EInfix (EVar "f") "." (EVar "g")) (PVar "x")) +status: pass diff --git a/test/Test/Fixtures/golden/pattern/view-pattern-section.yaml b/test/Test/Fixtures/golden/pattern/view-pattern-section.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/view-pattern-section.yaml @@ -0,0 +1,6 @@ +extensions: [ViewPatterns] +input: | + ((== 0) -> True) +ast: |- + PParen (PView (EParen (ESectionR "==" (EInt 0 TInteger))) (PCon "True" [])) +status: pass diff --git a/test/Test/Fixtures/golden/pragma/language-leading-comma.yaml b/test/Test/Fixtures/golden/pragma/language-leading-comma.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pragma/language-leading-comma.yaml @@ -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 diff --git a/test/Test/Fixtures/golden/pragma/language-multiple-multiline.yaml b/test/Test/Fixtures/golden/pragma/language-multiple-multiline.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pragma/language-multiple-multiline.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/comments/arrow-operator-in-expr.yaml b/test/Test/Fixtures/lexer/comments/arrow-operator-in-expr.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/comments/arrow-operator-in-expr.yaml @@ -0,0 +1,9 @@ +extensions: [] +input: | + x --> y +tokens: + - 'TkVarId "x"' + - 'TkVarSym "-->"' + - 'TkVarId "y"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/comments/comment-between-identifiers.yaml b/test/Test/Fixtures/lexer/comments/comment-between-identifiers.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/comments/comment-between-identifiers.yaml @@ -0,0 +1,10 @@ +extensions: [] +input: | + x -- comment + y +tokens: + - 'TkVarId "x"' + - 'TkLineComment' + - 'TkVarId "y"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/comments/dash-dash-backtick-operator.yaml b/test/Test/Fixtures/lexer/comments/dash-dash-backtick-operator.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/comments/dash-dash-backtick-operator.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "--`" +tokens: + - 'TkLineComment' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/comments/dash-dash-dollar-operator.yaml b/test/Test/Fixtures/lexer/comments/dash-dash-dollar-operator.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/comments/dash-dash-dollar-operator.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "--$" +tokens: + - 'TkVarSym "--$"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/comments/dash-dash-foo-comment.yaml b/test/Test/Fixtures/lexer/comments/dash-dash-foo-comment.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/comments/dash-dash-foo-comment.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "--foo" +tokens: + - 'TkLineComment' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/comments/dash-dash-gt-operator.yaml b/test/Test/Fixtures/lexer/comments/dash-dash-gt-operator.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/comments/dash-dash-gt-operator.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "-->" +tokens: + - 'TkVarSym "-->"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/comments/nested-block-comment.yaml b/test/Test/Fixtures/lexer/comments/nested-block-comment.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/comments/nested-block-comment.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "{- outer {- inner -} outer -}" +tokens: + - 'TkBlockComment' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/comments/pipe-dash-dash-operator.yaml b/test/Test/Fixtures/lexer/comments/pipe-dash-dash-operator.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/comments/pipe-dash-dash-operator.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "|--" +tokens: + - 'TkVarSym "|--"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/comments/quadruple-dash-comment.yaml b/test/Test/Fixtures/lexer/comments/quadruple-dash-comment.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/comments/quadruple-dash-comment.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "----" +tokens: + - 'TkLineComment' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/comments/simple-line-comment.yaml b/test/Test/Fixtures/lexer/comments/simple-line-comment.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/comments/simple-line-comment.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "-- simple comment" +tokens: + - 'TkLineComment' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/comments/triple-dash-comment.yaml b/test/Test/Fixtures/lexer/comments/triple-dash-comment.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/comments/triple-dash-comment.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "---" +tokens: + - 'TkLineComment' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/arrows-or-section.yaml b/test/Test/Fixtures/lexer/core/arrows-or-section.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/arrows-or-section.yaml @@ -0,0 +1,10 @@ +extensions: + - Arrows +input: "(|| True)" +tokens: + - 'TkSpecialLParen' + - 'TkVarSym "||"' + - 'TkConId "True"' + - 'TkSpecialRParen' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/char-literal-too-long.yaml b/test/Test/Fixtures/lexer/core/char-literal-too-long.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/char-literal-too-long.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "'ab'" +tokens: + - 'TkError "invalid char literal"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/hex-fractional-no-exponent.yaml b/test/Test/Fixtures/lexer/core/hex-fractional-no-exponent.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/hex-fractional-no-exponent.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "0x5e.a" +tokens: + - 'TkFloat 94.625 TFractional' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/multiline-escaped-triple-quote.yaml b/test/Test/Fixtures/lexer/core/multiline-escaped-triple-quote.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/multiline-escaped-triple-quote.yaml @@ -0,0 +1,9 @@ +extensions: [MultilineStrings] +input: | + """ + \"\"\" + """ +tokens: + - 'TkString "\"\"\""' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/multiline-string-gap-before-close.yaml b/test/Test/Fixtures/lexer/core/multiline-string-gap-before-close.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/multiline-string-gap-before-close.yaml @@ -0,0 +1,11 @@ +extensions: [MultilineStrings] +input: | + """ + Line 1 + Line 2 + Line 3\ + \""" +tokens: + - 'TkString "Line 1\nLine 2\nLine 3"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/multiline-unescaped-quotes.yaml b/test/Test/Fixtures/lexer/core/multiline-unescaped-quotes.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/multiline-unescaped-quotes.yaml @@ -0,0 +1,9 @@ +extensions: [MultilineStrings] +input: | + """ + "Hello" + """ +tokens: + - 'TkString "\"Hello\""' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/negative-binary-integer.yaml b/test/Test/Fixtures/lexer/core/negative-binary-integer.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/negative-binary-integer.yaml @@ -0,0 +1,8 @@ +# Negative binary integer with NegativeLiterals extension +extensions: + - NegativeLiterals +input: "-0b101" +tokens: + - 'TkInteger -5 TInteger' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/negative-hex-float.yaml b/test/Test/Fixtures/lexer/core/negative-hex-float.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/negative-hex-float.yaml @@ -0,0 +1,8 @@ +# Negative hex float with NegativeLiterals extension +extensions: + - NegativeLiterals +input: "-0x1p2" +tokens: + - 'TkFloat -4.0 TFractional' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/negative-hex-integer.yaml b/test/Test/Fixtures/lexer/core/negative-hex-integer.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/negative-hex-integer.yaml @@ -0,0 +1,8 @@ +# Negative hex integer with NegativeLiterals extension +extensions: + - NegativeLiterals +input: "-0x10" +tokens: + - 'TkInteger -16 TInteger' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/negative-magic-hash-double.yaml b/test/Test/Fixtures/lexer/core/negative-magic-hash-double.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/negative-magic-hash-double.yaml @@ -0,0 +1,7 @@ +extensions: + - MagicHash +input: "-2.5##" +tokens: + - 'TkFloat (-5 % 2) TDoubleHash' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/negative-magic-hash-float.yaml b/test/Test/Fixtures/lexer/core/negative-magic-hash-float.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/negative-magic-hash-float.yaml @@ -0,0 +1,7 @@ +extensions: + - MagicHash +input: "-3.14#" +tokens: + - 'TkFloat (-157 % 50) TFloatHash' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/negative-magic-hash-int.yaml b/test/Test/Fixtures/lexer/core/negative-magic-hash-int.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/negative-magic-hash-int.yaml @@ -0,0 +1,7 @@ +extensions: + - MagicHash +input: "-1#" +tokens: + - 'TkInteger (-1) TIntHash' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/negative-magic-hash-no-merge-plain.yaml b/test/Test/Fixtures/lexer/core/negative-magic-hash-no-merge-plain.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/negative-magic-hash-no-merge-plain.yaml @@ -0,0 +1,8 @@ +extensions: + - MagicHash +input: "-1" +tokens: + - 'TkVarSym "-"' + - 'TkInteger 1 TInteger' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/negative-octal-integer.yaml b/test/Test/Fixtures/lexer/core/negative-octal-integer.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/negative-octal-integer.yaml @@ -0,0 +1,8 @@ +# Negative octal integer with NegativeLiterals extension +extensions: + - NegativeLiterals +input: "-0o17" +tokens: + - 'TkInteger -15 TInteger' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/negative-with-extension.yaml b/test/Test/Fixtures/lexer/core/negative-with-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/negative-with-extension.yaml @@ -0,0 +1,7 @@ +extensions: + - NegativeLiterals +input: "-10" +tokens: + - 'TkInteger (-10) TInteger' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/negative-without-extension.yaml b/test/Test/Fixtures/lexer/core/negative-without-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/negative-without-extension.yaml @@ -0,0 +1,7 @@ +extensions: [] +input: "-10" +tokens: + - 'TkVarSym "-"' + - 'TkInteger 10 TInteger' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/nested-let-layout-in.yaml b/test/Test/Fixtures/lexer/core/nested-let-layout-in.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/nested-let-layout-in.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/core/promoted-type-without-datakinds.yaml b/test/Test/Fixtures/lexer/core/promoted-type-without-datakinds.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/promoted-type-without-datakinds.yaml @@ -0,0 +1,7 @@ +extensions: [] +input: "'True" +tokens: + - "TkVarSym \"'\"" + - "TkConId \"True\"" + - "TkEOF" +status: pass diff --git a/test/Test/Fixtures/lexer/core/qualified-consym.yaml b/test/Test/Fixtures/lexer/core/qualified-consym.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/qualified-consym.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "Data.List.:++" +tokens: + - 'TkQConSym "Data.List" ":++"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/qualified-varsym-deep.yaml b/test/Test/Fixtures/lexer/core/qualified-varsym-deep.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/qualified-varsym-deep.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "A.B.C.++" +tokens: + - 'TkQVarSym "A.B.C" "++"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/qualified-varsym.yaml b/test/Test/Fixtures/lexer/core/qualified-varsym.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/qualified-varsym.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "Prelude.+" +tokens: + - 'TkQVarSym "Prelude" "+"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/shebang-leading-space.yaml b/test/Test/Fixtures/lexer/core/shebang-leading-space.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/shebang-leading-space.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/core/shebang-leading.yaml b/test/Test/Fixtures/lexer/core/shebang-leading.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/shebang-leading.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/core/string-escaped-quote.yaml b/test/Test/Fixtures/lexer/core/string-escaped-quote.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/string-escaped-quote.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: '"a\"b"' +tokens: + - 'TkString "a\"b"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/string-gap-before-close.yaml b/test/Test/Fixtures/lexer/core/string-gap-before-close.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/string-gap-before-close.yaml @@ -0,0 +1,7 @@ +extensions: [] +input: '"\ + \"' +tokens: + - 'TkString ""' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/string-gap-before-escape-looking-char.yaml b/test/Test/Fixtures/lexer/core/string-gap-before-escape-looking-char.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/string-gap-before-escape-looking-char.yaml @@ -0,0 +1,7 @@ +extensions: [] +input: '"\ + \c"' +tokens: + - 'TkString "c"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/string-gap-mid-body.yaml b/test/Test/Fixtures/lexer/core/string-gap-mid-body.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/string-gap-mid-body.yaml @@ -0,0 +1,7 @@ +extensions: [] +input: '"ab\ + \cd"' +tokens: + - 'TkString "abcd"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/template-haskell-type-quote-spaced-name.yaml b/test/Test/Fixtures/lexer/core/template-haskell-type-quote-spaced-name.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/template-haskell-type-quote-spaced-name.yaml @@ -0,0 +1,10 @@ +extensions: + - TemplateHaskell +input: "x = '' name" +tokens: + - 'TkVarId "x"' + - 'TkReservedEquals' + - 'TkTHTypeQuoteTick' + - 'TkVarId "name"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/unterminated-string.yaml b/test/Test/Fixtures/lexer/core/unterminated-string.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/unterminated-string.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: '"unterminated' +tokens: + - 'TkError "unterminated string literal"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/layout/do-if-then-else-at-layout.yaml b/test/Test/Fixtures/lexer/layout/do-if-then-else-at-layout.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/layout/do-if-then-else-at-layout.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/layout/then-do-single-stmt.yaml b/test/Test/Fixtures/lexer/layout/then-do-single-stmt.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/layout/then-do-single-stmt.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/layout/where-tabs-after-else.yaml b/test/Test/Fixtures/lexer/layout/where-tabs-after-else.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/layout/where-tabs-after-else.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/module/empty-module.yaml b/test/Test/Fixtures/lexer/module/empty-module.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/module/empty-module.yaml @@ -0,0 +1,7 @@ +extensions: [] +input: "" +tokens: + - 'TkSpecialLBrace' + - 'TkSpecialRBrace' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/module/module-header-empty-body.yaml b/test/Test/Fixtures/lexer/module/module-header-empty-body.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/module/module-header-empty-body.yaml @@ -0,0 +1,10 @@ +extensions: [] +input: "module Demo where" +tokens: + - 'TkKeywordModule' + - 'TkConId "Demo"' + - 'TkKeywordWhere' + - 'TkSpecialLBrace' + - 'TkSpecialRBrace' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/module/shebang-middle.yaml b/test/Test/Fixtures/lexer/module/shebang-middle.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/module/shebang-middle.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/binary-double-underscore.yaml b/test/Test/Fixtures/lexer/numeric-underscores/binary-double-underscore.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/binary-double-underscore.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/binary-packbits.yaml b/test/Test/Fixtures/lexer/numeric-underscores/binary-packbits.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/binary-packbits.yaml @@ -0,0 +1,7 @@ +extensions: + - NumericUnderscores +input: "0b1_11_01_0000_0_111" +tokens: + - 'TkInteger 7431 TInteger' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/numeric-underscores/binary-with-extension.yaml b/test/Test/Fixtures/lexer/numeric-underscores/binary-with-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/binary-with-extension.yaml @@ -0,0 +1,7 @@ +extensions: + - NumericUnderscores +input: "0b01_0000_0000" +tokens: + - 'TkInteger 256 TInteger' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/numeric-underscores/binary-without-extension.yaml b/test/Test/Fixtures/lexer/numeric-underscores/binary-without-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/binary-without-extension.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/decimal-double-underscore.yaml b/test/Test/Fixtures/lexer/numeric-underscores/decimal-double-underscore.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/decimal-double-underscore.yaml @@ -0,0 +1,8 @@ +# Double underscore is valid per GHC NumericUnderscores +extensions: + - NumericUnderscores +input: "1__000000" +tokens: + - 'TkInteger 1000000 TInteger' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/numeric-underscores/decimal-invalid-leading-underscore.yaml b/test/Test/Fixtures/lexer/numeric-underscores/decimal-invalid-leading-underscore.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/decimal-invalid-leading-underscore.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/decimal-trailing-underscore-invalid.yaml b/test/Test/Fixtures/lexer/numeric-underscores/decimal-trailing-underscore-invalid.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/decimal-trailing-underscore-invalid.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/decimal-with-extension.yaml b/test/Test/Fixtures/lexer/numeric-underscores/decimal-with-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/decimal-with-extension.yaml @@ -0,0 +1,7 @@ +extensions: + - NumericUnderscores +input: "1_000_000" +tokens: + - 'TkInteger 1000000 TInteger' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/numeric-underscores/decimal-without-extension.yaml b/test/Test/Fixtures/lexer/numeric-underscores/decimal-without-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/decimal-without-extension.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/float-avogadro.yaml b/test/Test/Fixtures/lexer/numeric-underscores/float-avogadro.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/float-avogadro.yaml @@ -0,0 +1,7 @@ +extensions: + - NumericUnderscores +input: "6.022_140_857e+23" +tokens: + - 'TkFloat 6.022140857e23 TFractional' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/numeric-underscores/float-exp-double-underscore-before-e.yaml b/test/Test/Fixtures/lexer/numeric-underscores/float-exp-double-underscore-before-e.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/float-exp-double-underscore-before-e.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/float-exp-underscore-before-e.yaml b/test/Test/Fixtures/lexer/numeric-underscores/float-exp-underscore-before-e.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/float-exp-underscore-before-e.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/float-faraday.yaml b/test/Test/Fixtures/lexer/numeric-underscores/float-faraday.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/float-faraday.yaml @@ -0,0 +1,7 @@ +extensions: + - NumericUnderscores +input: "96_485.332_89" +tokens: + - 'TkFloat 96485.33289 TFractional' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-trailing-underscore-exp.yaml b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-trailing-underscore-exp.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-trailing-underscore-exp.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-trailing-underscore.yaml b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-trailing-underscore.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-trailing-underscore.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-dot.yaml b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-dot.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-dot.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-e-no-sign.yaml b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-e-no-sign.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-e-no-sign.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-e.yaml b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-e.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-e.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-sign.yaml b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-sign.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-after-sign.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-before-dot.yaml b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-before-dot.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/float-invalid-underscore-before-dot.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/float-pi-with-extension.yaml b/test/Test/Fixtures/lexer/numeric-underscores/float-pi-with-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/float-pi-with-extension.yaml @@ -0,0 +1,7 @@ +extensions: + - NumericUnderscores +input: "3.141_592_653_589_793" +tokens: + - 'TkFloat 3.141592653589793 TFractional' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/numeric-underscores/float-pi-without-extension.yaml b/test/Test/Fixtures/lexer/numeric-underscores/float-pi-without-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/float-pi-without-extension.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/hex-double-leading-underscore.yaml b/test/Test/Fixtures/lexer/numeric-underscores/hex-double-leading-underscore.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/hex-double-leading-underscore.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/hex-leading-underscore.yaml b/test/Test/Fixtures/lexer/numeric-underscores/hex-leading-underscore.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/hex-leading-underscore.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/hex-with-extension.yaml b/test/Test/Fixtures/lexer/numeric-underscores/hex-with-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/hex-with-extension.yaml @@ -0,0 +1,7 @@ +extensions: + - NumericUnderscores +input: "0xff_00_00" +tokens: + - 'TkInteger 16711680 TInteger' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/numeric-underscores/hex-without-extension.yaml b/test/Test/Fixtures/lexer/numeric-underscores/hex-without-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/hex-without-extension.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/magic-hash-double-suffix.yaml b/test/Test/Fixtures/lexer/numeric-underscores/magic-hash-double-suffix.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/magic-hash-double-suffix.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/numeric-underscores/octal-with-extension.yaml b/test/Test/Fixtures/lexer/numeric-underscores/octal-with-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/octal-with-extension.yaml @@ -0,0 +1,8 @@ +# Octal literal with underscores +extensions: + - NumericUnderscores +input: "0o777_777" +tokens: + - 'TkInteger 262143 TInteger' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/numeric-underscores/octal-without-extension.yaml b/test/Test/Fixtures/lexer/numeric-underscores/octal-without-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/numeric-underscores/octal-without-extension.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/overloaded-labels/basic.yaml b/test/Test/Fixtures/lexer/overloaded-labels/basic.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/overloaded-labels/basic.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/pragma/language-leading-comma.yaml b/test/Test/Fixtures/lexer/pragma/language-leading-comma.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/pragma/language-leading-comma.yaml @@ -0,0 +1,11 @@ +extensions: [] +input: | + {-# LANGUAGE + DataKinds + , DeriveGeneric + , DeriveDataTypeable + #-} +tokens: + - 'TkPragma (PragmaLanguage [EnableExtension DataKinds, EnableExtension DeriveGeneric, EnableExtension DeriveDataTypeable])' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/pragma/language-multiline.yaml b/test/Test/Fixtures/lexer/pragma/language-multiline.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/pragma/language-multiline.yaml @@ -0,0 +1,10 @@ +extensions: [] +input: | + {-# LANGUAGE + BangPatterns, + GADTs + #-} +tokens: + - 'TkPragma (PragmaLanguage [EnableExtension BangPatterns, EnableExtension GADTs])' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/symbols/dollar-backtick-dollar.yaml b/test/Test/Fixtures/lexer/symbols/dollar-backtick-dollar.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/symbols/dollar-backtick-dollar.yaml @@ -0,0 +1,8 @@ +extensions: [] +input: "$`$" +tokens: + - 'TkVarSym "$"' + - 'TkSpecialBacktick' + - 'TkVarSym "$"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/symbols/promoted-operator-with-space.yaml b/test/Test/Fixtures/lexer/symbols/promoted-operator-with-space.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/symbols/promoted-operator-with-space.yaml @@ -0,0 +1,8 @@ +extensions: + - DataKinds +input: "' :<>:" +tokens: + - "TkVarSym \"'\"" + - "TkConSym \":<>:\"" + - "TkEOF" +status: pass diff --git a/test/Test/Fixtures/lexer/symbols/unicode-em-dash-operator.yaml b/test/Test/Fixtures/lexer/symbols/unicode-em-dash-operator.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/symbols/unicode-em-dash-operator.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "——" +tokens: + - 'TkVarSym "——"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/symbols/unicode-en-dash-operator.yaml b/test/Test/Fixtures/lexer/symbols/unicode-en-dash-operator.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/symbols/unicode-en-dash-operator.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "–" +tokens: + - 'TkVarSym "–"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/symbols/unicode-undertie-operator.yaml b/test/Test/Fixtures/lexer/symbols/unicode-undertie-operator.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/symbols/unicode-undertie-operator.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "‿" +tokens: + - 'TkVarSym "‿"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-identifiers/accented-latin.yaml b/test/Test/Fixtures/lexer/unicode-identifiers/accented-latin.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-identifiers/accented-latin.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "café" +tokens: + - 'TkVarId "café"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-identifiers/greek-lowercase.yaml b/test/Test/Fixtures/lexer/unicode-identifiers/greek-lowercase.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-identifiers/greek-lowercase.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "αβγ" +tokens: + - 'TkVarId "αβγ"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-identifiers/greek-uppercase.yaml b/test/Test/Fixtures/lexer/unicode-identifiers/greek-uppercase.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-identifiers/greek-uppercase.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "Σtype" +tokens: + - 'TkConId "Σtype"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-identifiers/mixed-unicode-ascii.yaml b/test/Test/Fixtures/lexer/unicode-identifiers/mixed-unicode-ascii.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-identifiers/mixed-unicode-ascii.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "naïve" +tokens: + - 'TkVarId "naïve"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-identifiers/titlecase.yaml b/test/Test/Fixtures/lexer/unicode-identifiers/titlecase.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-identifiers/titlecase.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "Džfoo" +tokens: + - 'TkConId "Džfoo"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-identifiers/unicode-start-with-tail.yaml b/test/Test/Fixtures/lexer/unicode-identifiers/unicode-start-with-tail.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-identifiers/unicode-start-with-tail.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "λ123" +tokens: + - 'TkVarId "λ123"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/arrow-tail-left.yaml b/test/Test/Fixtures/lexer/unicode-syntax/arrow-tail-left.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/arrow-tail-left.yaml @@ -0,0 +1,7 @@ +extensions: + - UnicodeSyntax +input: "⤙" +tokens: + - 'TkVarSym "-<"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/arrow-tail-right.yaml b/test/Test/Fixtures/lexer/unicode-syntax/arrow-tail-right.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/arrow-tail-right.yaml @@ -0,0 +1,7 @@ +extensions: + - UnicodeSyntax +input: "⤚" +tokens: + - 'TkVarSym ">-"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/banana-brackets.yaml b/test/Test/Fixtures/lexer/unicode-syntax/banana-brackets.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/banana-brackets.yaml @@ -0,0 +1,9 @@ +extensions: + - UnicodeSyntax +input: "⦇ x ⦈" +tokens: + - 'TkVarSym "(|"' + - 'TkVarId "x"' + - 'TkVarSym "|)"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/double-arrow-tail-left.yaml b/test/Test/Fixtures/lexer/unicode-syntax/double-arrow-tail-left.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/double-arrow-tail-left.yaml @@ -0,0 +1,7 @@ +extensions: + - UnicodeSyntax +input: "⤛" +tokens: + - 'TkVarSym "-<<"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/double-arrow-tail-right.yaml b/test/Test/Fixtures/lexer/unicode-syntax/double-arrow-tail-right.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/double-arrow-tail-right.yaml @@ -0,0 +1,7 @@ +extensions: + - UnicodeSyntax +input: "⤜" +tokens: + - 'TkVarSym ">>-"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/double-arrow.yaml b/test/Test/Fixtures/lexer/unicode-syntax/double-arrow.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/double-arrow.yaml @@ -0,0 +1,10 @@ +extensions: + - UnicodeSyntax +input: "Eq a ⇒ a" +tokens: + - 'TkConId "Eq"' + - 'TkVarId "a"' + - 'TkReservedDoubleArrow' + - 'TkVarId "a"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/double-colon.yaml b/test/Test/Fixtures/lexer/unicode-syntax/double-colon.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/double-colon.yaml @@ -0,0 +1,9 @@ +extensions: + - UnicodeSyntax +input: "x ∷ Int" +tokens: + - 'TkVarId "x"' + - 'TkReservedDoubleColon' + - 'TkConId "Int"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/forall.yaml b/test/Test/Fixtures/lexer/unicode-syntax/forall.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/forall.yaml @@ -0,0 +1,8 @@ +extensions: + - UnicodeSyntax +input: "∀ a" +tokens: + - "TkKeywordForall" + - 'TkVarId "a"' + - "TkEOF" +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/full-signature.yaml b/test/Test/Fixtures/lexer/unicode-syntax/full-signature.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/full-signature.yaml @@ -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 diff --git a/test/Test/Fixtures/lexer/unicode-syntax/left-arrow.yaml b/test/Test/Fixtures/lexer/unicode-syntax/left-arrow.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/left-arrow.yaml @@ -0,0 +1,9 @@ +extensions: + - UnicodeSyntax +input: "x ← y" +tokens: + - 'TkVarId "x"' + - 'TkReservedLeftArrow' + - 'TkVarId "y"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/linear-arrow.yaml b/test/Test/Fixtures/lexer/unicode-syntax/linear-arrow.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/linear-arrow.yaml @@ -0,0 +1,7 @@ +extensions: + - UnicodeSyntax +input: "⊸" +tokens: + - 'TkLinearArrow' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/no-extension.yaml b/test/Test/Fixtures/lexer/unicode-syntax/no-extension.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/no-extension.yaml @@ -0,0 +1,6 @@ +extensions: [] +input: "∷" +tokens: + - 'TkVarSym "∷"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/right-arrow.yaml b/test/Test/Fixtures/lexer/unicode-syntax/right-arrow.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/right-arrow.yaml @@ -0,0 +1,9 @@ +extensions: + - UnicodeSyntax +input: "a → b" +tokens: + - 'TkVarId "a"' + - 'TkReservedRightArrow' + - 'TkVarId "b"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/semantic-brackets.yaml b/test/Test/Fixtures/lexer/unicode-syntax/semantic-brackets.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/semantic-brackets.yaml @@ -0,0 +1,9 @@ +extensions: + - UnicodeSyntax +input: "⟦ x ⟧" +tokens: + - 'TkVarSym "[|"' + - 'TkVarId "x"' + - 'TkVarSym "|]"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/unicode-syntax/star.yaml b/test/Test/Fixtures/lexer/unicode-syntax/star.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/unicode-syntax/star.yaml @@ -0,0 +1,7 @@ +extensions: + - UnicodeSyntax +input: "★" +tokens: + - 'TkVarSym "★"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/oracle/Arrows/case-nested-do-tuple-bind.hs b/test/Test/Fixtures/oracle/Arrows/case-nested-do-tuple-bind.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/case-nested-do-tuple-bind.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Arrows/command-infix-bnf-operands.hs b/test/Test/Fixtures/oracle/Arrows/command-infix-bnf-operands.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/command-infix-bnf-operands.hs @@ -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 } diff --git a/test/Test/Fixtures/oracle/Arrows/conditional-if-then-else.hs b/test/Test/Fixtures/oracle/Arrows/conditional-if-then-else.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/conditional-if-then-else.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Arrows/conditional-nested.hs b/test/Test/Fixtures/oracle/Arrows/conditional-nested.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/conditional-nested.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Arrows/do.hs b/test/Test/Fixtures/oracle/Arrows/do.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/do.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Arrows #-} +module Do where + +f g h = proc x -> do + y <- g -< x + h -< y diff --git a/test/Test/Fixtures/oracle/Arrows/infix-expression-arrow-lhs.hs b/test/Test/Fixtures/oracle/Arrows/infix-expression-arrow-lhs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/infix-expression-arrow-lhs.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Arrows #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +module M where + +f = proc x -> [] `a` [] -< let y = (# #) in 846# diff --git a/test/Test/Fixtures/oracle/Arrows/infix-in-do.hs b/test/Test/Fixtures/oracle/Arrows/infix-in-do.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/infix-in-do.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Arrows/infix-simple.hs b/test/Test/Fixtures/oracle/Arrows/infix-simple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/infix-simple.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/Arrows/negated-proc.hs b/test/Test/Fixtures/oracle/Arrows/negated-proc.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/negated-proc.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Arrows #-} +module NegatedProc where + +x = - proc _ -> a -<< () diff --git a/test/Test/Fixtures/oracle/Arrows/operator-dollar-left-of-arrow.hs b/test/Test/Fixtures/oracle/Arrows/operator-dollar-left-of-arrow.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/operator-dollar-left-of-arrow.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Arrows/operator-fat-arrow-left.hs b/test/Test/Fixtures/oracle/Arrows/operator-fat-arrow-left.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/operator-fat-arrow-left.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Arrows #-} +module ArrowOperatorFatArrowLeft where + +import Control.Arrow + +f g = proc x -> g -< x diff --git a/test/Test/Fixtures/oracle/Arrows/operator-fat-arrow-right.hs b/test/Test/Fixtures/oracle/Arrows/operator-fat-arrow-right.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/operator-fat-arrow-right.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Arrows/operator-or-section.hs b/test/Test/Fixtures/oracle/Arrows/operator-or-section.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/operator-or-section.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Arrows #-} +module ArrowOperatorOrSection where + +fn = (|| True) diff --git a/test/Test/Fixtures/oracle/Arrows/proc-block-let-arrow-lhs.hs b/test/Test/Fixtures/oracle/Arrows/proc-block-let-arrow-lhs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/proc-block-let-arrow-lhs.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Arrows #-} +{-# LANGUAGE BlockArguments #-} +module ProcBlockLetArrowLhs where + +f g = proc x -> (g let { y = x } in y) -< () diff --git a/test/Test/Fixtures/oracle/Arrows/proc.hs b/test/Test/Fixtures/oracle/Arrows/proc.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/proc.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Arrows #-} +module Proc where + +f g = proc x -> g -< x diff --git a/test/Test/Fixtures/oracle/Arrows/rec-basic.hs b/test/Test/Fixtures/oracle/Arrows/rec-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/rec-basic.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Arrows/rec-multiple.hs b/test/Test/Fixtures/oracle/Arrows/rec-multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/rec-multiple.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/Arrows/unicode-conditional.hs b/test/Test/Fixtures/oracle/Arrows/unicode-conditional.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/unicode-conditional.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Arrows/unicode-fat-arrow-right.hs b/test/Test/Fixtures/oracle/Arrows/unicode-fat-arrow-right.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/unicode-fat-arrow-right.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Arrows/unicode-rec.hs b/test/Test/Fixtures/oracle/Arrows/unicode-rec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Arrows/unicode-rec.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/BangPatterns/bang-case-alt.hs b/test/Test/Fixtures/oracle/BangPatterns/bang-case-alt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BangPatterns/bang-case-alt.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/BangPatterns/bang-fun-arg.hs b/test/Test/Fixtures/oracle/BangPatterns/bang-fun-arg.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BangPatterns/bang-fun-arg.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BangPatterns #-} + +module BangPatternsFunArg where + +strictId :: Int -> Int +strictId !x = x diff --git a/test/Test/Fixtures/oracle/BangPatterns/bang-lambda.hs b/test/Test/Fixtures/oracle/BangPatterns/bang-lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BangPatterns/bang-lambda.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BangPatterns #-} + +module BangPatternsLambda where + +applyStrict :: (Int -> Int) -> Int -> Int +applyStrict f = (\ !x -> f x) diff --git a/test/Test/Fixtures/oracle/BangPatterns/bang-let-binding.hs b/test/Test/Fixtures/oracle/BangPatterns/bang-let-binding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BangPatterns/bang-let-binding.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/BangPatterns/bang-let-guarded.hs b/test/Test/Fixtures/oracle/BangPatterns/bang-let-guarded.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BangPatterns/bang-let-guarded.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BangPatterns #-} + +module BangPatternsLetGuarded where + +test :: Bool -> Int +test positive = + let !x | True = 1 + in x diff --git a/test/Test/Fixtures/oracle/BangPatterns/bang-parenthesized-operator-as-pattern.hs b/test/Test/Fixtures/oracle/BangPatterns/bang-parenthesized-operator-as-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BangPatterns/bang-parenthesized-operator-as-pattern.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BangPatterns #-} +module BangParenthesizedOperatorAsPattern where + +data C = C + +fn !(+)@C = () diff --git a/test/Test/Fixtures/oracle/BangPatterns/bang-where.hs b/test/Test/Fixtures/oracle/BangPatterns/bang-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BangPatterns/bang-where.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/BangPatterns/prefix-pattern-qualifiers.hs b/test/Test/Fixtures/oracle/BangPatterns/prefix-pattern-qualifiers.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BangPatterns/prefix-pattern-qualifiers.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/BangPatterns/unpack-no-space-strictness.hs b/test/Test/Fixtures/oracle/BangPatterns/unpack-no-space-strictness.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BangPatterns/unpack-no-space-strictness.hs @@ -0,0 +1,2 @@ +{- ORACLE_TEST pass -} +data Pair a = Null | Cons a {-# UNPACK #-}!(IORef (Pair a)) diff --git a/test/Test/Fixtures/oracle/BinaryLiterals/binary-literals-basic.hs b/test/Test/Fixtures/oracle/BinaryLiterals/binary-literals-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BinaryLiterals/binary-literals-basic.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/BinaryLiterals/binary-literals-negative.hs b/test/Test/Fixtures/oracle/BinaryLiterals/binary-literals-negative.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BinaryLiterals/binary-literals-negative.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BinaryLiterals #-} + +module BinaryLiteralsNegative where + +signedValues :: [Int] +signedValues = [0b1, -0b1, -0B10, 0b11] diff --git a/test/Test/Fixtures/oracle/BinaryLiterals/binary-literals-patterns.hs b/test/Test/Fixtures/oracle/BinaryLiterals/binary-literals-patterns.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BinaryLiterals/binary-literals-patterns.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/BlockArguments/as-pattern-lambda.hs b/test/Test/Fixtures/oracle/BlockArguments/as-pattern-lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BlockArguments/as-pattern-lambda.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021, BlockArguments #-} +module AsPatternLambda where + +f = id \x@(Just y) -> y diff --git a/test/Test/Fixtures/oracle/BlockArguments/basic-case.hs b/test/Test/Fixtures/oracle/BlockArguments/basic-case.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BlockArguments/basic-case.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BlockArguments #-} +module BasicCase where + +f x = id case x of + _ -> () diff --git a/test/Test/Fixtures/oracle/BlockArguments/basic-do.hs b/test/Test/Fixtures/oracle/BlockArguments/basic-do.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BlockArguments/basic-do.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BlockArguments #-} +module BasicDo where + +f = id do + pure () diff --git a/test/Test/Fixtures/oracle/BlockArguments/basic-if.hs b/test/Test/Fixtures/oracle/BlockArguments/basic-if.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BlockArguments/basic-if.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BlockArguments #-} +module BasicIf where + +f x y z = id if x then y else z diff --git a/test/Test/Fixtures/oracle/BlockArguments/basic-lambda.hs b/test/Test/Fixtures/oracle/BlockArguments/basic-lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/BlockArguments/basic-lambda.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BlockArguments #-} +module BasicLambda where + +f = id \x -> x diff --git a/test/Test/Fixtures/oracle/CPP/infix-funlhs-cpp-variants.hs b/test/Test/Fixtures/oracle/CPP/infix-funlhs-cpp-variants.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/CPP/infix-funlhs-cpp-variants.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/CPP/macro-expansion-block-comment-literal.hs b/test/Test/Fixtures/oracle/CPP/macro-expansion-block-comment-literal.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/CPP/macro-expansion-block-comment-literal.hs @@ -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 -> () + _ -> () diff --git a/test/Test/Fixtures/oracle/ClassGuards/guarded-method-comprehensive.hs b/test/Test/Fixtures/oracle/ClassGuards/guarded-method-comprehensive.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ClassGuards/guarded-method-comprehensive.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ClassGuards/guarded-method-variations.hs b/test/Test/Fixtures/oracle/ClassGuards/guarded-method-variations.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ClassGuards/guarded-method-variations.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ClassGuards/guarded-method.hs b/test/Test/Fixtures/oracle/ClassGuards/guarded-method.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ClassGuards/guarded-method.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-kind-signature-rhs-roundtrip.hs b/test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-kind-signature-rhs-roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-kind-signature-rhs-roundtrip.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-poly-arity-zero.hs b/test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-poly-arity-zero.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-poly-arity-zero.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} + +f :: (() ~ () => a) -> a +f x = x diff --git a/test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-poly-paren-infix-equality.hs b/test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-poly-paren-infix-equality.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-poly-paren-infix-equality.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-poly-type-equality.hs b/test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-poly-type-equality.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ConstraintPolymorphism/constraint-poly-type-equality.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DataKinds/builtin-cons-type.hs b/test/Test/Fixtures/oracle/DataKinds/builtin-cons-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/builtin-cons-type.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +module BuiltinConsType where + +x :: (:) +x = undefined diff --git a/test/Test/Fixtures/oracle/DataKinds/datakinds-numeric-type-literal.hs b/test/Test/Fixtures/oracle/DataKinds/datakinds-numeric-type-literal.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/datakinds-numeric-type-literal.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +module M where +import Data.Proxy +_1 :: Proxy 1 +_1 = Proxy diff --git a/test/Test/Fixtures/oracle/DataKinds/list-promoted-kind.hs b/test/Test/Fixtures/oracle/DataKinds/list-promoted-kind.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/list-promoted-kind.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +module ListPromotedKind where + +import Data.Proxy +fn :: Proxy (() ': '[]) +fn = undefined diff --git a/test/Test/Fixtures/oracle/DataKinds/promoted-builtin.hs b/test/Test/Fixtures/oracle/DataKinds/promoted-builtin.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/promoted-builtin.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +module PromotedBuiltin where + +type T = "Hello" diff --git a/test/Test/Fixtures/oracle/DataKinds/promoted-cons-kind.hs b/test/Test/Fixtures/oracle/DataKinds/promoted-cons-kind.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/promoted-cons-kind.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +module PromotedConsKind where + +type T = a ': b diff --git a/test/Test/Fixtures/oracle/DataKinds/promoted-ctor.hs b/test/Test/Fixtures/oracle/DataKinds/promoted-ctor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/promoted-ctor.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +module PromotedCtor where + +data Nat = Zero | Succ Nat +type T = 'Zero diff --git a/test/Test/Fixtures/oracle/DataKinds/promoted-empty-list-type-constructor.hs b/test/Test/Fixtures/oracle/DataKinds/promoted-empty-list-type-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/promoted-empty-list-type-constructor.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +module PromotedEmptyListTypeConstructor where + +type T = '[] diff --git a/test/Test/Fixtures/oracle/DataKinds/promoted-list.hs b/test/Test/Fixtures/oracle/DataKinds/promoted-list.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/promoted-list.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +module PromotedList where + +type T = '[Int, String] diff --git a/test/Test/Fixtures/oracle/DataKinds/promoted-string-type-operator.hs b/test/Test/Fixtures/oracle/DataKinds/promoted-string-type-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/promoted-string-type-operator.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds, TypeOperators #-} + +module PromotedTypeOperatorWithStrings where + +type Msg = 'Text "msg1" ':$$: 'Text "msg2" diff --git a/test/Test/Fixtures/oracle/DataKinds/promoted-tuple-leading-char.hs b/test/Test/Fixtures/oracle/DataKinds/promoted-tuple-leading-char.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/promoted-tuple-leading-char.hs @@ -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 = "" diff --git a/test/Test/Fixtures/oracle/DataKinds/promoted-tuple.hs b/test/Test/Fixtures/oracle/DataKinds/promoted-tuple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/promoted-tuple.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +module PromotedTuple where + +type T = '(Int, String) diff --git a/test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-chained.hs b/test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-chained.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-chained.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-minus.hs b/test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-minus.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-minus.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds, TypeOperators #-} + +module PromotedTypeOperatorMinus where + +type T1 = a '- b diff --git a/test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-with-names.hs b/test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-with-names.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-with-names.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-with-space.hs b/test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-with-space.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/promoted-type-operator-with-space.hs @@ -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.") diff --git a/test/Test/Fixtures/oracle/DataKinds/standalone-deriving-infix-promoted-lhs.hs b/test/Test/Fixtures/oracle/DataKinds/standalone-deriving-infix-promoted-lhs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/standalone-deriving-infix-promoted-lhs.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module StandaloneDerivingInfixPromotedLHS where + +class a :+ b + +deriving instance ((C) '()) :+ () diff --git a/test/Test/Fixtures/oracle/DataKinds/unquoted-list-type-edge-cases.hs b/test/Test/Fixtures/oracle/DataKinds/unquoted-list-type-edge-cases.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/unquoted-list-type-edge-cases.hs @@ -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] diff --git a/test/Test/Fixtures/oracle/DataKinds/unquoted-list-type.hs b/test/Test/Fixtures/oracle/DataKinds/unquoted-list-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DataKinds/unquoted-list-type.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +module UnquotedListType where + +type T = [Int, Bool] diff --git a/test/Test/Fixtures/oracle/Declarations/empty-where.hs b/test/Test/Fixtures/oracle/Declarations/empty-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Declarations/empty-where.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Haskell2010 #-} + +module EmptyWhere where + +-- Empty where clause (syntactically valid, though semantically useless) +test = x + where {} diff --git a/test/Test/Fixtures/oracle/Declarations/guarded-where-tuple-pattern.hs b/test/Test/Fixtures/oracle/Declarations/guarded-where-tuple-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Declarations/guarded-where-tuple-pattern.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Declarations/incomplete-case.hs b/test/Test/Fixtures/oracle/Declarations/incomplete-case.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Declarations/incomplete-case.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +instance Cls T1 where + val = case val of diff --git a/test/Test/Fixtures/oracle/Declarations/rope-uncons.hs b/test/Test/Fixtures/oracle/Declarations/rope-uncons.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Declarations/rope-uncons.hs @@ -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')) diff --git a/test/Test/Fixtures/oracle/DefaultSignatures/basic.hs b/test/Test/Fixtures/oracle/DefaultSignatures/basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DefaultSignatures/basic.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DefaultSignatures/context.hs b/test/Test/Fixtures/oracle/DefaultSignatures/context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DefaultSignatures/context.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DefaultSignatures/equality.hs b/test/Test/Fixtures/oracle/DefaultSignatures/equality.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DefaultSignatures/equality.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DerivingStrategies/deriving-multiple-clauses.hs b/test/Test/Fixtures/oracle/DerivingStrategies/deriving-multiple-clauses.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DerivingStrategies/deriving-multiple-clauses.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DerivingStrategies #-} + +module DerivingStrategiesMultipleClauses where + +data Box a = Box a + deriving stock (Eq) + deriving stock (Show) diff --git a/test/Test/Fixtures/oracle/DerivingStrategies/deriving-newtype-list.hs b/test/Test/Fixtures/oracle/DerivingStrategies/deriving-newtype-list.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DerivingStrategies/deriving-newtype-list.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DerivingStrategies #-} + +module DerivingStrategiesNewtypeList where + +newtype Total = Total Int + deriving newtype Eq diff --git a/test/Test/Fixtures/oracle/DerivingStrategies/deriving-newtype.hs b/test/Test/Fixtures/oracle/DerivingStrategies/deriving-newtype.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DerivingStrategies/deriving-newtype.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DerivingStrategies #-} + +module DerivingStrategiesNewtype where + +newtype Age = Age Int + deriving newtype (Eq, Ord, Show) diff --git a/test/Test/Fixtures/oracle/DerivingStrategies/deriving-stock-multi.hs b/test/Test/Fixtures/oracle/DerivingStrategies/deriving-stock-multi.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DerivingStrategies/deriving-stock-multi.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DerivingStrategies #-} + +module DerivingStrategiesStockMulti where + +data Pair a = Pair a a + deriving stock (Eq, Show) diff --git a/test/Test/Fixtures/oracle/DerivingStrategies/deriving-stock-single.hs b/test/Test/Fixtures/oracle/DerivingStrategies/deriving-stock-single.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DerivingStrategies/deriving-stock-single.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DerivingStrategies #-} + +module DerivingStrategiesStockSingle where + +data Tag = Tag + deriving stock (Eq) diff --git a/test/Test/Fixtures/oracle/DerivingVia/basic.hs b/test/Test/Fixtures/oracle/DerivingVia/basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DerivingVia/basic.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DerivingVia #-} +module Basic where + +newtype MyInt = MyInt Int + deriving Show via Int diff --git a/test/Test/Fixtures/oracle/DerivingVia/complex-via.hs b/test/Test/Fixtures/oracle/DerivingVia/complex-via.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DerivingVia/complex-via.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DerivingVia #-} +module ComplexVia where + +newtype T a = T a + deriving Eq via (Maybe a) diff --git a/test/Test/Fixtures/oracle/DerivingVia/deriving-via-mvector.hs b/test/Test/Fixtures/oracle/DerivingVia/deriving-via-mvector.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DerivingVia/deriving-via-mvector.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/DerivingVia/multiple-classes.hs b/test/Test/Fixtures/oracle/DerivingVia/multiple-classes.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DerivingVia/multiple-classes.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DerivingVia #-} +module MultipleClasses where + +newtype MyInt = MyInt Int + deriving (Eq, Ord) via Int diff --git a/test/Test/Fixtures/oracle/DerivingVia/multiple-via-clauses-context-boundary.hs b/test/Test/Fixtures/oracle/DerivingVia/multiple-via-clauses-context-boundary.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DerivingVia/multiple-via-clauses-context-boundary.hs @@ -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' diff --git a/test/Test/Fixtures/oracle/DerivingVia/standalone-via-instance.hs b/test/Test/Fixtures/oracle/DerivingVia/standalone-via-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DerivingVia/standalone-via-instance.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/DerivingVia/standalone.hs b/test/Test/Fixtures/oracle/DerivingVia/standalone.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DerivingVia/standalone.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} +module Standalone where + +newtype MyInt = MyInt Int +deriving via Int instance Show MyInt diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/bare-let-in-do-explicit.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/bare-let-in-do-explicit.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/bare-let-in-do-explicit.hs @@ -0,0 +1,10 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Haskell2010 #-} + +module BareLetInDoExplicit where + +-- Explicit empty braces in do block +test = do + let {} + x <- undefined + return () diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/bare-let-in-do-multiple.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/bare-let-in-do-multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/bare-let-in-do-multiple.hs @@ -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 () diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/bare-let-in-do.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/bare-let-in-do.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/bare-let-in-do.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Haskell2010 #-} + +module BareLetInDo where + +test = do + let + x <- undefined + return () diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-at-layout.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-at-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-at-layout.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-basic.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-basic.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-case-layout.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-case-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-case-layout.hs @@ -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 () diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-else-do-if-layout.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-else-do-if-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-else-do-if-layout.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-else-do-multiline-inner-if.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-else-do-multiline-inner-if.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-else-do-multiline-inner-if.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-following-stmt.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-following-stmt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-following-stmt.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-let-layout.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-let-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-let-layout.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-nested-do.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-nested-do.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-nested-do.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-nested-if.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-nested-if.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-nested-if.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-then-do-if-layout.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-then-do-if-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-then-do-if-layout.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-then-do-multi-stmt.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-then-do-multi-stmt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-then-do-multi-stmt.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-then-do-single-stmt.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-then-do-single-stmt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-and-if-then-else-then-do-single-stmt.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-block-alternative.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-block-alternative.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-block-alternative.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-infix-backtick-continuation.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-infix-backtick-continuation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-infix-backtick-continuation.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-infix-continuation.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-infix-continuation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-infix-continuation.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/do-let-in-multiline-bindings.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-let-in-multiline-bindings.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/do-let-in-multiline-bindings.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/DoAndIfThenElse/let-expression-do-statement-roundtrip.hs b/test/Test/Fixtures/oracle/DoAndIfThenElse/let-expression-do-statement-roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/DoAndIfThenElse/let-expression-do-statement-roundtrip.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/EmptyCase/empty-case-basic.hs b/test/Test/Fixtures/oracle/EmptyCase/empty-case-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyCase/empty-case-basic.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE EmptyCase #-} + +module EmptyCaseBasic where + +data Void + +absurd :: Void -> a +absurd v = case v of {} diff --git a/test/Test/Fixtures/oracle/EmptyCase/empty-case-implicit-eof.hs b/test/Test/Fixtures/oracle/EmptyCase/empty-case-implicit-eof.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyCase/empty-case-implicit-eof.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/EmptyCase/empty-case-implicit-rparen.hs b/test/Test/Fixtures/oracle/EmptyCase/empty-case-implicit-rparen.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyCase/empty-case-implicit-rparen.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/EmptyCase/empty-case-let.hs b/test/Test/Fixtures/oracle/EmptyCase/empty-case-let.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyCase/empty-case-let.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/EmptyCase/empty-case-multiline-type-param.hs b/test/Test/Fixtures/oracle/EmptyCase/empty-case-multiline-type-param.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyCase/empty-case-multiline-type-param.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE EmptyCase #-} + +module EmptyCaseMultilineTypeParam where + +data Test + a + +x = 1 diff --git a/test/Test/Fixtures/oracle/EmptyCase/empty-case-where.hs b/test/Test/Fixtures/oracle/EmptyCase/empty-case-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyCase/empty-case-where.hs @@ -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 {} diff --git a/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-basic.hs b/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-basic.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE EmptyDataDecls #-} + +module EmptyDataDeclsBasic where + +data Empty diff --git a/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-export.hs b/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-export.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-export.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE EmptyDataDecls #-} + +module EmptyDataDeclsExport (Empty, Phantom) where + +data Empty + +data Phantom a diff --git a/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-kind-context.hs b/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-kind-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-kind-context.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE KindSignatures #-} + +module EmptyDataDeclsWithKindContext where + +data (:+) :: C => () diff --git a/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-multi.hs b/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-multi.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-multi.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE EmptyDataDecls #-} + +module EmptyDataDeclsMulti where + +data A + +data B a diff --git a/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-param.hs b/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-param.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-param.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE EmptyDataDecls #-} + +module EmptyDataDeclsParam where + +data Phantom a diff --git a/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-with-kind.hs b/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-with-kind.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyDataDecls/empty-data-with-kind.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE KindSignatures #-} + +module EmptyDataDeclsWithKind where + +import Data.Kind (Type) + +data Tagged (a :: Type) diff --git a/test/Test/Fixtures/oracle/EmptyDataDeriving/basic.hs b/test/Test/Fixtures/oracle/EmptyDataDeriving/basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyDataDeriving/basic.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE EmptyDataDeriving #-} +module Basic where + +data Empty + deriving Show diff --git a/test/Test/Fixtures/oracle/EmptyDataDeriving/gadt.hs b/test/Test/Fixtures/oracle/EmptyDataDeriving/gadt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyDataDeriving/gadt.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE EmptyDataDeriving #-} +module GADT where + +data Empty where + deriving Show diff --git a/test/Test/Fixtures/oracle/EmptyDataDeriving/multiple.hs b/test/Test/Fixtures/oracle/EmptyDataDeriving/multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/EmptyDataDeriving/multiple.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE EmptyDataDeriving #-} +module Multiple where + +data Empty + deriving (Eq, Ord, Show) diff --git a/test/Test/Fixtures/oracle/ExistentialQuantification/existential-infix-constructor.hs b/test/Test/Fixtures/oracle/ExistentialQuantification/existential-infix-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExistentialQuantification/existential-infix-constructor.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExistentialQuantification/existential-infix-parenthesized-context.hs b/test/Test/Fixtures/oracle/ExistentialQuantification/existential-infix-parenthesized-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExistentialQuantification/existential-infix-parenthesized-context.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/ExistentialQuantification/existential-multi-constructor.hs b/test/Test/Fixtures/oracle/ExistentialQuantification/existential-multi-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExistentialQuantification/existential-multi-constructor.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExistentialQuantification/existential-prefix-context.hs b/test/Test/Fixtures/oracle/ExistentialQuantification/existential-prefix-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExistentialQuantification/existential-prefix-context.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExistentialQuantification/existential-prefix-nested-parenthesized-context.hs b/test/Test/Fixtures/oracle/ExistentialQuantification/existential-prefix-nested-parenthesized-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExistentialQuantification/existential-prefix-nested-parenthesized-context.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExistentialQuantification/existential-record-context.hs b/test/Test/Fixtures/oracle/ExistentialQuantification/existential-record-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExistentialQuantification/existential-record-context.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/forall-class-method.hs b/test/Test/Fixtures/oracle/ExplicitForAll/forall-class-method.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/forall-class-method.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ExplicitForAll #-} + +module ExplicitForAllClassMethod where + +class Poly f where + poly :: forall a. f a -> f a diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-head.hs b/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-head.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-head.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ScopedTypeVariables #-} + +module ForallInstanceHead where + +class C a + +instance forall a. C a where diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-kind-signature.hs b/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-kind-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-kind-signature.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} + +module ForallInstanceWithKindSignature where + +class C a + +instance forall (a :: *). C a where diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-multiple-binders.hs b/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-multiple-binders.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-multiple-binders.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-overlap.hs b/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-overlap.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-overlap.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} + +module ForallInstanceWithOverlap where + +class C a + +instance {-# OVERLAPPING #-} forall a. C [a] where diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-with-context.hs b/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-with-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/forall-instance-with-context.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/forall-kinded-inferred-binder.hs b/test/Test/Fixtures/oracle/ExplicitForAll/forall-kinded-inferred-binder.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/forall-kinded-inferred-binder.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/forall-local-signature.hs b/test/Test/Fixtures/oracle/ExplicitForAll/forall-local-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/forall-local-signature.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/forall-multiline-nested-constraint.hs b/test/Test/Fixtures/oracle/ExplicitForAll/forall-multiline-nested-constraint.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/forall-multiline-nested-constraint.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/forall-nested-arrow.hs b/test/Test/Fixtures/oracle/ExplicitForAll/forall-nested-arrow.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/forall-nested-arrow.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ExplicitForAll #-} + +module ExplicitForAllNestedArrow where + +apply :: (forall a. a -> a) -> Int +apply f = f 3 diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/forall-no-space-after-dot.hs b/test/Test/Fixtures/oracle/ExplicitForAll/forall-no-space-after-dot.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/forall-no-space-after-dot.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Haskell2010, ExplicitForAll, RankNTypes #-} +module ForallNoSpaceAfterDot where + +data ExactPi = Approximate (forall a.Floating a => a) diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/forall-top-level.hs b/test/Test/Fixtures/oracle/ExplicitForAll/forall-top-level.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/forall-top-level.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ExplicitForAll #-} + +module ExplicitForAllTopLevel where + +identity :: forall a. a -> a +identity x = x diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/forall-with-context.hs b/test/Test/Fixtures/oracle/ExplicitForAll/forall-with-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/forall-with-context.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ExplicitForAll #-} + +module ExplicitForAllWithContext where + +render :: forall a. Show a => a -> String +render = show diff --git a/test/Test/Fixtures/oracle/ExplicitForAll/instance-forall.hs b/test/Test/Fixtures/oracle/ExplicitForAll/instance-forall.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitForAll/instance-forall.hs @@ -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 _ = () diff --git a/test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-basic-modifiers.hs b/test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-basic-modifiers.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-basic-modifiers.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-with-as.hs b/test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-with-as.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-with-as.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-with-hiding.hs b/test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-with-hiding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-with-hiding.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-with-import-list.hs b/test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-with-import-list.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitLevelImports/explicit-level-with-import-list.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-export-type-data-wildcards.hs b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-export-type-data-wildcards.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-export-type-data-wildcards.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-export-type-wildcard-with-value.hs b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-export-type-wildcard-with-value.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-export-type-wildcard-with-value.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-export-type.hs b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-export-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-export-type.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ExplicitNamespaces #-} + +module ExplicitNamespacesExportType (type Token(..), makeToken) where + +data Token = Token + +makeToken :: Token +makeToken = Token diff --git a/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-fixity-data-operator.hs b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-fixity-data-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-fixity-data-operator.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-fixity-edge-cases.hs b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-fixity-edge-cases.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-fixity-edge-cases.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-fixity-type-operator.hs b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-fixity-type-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-fixity-type-operator.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-data-wildcard.hs b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-data-wildcard.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-data-wildcard.hs @@ -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 = () diff --git a/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-list.hs b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-list.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-list.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ExplicitNamespaces #-} + +module ExplicitNamespacesImportList where + +import Data.Kind (type Type) diff --git a/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-type-data-wildcards.hs b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-type-data-wildcards.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-type-data-wildcards.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-type-wildcard.hs b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-type-wildcard.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-type-wildcard.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-type.hs b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitNamespaces/explicit-namespaces-import-type.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ExplicitNamespaces #-} + +module ExplicitNamespacesImportType where + +import Data.Proxy (type Proxy (..)) + +mkProxy :: Proxy Int +mkProxy = Proxy diff --git a/test/Test/Fixtures/oracle/ExplicitNamespaces/export-qualified-operator.hs b/test/Test/Fixtures/oracle/ExplicitNamespaces/export-qualified-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExplicitNamespaces/export-qualified-operator.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} + +module ExportQualifiedOperator ( + (M..&.) +) where + +import qualified Data.Bits as M diff --git a/test/Test/Fixtures/oracle/ExportSyntax/export-spec-all.hs b/test/Test/Fixtures/oracle/ExportSyntax/export-spec-all.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExportSyntax/export-spec-all.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExportSyntax/qualified-constructor-export.hs b/test/Test/Fixtures/oracle/ExportSyntax/qualified-constructor-export.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExportSyntax/qualified-constructor-export.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} + +module QualifiedConstructorExport ( + M.C(M.A1, M.A2) + ) where + +import M + diff --git a/test/Test/Fixtures/oracle/ExportSyntax/qualified-export-mixed.hs b/test/Test/Fixtures/oracle/ExportSyntax/qualified-export-mixed.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExportSyntax/qualified-export-mixed.hs @@ -0,0 +1,11 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ExplicitNamespaces #-} + +module QualifiedExportEdgeCases ( + M.T(M.X, M.Y), + N.C(..) + ) where + +import M +import N + diff --git a/test/Test/Fixtures/oracle/Exports/export-empty-bundled-type.hs b/test/Test/Fixtures/oracle/Exports/export-empty-bundled-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Exports/export-empty-bundled-type.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} + +module ExportsEmptyBundledType (Text()) where + +data Text = Text diff --git a/test/Test/Fixtures/oracle/ExtendedLiterals/custom-operator-hash.hs b/test/Test/Fixtures/oracle/ExtendedLiterals/custom-operator-hash.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExtendedLiterals/custom-operator-hash.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExtendedLiterals/signed.hs b/test/Test/Fixtures/oracle/ExtendedLiterals/signed.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExtendedLiterals/signed.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ExtendedLiterals/unsigned.hs b/test/Test/Fixtures/oracle/ExtendedLiterals/unsigned.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ExtendedLiterals/unsigned.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/FlexibleInstances/flexible-instance-empty-no-where.hs b/test/Test/Fixtures/oracle/FlexibleInstances/flexible-instance-empty-no-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/FlexibleInstances/flexible-instance-empty-no-where.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE FlexibleInstances #-} + +module FlexibleInstanceEmptyNoWhere where + +class Unconstrained1 a + +instance Unconstrained1 a diff --git a/test/Test/Fixtures/oracle/FlexibleInstances/flexible-instance-empty-where.hs b/test/Test/Fixtures/oracle/FlexibleInstances/flexible-instance-empty-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/FlexibleInstances/flexible-instance-empty-where.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE FlexibleInstances #-} + +module FlexibleInstanceEmptyWhere where + +class Unconstrained2 a + +instance Unconstrained2 a where diff --git a/test/Test/Fixtures/oracle/FlexibleInstances/flexible-instance-with-braces.hs b/test/Test/Fixtures/oracle/FlexibleInstances/flexible-instance-with-braces.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/FlexibleInstances/flexible-instance-with-braces.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE FlexibleInstances #-} +instance Validity Scientific where {} diff --git a/test/Test/Fixtures/oracle/FlexibleInstances/instance-unit.hs b/test/Test/Fixtures/oracle/FlexibleInstances/instance-unit.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/FlexibleInstances/instance-unit.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE KindSignatures, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} +module InstanceUnit where + +class Unit x + +instance Unit a diff --git a/test/Test/Fixtures/oracle/FlexibleInstances/parenthesized-empty-list-instance.hs b/test/Test/Fixtures/oracle/FlexibleInstances/parenthesized-empty-list-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/FlexibleInstances/parenthesized-empty-list-instance.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE FlexibleInstances #-} +module ParenthesizedEmptyListInstance where + +class C a + +instance C ([]) diff --git a/test/Test/Fixtures/oracle/ForeignFunctionInterface/capi-interruptible-header-symbol.hs b/test/Test/Fixtures/oracle/ForeignFunctionInterface/capi-interruptible-header-symbol.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ForeignFunctionInterface/capi-interruptible-header-symbol.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ForeignFunctionInterface/ctype-data-two-strings.hs b/test/Test/Fixtures/oracle/ForeignFunctionInterface/ctype-data-two-strings.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ForeignFunctionInterface/ctype-data-two-strings.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ForeignFunctionInterface/ctype-newtype.hs b/test/Test/Fixtures/oracle/ForeignFunctionInterface/ctype-newtype.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ForeignFunctionInterface/ctype-newtype.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ForeignFunctionInterface/export.hs b/test/Test/Fixtures/oracle/ForeignFunctionInterface/export.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ForeignFunctionInterface/export.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ForeignFunctionInterface/import.hs b/test/Test/Fixtures/oracle/ForeignFunctionInterface/import.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ForeignFunctionInterface/import.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module Import where + +foreign import ccall "f" f :: Int -> Int diff --git a/test/Test/Fixtures/oracle/ForeignFunctionInterface/safety.hs b/test/Test/Fixtures/oracle/ForeignFunctionInterface/safety.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ForeignFunctionInterface/safety.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ForeignFunctionInterface/stdcall.hs b/test/Test/Fixtures/oracle/ForeignFunctionInterface/stdcall.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ForeignFunctionInterface/stdcall.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module StdCall where + +foreign import stdcall "f" f :: Int -> Int diff --git a/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-bidirectional.hs b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-bidirectional.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-bidirectional.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-class-instance.hs b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-class-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-class-instance.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-empty-left.hs b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-empty-left.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-empty-left.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module FunctionalDependenciesEmptyLeft where + +class KeepRight a b | -> b where + keepRight :: a -> b diff --git a/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-empty-right.hs b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-empty-right.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-empty-right.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module FunctionalDependenciesEmptyRight where + +class KeepLeft a b | a -> where + keepLeft :: a -> b -> a diff --git a/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-multi-left.hs b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-multi-left.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-multi-left.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-single.hs b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-single.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-single.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-with-context.hs b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-with-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/FunctionalDependencies/fundep-with-context.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/GADTSyntax/gadt-context.hs b/test/Test/Fixtures/oracle/GADTSyntax/gadt-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTSyntax/gadt-context.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/GADTSyntax/gadt-deriving.hs b/test/Test/Fixtures/oracle/GADTSyntax/gadt-deriving.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTSyntax/gadt-deriving.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/GADTSyntax/gadt-existential.hs b/test/Test/Fixtures/oracle/GADTSyntax/gadt-existential.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTSyntax/gadt-existential.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/GADTSyntax/gadt-infix.hs b/test/Test/Fixtures/oracle/GADTSyntax/gadt-infix.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTSyntax/gadt-infix.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GADTSyntax #-} + +module GadtInfix where + +infix 6 :--: +data T a where + (:--:) :: Int -> Bool -> T Int diff --git a/test/Test/Fixtures/oracle/GADTSyntax/gadt-maybe.hs b/test/Test/Fixtures/oracle/GADTSyntax/gadt-maybe.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTSyntax/gadt-maybe.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GADTSyntax #-} + +module GadtMaybe where + +data Maybe a where + Nothing :: Maybe a + Just :: a -> Maybe a diff --git a/test/Test/Fixtures/oracle/GADTSyntax/gadt-multi-con.hs b/test/Test/Fixtures/oracle/GADTSyntax/gadt-multi-con.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTSyntax/gadt-multi-con.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GADTSyntax #-} + +module GadtMultiCon where + +data T a where + T1, T2 :: a -> T a + T3 :: T a diff --git a/test/Test/Fixtures/oracle/GADTSyntax/gadt-newtype.hs b/test/Test/Fixtures/oracle/GADTSyntax/gadt-newtype.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTSyntax/gadt-newtype.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GADTSyntax #-} + +module GadtNewtype where + +newtype Down a where + Down :: a -> Down a diff --git a/test/Test/Fixtures/oracle/GADTSyntax/gadt-record.hs b/test/Test/Fixtures/oracle/GADTSyntax/gadt-record.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTSyntax/gadt-record.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/GADTSyntax/gadt-strict.hs b/test/Test/Fixtures/oracle/GADTSyntax/gadt-strict.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTSyntax/gadt-strict.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/GADTs/constructor-kind-binder.hs b/test/Test/Fixtures/oracle/GADTs/constructor-kind-binder.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTs/constructor-kind-binder.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +module GadtConstructorKindBinder where + +data T where + C :: (x :: *) -> T diff --git a/test/Test/Fixtures/oracle/GADTs/gadt-promoted-cons-in-type.hs b/test/Test/Fixtures/oracle/GADTs/gadt-promoted-cons-in-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTs/gadt-promoted-cons-in-type.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/GADTs/gadts-basic.hs b/test/Test/Fixtures/oracle/GADTs/gadts-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTs/gadts-basic.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GADTs #-} + +module GADTsBasic where + +data Term a where + TInt :: Int -> Term Int + TBool :: Bool -> Term Bool diff --git a/test/Test/Fixtures/oracle/GADTs/gadts-pattern-match.hs b/test/Test/Fixtures/oracle/GADTs/gadts-pattern-match.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTs/gadts-pattern-match.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/GADTs/gadts-record.hs b/test/Test/Fixtures/oracle/GADTs/gadts-record.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GADTs/gadts-record.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/GHCPrimSpecific/foreign-import-prim.hs b/test/Test/Fixtures/oracle/GHCPrimSpecific/foreign-import-prim.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GHCPrimSpecific/foreign-import-prim.hs @@ -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# #) diff --git a/test/Test/Fixtures/oracle/GHCPrimSpecific/list-constructor.hs b/test/Test/Fixtures/oracle/GHCPrimSpecific/list-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GHCPrimSpecific/list-constructor.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ListConstructor where + +data List a = [] | a : List a diff --git a/test/Test/Fixtures/oracle/GHCPrimSpecific/negative-fixity.hs b/test/Test/Fixtures/oracle/GHCPrimSpecific/negative-fixity.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GHCPrimSpecific/negative-fixity.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE NegativeLiterals #-} +module NegativeFixity where + +infixr -1 -> diff --git a/test/Test/Fixtures/oracle/GHCPrimSpecific/reserved-op-fixity.hs b/test/Test/Fixtures/oracle/GHCPrimSpecific/reserved-op-fixity.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GHCPrimSpecific/reserved-op-fixity.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module ReservedOpFixity where + +infixr 5 : +infix 4 ~ diff --git a/test/Test/Fixtures/oracle/GHCPrimSpecific/tuple-constructor.hs b/test/Test/Fixtures/oracle/GHCPrimSpecific/tuple-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GHCPrimSpecific/tuple-constructor.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/GHCPrimSpecific/unboxed-sum-constructor.hs b/test/Test/Fixtures/oracle/GHCPrimSpecific/unboxed-sum-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GHCPrimSpecific/unboxed-sum-constructor.hs @@ -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 #) diff --git a/test/Test/Fixtures/oracle/GHCPrimSpecific/unboxed-tuple-constructor.hs b/test/Test/Fixtures/oracle/GHCPrimSpecific/unboxed-tuple-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/GHCPrimSpecific/unboxed-tuple-constructor.hs @@ -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 #) diff --git a/test/Test/Fixtures/oracle/Hackage/aftovolio-bang-pattern-on-constructor.hs b/test/Test/Fixtures/oracle/Hackage/aftovolio-bang-pattern-on-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/aftovolio-bang-pattern-on-constructor.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BangPatterns #-} +module A where +f x = case x of + !EQ -> True + _ -> False diff --git a/test/Test/Fixtures/oracle/Hackage/aftovolio-negation-operator-precedence.hs b/test/Test/Fixtures/oracle/Hackage/aftovolio-negation-operator-precedence.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/aftovolio-negation-operator-precedence.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module A where +f l = (-l - 1) diff --git a/test/Test/Fixtures/oracle/Hackage/aftovolio-negative-literal-spacing.hs b/test/Test/Fixtures/oracle/Hackage/aftovolio-negative-literal-spacing.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/aftovolio-negative-literal-spacing.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module A where +f x = x == - 1 diff --git a/test/Test/Fixtures/oracle/Hackage/agda-where-guarded-type-sig-xfail.hs b/test/Test/Fixtures/oracle/Hackage/agda-where-guarded-type-sig-xfail.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/agda-where-guarded-type-sig-xfail.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +module AgdaWhereGuardedTypeSig where + +f x = y + where + y :: Int + | x > 0 = 1 + | otherwise = 0 diff --git a/test/Test/Fixtures/oracle/Hackage/alex-conapp-pattern-in-cons.hs b/test/Test/Fixtures/oracle/Hackage/alex-conapp-pattern-in-cons.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/alex-conapp-pattern-in-cons.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module A where +data T = C Int +f (C x : xs) = x diff --git a/test/Test/Fixtures/oracle/Hackage/alsa-core-empty-instance-where-layout.hs b/test/Test/Fixtures/oracle/Hackage/alsa-core-empty-instance-where-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/alsa-core-empty-instance-where-layout.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/barbies-parenthesized-infix-operator-instance.hs b/test/Test/Fixtures/oracle/Hackage/barbies-parenthesized-infix-operator-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/barbies-parenthesized-infix-operator-instance.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} +module BarbiesParenthesizedInfixOperatorInstance where + +instance (c & d) a diff --git a/test/Test/Fixtures/oracle/Hackage/bnfc-meta-nested-prefix-cons-pattern-pass.hs b/test/Test/Fixtures/oracle/Hackage/bnfc-meta-nested-prefix-cons-pattern-pass.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/bnfc-meta-nested-prefix-cons-pattern-pass.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module A where + +f ((:) ((:) a b) c) = a diff --git a/test/Test/Fixtures/oracle/Hackage/bnfc-meta-prefix-cons-pattern-pass.hs b/test/Test/Fixtures/oracle/Hackage/bnfc-meta-prefix-cons-pattern-pass.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/bnfc-meta-prefix-cons-pattern-pass.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module A where + +f xs = case xs of + (:) x ys -> x + [] -> error "empty" diff --git a/test/Test/Fixtures/oracle/Hackage/cabal-dollar-do-let-in.hs b/test/Test/Fixtures/oracle/Hackage/cabal-dollar-do-let-in.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/cabal-dollar-do-let-in.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/citeproc-newtype-parens.hs b/test/Test/Fixtures/oracle/Hackage/citeproc-newtype-parens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/citeproc-newtype-parens.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module CiteprocNewtypeParens where + +newtype (ReferenceMap a) = ReferenceMap { unReferenceMap :: [(a)] } + deriving (Show) diff --git a/test/Test/Fixtures/oracle/Hackage/configurator-export-case-alt-dollar-plus.hs b/test/Test/Fixtures/oracle/Hackage/configurator-export-case-alt-dollar-plus.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/configurator-export-case-alt-dollar-plus.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/csp-let-lhs-infix-roundtrip.hs b/test/Test/Fixtures/oracle/Hackage/csp-let-lhs-infix-roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/csp-let-lhs-infix-roundtrip.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/diagrams-contrib-hash-line-directive.hs b/test/Test/Fixtures/oracle/Hackage/diagrams-contrib-hash-line-directive.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/diagrams-contrib-hash-line-directive.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module A where +r = x + # line diff --git a/test/Test/Fixtures/oracle/Hackage/diagrams-contrib-negation-precedence.hs b/test/Test/Fixtures/oracle/Hackage/diagrams-contrib-negation-precedence.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/diagrams-contrib-negation-precedence.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module A where +f = - 1 / 2 diff --git a/test/Test/Fixtures/oracle/Hackage/dns-transform-list-comp.hs b/test/Test/Fixtures/oracle/Hackage/dns-transform-list-comp.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/dns-transform-list-comp.hs @@ -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 ] diff --git a/test/Test/Fixtures/oracle/Hackage/enumset-sizeof.hs b/test/Test/Fixtures/oracle/Hackage/enumset-sizeof.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/enumset-sizeof.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module EnumsetTakeWhileSizeOf where + +f x = takeWhile (< sizeOf x * 8) diff --git a/test/Test/Fixtures/oracle/Hackage/force-layout-parenthesized-lens-op-arg.hs b/test/Test/Fixtures/oracle/Hackage/force-layout-parenthesized-lens-op-arg.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/force-layout-parenthesized-lens-op-arg.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ForceLayoutParenthesizedLensArg where + +stepPos p = pos %~ (.+^ p ^. vel) $ p diff --git a/test/Test/Fixtures/oracle/Hackage/friendly-time-append-seconds-lambda.hs b/test/Test/Fixtures/oracle/Hackage/friendly-time-append-seconds-lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/friendly-time-append-seconds-lambda.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module FriendlyTimeAppendSecondsLambda where + +secondsAgo = \f -> (++ " seconds" ++ dir f) diff --git a/test/Test/Fixtures/oracle/Hackage/functor-products-associated-injective-type-family.hs b/test/Test/Fixtures/oracle/Hackage/functor-products-associated-injective-type-family.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/functor-products-associated-injective-type-family.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/generic-lens-core-paren-infix-type-family.hs b/test/Test/Fixtures/oracle/Hackage/generic-lens-core-paren-infix-type-family.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/generic-lens-core-paren-infix-type-family.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module GenericLensCoreParenInfixTypeFamily where + +type family (a ++ b) diff --git a/test/Test/Fixtures/oracle/Hackage/generic-lens-core-promoted-error-message-list-cons.hs b/test/Test/Fixtures/oracle/Hackage/generic-lens-core-promoted-error-message-list-cons.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/generic-lens-core-promoted-error-message-list-cons.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +module M where + +type M1 = '[ 'Text "alpha" ':<>: 'Text "beta", 'Text "gamma" ] diff --git a/test/Test/Fixtures/oracle/Hackage/generic-lens-core-promoted-error-message-list-singleton.hs b/test/Test/Fixtures/oracle/Hackage/generic-lens-core-promoted-error-message-list-singleton.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/generic-lens-core-promoted-error-message-list-singleton.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +module M where + +type M1 = '[ 'Text "alpha" ':<>: 'Text "beta" ] diff --git a/test/Test/Fixtures/oracle/Hackage/generick-associated-type-default-signatures-xfail.hs b/test/Test/Fixtures/oracle/Hackage/generick-associated-type-default-signatures-xfail.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/generick-associated-type-default-signatures-xfail.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/ghc-events-concat-if-chain-roundtrip-xfail.hs b/test/Test/Fixtures/oracle/Hackage/ghc-events-concat-if-chain-roundtrip-xfail.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/ghc-events-concat-if-chain-roundtrip-xfail.hs @@ -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 "" diff --git a/test/Test/Fixtures/oracle/Hackage/ghc-events-record-pattern-roundtrip-xfail.hs b/test/Test/Fixtures/oracle/Hackage/ghc-events-record-pattern-roundtrip-xfail.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/ghc-events-record-pattern-roundtrip-xfail.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module GhcEventsRecordPatternRoundtripXfail where +data Event = Event { ref :: Int } +f (Event {ref = ref}) = ref diff --git a/test/Test/Fixtures/oracle/Hackage/ghc-exactprint-parenthesised-class-head.hs b/test/Test/Fixtures/oracle/Hackage/ghc-exactprint-parenthesised-class-head.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/ghc-exactprint-parenthesised-class-head.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module A where + +class (Monad m) => (HasTransform m) where + liftT :: Int -> m Int diff --git a/test/Test/Fixtures/oracle/Hackage/ghc-hs-meta-record-field-view-pattern.hs b/test/Test/Fixtures/oracle/Hackage/ghc-hs-meta-record-field-view-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/ghc-hs-meta-record-field-view-pattern.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ViewPatterns #-} + +module M where + +data Box = Box {field :: Int} + +f (Box {field = id -> x}) = x diff --git a/test/Test/Fixtures/oracle/Hackage/graphviz-percent-section.hs b/test/Test/Fixtures/oracle/Hackage/graphviz-percent-section.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/graphviz-percent-section.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module A where + +f = (%1) diff --git a/test/Test/Fixtures/oracle/Hackage/happy-lib-negative-magic-hash-expression.hs b/test/Test/Fixtures/oracle/Hackage/happy-lib-negative-magic-hash-expression.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/happy-lib-negative-magic-hash-expression.hs @@ -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# diff --git a/test/Test/Fixtures/oracle/Hackage/happy-lib-negative-magic-hash-multiple-patterns.hs b/test/Test/Fixtures/oracle/Hackage/happy-lib-negative-magic-hash-multiple-patterns.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/happy-lib-negative-magic-hash-multiple-patterns.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/happy-lib-negative-magic-hash-pattern.hs b/test/Test/Fixtures/oracle/Hackage/happy-lib-negative-magic-hash-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/happy-lib-negative-magic-hash-pattern.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/happy-meta-scc-pragma-expr.hs b/test/Test/Fixtures/oracle/Hackage/happy-meta-scc-pragma-expr.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/happy-meta-scc-pragma-expr.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module HappyMetaSccPragmaExpr where +f x = {-# SCC "label" #-} x diff --git a/test/Test/Fixtures/oracle/Hackage/hmatrix-scc-pragma-xfail.hs b/test/Test/Fixtures/oracle/Hackage/hmatrix-scc-pragma-xfail.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/hmatrix-scc-pragma-xfail.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module A where +f x = {-# SCC "name" #-} x diff --git a/test/Test/Fixtures/oracle/Hackage/hmatrix-unicode-operator.hs b/test/Test/Fixtures/oracle/Hackage/hmatrix-unicode-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/hmatrix-unicode-operator.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnicodeSyntax #-} +module A where +(——) = undefined diff --git a/test/Test/Fixtures/oracle/Hackage/hpdf-typed-pattern-let-in-do.hs b/test/Test/Fixtures/oracle/Hackage/hpdf-typed-pattern-let-in-do.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/hpdf-typed-pattern-let-in-do.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/ihaskell-type-annotation-in-do-case-if-xfail.hs b/test/Test/Fixtures/oracle/Hackage/ihaskell-type-annotation-in-do-case-if-xfail.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/ihaskell-type-annotation-in-do-case-if-xfail.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/import-type-empty-constructors-xfail.hs b/test/Test/Fixtures/oracle/Hackage/import-type-empty-constructors-xfail.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/import-type-empty-constructors-xfail.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ImportTypeEmptyConstructorsXFail where + +import Data.Text (Text(), unpack) diff --git a/test/Test/Fixtures/oracle/Hackage/indents-expected-message.hs b/test/Test/Fixtures/oracle/Hackage/indents-expected-message.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/indents-expected-message.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module IndentsExpectedMessage where + +f ref pos = + ( prettyIndentation ref ++ " (started at line " ++ prettyLine ref ++ ")") + (unexpected pos) diff --git a/test/Test/Fixtures/oracle/Hackage/indexed-profunctors-hash-dot-export.hs b/test/Test/Fixtures/oracle/Hackage/indexed-profunctors-hash-dot-export.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/indexed-profunctors-hash-dot-export.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE OverloadedLabels #-} + +module IndexedProfunctorsHashDotExport + ( (#.), + ) +where + +(#.) x y = x diff --git a/test/Test/Fixtures/oracle/Hackage/json-spec-elm-lambda-cases.hs b/test/Test/Fixtures/oracle/Hackage/json-spec-elm-lambda-cases.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/json-spec-elm-lambda-cases.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LambdaCase #-} + +module M where + +f = \cases + True False -> 0 + _ _ -> 1 diff --git a/test/Test/Fixtures/oracle/Hackage/kind-apply-spine-lot.hs b/test/Test/Fixtures/oracle/Hackage/kind-apply-spine-lot.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/kind-apply-spine-lot.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/liquid-fixpoint-do-comment-layout.hs b/test/Test/Fixtures/oracle/Hackage/liquid-fixpoint-do-comment-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/liquid-fixpoint-do-comment-layout.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module A where + +f = do {- a -} x + {- b -} y diff --git a/test/Test/Fixtures/oracle/Hackage/liquid-fixpoint-do-multiline-comment-layout.hs b/test/Test/Fixtures/oracle/Hackage/liquid-fixpoint-do-multiline-comment-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/liquid-fixpoint-do-multiline-comment-layout.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module A where + +fn = do {- + -} hello + world diff --git a/test/Test/Fixtures/oracle/Hackage/manifolds-core-unicode-subscript-identifier.hs b/test/Test/Fixtures/oracle/Hackage/manifolds-core-unicode-subscript-identifier.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/manifolds-core-unicode-subscript-identifier.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} + +module M where + +f p₀ = p₀ diff --git a/test/Test/Fixtures/oracle/Hackage/manifolds-core-unicode-superscript-identifier.hs b/test/Test/Fixtures/oracle/Hackage/manifolds-core-unicode-superscript-identifier.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/manifolds-core-unicode-superscript-identifier.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnicodeSyntax #-} + +module M where + +data S⁰_ r = PositiveHalfSphere diff --git a/test/Test/Fixtures/oracle/Hackage/memotrie-associated-data-family-operator.hs b/test/Test/Fixtures/oracle/Hackage/memotrie-associated-data-family-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/memotrie-associated-data-family-operator.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module MemoTrieAssociatedDataFamilyOperator where + +class C a where + data (:*:) a :: * -> * diff --git a/test/Test/Fixtures/oracle/Hackage/mixed-types-num-type-sig-in-if-then-branch.hs b/test/Test/Fixtures/oracle/Hackage/mixed-types-num-type-sig-in-if-then-branch.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/mixed-types-num-type-sig-in-if-then-branch.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module A where +f = if True then x :: Int else x diff --git a/test/Test/Fixtures/oracle/Hackage/mptc-parenthesized-two-args-trailing.hs b/test/Test/Fixtures/oracle/Hackage/mptc-parenthesized-two-args-trailing.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/mptc-parenthesized-two-args-trailing.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiParamTypeClasses #-} +module A where +class C a b c +instance (C Int Bool) Char where diff --git a/test/Test/Fixtures/oracle/Hackage/named-text-kind-annotated-type-synonym.hs b/test/Test/Fixtures/oracle/Hackage/named-text-kind-annotated-type-synonym.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/named-text-kind-annotated-type-synonym.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/nonempty-containers-pattern-synonym-where-infix.hs b/test/Test/Fixtures/oracle/Hackage/nonempty-containers-pattern-synonym-where-infix.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/nonempty-containers-pattern-synonym-where-infix.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/Hackage/nonempty-containers-qualified-instance.hs b/test/Test/Fixtures/oracle/Hackage/nonempty-containers-qualified-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/nonempty-containers-qualified-instance.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/nonempty-containers-where-indent.hs b/test/Test/Fixtures/oracle/Hackage/nonempty-containers-where-indent.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/nonempty-containers-where-indent.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/oops-injective-type-family.hs b/test/Test/Fixtures/oracle/Hackage/oops-injective-type-family.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/oops-injective-type-family.hs @@ -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 '[] = () diff --git a/test/Test/Fixtures/oracle/Hackage/pandoc-arrow-case-pattern-guard-xfail.hs b/test/Test/Fixtures/oracle/Hackage/pandoc-arrow-case-pattern-guard-xfail.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/pandoc-arrow-case-pattern-guard-xfail.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/pantry-local-signature-let-in-do.hs b/test/Test/Fixtures/oracle/Hackage/pantry-local-signature-let-in-do.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/pantry-local-signature-let-in-do.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/parenthesized-prefix-no-trailing.hs b/test/Test/Fixtures/oracle/Hackage/parenthesized-prefix-no-trailing.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/parenthesized-prefix-no-trailing.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module A where +class C a +instance (C Int) where diff --git a/test/Test/Fixtures/oracle/Hackage/pqueue-infix-pattern-synonym-where-clause.hs b/test/Test/Fixtures/oracle/Hackage/pqueue-infix-pattern-synonym-where-clause.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/pqueue-infix-pattern-synonym-where-clause.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/ratio-int-parenthesized-compare.hs b/test/Test/Fixtures/oracle/Hackage/ratio-int-parenthesized-compare.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/ratio-int-parenthesized-compare.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module RatioIntParenthesizedCompare where + +enumFromTo n m = takeWhile (<= m + 1 / 2) (enumFrom n) diff --git a/test/Test/Fixtures/oracle/Hackage/resourcet-export-pattern-synonym-after-dotdot.hs b/test/Test/Fixtures/oracle/Hackage/resourcet-export-pattern-synonym-after-dotdot.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/resourcet-export-pattern-synonym-after-dotdot.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PatternSynonyms #-} + +module M (T (.., P)) where + +data T = A + +pattern P :: T +pattern P = A diff --git a/test/Test/Fixtures/oracle/Hackage/roundingfiasco-word64-binary-literal-case-alt.hs b/test/Test/Fixtures/oracle/Hackage/roundingfiasco-word64-binary-literal-case-alt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/roundingfiasco-word64-binary-literal-case-alt.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE ExtendedLiterals #-} +{-# LANGUAGE MagicHash #-} + +module M where + +f x = case x of + 0b0#Word64 -> 0# diff --git a/test/Test/Fixtures/oracle/Hackage/row-types-nbsp-layout.hs b/test/Test/Fixtures/oracle/Hackage/row-types-nbsp-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/row-types-nbsp-layout.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +module RowTypesNbspLayout where + +type family F a where +  F a = a +  F b = b diff --git a/test/Test/Fixtures/oracle/Hackage/sbv-function-head-at-operator.hs b/test/Test/Fixtures/oracle/Hackage/sbv-function-head-at-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/sbv-function-head-at-operator.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +f e (@) = do + undefined + diff --git a/test/Test/Fixtures/oracle/Hackage/sbv-function-head-type-sig.hs b/test/Test/Fixtures/oracle/Hackage/sbv-function-head-type-sig.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/sbv-function-head-type-sig.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +f (fn :: Int -> Int) = fn + diff --git a/test/Test/Fixtures/oracle/Hackage/sbv-gadt-record-at-field.hs b/test/Test/Fixtures/oracle/Hackage/sbv-gadt-record-at-field.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/sbv-gadt-record-at-field.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/sbv-promoted-string-type-app-pattern-xfail.hs b/test/Test/Fixtures/oracle/Hackage/sbv-promoted-string-type-app-pattern-xfail.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/sbv-promoted-string-type-app-pattern-xfail.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/sbv-template-splice-instance-head.hs b/test/Test/Fixtures/oracle/Hackage/sbv-template-splice-instance-head.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/sbv-template-splice-instance-head.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +module S where + +class C a + +instance C $(pure Int) diff --git a/test/Test/Fixtures/oracle/Hackage/sbv-typed-infix-app-roundtrip.hs b/test/Test/Fixtures/oracle/Hackage/sbv-typed-infix-app-roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/sbv-typed-infix-app-roundtrip.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +f = (fromBytes :: Int -> Int) 1 # other 2 + diff --git a/test/Test/Fixtures/oracle/Hackage/sbv-unicode-varid-method.hs b/test/Test/Fixtures/oracle/Hackage/sbv-unicode-varid-method.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/sbv-unicode-varid-method.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module S where + +class C α where + ﬧ :: α -> α + diff --git a/test/Test/Fixtures/oracle/Hackage/shake-pattern-guard-type-signature.hs b/test/Test/Fixtures/oracle/Hackage/shake-pattern-guard-type-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/shake-pattern-guard-type-signature.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/slack-web-type-annotation-in-if-then-else.hs b/test/Test/Fixtures/oracle/Hackage/slack-web-type-annotation-in-if-then-else.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/slack-web-type-annotation-in-if-then-else.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module SlackWebTypeAnnotationInIfThenElse where + +f = if x then y :: T else z diff --git a/test/Test/Fixtures/oracle/Hackage/snap-core-mptc-parenthesized-instance-head.hs b/test/Test/Fixtures/oracle/Hackage/snap-core-mptc-parenthesized-instance-head.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/snap-core-mptc-parenthesized-instance-head.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiParamTypeClasses #-} +module A where +class C a b +instance (C Int) Bool where diff --git a/test/Test/Fixtures/oracle/Hackage/snap-core-scc-pragma-in-binding.hs b/test/Test/Fixtures/oracle/Hackage/snap-core-scc-pragma-in-binding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/snap-core-scc-pragma-in-binding.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module A where +f = g + where + g = {-# SCC "name" #-} undefined diff --git a/test/Test/Fixtures/oracle/Hackage/sop-core-paren-backtick-instance-head.hs b/test/Test/Fixtures/oracle/Hackage/sop-core-paren-backtick-instance-head.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/sop-core-paren-backtick-instance-head.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +module SopCoreParenBacktickInstanceHead where + +class (f `C` g) x +instance (f `C` g) x diff --git a/test/Test/Fixtures/oracle/Hackage/splitmix-distributions-negation-parens.hs b/test/Test/Fixtures/oracle/Hackage/splitmix-distributions-negation-parens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/splitmix-distributions-negation-parens.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/srtree-if-arithmetic-sequence-bound.hs b/test/Test/Fixtures/oracle/Hackage/srtree-if-arithmetic-sequence-bound.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/srtree-if-arithmetic-sequence-bound.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module SrtreeIfArithmeticSequenceBound where + +f maxSize = + randomFrom [if maxSize > 4 then 4 else 1 .. maxSize] diff --git a/test/Test/Fixtures/oracle/Hackage/standalone-deriving-parenthesized-prefix.hs b/test/Test/Fixtures/oracle/Hackage/standalone-deriving-parenthesized-prefix.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/standalone-deriving-parenthesized-prefix.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +module A where +class C a b +deriving instance (C Int) Bool diff --git a/test/Test/Fixtures/oracle/Hackage/symbolize-export-double-hash-identifier.hs b/test/Test/Fixtures/oracle/Hackage/symbolize-export-double-hash-identifier.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/symbolize-export-double-hash-identifier.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MagicHash #-} + +module M (f##) where + +f## = undefined diff --git a/test/Test/Fixtures/oracle/Hackage/tao-example-promoted-lists-roundtrip.hs b/test/Test/Fixtures/oracle/Hackage/tao-example-promoted-lists-roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/tao-example-promoted-lists-roundtrip.hs @@ -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] ]) diff --git a/test/Test/Fixtures/oracle/Hackage/termbox-bundled-pattern-export.hs b/test/Test/Fixtures/oracle/Hackage/termbox-bundled-pattern-export.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/termbox-bundled-pattern-export.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PatternSynonyms #-} + +module M (T (.., P)) where + +data T = T + +pattern P :: T +pattern P = T diff --git a/test/Test/Fixtures/oracle/Hackage/test-fun-type-operator-context.hs b/test/Test/Fixtures/oracle/Hackage/test-fun-type-operator-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/test-fun-type-operator-context.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} +module TestFunTypeOperatorContextXfail where + +data Var = Var + +data Expr = Expr + +data Ctx = (Var, Expr) :. Ctx diff --git a/test/Test/Fixtures/oracle/Hackage/thyme-lambda-record-wildcard-xfail.hs b/test/Test/Fixtures/oracle/Hackage/thyme-lambda-record-wildcard-xfail.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/thyme-lambda-record-wildcard-xfail.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RecordWildCards #-} +module ThymeLambdaRecordWildcard where + +f = (\ TimeZone {..} -> undefined, \ TimeZone {..} -> undefined) diff --git a/test/Test/Fixtures/oracle/Hackage/traverse-with-class-th-tuple-name-quote.hs b/test/Test/Fixtures/oracle/Hackage/traverse-with-class-th-tuple-name-quote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/traverse-with-class-th-tuple-name-quote.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} + +module TraverseWithClassTHTupleNameQuote where + +f = ''(,) diff --git a/test/Test/Fixtures/oracle/Hackage/type-set-type-instance-dollar-application.hs b/test/Test/Fixtures/oracle/Hackage/type-set-type-instance-dollar-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/type-set-type-instance-dollar-application.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/typelevel-tools-yj-infix-instance-context.hs b/test/Test/Fixtures/oracle/Hackage/typelevel-tools-yj-infix-instance-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/typelevel-tools-yj-infix-instance-context.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/Hackage/typelevel-tools-yj-infix-instance-head.hs b/test/Test/Fixtures/oracle/Hackage/typelevel-tools-yj-infix-instance-head.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/typelevel-tools-yj-infix-instance-head.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Hackage/vinyl-type-family-default-compound-rhs.hs b/test/Test/Fixtures/oracle/Hackage/vinyl-type-family-default-compound-rhs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/vinyl-type-family-default-compound-rhs.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +module VinylTypeFamilyDefaultCompoundRhs where + +class C f where + type T f = f Int diff --git a/test/Test/Fixtures/oracle/Hackage/web3-ethereum-conpat-infix-parens.hs b/test/Test/Fixtures/oracle/Hackage/web3-ethereum-conpat-infix-parens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/web3-ethereum-conpat-infix-parens.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module Web3EthereumConpatInfixParens where +f (Just _ : _) = () diff --git a/test/Test/Fixtures/oracle/Hackage/web3-ethereum-record-wildcard-lambda-parens.hs b/test/Test/Fixtures/oracle/Hackage/web3-ethereum-record-wildcard-lambda-parens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/web3-ethereum-record-wildcard-lambda-parens.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RecordWildCards #-} +module Web3EthereumRecordWildcardLambdaParens where +data T = T {x :: Int} +f = \T{..} -> x diff --git a/test/Test/Fixtures/oracle/HexFloatLiterals/hex-float-literals-basic.hs b/test/Test/Fixtures/oracle/HexFloatLiterals/hex-float-literals-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/HexFloatLiterals/hex-float-literals-basic.hs @@ -0,0 +1,10 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE HexFloatLiterals #-} + +module HexFloatLiteralsBasic where + +unit :: Double +unit = 0x1p0 + +shifted :: Double +shifted = 0x1p4 diff --git a/test/Test/Fixtures/oracle/HexFloatLiterals/hex-float-literals-fraction.hs b/test/Test/Fixtures/oracle/HexFloatLiterals/hex-float-literals-fraction.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/HexFloatLiterals/hex-float-literals-fraction.hs @@ -0,0 +1,10 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE HexFloatLiterals #-} + +module HexFloatLiteralsFraction where + +half :: Double +half = 0x1p-1 + +fractional :: Double +fractional = 0x1.8p1 diff --git a/test/Test/Fixtures/oracle/HexFloatLiterals/hex-float-literals-list.hs b/test/Test/Fixtures/oracle/HexFloatLiterals/hex-float-literals-list.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/HexFloatLiterals/hex-float-literals-list.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE HexFloatLiterals #-} + +module HexFloatLiteralsList where + +constants :: [Double] +constants = [0X1.0p0, 0x1.2p3, -0x1p2, 0xAp-1] diff --git a/test/Test/Fixtures/oracle/ImplicitParams/binding.hs b/test/Test/Fixtures/oracle/ImplicitParams/binding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ImplicitParams/binding.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ImplicitParams #-} +module Binding where + +f = ?x where ?x = 10 diff --git a/test/Test/Fixtures/oracle/ImplicitParams/complicated-type.hs b/test/Test/Fixtures/oracle/ImplicitParams/complicated-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ImplicitParams/complicated-type.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ImplicitParams/gadts.hs b/test/Test/Fixtures/oracle/ImplicitParams/gadts.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ImplicitParams/gadts.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImplicitParams #-} +module GADTsImplicitParams where + +data T where + MkT :: (?f :: Int) => T diff --git a/test/Test/Fixtures/oracle/ImplicitParams/infix-operators.hs b/test/Test/Fixtures/oracle/ImplicitParams/infix-operators.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ImplicitParams/infix-operators.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ImplicitParams #-} +module InfixOperators where + +f t = let { ?x = t; ?y = ?x + 1 } in ?x + ?y diff --git a/test/Test/Fixtures/oracle/ImplicitParams/keyword-names.hs b/test/Test/Fixtures/oracle/ImplicitParams/keyword-names.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ImplicitParams/keyword-names.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ImplicitParams/let-bindings.hs b/test/Test/Fixtures/oracle/ImplicitParams/let-bindings.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ImplicitParams/let-bindings.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ImplicitParams #-} +module LetBindings where + +f t = let { ?x = t; ?y = ?x + (1::Int) } in ?x + ?y diff --git a/test/Test/Fixtures/oracle/ImplicitParams/standalone-implicit-param.hs b/test/Test/Fixtures/oracle/ImplicitParams/standalone-implicit-param.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ImplicitParams/standalone-implicit-param.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ImplicitParams/type-synonym-implicit-param.hs b/test/Test/Fixtures/oracle/ImplicitParams/type-synonym-implicit-param.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ImplicitParams/type-synonym-implicit-param.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ImplicitParams/type.hs b/test/Test/Fixtures/oracle/ImplicitParams/type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ImplicitParams/type.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ImplicitParams #-} +module Type where + +f :: (?x :: Int) => Int +f = ?x diff --git a/test/Test/Fixtures/oracle/ImportQualifiedPost/import-qualified-post-as.hs b/test/Test/Fixtures/oracle/ImportQualifiedPost/import-qualified-post-as.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ImportQualifiedPost/import-qualified-post-as.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ImportQualifiedPost/import-qualified-post-basic.hs b/test/Test/Fixtures/oracle/ImportQualifiedPost/import-qualified-post-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ImportQualifiedPost/import-qualified-post-basic.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ImportQualifiedPost #-} + +module ImportQualifiedPostBasic where + +import Data.List qualified as List + +sorted :: [Int] -> [Int] +sorted = List.sort diff --git a/test/Test/Fixtures/oracle/ImportQualifiedPost/import-qualified-post-hiding.hs b/test/Test/Fixtures/oracle/ImportQualifiedPost/import-qualified-post-hiding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ImportQualifiedPost/import-qualified-post-hiding.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-basic.hs b/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-basic.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-constrained.hs b/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-constrained.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-constrained.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-default.hs b/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-default.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-default.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-multi-method.hs b/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-multi-method.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-multi-method.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-where-layout.hs b/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-where-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/InstanceSigs/instance-sig-where-layout.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/KindSignatures/forall-body-kindsig-forall-subject.hs b/test/Test/Fixtures/oracle/KindSignatures/forall-body-kindsig-forall-subject.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/KindSignatures/forall-body-kindsig-forall-subject.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PartialTypeSignatures #-} + +module ForallBodyKindSigForallSubject where + +type T = forall a. forall a. forall a. _ :: _ diff --git a/test/Test/Fixtures/oracle/KindSignatures/kindsig-class-head-star.hs b/test/Test/Fixtures/oracle/KindSignatures/kindsig-class-head-star.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/KindSignatures/kindsig-class-head-star.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StarIsType #-} + +module KindSignaturesClassHeadStar where + +class Unit (x :: *) diff --git a/test/Test/Fixtures/oracle/KindSignatures/kindsig-class-head.hs b/test/Test/Fixtures/oracle/KindSignatures/kindsig-class-head.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/KindSignatures/kindsig-class-head.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/KindSignatures/kindsig-constraint.hs b/test/Test/Fixtures/oracle/KindSignatures/kindsig-constraint.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/KindSignatures/kindsig-constraint.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/KindSignatures/kindsig-data-param.hs b/test/Test/Fixtures/oracle/KindSignatures/kindsig-data-param.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/KindSignatures/kindsig-data-param.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE KindSignatures #-} + +module KindSignaturesDataParam where + +import Data.Kind (Type) + +data Proxy (a :: Type) = Proxy diff --git a/test/Test/Fixtures/oracle/KindSignatures/kindsig-higher-kinded.hs b/test/Test/Fixtures/oracle/KindSignatures/kindsig-higher-kinded.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/KindSignatures/kindsig-higher-kinded.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/KindSignatures/kindsig-multiple-constraints.hs b/test/Test/Fixtures/oracle/KindSignatures/kindsig-multiple-constraints.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/KindSignatures/kindsig-multiple-constraints.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/KindSignatures/kindsig-newtype.hs b/test/Test/Fixtures/oracle/KindSignatures/kindsig-newtype.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/KindSignatures/kindsig-newtype.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/LambdaCase/do-where-after-module.hs b/test/Test/Fixtures/oracle/LambdaCase/do-where-after-module.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LambdaCase/do-where-after-module.hs @@ -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 = '[] diff --git a/test/Test/Fixtures/oracle/LambdaCase/lambda-case-application-with-guards.hs b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-application-with-guards.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-application-with-guards.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/LambdaCase/lambda-case-basic.hs b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-basic.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LambdaCase #-} + +module LambdaCaseBasic where + +describeBool :: Bool -> String +describeBool = \case + True -> "yes" + False -> "no" diff --git a/test/Test/Fixtures/oracle/LambdaCase/lambda-case-cases-binder.hs b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-cases-binder.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-cases-binder.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LambdaCase #-} + +module LambdaCaseCasesBinder where + +identityCases :: a -> a +identityCases = \cases -> cases diff --git a/test/Test/Fixtures/oracle/LambdaCase/lambda-case-empty.hs b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-empty.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-empty.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LambdaCase #-} + +module LambdaCaseEmpty where + +absurdBool :: Bool -> Int +absurdBool = \case {} diff --git a/test/Test/Fixtures/oracle/LambdaCase/lambda-case-guards.hs b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-guards.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-guards.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LambdaCase #-} + +module LambdaCaseGuards where + +parity :: Int -> String +parity = \case + n | even n -> "even" + _ -> "odd" diff --git a/test/Test/Fixtures/oracle/LambdaCase/lambda-case-in-application.hs b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-in-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-in-application.hs @@ -0,0 +1,12 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LambdaCase #-} + +module LambdaCaseInApplication where + +describeMany :: [Maybe Int] -> [String] +describeMany = + map + (\case + Just n -> "just" + Nothing -> "nothing" + ) diff --git a/test/Test/Fixtures/oracle/LambdaCase/lambda-case-locally-bound.hs b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-locally-bound.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-locally-bound.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/LambdaCase/lambda-case-nested.hs b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-nested.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-nested.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/LambdaCase/lambda-case-quasiquote-guard.hs b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-quasiquote-guard.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LambdaCase/lambda-case-quasiquote-guard.hs @@ -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' diff --git a/test/Test/Fixtures/oracle/LambdaCase/parenthesized-empty-lambda-case.hs b/test/Test/Fixtures/oracle/LambdaCase/parenthesized-empty-lambda-case.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LambdaCase/parenthesized-empty-lambda-case.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LambdaCase #-} + +module M where + +x = (\case) diff --git a/test/Test/Fixtures/oracle/LambdaCase/parenthesized-empty-lambda-cases.hs b/test/Test/Fixtures/oracle/LambdaCase/parenthesized-empty-lambda-cases.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LambdaCase/parenthesized-empty-lambda-cases.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LambdaCase #-} + +module M where + +x = (\cases) diff --git a/test/Test/Fixtures/oracle/Layout/case-where.hs b/test/Test/Fixtures/oracle/Layout/case-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/case-where.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +module CaseWhere where + +run r = + case r of + OK n -> () + where + x = () diff --git a/test/Test/Fixtures/oracle/Layout/duplicate-where.hs b/test/Test/Fixtures/oracle/Layout/duplicate-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/duplicate-where.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Layout/guard-let-layout-where-case.hs b/test/Test/Fixtures/oracle/Layout/guard-let-layout-where-case.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/guard-let-layout-where-case.hs @@ -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 + = ' [] diff --git a/test/Test/Fixtures/oracle/Layout/implicit-layout-stress.hs b/test/Test/Fixtures/oracle/Layout/implicit-layout-stress.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/implicit-layout-stress.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/Layout/nested-case-where.hs b/test/Test/Fixtures/oracle/Layout/nested-case-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/nested-case-where.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Layout/top-level-where-deprecated-boundary.hs b/test/Test/Fixtures/oracle/Layout/top-level-where-deprecated-boundary.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/top-level-where-deprecated-boundary.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Layout/triple-nested-case-where.hs b/test/Test/Fixtures/oracle/Layout/triple-nested-case-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/triple-nested-case-where.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-basic.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-basic.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LinearTypes #-} +module LinearArrowBasic where + +f :: a %1 -> b +f = undefined diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-many.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-many.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-many.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LinearTypes #-} +module LinearArrowMany where + +f :: a %Many -> b +f = undefined diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-nested.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-nested.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-nested.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LinearTypes #-} +module LinearArrowNested where + +f :: (a %1 -> b) %1 -> a -> b +f g x = g x diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-poly.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-poly.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-poly.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LinearTypes #-} +module LinearArrowPoly where + +f :: a %m -> b +f = undefined diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-promoted-many.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-promoted-many.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-promoted-many.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LinearTypes #-} +module LinearArrowPromotedMany where + +f :: a %'Many -> b +f = undefined diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-spaced-not-linear.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-spaced-not-linear.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-spaced-not-linear.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-unicode.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-unicode.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-arrow-unicode.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE UnicodeSyntax #-} +module LinearArrowUnicode where + +f :: a ⊸ b +f = undefined diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-gadt-constructor.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-gadt-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-gadt-constructor.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-let-binding.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-let-binding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-let-binding.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LinearTypes #-} +module LinearLetBinding where + +h :: Int -> Int +h x = let %1 y = x in y diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-let-many-binding.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-let-many-binding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-let-many-binding.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LinearTypes #-} +module LinearLetManyBinding where + +h :: Int -> Int +h x = let %Many y = x in y diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-newtype.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-newtype.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-newtype.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LinearTypes #-} +module LinearNewtype where + +newtype Wrap a = Wrap { unwrap :: a } diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-record-field-many.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-record-field-many.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-record-field-many.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LinearTypes #-} +module LinearRecordFieldMany where + +data T a b = MkT { x %'Many :: a, y :: b } diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-record-field-poly.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-record-field-poly.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-record-field-poly.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LinearTypes #-} +module LinearRecordFieldPoly where + +data T a m = MkT { x %m :: a } diff --git a/test/Test/Fixtures/oracle/LinearTypes/linear-where-binding.hs b/test/Test/Fixtures/oracle/LinearTypes/linear-where-binding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LinearTypes/linear-where-binding.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LinearTypes #-} +module LinearWhereBinding where + +h :: Int -> Int +h x = y + where + %1 y = x diff --git a/test/Test/Fixtures/oracle/LocalFixity/local-infix-let.hs b/test/Test/Fixtures/oracle/LocalFixity/local-infix-let.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LocalFixity/local-infix-let.hs @@ -0,0 +1,2 @@ +{- ORACLE_TEST pass -} +main = let { infixl 7 *%; x = 5 *% 3 *% 2 } in x diff --git a/test/Test/Fixtures/oracle/LocalFixity/local-infix-multi-ops.hs b/test/Test/Fixtures/oracle/LocalFixity/local-infix-multi-ops.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LocalFixity/local-infix-multi-ops.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +f x = x .>. (y .<. z) + where + infixl 4 .>., .<. + (.>.) = (>) + (.<.) = (<) + y = 10 + z = 5 diff --git a/test/Test/Fixtures/oracle/LocalFixity/local-infix-multiple.hs b/test/Test/Fixtures/oracle/LocalFixity/local-infix-multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LocalFixity/local-infix-multiple.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/LocalFixity/local-infix-where.hs b/test/Test/Fixtures/oracle/LocalFixity/local-infix-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LocalFixity/local-infix-where.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/LocalTypeSignatures/let-binding-signature.hs b/test/Test/Fixtures/oracle/LocalTypeSignatures/let-binding-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LocalTypeSignatures/let-binding-signature.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module LetBindingSignature where + +f = let x :: Double = 1 in x diff --git a/test/Test/Fixtures/oracle/LocalTypeSignatures/where-binding-signature.hs b/test/Test/Fixtures/oracle/LocalTypeSignatures/where-binding-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/LocalTypeSignatures/where-binding-signature.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module WhereBindingSignature where + +f = x + where + x :: Double = 1 diff --git a/test/Test/Fixtures/oracle/MagicHash/basic.hs b/test/Test/Fixtures/oracle/MagicHash/basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MagicHash/basic.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MagicHash #-} +module Basic where + +x# :: Int# +x# = 42# diff --git a/test/Test/Fixtures/oracle/MagicHash/infix-operator-layout.hs b/test/Test/Fixtures/oracle/MagicHash/infix-operator-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MagicHash/infix-operator-layout.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MagicHash #-} + +module MagicHashOperatorLayout where + +fn = val + #! val diff --git a/test/Test/Fixtures/oracle/MagicHash/literals.hs b/test/Test/Fixtures/oracle/MagicHash/literals.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MagicHash/literals.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MagicHash #-} +module Literals where + +c# = 'a'# +s# = "hello"# diff --git a/test/Test/Fixtures/oracle/MagicHash/negated-primitive-spaced.hs b/test/Test/Fixtures/oracle/MagicHash/negated-primitive-spaced.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MagicHash/negated-primitive-spaced.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MagicHash #-} +module NegatedPrimitiveSpaced where + +x = - 10# diff --git a/test/Test/Fixtures/oracle/MagicHash/word-literal-double-hash.hs b/test/Test/Fixtures/oracle/MagicHash/word-literal-double-hash.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MagicHash/word-literal-double-hash.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MagicHash #-} + +module WordLiteralDoubleHash where + +import GHC.Exts + +f = W# 0## diff --git a/test/Test/Fixtures/oracle/MultiParamTypeClasses/lawful-instance.hs b/test/Test/Fixtures/oracle/MultiParamTypeClasses/lawful-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiParamTypeClasses/lawful-instance.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE UndecidableSuperclasses #-} +module LawfulInstance where + +class c t => Lawful c t diff --git a/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-class-basic.hs b/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-class-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-class-basic.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiParamTypeClasses #-} + +module MultiParamTypeClassesClassBasic where + +class Converts a b where + convert :: a -> b diff --git a/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-constrained-method.hs b/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-constrained-method.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-constrained-method.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiParamTypeClasses #-} + +module MultiParamTypeClassesConstrainedMethod where + +class Render a b where + render :: Show a => a -> b -> String diff --git a/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-deriving-with-type-arg.hs b/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-deriving-with-type-arg.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-deriving-with-type-arg.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiParamTypeClasses #-} + +module MptcDerivingWithTypeArg where + +newtype SequenceIdT s m = SequenceIdT m deriving (MonadState s, MonadTrans) diff --git a/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-instance-basic.hs b/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-instance-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-instance-basic.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-superclass.hs b/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-superclass.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-superclass.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-three-params.hs b/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-three-params.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiParamTypeClasses/mptc-three-params.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/MultiWayIf/basic.hs b/test/Test/Fixtures/oracle/MultiWayIf/basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiWayIf/basic.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/MultiWayIf/indented.hs b/test/Test/Fixtures/oracle/MultiWayIf/indented.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiWayIf/indented.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/MultiWayIf/infix-branch-type-signature.hs b/test/Test/Fixtures/oracle/MultiWayIf/infix-branch-type-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiWayIf/infix-branch-type-signature.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiWayIf #-} + +module InfixBranchTypeSignature where + +x = if | True -> a + + b :: Int diff --git a/test/Test/Fixtures/oracle/MultiWayIf/left-infix-roundtrip.hs b/test/Test/Fixtures/oracle/MultiWayIf/left-infix-roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiWayIf/left-infix-roundtrip.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiWayIf #-} +module MultiWayIfLeftInfixRoundtrip where + +f = (if | True -> ()) `a` 'x' diff --git a/test/Test/Fixtures/oracle/MultiWayIf/multiway-if-infix-roundtrip.hs b/test/Test/Fixtures/oracle/MultiWayIf/multiway-if-infix-roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiWayIf/multiway-if-infix-roundtrip.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiWayIf #-} +module MultiWayIfInfixRoundtrip where + +f = x ++ + if | True -> () diff --git a/test/Test/Fixtures/oracle/MultiWayIf/nested.hs b/test/Test/Fixtures/oracle/MultiWayIf/nested.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiWayIf/nested.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/MultiWayIf/non-aligned-guards.hs b/test/Test/Fixtures/oracle/MultiWayIf/non-aligned-guards.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiWayIf/non-aligned-guards.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/MultiWayIf/offside-infix.hs b/test/Test/Fixtures/oracle/MultiWayIf/offside-infix.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiWayIf/offside-infix.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiWayIf #-} +module OffsideInfix where + +f = + if | True + -> + 1 + + 2 diff --git a/test/Test/Fixtures/oracle/MultiWayIf/pattern-guard-type-signature-unboxed-sum.hs b/test/Test/Fixtures/oracle/MultiWayIf/pattern-guard-type-signature-unboxed-sum.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiWayIf/pattern-guard-type-signature-unboxed-sum.hs @@ -0,0 +1,14 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} + +module PatternGuardTypeSignatureUnboxedSum where + +(# + | + | [] + | #) = + if | (# #) <- (() :: (# (# [a||] | C #) | * #)) + -> 0 diff --git a/test/Test/Fixtures/oracle/MultiWayIf/pattern-guards.hs b/test/Test/Fixtures/oracle/MultiWayIf/pattern-guards.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultiWayIf/pattern-guards.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/MultilineStrings/basic.hs b/test/Test/Fixtures/oracle/MultilineStrings/basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultilineStrings/basic.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultilineStrings #-} +module Basic where + +s :: String +s = """ + Hello, + World! + """ diff --git a/test/Test/Fixtures/oracle/MultilineStrings/empty.hs b/test/Test/Fixtures/oracle/MultilineStrings/empty.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultilineStrings/empty.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultilineStrings #-} +module Empty where + +s :: String +s = """""" diff --git a/test/Test/Fixtures/oracle/MultilineStrings/escape.hs b/test/Test/Fixtures/oracle/MultilineStrings/escape.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultilineStrings/escape.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultilineStrings #-} +module Escape where + +s :: String +s = """ + Line 1\nLine 2 + """ diff --git a/test/Test/Fixtures/oracle/MultilineStrings/escaped-quote-with-continuation.hs b/test/Test/Fixtures/oracle/MultilineStrings/escaped-quote-with-continuation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultilineStrings/escaped-quote-with-continuation.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} + +x = [ + (A, "\ +\") + , (B, "\ +\c") + ] diff --git a/test/Test/Fixtures/oracle/MultilineStrings/help-message-unicode-quote.hs b/test/Test/Fixtures/oracle/MultilineStrings/help-message-unicode-quote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultilineStrings/help-message-unicode-quote.hs @@ -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\ +\ 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\ +\" diff --git a/test/Test/Fixtures/oracle/MultilineStrings/indentation.hs b/test/Test/Fixtures/oracle/MultilineStrings/indentation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultilineStrings/indentation.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultilineStrings #-} +module Indentation where + +s :: String +s = """ + This is indented + by two spaces. + """ diff --git a/test/Test/Fixtures/oracle/MultilineStrings/manual-linebreaks.hs b/test/Test/Fixtures/oracle/MultilineStrings/manual-linebreaks.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultilineStrings/manual-linebreaks.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultilineStrings #-} +module ManualLinebreaks where + +s :: String +s = """ + Hello \& + World + """ diff --git a/test/Test/Fixtures/oracle/MultilineStrings/single-line.hs b/test/Test/Fixtures/oracle/MultilineStrings/single-line.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultilineStrings/single-line.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultilineStrings #-} +module SingleLine where + +s :: String +s = """One line""" diff --git a/test/Test/Fixtures/oracle/MultilineStrings/string-gap-type-error-indentation.hs b/test/Test/Fixtures/oracle/MultilineStrings/string-gap-type-error-indentation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/MultilineStrings/string-gap-type-error-indentation.hs @@ -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." + ) diff --git a/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-case.hs b/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-case.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-case.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-construct.hs b/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-construct.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-construct.hs @@ -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} diff --git a/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-let.hs b/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-let.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-let.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-mixed.hs b/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-mixed.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-mixed.hs @@ -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} diff --git a/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-pattern.hs b/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NamedFieldPuns/named-puns-pattern.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/NamedFieldPuns/record-unpack-pragma.hs b/test/Test/Fixtures/oracle/NamedFieldPuns/record-unpack-pragma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NamedFieldPuns/record-unpack-pragma.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE NamedFieldPuns #-} + +data BQueue a = BQueue + { bqRead :: {-# UNPACK #-}!Int + } diff --git a/test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-expression-signature.hs b/test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-expression-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-expression-signature.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE NamedWildCards #-} + +module NamedWildcardExpressionSignature where + +identityExpr :: Int +identityExpr = (id :: _b -> _b) 7 diff --git a/test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-forall.hs b/test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-forall.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-forall.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE NamedWildCards, ExplicitForAll #-} + +module NamedWildcardForall where + +poly :: forall _a. _a -> _a +poly x = x diff --git a/test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-multi-hole.hs b/test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-multi-hole.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-multi-hole.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE NamedWildCards #-} + +module NamedWildcardMultiHole where + +pair :: _x -> _y -> (_x, _y) +pair x y = (x, y) diff --git a/test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-top-signature.hs b/test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-top-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NamedWildCards/named-wildcard-top-signature.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE NamedWildCards #-} + +module NamedWildcardTopSignature where + +identity :: _a -> _a +identity x = x diff --git a/test/Test/Fixtures/oracle/NonEmptyPattern/associativity.hs b/test/Test/Fixtures/oracle/NonEmptyPattern/associativity.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NonEmptyPattern/associativity.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} +module NonEmptyPattern where + +import Data.List.NonEmpty (NonEmpty(..)) + +f (x :| y : ys) = undefined +f _ = undefined diff --git a/test/Test/Fixtures/oracle/NonEmptyPattern/cons-chain.hs b/test/Test/Fixtures/oracle/NonEmptyPattern/cons-chain.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NonEmptyPattern/cons-chain.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} +module ConsChain where + +f (x : y : z : zs) = undefined +f _ = undefined diff --git a/test/Test/Fixtures/oracle/NonEmptyPattern/explicit-parens.hs b/test/Test/Fixtures/oracle/NonEmptyPattern/explicit-parens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NonEmptyPattern/explicit-parens.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} +module ExplicitParens where + +import Data.List.NonEmpty (NonEmpty(..)) + +f ((x :| y) : ys) = undefined +f _ = undefined diff --git a/test/Test/Fixtures/oracle/NondecreasingIndentation/nested-do-deep.hs b/test/Test/Fixtures/oracle/NondecreasingIndentation/nested-do-deep.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NondecreasingIndentation/nested-do-deep.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/NondecreasingIndentation/nested-do-lambda.hs b/test/Test/Fixtures/oracle/NondecreasingIndentation/nested-do-lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NondecreasingIndentation/nested-do-lambda.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/NondecreasingIndentation/nested-do-simple.hs b/test/Test/Fixtures/oracle/NondecreasingIndentation/nested-do-simple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NondecreasingIndentation/nested-do-simple.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/NullaryTypeClasses/nullary-class.hs b/test/Test/Fixtures/oracle/NullaryTypeClasses/nullary-class.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NullaryTypeClasses/nullary-class.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module NullaryClass where + +class BearerAuthNotEnabled diff --git a/test/Test/Fixtures/oracle/NumericUnderscores/numeric-underscores-floating.hs b/test/Test/Fixtures/oracle/NumericUnderscores/numeric-underscores-floating.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NumericUnderscores/numeric-underscores-floating.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/NumericUnderscores/numeric-underscores-integers.hs b/test/Test/Fixtures/oracle/NumericUnderscores/numeric-underscores-integers.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NumericUnderscores/numeric-underscores-integers.hs @@ -0,0 +1,10 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE NumericUnderscores #-} + +module NumericUnderscoresIntegers where + +million :: Integer +million = 1_000_000 + +hexWord :: Integer +hexWord = 0xDEAD_BEEF diff --git a/test/Test/Fixtures/oracle/NumericUnderscores/numeric-underscores-pattern.hs b/test/Test/Fixtures/oracle/NumericUnderscores/numeric-underscores-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NumericUnderscores/numeric-underscores-pattern.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/OverlappingInstances/foldable-ranger-overlappable.hs b/test/Test/Fixtures/oracle/OverlappingInstances/foldable-ranger-overlappable.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/OverlappingInstances/foldable-ranger-overlappable.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/OverlappingInstances/instance-incoherent-pragma.hs b/test/Test/Fixtures/oracle/OverlappingInstances/instance-incoherent-pragma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/OverlappingInstances/instance-incoherent-pragma.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/OverlappingInstances/instance-overlappable-pragma.hs b/test/Test/Fixtures/oracle/OverlappingInstances/instance-overlappable-pragma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/OverlappingInstances/instance-overlappable-pragma.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/OverlappingInstances/instance-overlapping-pragma.hs b/test/Test/Fixtures/oracle/OverlappingInstances/instance-overlapping-pragma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/OverlappingInstances/instance-overlapping-pragma.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/OverlappingInstances/instance-overlaps-pragma.hs b/test/Test/Fixtures/oracle/OverlappingInstances/instance-overlaps-pragma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/OverlappingInstances/instance-overlaps-pragma.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/OverloadedLabels/basic.hs b/test/Test/Fixtures/oracle/OverloadedLabels/basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/OverloadedLabels/basic.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/OverloadedLabels/hash-prefix-operator.hs b/test/Test/Fixtures/oracle/OverloadedLabels/hash-prefix-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/OverloadedLabels/hash-prefix-operator.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/OverloadedLabels/infix-overloaded-label.hs b/test/Test/Fixtures/oracle/OverloadedLabels/infix-overloaded-label.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/OverloadedLabels/infix-overloaded-label.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/OverloadedLabels/negated-label.hs b/test/Test/Fixtures/oracle/OverloadedLabels/negated-label.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/OverloadedLabels/negated-label.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE OverloadedLabels #-} +module NegatedLabel where + +x = - #label diff --git a/test/Test/Fixtures/oracle/OverloadedLabels/quoted.hs b/test/Test/Fixtures/oracle/OverloadedLabels/quoted.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/OverloadedLabels/quoted.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/PackageImports/package-imports-basic.hs b/test/Test/Fixtures/oracle/PackageImports/package-imports-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PackageImports/package-imports-basic.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PackageImports/package-imports-qualified-post.hs b/test/Test/Fixtures/oracle/PackageImports/package-imports-qualified-post.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PackageImports/package-imports-qualified-post.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PackageImports/package-imports-qualified.hs b/test/Test/Fixtures/oracle/PackageImports/package-imports-qualified.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PackageImports/package-imports-qualified.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PackageImports/safe-import-variations.hs b/test/Test/Fixtures/oracle/PackageImports/safe-import-variations.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PackageImports/safe-import-variations.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PackageImports/safe-package-import.hs b/test/Test/Fixtures/oracle/PackageImports/safe-package-import.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PackageImports/safe-package-import.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Safe, PackageImports #-} + +module SafePackageImport where + +import safe "base" Control.Applicative (pure) diff --git a/test/Test/Fixtures/oracle/ParallelListComp/parallel-list-comp-basic.hs b/test/Test/Fixtures/oracle/ParallelListComp/parallel-list-comp-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ParallelListComp/parallel-list-comp-basic.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module ParallelListCompBasic where + +pairs :: [a] -> [b] -> [(a, b)] +pairs xs ys = [ (x, y) | x <- xs | y <- ys ] diff --git a/test/Test/Fixtures/oracle/Parens/arrow-command-infix-rhs-nested.hs b/test/Test/Fixtures/oracle/Parens/arrow-command-infix-rhs-nested.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/arrow-command-infix-rhs-nested.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Arrows #-} +module M where + +x = proc _ -> do + [] -<< [] + `a` (([] -<< []) + ([] -< [])) diff --git a/test/Test/Fixtures/oracle/Parens/arrow-infix-chain-rhs.hs b/test/Test/Fixtures/oracle/Parens/arrow-infix-chain-rhs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/arrow-infix-chain-rhs.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/Parens/arrow-rhs-typesig.hs b/test/Test/Fixtures/oracle/Parens/arrow-rhs-typesig.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/arrow-rhs-typesig.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Parens/case-type-signature.hs b/test/Test/Fixtures/oracle/Parens/case-type-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/case-type-signature.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE EmptyCase #-} +module M where + +x = case a of {} :: Int diff --git a/test/Test/Fixtures/oracle/Parens/context-forall-kind-signature.hs b/test/Test/Fixtures/oracle/Parens/context-forall-kind-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/context-forall-kind-signature.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Parens/data-forall-kind-sig.hs b/test/Test/Fixtures/oracle/Parens/data-forall-kind-sig.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/data-forall-kind-sig.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module M where + +data T = forall (a :: T). C a diff --git a/test/Test/Fixtures/oracle/Parens/do-let-in-expression-stmt.hs b/test/Test/Fixtures/oracle/Parens/do-let-in-expression-stmt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/do-let-in-expression-stmt.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module DoLetInExpressionStmt where + +f m = do + let x = 1 in m x diff --git a/test/Test/Fixtures/oracle/Parens/do-type-signature.hs b/test/Test/Fixtures/oracle/Parens/do-type-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/do-type-signature.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PartialTypeSignatures #-} +module M where + +x = do + a + :: _ diff --git a/test/Test/Fixtures/oracle/Parens/infix-head-infix-pattern.hs b/test/Test/Fixtures/oracle/Parens/infix-head-infix-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/infix-head-infix-pattern.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module M where + +x = let _ + _ :+ _ = () in [] diff --git a/test/Test/Fixtures/oracle/Parens/infix-lambda.hs b/test/Test/Fixtures/oracle/Parens/infix-lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/infix-lambda.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module M where + +warnIfNullable r = when True $ P $ \s -> + Right (s {warnings = WarnNullableRExp pos w : warnings s}, ()) diff --git a/test/Test/Fixtures/oracle/Parens/infix-pneg.hs b/test/Test/Fixtures/oracle/Parens/infix-pneg.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/infix-pneg.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +module M where + +x (_ :+ -0) = 0 +x (-0 :+ _) = 0 + +_ + -0 = 0 +-0 + _ = 0 diff --git a/test/Test/Fixtures/oracle/Parens/lambda-case-type-signature.hs b/test/Test/Fixtures/oracle/Parens/lambda-case-type-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/lambda-case-type-signature.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LambdaCase #-} + +module M where + +x = \case :: Int diff --git a/test/Test/Fixtures/oracle/Parens/lambda-cases-infix-lhs.hs b/test/Test/Fixtures/oracle/Parens/lambda-cases-infix-lhs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/lambda-cases-infix-lhs.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LambdaCase #-} + +module M where + +x = \cases + y diff --git a/test/Test/Fixtures/oracle/Parens/lambda-cases-type-signature.hs b/test/Test/Fixtures/oracle/Parens/lambda-cases-type-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/lambda-cases-type-signature.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LambdaCase #-} + +module M where + +x = \cases :: Int diff --git a/test/Test/Fixtures/oracle/Parens/lambda-guard-expression-with-qualifier.hs b/test/Test/Fixtures/oracle/Parens/lambda-guard-expression-with-qualifier.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/lambda-guard-expression-with-qualifier.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +module M where + +x = + case [() ..] of + _ + | \_ -> () + , a + -> a diff --git a/test/Test/Fixtures/oracle/Parens/lambda-guard-expression.hs b/test/Test/Fixtures/oracle/Parens/lambda-guard-expression.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/lambda-guard-expression.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +module M where + +x = + case [() ..] of + _ + | \_ -> () + -> a diff --git a/test/Test/Fixtures/oracle/Parens/list-comp-then-parallel-list-comp.hs b/test/Test/Fixtures/oracle/Parens/list-comp-then-parallel-list-comp.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/list-comp-then-parallel-list-comp.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE TransformListComp #-} +module M where + +x = [[] | then [[] | [] | then [] by []] by []] diff --git a/test/Test/Fixtures/oracle/Parens/list-comp-then-type-quote.hs b/test/Test/Fixtures/oracle/Parens/list-comp-then-type-quote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/list-comp-then-type-quote.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TransformListComp #-} +module M where + +x = [[] | then [t| _ |] by []] diff --git a/test/Test/Fixtures/oracle/Parens/log-base-modify-seq-parens.hs b/test/Test/Fixtures/oracle/Parens/log-base-modify-seq-parens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/log-base-modify-seq-parens.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} + +module MonoidAppendParen where + +appendToRef ref msg' = ref (<> msg' <> "\n") diff --git a/test/Test/Fixtures/oracle/Parens/monad-metrics-section-operator-paren.hs b/test/Test/Fixtures/oracle/Parens/monad-metrics-section-operator-paren.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/monad-metrics-section-operator-paren.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ParenSectionExponent where + +nsToUs = (/ 10^(3 :: Int)) diff --git a/test/Test/Fixtures/oracle/Parens/multiway-if-infix-rhs.hs b/test/Test/Fixtures/oracle/Parens/multiway-if-infix-rhs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/multiway-if-infix-rhs.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Parens/multiway-if-type-signature.hs b/test/Test/Fixtures/oracle/Parens/multiway-if-type-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/multiway-if-type-signature.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PartialTypeSignatures #-} +module M where + +x = if | let _ = () + -> a + :: _ diff --git a/test/Test/Fixtures/oracle/Parens/negated-lambda.hs b/test/Test/Fixtures/oracle/Parens/negated-lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/negated-lambda.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module M where + +x = - \ _ -> () diff --git a/test/Test/Fixtures/oracle/Parens/negative-bit.hs b/test/Test/Fixtures/oracle/Parens/negative-bit.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/negative-bit.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module M where + +n = -bit (w - 1) diff --git a/test/Test/Fixtures/oracle/Parens/negative-one.hs b/test/Test/Fixtures/oracle/Parens/negative-one.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/negative-one.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module M where + +svDecrement x = svAddConstant x (-1 :: Integer) diff --git a/test/Test/Fixtures/oracle/Parens/nonfinal-case-block-arg.hs b/test/Test/Fixtures/oracle/Parens/nonfinal-case-block-arg.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/nonfinal-case-block-arg.hs @@ -0,0 +1,10 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BlockArguments #-} +module M where + +x = finally + case a of + True -> b + False -> c + do + d diff --git a/test/Test/Fixtures/oracle/Parens/numeric-record-dot.hs b/test/Test/Fixtures/oracle/Parens/numeric-record-dot.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/numeric-record-dot.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE OverloadedRecordDot #-} + +module M where + +x = 0.x diff --git a/test/Test/Fixtures/oracle/Parens/proc-case-guard.hs b/test/Test/Fixtures/oracle/Parens/proc-case-guard.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/proc-case-guard.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Arrows #-} +module M where + +x = case () of _ | proc _ -> a -<< () -> () diff --git a/test/Test/Fixtures/oracle/Parens/qualified-con-pattern-signature-bind.hs b/test/Test/Fixtures/oracle/Parens/qualified-con-pattern-signature-bind.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/qualified-con-pattern-signature-bind.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PartialTypeSignatures #-} +module M where + +x = let A.C :: _ = [] in [] diff --git a/test/Test/Fixtures/oracle/Parens/qualified-splice.hs b/test/Test/Fixtures/oracle/Parens/qualified-splice.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/qualified-splice.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} + +module M where + +x = $A.a diff --git a/test/Test/Fixtures/oracle/Parens/scc-typesig.hs b/test/Test/Fixtures/oracle/Parens/scc-typesig.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/scc-typesig.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module M where + +n = {-# SCC "tag" #-} fn arg :: () diff --git a/test/Test/Fixtures/oracle/Parens/seq-infix-lambda.hs b/test/Test/Fixtures/oracle/Parens/seq-infix-lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/seq-infix-lambda.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module M where + +n = \(n1 `Inf` n2 `Inf` ns) -> () + +fn (a `App` b `App` c) = () diff --git a/test/Test/Fixtures/oracle/Parens/th-instance-dollar.hs b/test/Test/Fixtures/oracle/Parens/th-instance-dollar.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/th-instance-dollar.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +module M where + +x = [d| instance X $a |] diff --git a/test/Test/Fixtures/oracle/Parens/th-name-quote-record-dot.hs b/test/Test/Fixtures/oracle/Parens/th-name-quote-record-dot.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/th-name-quote-record-dot.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TemplateHaskell #-} + +module M where + +x = ' ().a diff --git a/test/Test/Fixtures/oracle/Parens/th-proxy-dollar.hs b/test/Test/Fixtures/oracle/Parens/th-proxy-dollar.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/th-proxy-dollar.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +module M where + +x = [| Proxy :: Proxy $a |] diff --git a/test/Test/Fixtures/oracle/Parens/th-qualified-splice-record-dot-base.hs b/test/Test/Fixtures/oracle/Parens/th-qualified-splice-record-dot-base.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/th-qualified-splice-record-dot-base.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TemplateHaskell #-} + +module M where + +x = ($A.a).a diff --git a/test/Test/Fixtures/oracle/Parens/th-splice-record-dot-bare.hs b/test/Test/Fixtures/oracle/Parens/th-splice-record-dot-bare.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/th-splice-record-dot-bare.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TemplateHaskell #-} + +module M where + +x = $().a diff --git a/test/Test/Fixtures/oracle/Parens/th-type-name-quote-record-dot.hs b/test/Test/Fixtures/oracle/Parens/th-type-name-quote-record-dot.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/th-type-name-quote-record-dot.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TemplateHaskell #-} + +module M where + +x = '' ().a diff --git a/test/Test/Fixtures/oracle/Parens/th-typed-splice-record-dot-bare.hs b/test/Test/Fixtures/oracle/Parens/th-typed-splice-record-dot-bare.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/th-typed-splice-record-dot-bare.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TemplateHaskell #-} + +module M where + +x = $$().a diff --git a/test/Test/Fixtures/oracle/Parens/trailing-if.hs b/test/Test/Fixtures/oracle/Parens/trailing-if.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/trailing-if.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Parens/typed-splice-unit.hs b/test/Test/Fixtures/oracle/Parens/typed-splice-unit.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/typed-splice-unit.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} + +module M where + +x = $$() + +y = $() diff --git a/test/Test/Fixtures/oracle/Parens/typesig-lambda.hs b/test/Test/Fixtures/oracle/Parens/typesig-lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/typesig-lambda.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module M where + +n = \(Just a :: Maybe ()) -> a diff --git a/test/Test/Fixtures/oracle/Parens/view-pattern-block-app-arg.hs b/test/Test/Fixtures/oracle/Parens/view-pattern-block-app-arg.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/view-pattern-block-app-arg.hs @@ -0,0 +1,16 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE ViewPatterns #-} + +module ViewPatternBlockAppArg where + +f (# + [] + if | let { } + -> + [] + [] + -> _ + | #) = () diff --git a/test/Test/Fixtures/oracle/Parens/view-pattern-if-multiway-if-type-signature.hs b/test/Test/Fixtures/oracle/Parens/view-pattern-if-multiway-if-type-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/view-pattern-if-multiway-if-type-signature.hs @@ -0,0 +1,13 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE ViewPatterns #-} +module M where + +x (# + | if [] then [] else if | [] + -> + [] + :: _ + -> _ + | #) = () diff --git a/test/Test/Fixtures/oracle/Parens/view-pattern-list-multiway-if-type-signature.hs b/test/Test/Fixtures/oracle/Parens/view-pattern-list-multiway-if-type-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/view-pattern-list-multiway-if-type-signature.hs @@ -0,0 +1,10 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ViewPatterns #-} +module M where + +x [if | [] + -> + [] + :: _ + -> _] = () diff --git a/test/Test/Fixtures/oracle/Parens/view-pattern-multiway-if-type-signature.hs b/test/Test/Fixtures/oracle/Parens/view-pattern-multiway-if-type-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Parens/view-pattern-multiway-if-type-signature.hs @@ -0,0 +1,13 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE ViewPatterns #-} +module M where + +x (# + | if | [] + -> + [] + :: _ + -> _ + | #) = () diff --git a/test/Test/Fixtures/oracle/ParenthesizedTypeHead/class-parens.hs b/test/Test/Fixtures/oracle/ParenthesizedTypeHead/class-parens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ParenthesizedTypeHead/class-parens.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module A where + +class (MyClass a) where + myMethod :: a -> Int diff --git a/test/Test/Fixtures/oracle/ParenthesizedTypeHead/data-parens-multi-params.hs b/test/Test/Fixtures/oracle/ParenthesizedTypeHead/data-parens-multi-params.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ParenthesizedTypeHead/data-parens-multi-params.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module A where + +data (Map k v) = Map [(k, v)] diff --git a/test/Test/Fixtures/oracle/ParenthesizedTypeHead/data-parens-tail-params.hs b/test/Test/Fixtures/oracle/ParenthesizedTypeHead/data-parens-tail-params.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ParenthesizedTypeHead/data-parens-tail-params.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module A where + +data (Pair a) b = Pair a b diff --git a/test/Test/Fixtures/oracle/ParenthesizedTypeHead/newtype-parens-single-param.hs b/test/Test/Fixtures/oracle/ParenthesizedTypeHead/newtype-parens-single-param.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ParenthesizedTypeHead/newtype-parens-single-param.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module A where + +newtype (Wrapper a) = Wrapper a diff --git a/test/Test/Fixtures/oracle/ParenthesizedTypeHead/type-synonym-parens.hs b/test/Test/Fixtures/oracle/ParenthesizedTypeHead/type-synonym-parens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ParenthesizedTypeHead/type-synonym-parens.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module A where + +type (Synonym a) = [a] diff --git a/test/Test/Fixtures/oracle/PartialTypeSignatures/just1.hs b/test/Test/Fixtures/oracle/PartialTypeSignatures/just1.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PartialTypeSignatures/just1.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PartialTypeSignatures #-} +module Just1 where + +just1 :: _ Int +just1 = Just 1 diff --git a/test/Test/Fixtures/oracle/PartialTypeSignatures/just2.hs b/test/Test/Fixtures/oracle/PartialTypeSignatures/just2.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PartialTypeSignatures/just2.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PartialTypeSignatures #-} +module Just2 where + +just2 :: Maybe _ +just2 = Just False diff --git a/test/Test/Fixtures/oracle/PartialTypeSignatures/let-binding.hs b/test/Test/Fixtures/oracle/PartialTypeSignatures/let-binding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PartialTypeSignatures/let-binding.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PartialTypeSignatures #-} +module LetBinding where + +x = let y :: _; y = False in y diff --git a/test/Test/Fixtures/oracle/PartialTypeSignatures/list1.hs b/test/Test/Fixtures/oracle/PartialTypeSignatures/list1.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PartialTypeSignatures/list1.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PartialTypeSignatures #-} +module List1 where + +list :: _ Int +list = [1] diff --git a/test/Test/Fixtures/oracle/PartialTypeSignatures/list2.hs b/test/Test/Fixtures/oracle/PartialTypeSignatures/list2.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PartialTypeSignatures/list2.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PartialTypeSignatures #-} +module List2 where + +list :: [_] +list = [1] diff --git a/test/Test/Fixtures/oracle/PartialTypeSignatures/multi-constraint.hs b/test/Test/Fixtures/oracle/PartialTypeSignatures/multi-constraint.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PartialTypeSignatures/multi-constraint.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PartialTypeSignatures #-} +module MultiConstraint where + +x :: (Enum a, _) => a -> String +x = show diff --git a/test/Test/Fixtures/oracle/PartialTypeSignatures/named-wildcard.hs b/test/Test/Fixtures/oracle/PartialTypeSignatures/named-wildcard.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PartialTypeSignatures/named-wildcard.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE NamedWildCards #-} +module NamedWildcard where + +f :: _a -> Int +f x = 42 diff --git a/test/Test/Fixtures/oracle/PartialTypeSignatures/pattern-wildcard.hs b/test/Test/Fixtures/oracle/PartialTypeSignatures/pattern-wildcard.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PartialTypeSignatures/pattern-wildcard.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PartialTypeSignatures #-} +module PatternWildcard where + +foo :: _ +foo (x :: _) = (x :: _) diff --git a/test/Test/Fixtures/oracle/PartialTypeSignatures/qualified-constraint.hs b/test/Test/Fixtures/oracle/PartialTypeSignatures/qualified-constraint.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PartialTypeSignatures/qualified-constraint.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PartialTypeSignatures #-} +module QualifiedConstraint where + +x :: _ => a -> String +x = show diff --git a/test/Test/Fixtures/oracle/PartialTypeSignatures/wildcard.hs b/test/Test/Fixtures/oracle/PartialTypeSignatures/wildcard.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PartialTypeSignatures/wildcard.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PartialTypeSignatures #-} +module Wildcard where + +f :: _ -> Int +f x = 42 diff --git a/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-case-alt.hs b/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-case-alt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-case-alt.hs @@ -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 -> [] diff --git a/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-let-in-expression.hs b/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-let-in-expression.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-let-in-expression.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-multi-qualifiers.hs b/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-multi-qualifiers.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-multi-qualifiers.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PatternGuards #-} + +module PatternGuardMultiQualifiers where + +firstPositive :: [Int] -> Int +firstPositive xs + | y : _ <- xs, y > 0 = y + | otherwise = 0 diff --git a/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-single.hs b/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-single.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-single.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PatternGuards #-} + +module PatternGuardSingle where + +headOrZero :: [Int] -> Int +headOrZero xs + | y : _ <- xs = y + | otherwise = 0 diff --git a/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-with-let.hs b/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-with-let.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternGuards/pattern-guard-with-let.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternOperators/infix-function-equation-infix-pattern-operands.hs b/test/Test/Fixtures/oracle/PatternOperators/infix-function-equation-infix-pattern-operands.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternOperators/infix-function-equation-infix-pattern-operands.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module InfixFunctionEquationInfixPatternOperands where + +data List a = Nil | a :&: List a + +a :&: as == b :&: bs = () diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-bidirectional-prefix.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-bidirectional-prefix.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-bidirectional-prefix.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-complete-pragma.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-complete-pragma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-complete-pragma.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicit-where-view-pattern-layout.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicit-where-view-pattern-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicit-where-view-pattern-layout.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional-infix-backtick.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional-infix-backtick.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional-infix-backtick.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PatternSynonyms #-} +module A where +pattern x `Cons` xs <- (x : xs) + where + x `Cons` xs = x : xs diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional-infix-conapp.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional-infix-conapp.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional-infix-conapp.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional-infix-symbol.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional-infix-symbol.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional-infix-symbol.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-explicitly-bidirectional.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-data-keyword.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-data-keyword.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-data-keyword.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-double-dot.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-double-dot.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-double-dot.hs @@ -0,0 +1,12 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PatternSynonyms #-} +module PatternSynonymsExportDoubleDot + ( X + ( A, + B, + .. + ), + ) +where + +data X = A | B diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-pattern-keyword.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-pattern-keyword.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-pattern-keyword.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-pattern-wildcard.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-pattern-wildcard.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-export-pattern-wildcard.hs @@ -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 = () diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-data-keyword.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-data-keyword.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-data-keyword.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PatternSynonyms #-} + +module PatternSynonymsImportDataKeyword where + +import PatternSynonymsSource (pattern Zero, pattern Succ) + +buildZero = Zero +buildOne = Succ Zero diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-export-bundled-data.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-export-bundled-data.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-export-bundled-data.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-export-bundled.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-export-bundled.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-export-bundled.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-pattern-keyword.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-pattern-keyword.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-pattern-keyword.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-pattern-wildcard.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-pattern-wildcard.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-import-pattern-wildcard.hs @@ -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 = () diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-infix-backticks.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-infix-backticks.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-infix-backticks.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-infix-symbol.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-infix-symbol.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-infix-symbol.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-inline-pragmas.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-inline-pragmas.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-inline-pragmas.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-record-bidirectional.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-record-bidirectional.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-record-bidirectional.hs @@ -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} diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-record-unidirectional.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-record-unidirectional.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-record-unidirectional.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-signature-basic.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-signature-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-signature-basic.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-signature-dual-context.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-signature-dual-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-signature-dual-context.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-signature-type-application.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-signature-type-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-signature-type-application.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-unidirectional-prefix.hs b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-unidirectional-prefix.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSynonyms/pattern-synonyms-unidirectional-prefix.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSyntax/case-cons-continuation.hs b/test/Test/Fixtures/oracle/PatternSyntax/case-cons-continuation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSyntax/case-cons-continuation.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/PatternSyntax/case-dollar-continuation.hs b/test/Test/Fixtures/oracle/PatternSyntax/case-dollar-continuation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSyntax/case-dollar-continuation.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +module CaseDollarContinuation where + +f x y = + case x of + Just z -> z + Nothing -> id + $ y diff --git a/test/Test/Fixtures/oracle/PatternSyntax/infix-function-pattern.hs b/test/Test/Fixtures/oracle/PatternSyntax/infix-function-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSyntax/infix-function-pattern.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} + +module InfixFunctionPattern where + +f :: T -> T -> T +x #|# _ = x +_ #|# y = y diff --git a/test/Test/Fixtures/oracle/PatternSyntax/list-irrefutable-infix-patterns.hs b/test/Test/Fixtures/oracle/PatternSyntax/list-irrefutable-infix-patterns.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSyntax/list-irrefutable-infix-patterns.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSyntax/multiple-operator-patterns.hs b/test/Test/Fixtures/oracle/PatternSyntax/multiple-operator-patterns.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSyntax/multiple-operator-patterns.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSyntax/nested-parenthesized-operator-as-pattern.hs b/test/Test/Fixtures/oracle/PatternSyntax/nested-parenthesized-operator-as-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSyntax/nested-parenthesized-operator-as-pattern.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} + +module NestedParenthesizedOperatorAsPattern where + +data C = C + +fn (+)@(+)@C = () diff --git a/test/Test/Fixtures/oracle/PatternSyntax/operator-pattern.hs b/test/Test/Fixtures/oracle/PatternSyntax/operator-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSyntax/operator-pattern.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSyntax/operator-section-in-pattern.hs b/test/Test/Fixtures/oracle/PatternSyntax/operator-section-in-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSyntax/operator-section-in-pattern.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/PatternSyntax/question-mark-operator-pattern.hs b/test/Test/Fixtures/oracle/PatternSyntax/question-mark-operator-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSyntax/question-mark-operator-pattern.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module QuestionMarkOperatorPattern where + +foldl' (??) z xs = (foldr (?!) id xs) z + where + x ?! g = g . (?? x) diff --git a/test/Test/Fixtures/oracle/PatternSyntax/wildcard-infix-patterns.hs b/test/Test/Fixtures/oracle/PatternSyntax/wildcard-infix-patterns.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSyntax/wildcard-infix-patterns.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Patterns/cons-pattern-nested-parens.hs b/test/Test/Fixtures/oracle/Patterns/cons-pattern-nested-parens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Patterns/cons-pattern-nested-parens.hs @@ -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 _ = [] diff --git a/test/Test/Fixtures/oracle/Patterns/escaped-backslash-cons-pattern.hs b/test/Test/Fixtures/oracle/Patterns/escaped-backslash-cons-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Patterns/escaped-backslash-cons-pattern.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module X where + +go xs = case xs of + '^' : '\\' : xs -> '\^\' : go xs + ys -> ys diff --git a/test/Test/Fixtures/oracle/Patterns/prefix-constructor-nothing.hs b/test/Test/Fixtures/oracle/Patterns/prefix-constructor-nothing.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Patterns/prefix-constructor-nothing.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +module PrefixConstructorNothing where + +data T = T (Maybe Int) (Maybe Int) + +f (T Nothing Nothing) = () +f _ = () diff --git a/test/Test/Fixtures/oracle/Patterns/qualified-constructor-sym-record.hs b/test/Test/Fixtures/oracle/Patterns/qualified-constructor-sym-record.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Patterns/qualified-constructor-sym-record.hs @@ -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.:+) {} = () diff --git a/test/Test/Fixtures/oracle/PolyKinds/kind-paren-forall-minimal.hs b/test/Test/Fixtures/oracle/PolyKinds/kind-paren-forall-minimal.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PolyKinds/kind-paren-forall-minimal.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PolyKinds, ExplicitForAll #-} + +module KindParenForall where + +f :: forall k (a :: k). a +f = undefined diff --git a/test/Test/Fixtures/oracle/PolyKinds/paren-kind-forall.hs b/test/Test/Fixtures/oracle/PolyKinds/paren-kind-forall.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PolyKinds/paren-kind-forall.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/QualifiedDo/basic.hs b/test/Test/Fixtures/oracle/QualifiedDo/basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/QualifiedDo/basic.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE QualifiedDo #-} +module Basic where + +x = M.do + return () diff --git a/test/Test/Fixtures/oracle/QualifiedDo/qualified-do-bind.hs b/test/Test/Fixtures/oracle/QualifiedDo/qualified-do-bind.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/QualifiedDo/qualified-do-bind.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE QualifiedDo #-} +module QualifiedDoBind where + +f = M.do + x <- action + return x diff --git a/test/Test/Fixtures/oracle/QualifiedDo/qualified-do-let.hs b/test/Test/Fixtures/oracle/QualifiedDo/qualified-do-let.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/QualifiedDo/qualified-do-let.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE QualifiedDo #-} +module QualifiedDoLet where + +f = M.do + let x = 1 + return x diff --git a/test/Test/Fixtures/oracle/QualifiedDo/qualified-mdo-bind.hs b/test/Test/Fixtures/oracle/QualifiedDo/qualified-mdo-bind.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/QualifiedDo/qualified-mdo-bind.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE QualifiedDo, RecursiveDo #-} +module QualifiedMdoBind where + +f = M.mdo + x <- action + return x diff --git a/test/Test/Fixtures/oracle/QuantifiedConstraints/constraint-operators.hs b/test/Test/Fixtures/oracle/QuantifiedConstraints/constraint-operators.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/QuantifiedConstraints/constraint-operators.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/QuasiQuotes/decl-quasiquote.hs b/test/Test/Fixtures/oracle/QuasiQuotes/decl-quasiquote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/QuasiQuotes/decl-quasiquote.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE QuasiQuotes #-} +module DeclQuasiQuote where +[qq||] diff --git a/test/Test/Fixtures/oracle/QuasiQuotes/expr-quasiquote-jmacro.hs b/test/Test/Fixtures/oracle/QuasiQuotes/expr-quasiquote-jmacro.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/QuasiQuotes/expr-quasiquote-jmacro.hs @@ -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)`; })(); |] diff --git a/test/Test/Fixtures/oracle/QuasiQuotes/expr-quasiquote.hs b/test/Test/Fixtures/oracle/QuasiQuotes/expr-quasiquote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/QuasiQuotes/expr-quasiquote.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE QuasiQuotes #-} +module ExprQuasiQuote where + +x = [sql|select * from users where id = 1|] diff --git a/test/Test/Fixtures/oracle/QuasiQuotes/pat-quasiquote.hs b/test/Test/Fixtures/oracle/QuasiQuotes/pat-quasiquote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/QuasiQuotes/pat-quasiquote.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE QuasiQuotes #-} +module PatQuasiQuote where + +isMatch [sql|user:{id}|] = True +isMatch _ = False diff --git a/test/Test/Fixtures/oracle/QuasiQuotes/quasiquote-d-layout-case-payload.hs b/test/Test/Fixtures/oracle/QuasiQuotes/quasiquote-d-layout-case-payload.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/QuasiQuotes/quasiquote-d-layout-case-payload.hs @@ -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 |] diff --git a/test/Test/Fixtures/oracle/QuasiQuotes/type-quasiquote.hs b/test/Test/Fixtures/oracle/QuasiQuotes/type-quasiquote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/QuasiQuotes/type-quasiquote.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE QuasiQuotes #-} +module TypeQuasiQuote where + +f :: [sql|INT|] -> Int +f _ = 0 diff --git a/test/Test/Fixtures/oracle/RecordOperators/newtype-operator-field.hs b/test/Test/Fixtures/oracle/RecordOperators/newtype-operator-field.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecordOperators/newtype-operator-field.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} + +newtype Managed a = Managed { (>>-) :: a -> a } diff --git a/test/Test/Fixtures/oracle/RecordSyntax/as-field-construction.hs b/test/Test/Fixtures/oracle/RecordSyntax/as-field-construction.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecordSyntax/as-field-construction.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} + +data Node = Node {as :: Int} + +f :: Node +f = Node {as = 1} diff --git a/test/Test/Fixtures/oracle/RecordSyntax/operator-field.hs b/test/Test/Fixtures/oracle/RecordSyntax/operator-field.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecordSyntax/operator-field.hs @@ -0,0 +1,2 @@ +{- ORACLE_TEST pass -} +newtype T = MkT { ($$) :: Int } diff --git a/test/Test/Fixtures/oracle/RecordWildCards/construction.hs b/test/Test/Fixtures/oracle/RecordWildCards/construction.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecordWildCards/construction.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RecordWildCards #-} +module Construction where + +data Point = Point { x, y :: Int } + +f x y = Point{..} diff --git a/test/Test/Fixtures/oracle/RecordWildCards/do-binding.hs b/test/Test/Fixtures/oracle/RecordWildCards/do-binding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecordWildCards/do-binding.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RecordWildCards #-} +module DoBinding where + +x = do + Loc {..} <- location + pure () diff --git a/test/Test/Fixtures/oracle/RecordWildCards/do-tuple-as-pattern-deep.hs b/test/Test/Fixtures/oracle/RecordWildCards/do-tuple-as-pattern-deep.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecordWildCards/do-tuple-as-pattern-deep.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/RecordWildCards/do-tuple-as-pattern-simple.hs b/test/Test/Fixtures/oracle/RecordWildCards/do-tuple-as-pattern-simple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecordWildCards/do-tuple-as-pattern-simple.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/RecordWildCards/do-tuple-as-pattern.hs b/test/Test/Fixtures/oracle/RecordWildCards/do-tuple-as-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecordWildCards/do-tuple-as-pattern.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/RecordWildCards/function-pattern.hs b/test/Test/Fixtures/oracle/RecordWildCards/function-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecordWildCards/function-pattern.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RecordWildCards #-} +module FunctionPattern where + +data Record = Record { a :: Int, b :: Double } +fn Record{..} = () diff --git a/test/Test/Fixtures/oracle/RecordWildCards/function-tuple-as-pattern.hs b/test/Test/Fixtures/oracle/RecordWildCards/function-tuple-as-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecordWildCards/function-tuple-as-pattern.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/RecordWildCards/mixed.hs b/test/Test/Fixtures/oracle/RecordWildCards/mixed.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecordWildCards/mixed.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RecordWildCards #-} +module Mixed where + +data Point = Point { x, y :: Int } + +f Point{x, ..} = x + y diff --git a/test/Test/Fixtures/oracle/RecordWildCards/pattern.hs b/test/Test/Fixtures/oracle/RecordWildCards/pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecordWildCards/pattern.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RecordWildCards #-} +module Pattern where + +data Point = Point { x, y :: Int } + +f Point{..} = x + y diff --git a/test/Test/Fixtures/oracle/RecursiveDo/mdo-view-pattern.hs b/test/Test/Fixtures/oracle/RecursiveDo/mdo-view-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecursiveDo/mdo-view-pattern.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ViewPatterns #-} + +module MDoViewPattern where + +f :: a -> a +f (mdo pure x -> y) = y diff --git a/test/Test/Fixtures/oracle/RecursiveDo/mdo.hs b/test/Test/Fixtures/oracle/RecursiveDo/mdo.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecursiveDo/mdo.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RecursiveDo #-} +module MDo where + +f = mdo + x <- return 1 + return x diff --git a/test/Test/Fixtures/oracle/RecursiveDo/rec.hs b/test/Test/Fixtures/oracle/RecursiveDo/rec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RecursiveDo/rec.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RecursiveDo #-} +module Rec where + +f = do + rec + x <- return 1 + return x diff --git a/test/Test/Fixtures/oracle/RequiredTypeArguments/basic.hs b/test/Test/Fixtures/oracle/RequiredTypeArguments/basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RequiredTypeArguments/basic.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RequiredTypeArguments #-} +module Basic where + +x = f (type Int) 5 diff --git a/test/Test/Fixtures/oracle/RequiredTypeArguments/pattern.hs b/test/Test/Fixtures/oracle/RequiredTypeArguments/pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RequiredTypeArguments/pattern.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RequiredTypeArguments #-} +module Pattern where + +f (type a) x = x diff --git a/test/Test/Fixtures/oracle/RoleAnnotations/role-multi-parameter.hs b/test/Test/Fixtures/oracle/RoleAnnotations/role-multi-parameter.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RoleAnnotations/role-multi-parameter.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RoleAnnotations #-} + +module RoleMultiParameter where + +type role MultiBox representational phantom +data MultiBox a b = MultiBox a diff --git a/test/Test/Fixtures/oracle/RoleAnnotations/role-on-class-after-definition.hs b/test/Test/Fixtures/oracle/RoleAnnotations/role-on-class-after-definition.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RoleAnnotations/role-on-class-after-definition.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RoleAnnotations #-} + +module RoleOnClassAfterDefinition where + +class C a b where + method :: a -> b -> () + +type role C representational _ diff --git a/test/Test/Fixtures/oracle/RoleAnnotations/role-on-newtype.hs b/test/Test/Fixtures/oracle/RoleAnnotations/role-on-newtype.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RoleAnnotations/role-on-newtype.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RoleAnnotations #-} + +module RoleOnNewtype where + +type role Wrap nominal +newtype Wrap a = Wrap a diff --git a/test/Test/Fixtures/oracle/RoleAnnotations/role-parenthesized-operator.hs b/test/Test/Fixtures/oracle/RoleAnnotations/role-parenthesized-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RoleAnnotations/role-parenthesized-operator.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RoleAnnotations #-} + +module RoleParenthesizedOperator where + +data a := b = Pair a b + +type role (:=) nominal nominal diff --git a/test/Test/Fixtures/oracle/RoleAnnotations/role-single-parameter.hs b/test/Test/Fixtures/oracle/RoleAnnotations/role-single-parameter.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RoleAnnotations/role-single-parameter.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RoleAnnotations #-} + +module RoleSingleParameter where + +type role NominalBox nominal +data NominalBox a = NominalBox a diff --git a/test/Test/Fixtures/oracle/RoleAnnotations/role-with-infer.hs b/test/Test/Fixtures/oracle/RoleAnnotations/role-with-infer.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/RoleAnnotations/role-with-infer.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE RoleAnnotations #-} + +module RoleWithInfer where + +type role InferBox _ nominal +data InferBox a b = InferBox b diff --git a/test/Test/Fixtures/oracle/ScopedTypeVariables/constructor-pattern-type-sig-equation.hs b/test/Test/Fixtures/oracle/ScopedTypeVariables/constructor-pattern-type-sig-equation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ScopedTypeVariables/constructor-pattern-type-sig-equation.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ScopedTypeVariables #-} +module ConstructorPatternTypeSigEquation where + +C :: forall a. Show a => a = C diff --git a/test/Test/Fixtures/oracle/ScopedTypeVariables/pattern-type-sig-equation-where.hs b/test/Test/Fixtures/oracle/ScopedTypeVariables/pattern-type-sig-equation-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ScopedTypeVariables/pattern-type-sig-equation-where.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ScopedTypeVariables #-} +module PatternTypeSigEquationWhere where + +f :: Int = x + where x = 42 diff --git a/test/Test/Fixtures/oracle/ScopedTypeVariables/pattern-type-sig-equation.hs b/test/Test/Fixtures/oracle/ScopedTypeVariables/pattern-type-sig-equation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ScopedTypeVariables/pattern-type-sig-equation.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ScopedTypeVariables #-} +module PatternTypeSigEquation where + +f :: Int = 0 diff --git a/test/Test/Fixtures/oracle/ScopedTypeVariables/typed-do-bind.hs b/test/Test/Fixtures/oracle/ScopedTypeVariables/typed-do-bind.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ScopedTypeVariables/typed-do-bind.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/SourceImports/source-qualified-import.hs b/test/Test/Fixtures/oracle/SourceImports/source-qualified-import.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/SourceImports/source-qualified-import.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ImportQualifiedPost #-} + +module SourceImportQualified where + +import {-# SOURCE #-} qualified Test.ChasingBottoms.IsBottom as B diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/partial-type-sig.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/partial-type-sig.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/partial-type-sig.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PartialTypeSignatures #-} +module PartialTypeSigDeriving where + +data Foo a = Foo a + +deriving instance _ => Eq (Foo a) diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-basic.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-basic.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE StandaloneDeriving #-} + +module StandaloneDerivingBasic where + +data Box a = Box a + +deriving instance Eq a => Eq (Box a) diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-forall.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-forall.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-forall.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module StandaloneDerivingForall where + +class C a + +deriving instance forall a. C a diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-layout.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-layout.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE StandaloneDeriving #-} + +module StandaloneDerivingLayout where + +data W a = W a + +deriving instance + Show a => Show (W a) diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-multi-arg.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-multi-arg.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-multi-arg.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-nested-type.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-nested-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-nested-type.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-no-context.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-no-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-no-context.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-parenthesized.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-parenthesized.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-parenthesized.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-qualified.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-qualified.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-qualified.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-strategy-anyclass.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-strategy-anyclass.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-strategy-anyclass.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-strategy-newtype.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-strategy-newtype.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-strategy-newtype.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-strategy-stock.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-strategy-stock.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-strategy-stock.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-type-application.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-type-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-type-application.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-with-context.hs b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-with-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneDeriving/standalone-deriving-with-context.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/StandaloneKindSignatures/dependent-kind-variable.hs b/test/Test/Fixtures/oracle/StandaloneKindSignatures/dependent-kind-variable.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneKindSignatures/dependent-kind-variable.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE StandaloneKindSignatures, PolyKinds, ExplicitForAll #-} + +module DependentKindVariable where + +type Foo :: forall {k}. k -> * +data Foo x = Foo diff --git a/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-chained-visible-forall.hs b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-chained-visible-forall.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-chained-visible-forall.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-class.hs b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-class.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-class.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-data-inline-gadt.hs b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-data-inline-gadt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-data-inline-gadt.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-data.hs b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-data.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-data.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-higher-order.hs b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-higher-order.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-higher-order.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-nested-bare-kind-signature.hs b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-nested-bare-kind-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-nested-bare-kind-signature.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE StandaloneKindSignatures #-} + +module StandaloneKindNestedBareKindSignature where + +type T :: _ :: _ +data T diff --git a/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-newtype-traditional.hs b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-newtype-traditional.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-newtype-traditional.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds, StandaloneKindSignatures #-} + +module InlineKindSignatureNewtypeTraditional where + +import Data.Kind (Type) + +newtype T :: Type -> Type where + MkT :: () diff --git a/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-newtype-unlifted.hs b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-newtype-unlifted.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-newtype-unlifted.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds, StandaloneKindSignatures #-} + +module InlineKindSignatureGADT where + +newtype T :: TYPE 'WordRep where + MkT :: () diff --git a/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-nullary.hs b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-nullary.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-nullary.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE StandaloneKindSignatures #-} + +module StandaloneKindNullary where + +import Data.Kind (Type) + +type Range :: Type +data Range = Range diff --git a/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-type-operator-data.hs b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-type-operator-data.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-type-operator-data.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-type-synonym.hs b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-type-synonym.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StandaloneKindSignatures/standalone-kind-type-synonym.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/StrictData/lazy-field-annotation.hs b/test/Test/Fixtures/oracle/StrictData/lazy-field-annotation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/StrictData/lazy-field-annotation.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module LazyFieldAnnotation where + +data MapF k v r = TipF | BinF Int k ~v r r diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/domain-aeson-qualified-operator-name-quote.hs b/test/Test/Fixtures/oracle/TemplateHaskell/domain-aeson-qualified-operator-name-quote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/domain-aeson-qualified-operator-name-quote.hs @@ -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.-) diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/file-embed-lzma-typed-quote-let-splice.hs b/test/Test/Fixtures/oracle/TemplateHaskell/file-embed-lzma-typed-quote-let-splice.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/file-embed-lzma-typed-quote-let-splice.hs @@ -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 + ||] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-cpp-both.hs b/test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-cpp-both.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-cpp-both.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-splice-interaction.hs b/test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-splice-interaction.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-splice-interaction.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-splice-pattern.hs b/test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-splice-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-splice-pattern.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} + +module InfixFunlhsThSplicePattern where + +$splice `fn` () = () diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-variants.hs b/test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-variants.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/infix-funlhs-th-variants.hs @@ -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)) diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/negated-splice-spaced.hs b/test/Test/Fixtures/oracle/TemplateHaskell/negated-splice-spaced.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/negated-splice-spaced.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +module NegatedSpliceSpaced where + +x = - $a diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th-empty-list-name-quote.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th-empty-list-name-quote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th-empty-list-name-quote.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th-empty-list-quote-after-arrow.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th-empty-list-quote-after-arrow.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th-empty-list-quote-after-arrow.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} + +module X where + +import Language.Haskell.TH + +headOfType ArrowT = ''(->) +headOfType ListT = ''[] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th-quote-promoted-arrow.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th-quote-promoted-arrow.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th-quote-promoted-arrow.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} + +module THQuotePromotedArrow where + +f = ''(->) diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th-quote-tick-operator.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th-quote-tick-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th-quote-tick-operator.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE DataKinds #-} + +module THQuoteTickOperator where + +type (:>) a b = '(a, b) + +test = ''(:>) diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_data_decl.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_data_decl.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_data_decl.hs @@ -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 |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_empty.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_empty.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_empty.hs @@ -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| |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_gadt.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_gadt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_gadt.hs @@ -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 + |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_guard_fun_sig.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_guard_fun_sig.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_guard_fun_sig.hs @@ -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|] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_in_do.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_in_do.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_in_do.hs @@ -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 + |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_mixed_semi.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_mixed_semi.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_mixed_semi.hs @@ -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 + |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_multi_newlines.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_multi_newlines.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_multi_newlines.hs @@ -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" + |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_multiple.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_multiple.hs @@ -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 |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_newtype.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_newtype.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_newtype.hs @@ -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 |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_record.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_record.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_record.hs @@ -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 + } + |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_type_synonym.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_type_synonym.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_type_synonym.hs @@ -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] |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_with_sig.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_with_sig.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_decl_quote_with_sig.hs @@ -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 + |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_implicit_splice_decl.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_implicit_splice_decl.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_implicit_splice_decl.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +module TH_Implicit_Splice_Decl where + +return [] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_negated_typed_splice_type_app.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_negated_typed_splice_type_app.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_negated_typed_splice_type_app.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_nested_splice.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_nested_splice.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_nested_splice.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +module TH_Nested_Splice where + +x = [| 1 + $y |] +z = [|| 1 + $$y ||] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_operator_splice_e.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_operator_splice_e.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_operator_splice_e.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +module TH_Operator_Splice_E where + +x = $(&&) +y = $(+) diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_operator_splice_p.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_operator_splice_p.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_operator_splice_p.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +module TH_Operator_Splice_P where + +x $(*) = () diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_promoted_cons_edge_cases.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_promoted_cons_edge_cases.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_promoted_cons_edge_cases.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_quote_then_promoted_cons.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_quote_then_promoted_cons.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_quote_then_promoted_cons.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_singletons_type_sig.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_singletons_type_sig.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_singletons_type_sig.hs @@ -0,0 +1,11 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} + +module THSingletonsWithTypeSig where + +x = + singletons + [d| + f :: Int -> Int + f y = y + |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_splice_decl.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_splice_decl.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_splice_decl.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +module TH_Splice_Decl where + +$decl + +$(makeLenses ''Foo) diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_splice_e.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_splice_e.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_splice_e.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +module TH_Splice_E where + +x = $expr +y = $(expr arg) diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_splice_p.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_splice_p.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_splice_p.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +module TH_Splice_P where + +f $pat = True +g $(pat arg) = False diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_splice_t.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_splice_t.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_splice_t.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +module TH_Splice_T where + +type T = $typ +type U = $(typ arg) diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_type_splice_decl_quote_infix_body.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_type_splice_decl_quote_infix_body.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_type_splice_decl_quote_infix_body.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} + +module TH_TypeSpliceDeclQuoteInfixBody where + +x = [d| instance Show $(return $ ConT name) where show _ = abbrev |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_typed_splice.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_typed_splice.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_typed_splice.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskell #-} +module TH_Typed_Splice where + +x = $$expr +y = $$(expr arg) diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/th_value_quote_still_works.hs b/test/Test/Fixtures/oracle/TemplateHaskell/th_value_quote_still_works.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/th_value_quote_still_works.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/top-level-infix-splices.hs b/test/Test/Fixtures/oracle/TemplateHaskell/top-level-infix-splices.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/top-level-infix-splices.hs @@ -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] ] diff --git a/test/Test/Fixtures/oracle/TemplateHaskell/type-quote-constrained-signature.hs b/test/Test/Fixtures/oracle/TemplateHaskell/type-quote-constrained-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskell/type-quote-constrained-signature.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +module TypeQuoteConstrainedSignature where + +x = [t| C |] :: (:+) => () diff --git a/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_all_quote_forms.hs b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_all_quote_forms.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_all_quote_forms.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_arrow_type.hs b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_arrow_type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_arrow_type.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_name_quote.hs b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_name_quote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_name_quote.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskellQuotes #-} +module THQ_Name_Quote where + +fName = 'map +trueName = 'True +fNameSpace = ' map diff --git a/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_op_quote.hs b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_op_quote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_op_quote.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskellQuotes #-} +module THQ_Op_Quote where + +opName = '(+) +conOpName = '(:) diff --git a/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_paren_op.hs b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_paren_op.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_paren_op.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE TemplateHaskell #-} + +module THQuoteTickOperator where + +f = ''(:>) diff --git a/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_d.hs b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_d.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_d.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskellQuotes #-} +module THQ_Quote_D where + +decl = [d| f x = x |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_e.hs b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_e.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_e.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskellQuotes #-} +module THQ_Quote_E where + +f = [| 1 + 2 |] +g = [e| 1 + 2 |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_p.hs b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_p.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_p.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskellQuotes #-} +module THQ_Quote_P where + +pat = [p| Just x |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_t.hs b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_t.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_quote_t.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskellQuotes #-} +module THQ_Quote_T where + +typ = [t| Int -> Int |] diff --git a/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_type_quote.hs b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_type_quote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_type_quote.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskellQuotes #-} +module THQ_Type_Quote where + +tName = ''Int +cName = ''Eq +tNameSpace = ''Int diff --git a/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_typed_quote.hs b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_typed_quote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_typed_quote.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TemplateHaskellQuotes #-} +module THQ_Typed_Quote where + +tq = [|| 1 + 2 ||] +tqe = [e|| 1 + 2 ||] diff --git a/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_typed_splice.hs b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_typed_splice.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/thq_typed_splice.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TemplateHaskellQuotes/type-quote-splice-type-application.hs b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/type-quote-splice-type-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TemplateHaskellQuotes/type-quote-splice-type-application.hs @@ -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|] diff --git a/test/Test/Fixtures/oracle/TransformListComp/group-after-guard.hs b/test/Test/Fixtures/oracle/TransformListComp/group-after-guard.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/group-after-guard.hs @@ -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 ] diff --git a/test/Test/Fixtures/oracle/TransformListComp/group-by-using.hs b/test/Test/Fixtures/oracle/TransformListComp/group-by-using.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/group-by-using.hs @@ -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 ] diff --git a/test/Test/Fixtures/oracle/TransformListComp/group-using.hs b/test/Test/Fixtures/oracle/TransformListComp/group-using.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/group-using.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TransformListComp #-} +module GroupUsing where +f xs = [ x | x <- xs, then group using inits ] diff --git a/test/Test/Fixtures/oracle/TransformListComp/let-before-group.hs b/test/Test/Fixtures/oracle/TransformListComp/let-before-group.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/let-before-group.hs @@ -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 ] diff --git a/test/Test/Fixtures/oracle/TransformListComp/multiple-transforms.hs b/test/Test/Fixtures/oracle/TransformListComp/multiple-transforms.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/multiple-transforms.hs @@ -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 ] diff --git a/test/Test/Fixtures/oracle/TransformListComp/then-by-closed-boundaries.hs b/test/Test/Fixtures/oracle/TransformListComp/then-by-closed-boundaries.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/then-by-closed-boundaries.hs @@ -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 = () diff --git a/test/Test/Fixtures/oracle/TransformListComp/then-by-complex-expr.hs b/test/Test/Fixtures/oracle/TransformListComp/then-by-complex-expr.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/then-by-complex-expr.hs @@ -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) ] diff --git a/test/Test/Fixtures/oracle/TransformListComp/then-by-lambda-case.hs b/test/Test/Fixtures/oracle/TransformListComp/then-by-lambda-case.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/then-by-lambda-case.hs @@ -0,0 +1,12 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TransformListComp #-} + +module TransformListCompThenByLambdaCase where + +x = [ [] + | let _ = [] + , then [] + `a` \case + _ -> [] by [] + ] diff --git a/test/Test/Fixtures/oracle/TransformListComp/then-f-by-e.hs b/test/Test/Fixtures/oracle/TransformListComp/then-f-by-e.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/then-f-by-e.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TransformListComp #-} +module ThenFByE where +f xs = [ x | x <- xs, then sortWith by x ] diff --git a/test/Test/Fixtures/oracle/TransformListComp/then-f-single.hs b/test/Test/Fixtures/oracle/TransformListComp/then-f-single.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/then-f-single.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TransformListComp #-} +module ThenFSingle where +f xs = [ x | x <- xs, then reverse ] diff --git a/test/Test/Fixtures/oracle/TransformListComp/then-f.hs b/test/Test/Fixtures/oracle/TransformListComp/then-f.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/then-f.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TransformListComp #-} +module ThenF where +f xs = [ x | x <- xs, then take 5 ] diff --git a/test/Test/Fixtures/oracle/TransformListComp/then-infix-expr.hs b/test/Test/Fixtures/oracle/TransformListComp/then-infix-expr.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/then-infix-expr.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TransformListComp #-} +module ThenInfixExpr where +f xs = [ x | x <- xs, then reverse . sort ] diff --git a/test/Test/Fixtures/oracle/TransformListComp/then-paren-fn.hs b/test/Test/Fixtures/oracle/TransformListComp/then-paren-fn.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/then-paren-fn.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TransformListComp #-} +module ThenParenFn where +f xs = [ x | x <- xs, then (take 3) ] diff --git a/test/Test/Fixtures/oracle/TransformListComp/then-qualified-fn.hs b/test/Test/Fixtures/oracle/TransformListComp/then-qualified-fn.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/then-qualified-fn.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TransformListComp #-} +module ThenQualifiedFn where +f xs = [ x | x <- xs, then Data.List.sort ] diff --git a/test/Test/Fixtures/oracle/TuplePatterns/list-comp.hs b/test/Test/Fixtures/oracle/TuplePatterns/list-comp.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TuplePatterns/list-comp.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} +module TuplePatterns where + +f = [(,) x () | (,) x () <- []] diff --git a/test/Test/Fixtures/oracle/TupleSections/tuple-section-left.hs b/test/Test/Fixtures/oracle/TupleSections/tuple-section-left.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TupleSections/tuple-section-left.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TupleSections #-} + +module TupleSectionLeft where + +pairWithOne :: Int -> (Int, Int) +pairWithOne = (1,) diff --git a/test/Test/Fixtures/oracle/TupleSections/tuple-section-middle.hs b/test/Test/Fixtures/oracle/TupleSections/tuple-section-middle.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TupleSections/tuple-section-middle.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TupleSections #-} + +module TupleSectionMiddle where + +fillMiddle :: Int -> (Int, Int, Int) +fillMiddle = (,2,) diff --git a/test/Test/Fixtures/oracle/TupleSections/tuple-section-nested.hs b/test/Test/Fixtures/oracle/TupleSections/tuple-section-nested.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TupleSections/tuple-section-nested.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TupleSections #-} + +module TupleSectionNested where + +nested :: Int -> ((Int, Int), Int) +nested = ((,3),) diff --git a/test/Test/Fixtures/oracle/TupleSections/tuple-section-right.hs b/test/Test/Fixtures/oracle/TupleSections/tuple-section-right.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TupleSections/tuple-section-right.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TupleSections #-} + +module TupleSectionRight where + +pairWithLast :: Int -> (Int, Int) +pairWithLast = (,1) diff --git a/test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction-chained-application.hs b/test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction-chained-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction-chained-application.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction-parenthesized-partial-application.hs b/test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction-parenthesized-partial-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction-parenthesized-partial-application.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction-partial-application.hs b/test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction-partial-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction-partial-application.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction.hs b/test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeAbstractions/type-synonym-abstraction.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeApplications/type-applications-chained.hs b/test/Test/Fixtures/oracle/TypeApplications/type-applications-chained.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeApplications/type-applications-chained.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeApplications/type-applications-expr-basic.hs b/test/Test/Fixtures/oracle/TypeApplications/type-applications-expr-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeApplications/type-applications-expr-basic.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/TypeApplications/type-applications-let-where.hs b/test/Test/Fixtures/oracle/TypeApplications/type-applications-let-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeApplications/type-applications-let-where.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeApplications/type-applications-list-type.hs b/test/Test/Fixtures/oracle/TypeApplications/type-applications-list-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeApplications/type-applications-list-type.hs @@ -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] diff --git a/test/Test/Fixtures/oracle/TypeApplications/type-applications-no-space.hs b/test/Test/Fixtures/oracle/TypeApplications/type-applications-no-space.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeApplications/type-applications-no-space.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeApplications #-} +module TypeApplicationsNoSpace where + +f :: a -> a +f x = x + +x :: Int +x = f @Int 1 diff --git a/test/Test/Fixtures/oracle/TypeApplications/type-applications-paren-type.hs b/test/Test/Fixtures/oracle/TypeApplications/type-applications-paren-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeApplications/type-applications-paren-type.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/TypeApplications/visible-type-application-star-is-type.hs b/test/Test/Fixtures/oracle/TypeApplications/visible-type-application-star-is-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeApplications/visible-type-application-star-is-type.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} + +data Proxy (a :: *) = Proxy + +x :: Proxy (*) +x = Proxy @(*) diff --git a/test/Test/Fixtures/oracle/TypeData/basic.hs b/test/Test/Fixtures/oracle/TypeData/basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeData/basic.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeData #-} +module Basic where + +type data Nat = Zero | Succ Nat diff --git a/test/Test/Fixtures/oracle/TypeFamilies/associated-data-family-infix-instance.hs b/test/Test/Fixtures/oracle/TypeFamilies/associated-data-family-infix-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/associated-data-family-infix-instance.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/associated-data-infix-operator.hs b/test/Test/Fixtures/oracle/TypeFamilies/associated-data-infix-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/associated-data-infix-operator.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module AssociatedDataInfixOperator where + +class C a where + data x :*: y :: * diff --git a/test/Test/Fixtures/oracle/TypeFamilies/associated-data.hs b/test/Test/Fixtures/oracle/TypeFamilies/associated-data.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/associated-data.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/associated-type-default.hs b/test/Test/Fixtures/oracle/TypeFamilies/associated-type-default.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/associated-type-default.hs @@ -0,0 +1,11 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} + +module AssociatedTypeDefault where + +-- Type family default equation without 'instance' keyword. +-- GHC allows: type F a = inside a class body as shorthand for +-- type instance F a = . +class Foo n where + type O n + type O n = Int diff --git a/test/Test/Fixtures/oracle/TypeFamilies/associated-type-injectivity.hs b/test/Test/Fixtures/oracle/TypeFamilies/associated-type-injectivity.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/associated-type-injectivity.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +module AssociatedTypeInjectivity where + +class C a where + type Elem a = r | r -> a diff --git a/test/Test/Fixtures/oracle/TypeFamilies/associated-type.hs b/test/Test/Fixtures/oracle/TypeFamilies/associated-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/associated-type.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +module AssociatedType where + +import Data.Kind (Type) + +class Collects ce where + type Elem ce :: Type diff --git a/test/Test/Fixtures/oracle/TypeFamilies/basic.hs b/test/Test/Fixtures/oracle/TypeFamilies/basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/basic.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +module Basic where + +type family F a diff --git a/test/Test/Fixtures/oracle/TypeFamilies/closed-type-family-forall.hs b/test/Test/Fixtures/oracle/TypeFamilies/closed-type-family-forall.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/closed-type-family-forall.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/closed-type-family.hs b/test/Test/Fixtures/oracle/TypeFamilies/closed-type-family.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/closed-type-family.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +module ClosedTypeFamily where + +type family F a where + F Int = String + F a = a diff --git a/test/Test/Fixtures/oracle/TypeFamilies/data-family-index.hs b/test/Test/Fixtures/oracle/TypeFamilies/data-family-index.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/data-family-index.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +module DataFamilyIndex where + +import Data.Kind (Type) + +data family GMap k :: Type -> Type diff --git a/test/Test/Fixtures/oracle/TypeFamilies/data-family.hs b/test/Test/Fixtures/oracle/TypeFamilies/data-family.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/data-family.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +module DataFamily where + +data family D a diff --git a/test/Test/Fixtures/oracle/TypeFamilies/data-instance-gadt.hs b/test/Test/Fixtures/oracle/TypeFamilies/data-instance-gadt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/data-instance-gadt.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/data-instance-in-class-instance.hs b/test/Test/Fixtures/oracle/TypeFamilies/data-instance-in-class-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/data-instance-in-class-instance.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/TypeFamilies/data-instance-kind-signature.hs b/test/Test/Fixtures/oracle/TypeFamilies/data-instance-kind-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/data-instance-kind-signature.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/data-instance.hs b/test/Test/Fixtures/oracle/TypeFamilies/data-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/data-instance.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/TypeFamilies/default-associated-type-wildcard.hs b/test/Test/Fixtures/oracle/TypeFamilies/default-associated-type-wildcard.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/default-associated-type-wildcard.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +module DefaultAssociatedTypeWildcard where + +class C a where + type F a + type F _ = () diff --git a/test/Test/Fixtures/oracle/TypeFamilies/default-type-instance.hs b/test/Test/Fixtures/oracle/TypeFamilies/default-type-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/default-type-instance.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +module DefaultTypeInstance where + +class IsBoolMap v where + type Key v + type instance Key v = Int diff --git a/test/Test/Fixtures/oracle/TypeFamilies/explicit-forall.hs b/test/Test/Fixtures/oracle/TypeFamilies/explicit-forall.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/explicit-forall.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/infix-type-family-equation.hs b/test/Test/Fixtures/oracle/TypeFamilies/infix-type-family-equation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/infix-type-family-equation.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module InfixTypeFamilyEquation where + +type family a ** b where + a ** b = () diff --git a/test/Test/Fixtures/oracle/TypeFamilies/infix-type-family-head.hs b/test/Test/Fixtures/oracle/TypeFamilies/infix-type-family-head.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/infix-type-family-head.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module InfixTypeFamilyHead where + +type family l `And` r where + l `And` r = l diff --git a/test/Test/Fixtures/oracle/TypeFamilies/infix-type-family-symbol.hs b/test/Test/Fixtures/oracle/TypeFamilies/infix-type-family-symbol.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/infix-type-family-symbol.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module InfixTypeFamilySymbol where + +type family (***) a b diff --git a/test/Test/Fixtures/oracle/TypeFamilies/multiline-import-type-family.hs b/test/Test/Fixtures/oracle/TypeFamilies/multiline-import-type-family.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/multiline-import-type-family.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +import Generic.Data.Function.FoldMap.Constructor + ( GFoldMapC(gFoldMapC) + , GenericFoldMap(type GenericFoldMapM) ) diff --git a/test/Test/Fixtures/oracle/TypeFamilies/multiple-associated-instances.hs b/test/Test/Fixtures/oracle/TypeFamilies/multiple-associated-instances.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/multiple-associated-instances.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/newtype-instance-in-class-instance.hs b/test/Test/Fixtures/oracle/TypeFamilies/newtype-instance-in-class-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/newtype-instance-in-class-instance.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/TypeFamilies/newtype-instance.hs b/test/Test/Fixtures/oracle/TypeFamilies/newtype-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/newtype-instance.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +module NewtypeInstance where + +data family T a +newtype instance T Char = TC Bool diff --git a/test/Test/Fixtures/oracle/TypeFamilies/paren-infix-type-family-backtick.hs b/test/Test/Fixtures/oracle/TypeFamilies/paren-infix-type-family-backtick.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/paren-infix-type-family-backtick.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} + +module ParenInfixTypeFamilyBacktick where + +type family (a `And` b) diff --git a/test/Test/Fixtures/oracle/TypeFamilies/paren-infix-type-family-with-result-sig.hs b/test/Test/Fixtures/oracle/TypeFamilies/paren-infix-type-family-with-result-sig.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/paren-infix-type-family-with-result-sig.hs @@ -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] diff --git a/test/Test/Fixtures/oracle/TypeFamilies/polykinded-type-family.hs b/test/Test/Fixtures/oracle/TypeFamilies/polykinded-type-family.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/polykinded-type-family.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/promoted-types-in-equations.hs b/test/Test/Fixtures/oracle/TypeFamilies/promoted-types-in-equations.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/promoted-types-in-equations.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/star-list-kind-equations.hs b/test/Test/Fixtures/oracle/TypeFamilies/star-list-kind-equations.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/star-list-kind-equations.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds, TypeFamilies #-} +module StarListKindTypeFamily where + +type family F (xs :: [*]) (r :: *) :: * where + F '[] r = r diff --git a/test/Test/Fixtures/oracle/TypeFamilies/type-equality-family-application.hs b/test/Test/Fixtures/oracle/TypeFamilies/type-equality-family-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/type-equality-family-application.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/type-family-arity.hs b/test/Test/Fixtures/oracle/TypeFamilies/type-family-arity.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/type-family-arity.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +module TypeFamilyArity where + +import Data.Kind (Type) + +type family F a b :: Type -> Type diff --git a/test/Test/Fixtures/oracle/TypeFamilies/type-family-equation-backtick-operator.hs b/test/Test/Fixtures/oracle/TypeFamilies/type-family-equation-backtick-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/type-family-equation-backtick-operator.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/type-family-function-instance.hs b/test/Test/Fixtures/oracle/TypeFamilies/type-family-function-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/type-family-function-instance.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/type-family-infix-star-equation.hs b/test/Test/Fixtures/oracle/TypeFamilies/type-family-infix-star-equation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/type-family-infix-star-equation.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/type-family-unicode-quote.hs b/test/Test/Fixtures/oracle/TypeFamilies/type-family-unicode-quote.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/type-family-unicode-quote.hs @@ -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 '[] = '[] diff --git a/test/Test/Fixtures/oracle/TypeFamilies/type-instance-rhs-kind-annotation.hs b/test/Test/Fixtures/oracle/TypeFamilies/type-instance-rhs-kind-annotation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/type-instance-rhs-kind-annotation.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeFamilies/type-instance.hs b/test/Test/Fixtures/oracle/TypeFamilies/type-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/type-instance.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeFamilies #-} +module TypeInstance where + +type family Elem c +type instance Elem [e] = e diff --git a/test/Test/Fixtures/oracle/TypeFamilies/unpos-promoted-tuple.hs b/test/Test/Fixtures/oracle/TypeFamilies/unpos-promoted-tuple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/unpos-promoted-tuple.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/TypeFamilies/wildcards.hs b/test/Test/Fixtures/oracle/TypeFamilies/wildcards.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeFamilies/wildcards.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/TypeLevelOperators/constraint-implication.hs b/test/Test/Fixtures/oracle/TypeLevelOperators/constraint-implication.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeLevelOperators/constraint-implication.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeLevelOperators/parenthesized-minus-operator.hs b/test/Test/Fixtures/oracle/TypeLevelOperators/parenthesized-minus-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeLevelOperators/parenthesized-minus-operator.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} + +module ParenthesizedMinusOperator where + +f :: Int (-) String +f = undefined diff --git a/test/Test/Fixtures/oracle/TypeLevelOperators/subtraction-in-constraint.hs b/test/Test/Fixtures/oracle/TypeLevelOperators/subtraction-in-constraint.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeLevelOperators/subtraction-in-constraint.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE DataKinds #-} + +import GHC.TypeNats + +f :: KnownNat (n - m) => proxy n -> proxy m +f = undefined diff --git a/test/Test/Fixtures/oracle/TypeLevelOperators/subtraction-type-signature.hs b/test/Test/Fixtures/oracle/TypeLevelOperators/subtraction-type-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeLevelOperators/subtraction-type-signature.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} + +module TypeLevelSubtractionSignature where + +f :: Int - String -> Bool +f = undefined diff --git a/test/Test/Fixtures/oracle/TypeLevelOperators/subtraction-type-synonym.hs b/test/Test/Fixtures/oracle/TypeLevelOperators/subtraction-type-synonym.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeLevelOperators/subtraction-type-synonym.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} + +module TypeLevelSubtractionSynonym where + +type a - b = Either a b + +f :: Int - String +f = undefined diff --git a/test/Test/Fixtures/oracle/TypeOperators/constraint-operator-class.hs b/test/Test/Fixtures/oracle/TypeOperators/constraint-operator-class.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/constraint-operator-class.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} + +module ConstraintOperatorClass where + +class (c1 a, c2 a) => (:&&:) c1 c2 a diff --git a/test/Test/Fixtures/oracle/TypeOperators/infix-constructor-boxed-pair.hs b/test/Test/Fixtures/oracle/TypeOperators/infix-constructor-boxed-pair.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/infix-constructor-boxed-pair.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} + +module InfixConstructorBoxedPair where + +data D = (a, b) :. Int diff --git a/test/Test/Fixtures/oracle/TypeOperators/infix-constructor-boxed-unit.hs b/test/Test/Fixtures/oracle/TypeOperators/infix-constructor-boxed-unit.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/infix-constructor-boxed-unit.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} + +module InfixConstructorBoxedUnit where + +data D = () :. Int diff --git a/test/Test/Fixtures/oracle/TypeOperators/infix-data-head-kinded-binders.hs b/test/Test/Fixtures/oracle/TypeOperators/infix-data-head-kinded-binders.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/infix-data-head-kinded-binders.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeOperators/infix-instance-head-type-app.hs b/test/Test/Fixtures/oracle/TypeOperators/infix-instance-head-type-app.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/infix-instance-head-type-app.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeOperators/star-is-type-application-signature.hs b/test/Test/Fixtures/oracle/TypeOperators/star-is-type-application-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/star-is-type-application-signature.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} + +data Proxy a = Proxy + +mulProxy :: Proxy a -> Proxy b -> Proxy (a * b) +mulProxy _ _ = Proxy diff --git a/test/Test/Fixtures/oracle/TypeOperators/type-compose-constraint.hs b/test/Test/Fixtures/oracle/TypeOperators/type-compose-constraint.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/type-compose-constraint.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} + +module TypeComposeConstraint where + +import Data.Functor.Compose + +class (f (g x)) => (f `Compose` g) x diff --git a/test/Test/Fixtures/oracle/TypeOperators/type-family-operator-extended.hs b/test/Test/Fixtures/oracle/TypeOperators/type-family-operator-extended.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/type-family-operator-extended.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeOperators/type-family-operator.hs b/test/Test/Fixtures/oracle/TypeOperators/type-family-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/type-family-operator.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators, TypeFamilies #-} + +-- Type families with operator names are supported. + +module TypeFamilyOperator where + +type family (++) a b diff --git a/test/Test/Fixtures/oracle/TypeOperators/type-operator-class.hs b/test/Test/Fixtures/oracle/TypeOperators/type-operator-class.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/type-operator-class.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} + +module TypeOperatorClass where + +infix 4 :=: +class a :=: b where + proof :: a -> b -> () diff --git a/test/Test/Fixtures/oracle/TypeOperators/type-operator-data-infix.hs b/test/Test/Fixtures/oracle/TypeOperators/type-operator-data-infix.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/type-operator-data-infix.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} + +module TypeOperatorDataInfix where + +infixr 5 :+: +data a :+: b = InL a | InR b diff --git a/test/Test/Fixtures/oracle/TypeOperators/type-operator-data.hs b/test/Test/Fixtures/oracle/TypeOperators/type-operator-data.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/type-operator-data.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} + +module TypeOperatorData where + +data (f :+: g) e = Left' (f e) | Right' (g e) diff --git a/test/Test/Fixtures/oracle/TypeOperators/type-operator-gadt-constraint.hs b/test/Test/Fixtures/oracle/TypeOperators/type-operator-gadt-constraint.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/type-operator-gadt-constraint.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/TypeOperators/type-operator-qualified-constraint.hs b/test/Test/Fixtures/oracle/TypeOperators/type-operator-qualified-constraint.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/type-operator-qualified-constraint.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds, TypeOperators #-} +module TypeOperatorQualifiedConstraint where + +import GHC.TypeLits + +f :: (1 <= 2) => () +f = () diff --git a/test/Test/Fixtures/oracle/TypeOperators/type-operator-signature.hs b/test/Test/Fixtures/oracle/TypeOperators/type-operator-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/type-operator-signature.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/TypeOperators/type-operator-type-synonym-paren.hs b/test/Test/Fixtures/oracle/TypeOperators/type-operator-type-synonym-paren.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/type-operator-type-synonym-paren.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} + +module TypeOperatorTypeSynonymParen where + +type (:+:) = (,) + +usePlus :: Int :+: Int +usePlus = (1, 2) diff --git a/test/Test/Fixtures/oracle/TypeOperators/type-operator-type-synonym.hs b/test/Test/Fixtures/oracle/TypeOperators/type-operator-type-synonym.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/type-operator-type-synonym.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} + +module TypeOperatorTypeSynonym where + +infixr 6 :*: +type a :*: b = (a, b) diff --git a/test/Test/Fixtures/oracle/TypeOperators/type-synonym-operator-kinded-params.hs b/test/Test/Fixtures/oracle/TypeOperators/type-synonym-operator-kinded-params.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/type-synonym-operator-kinded-params.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} + +module TypeSynonymOperatorKindedParams where + +type (a :: k1) <= (b :: k2) = (a <=? b) ~ 'True diff --git a/test/Test/Fixtures/oracle/TypeOperators/type-variable-operator-type-synonym.hs b/test/Test/Fixtures/oracle/TypeOperators/type-variable-operator-type-synonym.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeOperators/type-variable-operator-type-synonym.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} + +module TypeVariableOperatorTypeSynonym where + +type f ~> g = f -> g diff --git a/test/Test/Fixtures/oracle/TypeSignatureGuards/constructor-equation.hs b/test/Test/Fixtures/oracle/TypeSignatureGuards/constructor-equation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeSignatureGuards/constructor-equation.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module TypeSignatureGuardsConstructorEquation where + +C :: D = C diff --git a/test/Test/Fixtures/oracle/TypeSignatureGuards/where-clause.hs b/test/Test/Fixtures/oracle/TypeSignatureGuards/where-clause.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TypeSignatureGuards/where-clause.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} +module TypeSignatureGuards where + +f = y + where + y :: Int + | True = 1 diff --git a/test/Test/Fixtures/oracle/UnboxedSums/basic.hs b/test/Test/Fixtures/oracle/UnboxedSums/basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedSums/basic.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnboxedSums #-} +module Basic where + +x = (# 1 | #) +y = (# | 2 #) diff --git a/test/Test/Fixtures/oracle/UnboxedSums/multiway-if-expression.hs b/test/Test/Fixtures/oracle/UnboxedSums/multiway-if-expression.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedSums/multiway-if-expression.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE UnboxedSums #-} + +module MultiWayIfExpression where + +x = (# | if | True -> () #) diff --git a/test/Test/Fixtures/oracle/UnboxedSums/newtype-maybe-hash-unboxed-sum.hs b/test/Test/Fixtures/oracle/UnboxedSums/newtype-maybe-hash-unboxed-sum.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedSums/newtype-maybe-hash-unboxed-sum.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/UnboxedSums/pattern.hs b/test/Test/Fixtures/oracle/UnboxedSums/pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedSums/pattern.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnboxedSums #-} +module Pattern where + +f x = case x of + (# | y #) -> y + (# y | #) -> y diff --git a/test/Test/Fixtures/oracle/UnboxedSums/type.hs b/test/Test/Fixtures/oracle/UnboxedSums/type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedSums/type.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnboxedSums #-} +module Type where + +f :: (# Int | Int #) -> Int +f (# x | #) = x +f (# | y #) = y diff --git a/test/Test/Fixtures/oracle/UnboxedSums/unboxed-sum-list-comp.hs b/test/Test/Fixtures/oracle/UnboxedSums/unboxed-sum-list-comp.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedSums/unboxed-sum-list-comp.hs @@ -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] | #) diff --git a/test/Test/Fixtures/oracle/UnboxedTuples/basic.hs b/test/Test/Fixtures/oracle/UnboxedTuples/basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedTuples/basic.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnboxedTuples #-} +module Basic where + +x = (# 1, 2 #) diff --git a/test/Test/Fixtures/oracle/UnboxedTuples/case-in-unboxed-tuple.hs b/test/Test/Fixtures/oracle/UnboxedTuples/case-in-unboxed-tuple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedTuples/case-in-unboxed-tuple.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnboxedTuples #-} +module CaseInUnboxedTuple where + +f x = (# case x of y -> y #) diff --git a/test/Test/Fixtures/oracle/UnboxedTuples/infix-constructor-unboxed-singleton.hs b/test/Test/Fixtures/oracle/UnboxedTuples/infix-constructor-unboxed-singleton.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedTuples/infix-constructor-unboxed-singleton.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} + +module InfixConstructorUnboxedSingleton where + +data D = (# a #) :. Int diff --git a/test/Test/Fixtures/oracle/UnboxedTuples/infix-constructor-unboxed-unit.hs b/test/Test/Fixtures/oracle/UnboxedTuples/infix-constructor-unboxed-unit.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedTuples/infix-constructor-unboxed-unit.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} + +module InfixConstructorUnboxedUnit where + +data D = (# #) :. Int diff --git a/test/Test/Fixtures/oracle/UnboxedTuples/layout-expressions.hs b/test/Test/Fixtures/oracle/UnboxedTuples/layout-expressions.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedTuples/layout-expressions.hs @@ -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 #) diff --git a/test/Test/Fixtures/oracle/UnboxedTuples/multiline-explicit-layout.hs b/test/Test/Fixtures/oracle/UnboxedTuples/multiline-explicit-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedTuples/multiline-explicit-layout.hs @@ -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 + +} diff --git a/test/Test/Fixtures/oracle/UnboxedTuples/multiline-implicit-layout.hs b/test/Test/Fixtures/oracle/UnboxedTuples/multiline-implicit-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedTuples/multiline-implicit-layout.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/UnboxedTuples/pattern.hs b/test/Test/Fixtures/oracle/UnboxedTuples/pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedTuples/pattern.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnboxedTuples #-} +module Pattern where + +f (# x, y #) = x diff --git a/test/Test/Fixtures/oracle/UnboxedTuples/singleton-pattern.hs b/test/Test/Fixtures/oracle/UnboxedTuples/singleton-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedTuples/singleton-pattern.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnboxedTuples #-} + +module SingletonPattern where + +f (# x #) = x diff --git a/test/Test/Fixtures/oracle/UnboxedTuples/singleton-type.hs b/test/Test/Fixtures/oracle/UnboxedTuples/singleton-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedTuples/singleton-type.hs @@ -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 #) diff --git a/test/Test/Fixtures/oracle/UnboxedTuples/singleton.hs b/test/Test/Fixtures/oracle/UnboxedTuples/singleton.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedTuples/singleton.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnboxedTuples #-} +module Singleton where + +x = (# 1 #) + +f (# y #) = y diff --git a/test/Test/Fixtures/oracle/UnboxedTuples/type.hs b/test/Test/Fixtures/oracle/UnboxedTuples/type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedTuples/type.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnboxedTuples #-} +module Type where + +f :: (# Int, Int #) -> (# Int, Int #) +f x = x diff --git a/test/Test/Fixtures/oracle/UnboxedTuples/unboxed-tuple-visible-type-application.hs b/test/Test/Fixtures/oracle/UnboxedTuples/unboxed-tuple-visible-type-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnboxedTuples/unboxed-tuple-visible-type-application.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnboxedTuples #-} + +module UnboxedTupleVisibleTypeApplication where + +x = (, ) @(# * | 'C #) diff --git a/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-export-module.hs b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-export-module.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-export-module.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} + +module UnicodeExportModule (module ℳℴ𝒹1.ℳℴ𝒹2.ℳℴ𝒹3) where + +import ℳℴ𝒹1.ℳℴ𝒹2.ℳℴ𝒹3 (x) diff --git a/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-import-multiple.hs b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-import-multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-import-multiple.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-import-qualified.hs b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-import-qualified.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-import-qualified.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} + +module UnicodeImportQualified where + +import qualified 𝔐𝔬𝔡1.𝔐𝔬𝔡2.𝔐𝔬𝔡3 as M + +useY :: Int +useY = M.y diff --git a/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-import-simple.hs b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-import-simple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-import-simple.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} + +module UnicodeImportSimple where + +import ℳℴ𝒹1.ℳℴ𝒹2.ℳℴ𝒹3 (x) + +useX :: Int +useX = x diff --git a/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-module-bold-script.hs b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-module-bold-script.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-module-bold-script.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} + +module 𝓜𝓸𝓭𝟏.𝓜𝓸𝓭𝟐.𝓜𝓸𝓭𝟑 where + +z :: Int +z = 3 diff --git a/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-module-fraktur.hs b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-module-fraktur.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-module-fraktur.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} + +module 𝔐𝔬𝔡1.𝔐𝔬𝔡2.𝔐𝔬𝔡3 where + +y :: Int +y = 2 diff --git a/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-module-math-bold-italic.hs b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-module-math-bold-italic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeModuleNames/unicode-module-math-bold-italic.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} + +module ℳℴ𝒹1.ℳℴ𝒹2.ℳℴ𝒹3 where + +x :: Int +x = 1 diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-bind-arrow.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-bind-arrow.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-bind-arrow.hs @@ -0,0 +1,10 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnicodeSyntax #-} + +module UnicodeSyntaxDo where + +testDo ∷ IO () +testDo = do + x ← return 42 + y ← return 99 + return () diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-class-arrow.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-class-arrow.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-class-arrow.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnicodeSyntax #-} + +module UnicodeClassArrow where + +class Foo a where + foo ∷ a → a diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-class-typevar.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-class-typevar.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-class-typevar.hs @@ -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 :: α diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-composition-operator.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-composition-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-composition-operator.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-constraint.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-constraint.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-constraint.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-double-colon.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-double-colon.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-double-colon.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-forall.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-forall.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-forall.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ExplicitForAll #-} + +module UnicodeSyntaxForall where + +identity ∷ ∀ a . a → a +identity x = x diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-identifier-continuation.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-identifier-continuation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-identifier-continuation.hs @@ -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ₜ) diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-lambda.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-lambda.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-asterism.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-asterism.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-asterism.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module UnicodeOperatorAsterism where + +(⁂) :: Int -> Int -> Int +(⁂) = (+) diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-double-exclamation.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-double-exclamation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-double-exclamation.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module UnicodeOperatorDoubleExclamation where + +(‼) :: [a] -> Int -> a +(‼) = (!!) diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-en-dash.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-en-dash.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-en-dash.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module UnicodeOperatorEnDash where + +(–) :: Int -> Int -> Int +(–) = (+) diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-undertie.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-undertie.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-operator-undertie.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module UnicodeOperatorUndertie where + +(‿) :: Int -> Int -> Int +(‿) = (+) diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-rank-n.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-rank-n.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-rank-n.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-star-expression-operator.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-star-expression-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-star-expression-operator.hs @@ -0,0 +1,12 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnicodeSyntax #-} + +module UnicodeStarExpressionOperator where + +infixl 7 ★ + +(★) ∷ Int → Int → Int +(★) = (*) + +value ∷ Int +value = 2 ★ 3 diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-star-type.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-star-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-star-type.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE StarIsType #-} +{-# LANGUAGE UnicodeSyntax #-} + +module UnicodeStarType where + +type StarKind = ★ diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-data.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-data.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-data.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnicodeSyntax #-} + +-- Unicode type variable in data declaration + +module UnicodeTypeVarData where + +data Tree α = Leaf α | Node (Tree α) (Tree α) diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-multiple.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-multiple.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnicodeSyntax #-} + +-- Multiple unicode type variables in class declaration + +module UnicodeTypeVarMultiple where + +class Functor φ where + fmap :: (α → β) → φ α → φ β diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-newtype.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-newtype.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-newtype.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnicodeSyntax #-} + +-- Unicode type variable in newtype declaration + +module UnicodeTypeVarNewtype where + +newtype Wrapper ψ = Wrap { unwrap :: ψ } diff --git a/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-synonym.hs b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-synonym.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/UnicodeSyntax/unicode-typevar-synonym.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE UnicodeSyntax #-} + +-- Unicode type variable in type synonym + +module UnicodeTypeVarSynonym where + +type Identity α = α diff --git a/test/Test/Fixtures/oracle/ViewPatterns/nested-view-pattern-lambda.hs b/test/Test/Fixtures/oracle/ViewPatterns/nested-view-pattern-lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ViewPatterns/nested-view-pattern-lambda.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/ViewPatterns/view-pattern-case-alternative.hs b/test/Test/Fixtures/oracle/ViewPatterns/view-pattern-case-alternative.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ViewPatterns/view-pattern-case-alternative.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-casealt.hs b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-casealt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-casealt.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-comp-parallel.hs b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-comp-parallel.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-comp-parallel.hs @@ -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] diff --git a/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-funarg.hs b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-funarg.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-funarg.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-guard-qualifier.hs b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-guard-qualifier.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-guard-qualifier.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-patbind.hs b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-patbind.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-patbind.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-funarg.hs b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-funarg.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-funarg.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ViewPatterns #-} + +module ViewPatternsTupleFunArg where + +f (id -> x, y) = x diff --git a/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-middle.hs b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-middle.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-middle.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-multiple.hs b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-multiple.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-nested.hs b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-nested.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-nested.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-second.hs b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-second.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-tuple-second.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-unboxed-sum.hs b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-unboxed-sum.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/ViewPatterns/viewpatterns-unboxed-sum.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/Whitespace/form-feed-in-binding.hs b/test/Test/Fixtures/oracle/Whitespace/form-feed-in-binding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Whitespace/form-feed-in-binding.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module FormFeedInBinding where + +x = 1 + +y = 2 diff --git a/test/Test/Fixtures/oracle/Whitespace/form-feed-in-expression.hs b/test/Test/Fixtures/oracle/Whitespace/form-feed-in-expression.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Whitespace/form-feed-in-expression.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module FormFeedInExpression where + +x = 1 + + 2 diff --git a/test/Test/Fixtures/oracle/Whitespace/form-feed-multiple.hs b/test/Test/Fixtures/oracle/Whitespace/form-feed-multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Whitespace/form-feed-multiple.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +module FormFeedMultiple where + +x = 1 + +y = 2 + +z = 3 diff --git a/test/Test/Fixtures/oracle/Whitespace/form-feed-top-level.hs b/test/Test/Fixtures/oracle/Whitespace/form-feed-top-level.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Whitespace/form-feed-top-level.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module FormFeedTopLevel where + +x = 1 diff --git a/test/Test/Fixtures/oracle/Whitespace/unicode-whitespace-top-level.hs b/test/Test/Fixtures/oracle/Whitespace/unicode-whitespace-top-level.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Whitespace/unicode-whitespace-top-level.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module UnicodeWhitespaceTopLevel where + +x = 1 +  +y = 2 diff --git a/test/Test/Fixtures/oracle/Whitespace/vertical-tab-top-level.hs b/test/Test/Fixtures/oracle/Whitespace/vertical-tab-top-level.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Whitespace/vertical-tab-top-level.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module VerticalTabTopLevel where + +x = 1 + +y = 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/cls-default.hs b/test/Test/Fixtures/oracle/haskell2010/cls-default.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/cls-default.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} + +class Cls a where a :&: as == b :&: bs = () diff --git a/test/Test/Fixtures/oracle/haskell2010/comments/dash-dash-backtick-comment.hs b/test/Test/Fixtures/oracle/haskell2010/comments/dash-dash-backtick-comment.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/comments/dash-dash-backtick-comment.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} + +module DashDashBacktickComment where + +x = 1 +--` +y = 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-class-package-imports.hs b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-class-package-imports.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-class-package-imports.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PackageImports #-} +module X where + +import "filepath" System.OsString.Internal.Types (OsString (..)) diff --git a/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-ffi-capi-calling-convention.hs b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-ffi-capi-calling-convention.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-ffi-capi-calling-convention.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-generic-instances-kind-arrow.hs b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-generic-instances-kind-arrow.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-generic-instances-kind-arrow.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BangPatterns, FlexibleInstances, KindSignatures, + ScopedTypeVariables, TypeOperators, + MultiParamTypeClasses, GADTs, FlexibleContexts #-} +module X where + +x :: Int +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-lowlevel-cpp-ifdef.hs b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-lowlevel-cpp-ifdef.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-lowlevel-cpp-ifdef.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-mix-cpp-if.hs b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-mix-cpp-if.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-mix-cpp-if.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-properties-unboxed-tuples.hs b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-properties-unboxed-tuples.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-properties-unboxed-tuples.hs @@ -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 #) diff --git a/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-regress-cpp-have-mmap.hs b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-regress-cpp-have-mmap.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-regress-cpp-have-mmap.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE CPP #-} +module X where + +#ifdef HAVE_MMAP +x :: Int +x = 1 +#endif diff --git a/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-xxh3-cpp-include.hs b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-xxh3-cpp-include.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-xxh3-cpp-include.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE CPP #-} +module X where + +#include "MachDeps.h" diff --git a/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-xxhash-tests-numeric-underscores.hs b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-xxhash-tests-numeric-underscores.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/corpus/hashable/hashable-xxhash-tests-numeric-underscores.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE NumericUnderscores #-} +module X where + +x :: Integer +x = 0xc77b_3abb_6f87_acd9 diff --git a/test/Test/Fixtures/oracle/haskell2010/corpus/vinyl-loeb-rloeb-section.hs b/test/Test/Fixtures/oracle/haskell2010/corpus/vinyl-loeb-rloeb-section.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/corpus/vinyl-loeb-rloeb-section.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} + +module VinylLoebRloebSection where + +rloeb x = go where go = rmap (($ go) . getCompose) x diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-default-funlhs.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-default-funlhs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-default-funlhs.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D34 where +class C a where { op :: a -> a; op x = x } diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-default-layout.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-default-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-default-layout.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module ClassDefaultLayout where +class C a where + op :: a -> a + op = id diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-default-var.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-default-var.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-default-var.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D33 where +class C a where { op :: a -> a; op = id } diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-fixity.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-fixity.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-fixity.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D35 where +class C a where { (<+>) :: a -> a -> a; infixl 6 <+> } diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-multiple-defaults.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-multiple-defaults.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-multiple-defaults.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-signature-context.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-signature-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-signature-context.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D32 where +class C a where { op :: Num b => a -> b -> a } diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-signature.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-cdecl-signature.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D31 where +class C a where { op :: a -> a } diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-minimal.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-minimal.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-minimal.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D25 where +class C a diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-super-paren-empty.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-super-paren-empty.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-super-paren-empty.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D28 where +class () => C a diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-super-paren-multiple.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-super-paren-multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-super-paren-multiple.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D30 where +class (Eq a, Show a) => C a diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-super-paren-single.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-super-paren-single.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-super-paren-single.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D29 where +class (Eq a) => C a diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-super-simple.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-super-simple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-super-simple.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D27 where +class Eq a => C a diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-universe-some.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-universe-some.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-universe-some.hs @@ -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]) diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class-where-empty.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class-where-empty.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class-where-empty.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D26 where +class C a where {} diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/class.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/class.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/class.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module D7 where +class Eq a => Named a where + nameOf :: a -> String diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-abstract.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-abstract.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-abstract.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D24 where +data Abstract a diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-context.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-context.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Haskell2010 #-} +module D12 where +data Eq a => Set a = NilSet | ConsSet a (Set a) diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-deriving-empty.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-deriving-empty.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-deriving-empty.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D23 where +data Phantom a = Phantom deriving () diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-deriving-single.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-deriving-single.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-deriving-single.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D22 where +data Flag = On | Off deriving Eq diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-infix-strict-left.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-infix-strict-left.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-infix-strict-left.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D16 where +data T = !Int :*: Bool diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-infix-strict-right.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-infix-strict-right.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-infix-strict-right.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D17 where +data T = Int :*: !Bool diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-infix.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-infix.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-infix.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D15 where +data Pair a = a :*: a diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-prefix-positional.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-prefix-positional.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-prefix-positional.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D13 where +data Box a = Box a diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-prefix-strict.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-prefix-strict.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-prefix-strict.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D14 where +data Pair a = Pair !a a diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-empty.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-empty.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-empty.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D18 where +data Unit = Unit {} diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-fields.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-fields.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-fields.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D19 where +data Person = Person { name :: String, age :: Int } diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-function-type-simple.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-function-type-simple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-function-type-simple.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module M where +data X = X { f :: Int -> Int } diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-function-type.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-function-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-function-type.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module M where +data Target a = Target { + lTarget :: a -> Double + , glTarget :: Maybe (a -> a) + } diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-grouped-fields.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-grouped-fields.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-grouped-fields.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D20 where +data Point = Point { x, y :: Int } diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-strict-field.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-strict-field.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data-record-strict-field.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D21 where +data StrictRec = StrictRec { payload :: !Int } diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/data.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/data.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/data.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D4 where +data Color = Red | Blue diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/default.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/default.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/default.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D10 where +default (Integer, Double) diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/deriving.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/deriving.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/deriving.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D11 where +data Mode = Fast | Slow deriving (Eq, Show) diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/fixity-unicode-op.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/fixity-unicode-op.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/fixity-unicode-op.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/fixity.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/fixity.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/fixity.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module D9 where +infixr 5 <++> +(<++>) :: [a] -> [a] -> [a] +(<++>) = (++ ) diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-append-list-pattern.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-append-list-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-append-list-pattern.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-con.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-con.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-con.hs @@ -0,0 +1,2 @@ +{- ORACLE_TEST pass -} +data A a b = a `Infix` b diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-backtick.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-backtick.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-backtick.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module InfixFunlhsBacktick where +x `myOp` y = x + y diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-bang.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-bang.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-bang.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module InfixFunlhsBang where +x ! y = () diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-basic.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-basic.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module InfixFunlhs where +x <+> y = x + y diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-class.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-class.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-class.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module InfixFunlhsClass where +class MyClass a where + x <+> y = undefined diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-guarded.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-guarded.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-guarded.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module InfixFunlhsGuarded where +x <=> y + | x < y = LT + | x > y = GT + | otherwise = EQ diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-instance-prefix-pattern.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-instance-prefix-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-instance-prefix-pattern.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-instance.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-instance.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-lambda.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-lambda.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module InfixFunlhsLambda where +mb ?> x = mb >>= \b -> when b x diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-let.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-let.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-let.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module InfixFunlhsLet where +f = let x <+> y = x + y in 1 <+> 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-local-pattern.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-local-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-local-pattern.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +module InfixFunlhsLocalPattern where + +data Expr = Var | Expr :$ Expr + +f = x + where + a :$ b `g` c + | True = x diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-local.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-local.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-local.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module InfixFunlhsLocal where +f = g + where + x <+> y = x + y + g = 1 <+> 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-minus-constructor-patterns.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-minus-constructor-patterns.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-minus-constructor-patterns.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-minus-negative-literal.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-minus-negative-literal.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-minus-negative-literal.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-pattern.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-pattern.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module InfixFunlhsPattern where +(Just a) <||> _ = Just a +Nothing <||> b = b diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-th-cpp.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-th-cpp.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-th-cpp.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-tilde.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-tilde.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-tilde.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module InfixFunlhsTilde where +x ~ y = () diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-where-empty.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-where-empty.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-where-empty.hs @@ -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 {} diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-with-sig.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-with-sig.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/infix-funlhs-with-sig.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module InfixFunlhsWithSig where +(<+>) :: Int -> Int -> Int +x <+> y = x + y diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/instance-method-guards.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/instance-method-guards.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/instance-method-guards.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module M where +class Class a where + fn :: a -> () +instance Class X where + fn a | True = () diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/instance-tuple-type-constructor.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/instance-tuple-type-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/instance-tuple-type-constructor.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/instance.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/instance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/instance.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/mixed-infix-prefix-bang.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/mixed-infix-prefix-bang.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/mixed-infix-prefix-bang.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BangPatterns #-} +module MixedInfixPrefixBang where +a ! b = a + b +f !x = x diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/multiple-equations.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/multiple-equations.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/multiple-equations.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module D2 where +f [] = 0 +f (_:xs) = 1 + f xs diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/newtype.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/newtype.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/newtype.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D5 where +newtype Wrap a = Wrap a diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/operator-funlhs-infix-application-backtick.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/operator-funlhs-infix-application-backtick.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/operator-funlhs-infix-application-backtick.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module M where +(g `op` h) x = g (h x) diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/operator-funlhs-infix-application.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/operator-funlhs-infix-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/operator-funlhs-infix-application.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module M where +(g . h) x = g (h x) diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/pattern-binding.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/pattern-binding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/pattern-binding.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D3 where +(x, y) = (1, 2) diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/pattern-synonym-negative-literal.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/pattern-synonym-negative-literal.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/pattern-synonym-negative-literal.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/type-signature-context-multiline.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/type-signature-context-multiline.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/type-signature-context-multiline.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +module DTypeSigCtxMultiline where + +memo :: (Ord a) + => (a -> b) + -> (a -> b) +memo f = f diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/type-signature.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/type-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/type-signature.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module D1 where +idInt :: Int -> Int +idInt x = x diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/type-synonym.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/type-synonym.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/type-synonym.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module D6 where +type Pair a = (a, a) diff --git a/test/Test/Fixtures/oracle/haskell2010/declarations/where-empty-braces.hs b/test/Test/Fixtures/oracle/haskell2010/declarations/where-empty-braces.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/declarations/where-empty-braces.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module WhereEmptyBraces where +-- An explicit empty where clause is valid syntax +f x = x where {} diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/application-constructor-partial.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/application-constructor-partial.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/application-constructor-partial.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExprS303AppConstructorPartial where +data D = D Int Int +x = D 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/application-left-assoc.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/application-left-assoc.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/application-left-assoc.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExprS303AppLeftAssoc where +f a b = a + b +x = f 1 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/arithmetic-seq.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/arithmetic-seq.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/arithmetic-seq.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module X10 where +x = [1,3..21] +y = [1..10] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from-then-to.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from-then-to.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from-then-to.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS310FromThenTo where +x = [1, 3 .. 10] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from-then.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from-then.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from-then.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS310FromThen where +x = [1, 3 ..] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from-to.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from-to.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from-to.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS310FromTo where +x = [1 .. 10] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/arithseq-from.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS310From where +x = [1 ..] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-gcon-listcon.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-gcon-listcon.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-gcon-listcon.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS302GConList where +x = [] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-gcon-tuplecon.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-gcon-tuplecon.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-gcon-tuplecon.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS302GConTuple where +x = (,,) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-gcon-unit.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-gcon-unit.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-gcon-unit.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS302GConUnit where +x = () diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-all.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-all.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-all.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module ExprS302LiteralAll where +xDecimal = 42 +xFloat = 3.14 +xChar = 'a' +xString = "abc" diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-char.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-char.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-char.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS302LiteralChar where +x = 'a' diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-float.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-float.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-float.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS302LiteralFloat where +x = 1.5 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-int.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-int.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-int.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS302LiteralInt where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-string.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-string.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-literal-string.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS302LiteralString where +x = "abc" diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-qcon.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-qcon.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-qcon.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExprS302QCon where +data D = C +x = C diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-qvar.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-qvar.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/atoms-qvar.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS302QVar where +x = Prelude.map diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/case-basic.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/case-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/case-basic.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS313CaseBasic where +x n = case n of { 0 -> 1; _ -> 2 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/case-guarded-alts.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/case-guarded-alts.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/case-guarded-alts.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS313CaseGuardedAlts where +x n = case n of { m | m > 0 -> m; _ -> 0 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/case-infix-rhs.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/case-infix-rhs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/case-infix-rhs.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X where +x = a + case b of { c -> d } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/case-of.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/case-of.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/case-of.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module X2 where +x m = case m of + Nothing -> 0 + Just n -> n diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/conditional-basic.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/conditional-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/conditional-basic.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS306ConditionalBasic where +x n = if n > 0 then n else 0 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/conditional-semicolons.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/conditional-semicolons.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/conditional-semicolons.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS306ConditionalSemicolons where +x n = if n > 0; then n; else 0 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-as-argument.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-as-argument.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-as-argument.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X where +x = f (do a;b) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-bind-stmt.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-bind-stmt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-bind-stmt.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS314DoBindStmt where +x = do { n <- Just 1; return n } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-empty-let-expression.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-empty-let-expression.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-empty-let-expression.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Haskell2010 #-} + +module DoEmptyLetExpression where + +x = do let in () diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-in-list.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-in-list.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-in-list.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X where +x = [do a;b] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-in-parens.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-in-parens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-in-parens.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X where +x = (do a;b) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-infix-rhs.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-infix-rhs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-infix-rhs.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X where +x = y <$ do a;b diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-let-function-binding-nested.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-let-function-binding-nested.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-let-function-binding-nested.hs @@ -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' diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-let-stmt.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-let-stmt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-let-stmt.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS314DoLetStmt where +x = do { let { n = 1 }; return n } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-notation.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-notation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-notation.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module X7 where +x = do + a <- Just 1 + b <- Just 2 + return (a + b) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-semicolon-let.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-semicolon-let.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-semicolon-let.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Haskell2010 #-} + +-- Explicit semicolons followed by let in do notation +f = do + ;let x = 1 + ;x diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-semicolon-mixed.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-semicolon-mixed.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-semicolon-mixed.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-semicolon-multiple.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-semicolon-multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-semicolon-multiple.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Haskell2010 #-} + +-- Multiple explicit semicolons in do notation +f = do + ;;let x = 1 + ;;x diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-sequence-stmts.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-sequence-stmts.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-sequence-stmts.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS314DoSequenceStmts where +x = do { a <- Just 1; b <- Just 2; return (a + b) } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/do-single-expression.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/do-single-expression.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/do-single-expression.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS314DoSingleExpression where +x = do { Just 1 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/errors-error.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/errors-error.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/errors-error.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS301Error where +x = error "boom" diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/errors-undefined.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/errors-undefined.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/errors-undefined.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS301Undefined where +x = undefined diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/existential-forall.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/existential-forall.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/existential-forall.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExistentialForall where + +toJSON ((f :: f a) :=> (g :: g a)) = () diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/expr-type-signature-basic.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/expr-type-signature-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/expr-type-signature-basic.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS316TypeSigBasic where +x = (1 :: Int) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/expr-type-signature-context.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/expr-type-signature-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/expr-type-signature-context.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS316TypeSigContext where +x = ((+1) :: Num a => a -> a) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/guard-expression-type-signature-fun.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/guard-expression-type-signature-fun.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/guard-expression-type-signature-fun.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/guard-expression-type-signature.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/guard-expression-type-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/guard-expression-type-signature.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} + +module GuardExpressionTypeSignature where + +f :: Bool -> Bool +f x + | x :: Bool = True + | otherwise = False diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/if-infix-rhs.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/if-infix-rhs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/if-infix-rhs.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X where +x = a + if b then c else d diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/if-then-else.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/if-then-else.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/if-then-else.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X1 where +x = if True then 1 else 0 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/infix-qconop.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/infix-qconop.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/infix-qconop.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS304InfixQConOp where +x = 1 : 2 : [] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/infix-qvarop.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/infix-qvarop.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/infix-qvarop.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS304InfixQVarOp where +x = 1 + 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/lambda-infix-rhs.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/lambda-infix-rhs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/lambda-infix-rhs.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X where +x = a + \y -> y diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/lambda-multi-apat.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/lambda-multi-apat.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/lambda-multi-apat.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS303LambdaMulti where +x = (\a b -> a + b) 1 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/lambda-pattern-apat.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/lambda-pattern-apat.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/lambda-pattern-apat.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS303LambdaPattern where +x = (\(a, b) -> a) (1, 2) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/lambda-single-apat.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/lambda-single-apat.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/lambda-single-apat.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS303LambdaSingle where +x = (\n -> n) 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/lambda.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/lambda.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X4 where +x = \n -> n + 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/let-basic.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/let-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/let-basic.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS312LetBasic where +x = let y = 1 in y diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/let-in.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/let-in.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/let-in.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X3 where +x n = let y = n + 1 in y * 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/let-infix-rhs.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/let-infix-rhs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/let-infix-rhs.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X where +x = a + let y = z in y diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/let-multiple-decls.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/let-multiple-decls.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/let-multiple-decls.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS312LetMultipleDecls where +x = let y = 1; z = 2 in y + z diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/let-nested-layout.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/let-nested-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/let-nested-layout.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +module ExprS312LetNestedLayout where + +x = let y = + let z = 1 + in z + in y diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/list-comprehension.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/list-comprehension.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/list-comprehension.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X9 where +x = [n * 2 | n <- [1..10], odd n] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/list-empty.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/list-empty.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/list-empty.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS307ListEmpty where +x = [] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/list-multiple.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/list-multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/list-multiple.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS307ListMultiple where +x = [1, 2, 3] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/list-singleton.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/list-singleton.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/list-singleton.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS307ListSingleton where +x = [1] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/list-tuple.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/list-tuple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/list-tuple.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X5 where +x = ([1,2,3], (1,2,3)) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-generator.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-generator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-generator.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS311Generator where +x xs = [n | n <- xs] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-guards.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-guards.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-guards.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS311Guards where +x xs = [n | n <- xs, n > 0] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-let-qualifier.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-let-qualifier.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-let-qualifier.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS311LetQualifier where +x xs = [m | n <- xs, let m = n + 1] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-multi-generator.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-multi-generator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/listcomp-multi-generator.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS311MultiGenerator where +x xs ys = [(a, b) | a <- xs, b <- ys] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/minus-with-parenthesized-negation.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/minus-with-parenthesized-negation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/minus-with-parenthesized-negation.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS304MinusParenNeg where +x = 1 - (-2) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/operators-backtick-conid.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/operators-backtick-conid.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/operators-backtick-conid.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExprS302BacktickConid where +data Pair = Pair Int Int +x = 1 `Pair` 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/operators-backtick-varid.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/operators-backtick-varid.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/operators-backtick-varid.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS302BacktickVarid where +x = 5 `mod` 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/operators-conop-colon.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/operators-conop-colon.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/operators-conop-colon.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS302ConopColon where +x = 1 : [] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/operators-varsym-paren.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/operators-varsym-paren.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/operators-varsym-paren.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS302VarsymParen where +x = (+) 1 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/paren-reserved-at-section.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/paren-reserved-at-section.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/paren-reserved-at-section.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE Haskell2010 #-} +module ParenReservedAtSection where + +(@) :: a -> b -> a +(@) x _ = x + +test = (@ ()) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/paren-section-fmap.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/paren-section-fmap.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/paren-section-fmap.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} +module ParenSectionFmap where + +writePandocWith f wo = + (foo . f <$>) + undefined diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/paren-section-multiple-ops.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/paren-section-multiple-ops.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/paren-section-multiple-ops.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/parenthesized-expression.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/parenthesized-expression.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/parenthesized-expression.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS309Paren where +x = (1 + 2) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-as-pattern.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-as-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-as-pattern.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS317PatAsPattern where +x xs = case xs of { ys@(y:_) -> y; [] -> 0 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-constructor-application.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-constructor-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-constructor-application.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExprS317PatConstructorApplication where +data Box = Box Int +x b = case b of { Box n -> n } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-infix-constructor.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-infix-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-infix-constructor.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS317PatInfixConstructor where +x xs = case xs of { y:ys -> y; [] -> 0 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-irrefutable.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-irrefutable.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-irrefutable.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS317PatIrrefutable where +x v = (\ ~(a, b) -> a) v diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-labeled.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-labeled.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-labeled.hs @@ -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 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-list.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-list.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-list.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS317PatList where +x xs = case xs of { [a, b] -> a + b; _ -> 0 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-literal.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-literal.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-literal.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS317PatLiteral where +x n = case n of { 1 -> 1; _ -> 0 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-negative-literal.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-negative-literal.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-negative-literal.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS317PatNegativeLiteral where +x n = case n of { -1 -> 1; _ -> 0 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-nullary-constructor.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-nullary-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-nullary-constructor.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExprS317PatNullaryConstructor where +data D = C +x d = case d of { C -> 1 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-parenthesized.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-parenthesized.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-parenthesized.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS317PatParenthesized where +x t = case t of { (n) -> n } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-tuple.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-tuple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-tuple.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS317PatTuple where +x t = case t of { (a, b) -> a + b } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-wildcard.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-wildcard.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/pattern-wildcard.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS317PatWildcard where +x t = case t of { (_, _) -> 1 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/prefix-negation.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/prefix-negation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/prefix-negation.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS304PrefixNegation where +x = -1 diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/qualified-dot-section-right.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/qualified-dot-section-right.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/qualified-dot-section-right.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module ExprQualifiedDotSectionRight where + +import qualified Prelude as Foo + +x = (Foo.. Foo.id) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/record-construction-empty.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/record-construction-empty.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/record-construction-empty.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExprS315RecordConstructionEmpty where +data R = R {} +x = R {} diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/record-construction-fields.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/record-construction-fields.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/record-construction-fields.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExprS315RecordConstructionFields where +data R = R { a :: Int, b :: Int } +x = R { a = 1, b = 2 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/record-construction-qualified-field.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/record-construction-qualified-field.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/record-construction-qualified-field.hs @@ -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} diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/record-field-selection.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/record-field-selection.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/record-field-selection.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExprS315FieldSelection where +data R = R { a :: Int } +x r = a r diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/record-update-chained.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/record-update-chained.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/record-update-chained.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExprS315RecordUpdateChained where +data R = R { a :: Int, b :: Int } +x r = r { a = 1 } { b = 2 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/record-update-multiple.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/record-update-multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/record-update-multiple.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExprS315RecordUpdateMultiple where +data R = R { a :: Int, b :: Int } +x r = r { a = 3, b = 4 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/record-update-paren-base.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/record-update-paren-base.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/record-update-paren-base.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExprS315RecordUpdateParenBase where +data R = R { a :: Int } +x r = (f r) { a = 1 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/record-update-single.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/record-update-single.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/record-update-single.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module ExprS315RecordUpdateSingle where +data R = R { a :: Int, b :: Int } +x r = r { a = 3 } diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/reserved-as.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/reserved-as.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/reserved-as.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +module ReservedKeywordAs where + +reserved :: as +reserved = undefined + +arg as = as diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/section-backtick-left.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/section-backtick-left.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/section-backtick-left.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS305SectionBacktickLeft where +x = map (`div` 2) [2, 4, 6] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/section-backtick-right.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/section-backtick-right.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/section-backtick-right.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS305SectionBacktickRight where +x = map (2 `div`) [2, 4, 6] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/section-bang.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/section-bang.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/section-bang.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprSectionBang where +f = (! 3) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/section-left.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/section-left.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/section-left.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS305SectionLeft where +x = map (1+) [1, 2, 3] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/section-right.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/section-right.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/section-right.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS305SectionRight where +x = map (+1) [1, 2, 3] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/sections.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/sections.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/sections.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module X6 where +x = map (+1) [1,2,3] +y = map (1+) [1,2,3] diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/tuple-pair.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/tuple-pair.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/tuple-pair.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS308TuplePair where +x = (1, 2) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/tuple-triple.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/tuple-triple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/tuple-triple.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS308TupleTriple where +x = (1, 2, 3) diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/unit-expression.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/unit-expression.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/unit-expression.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module ExprS309Unit where +x = () diff --git a/test/Test/Fixtures/oracle/haskell2010/expressions/where-clause.hs b/test/Test/Fixtures/oracle/haskell2010/expressions/where-clause.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/expressions/where-clause.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module X8 where +x n = y + 1 where y = n * 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/exprs/if-typed-condition-and-else-signature.hs b/test/Test/Fixtures/oracle/haskell2010/exprs/if-typed-condition-and-else-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/exprs/if-typed-condition-and-else-signature.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StarIsType #-} +module IfTypedConditionAndElseSignature where + +a = if a :: * then a else [] :: C => '7' diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-export-ccall-named.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-export-ccall-named.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-export-ccall-named.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-export-ccall-omitted-entity.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-export-ccall-omitted-entity.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-export-ccall-omitted-entity.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-export-stdcall-named.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-export-stdcall-named.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-export-stdcall-named.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-address-header-cid.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-address-header-cid.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-address-header-cid.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportAddressHeaderCid where +foreign import ccall "errno.h &errno" errnoPtr :: Ptr Int diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-address-only.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-address-only.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-address-only.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportAddressOnly where +foreign import ccall "&" errnoPtr :: Ptr Int diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ccall-basic.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ccall-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ccall-basic.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportCcallBasic where +foreign import ccall "puts" c_puts :: String -> IO Int diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ccall-safe.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ccall-safe.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ccall-safe.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportCcallSafe where +foreign import ccall safe "puts" c_puts_safe :: String -> IO Int diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ccall-unsafe.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ccall-unsafe.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ccall-unsafe.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportCcallUnsafe where +foreign import ccall unsafe "puts" c_puts_unsafe :: String -> IO Int diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-dynamic.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-dynamic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-dynamic.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportDynamic where +foreign import ccall "dynamic" mkFun :: Ptr (Int -> IO Int) -> (Int -> IO Int) diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-arrow.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-arrow.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-arrow.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportFtypeArrow where +foreign import ccall "plus1" plus1 :: Int -> IO Int diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-frtype-only.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-frtype-only.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-frtype-only.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportFtypeFrtypeOnly where +foreign import ccall "get_errno" getErrno :: Int diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-multi-arg.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-multi-arg.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-multi-arg.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportFtypeMultiArg where +foreign import ccall "plus" plus :: Int -> Int -> IO Int diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-result-unit.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-result-unit.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-ftype-result-unit.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportFtypeResultUnit where +foreign import ccall "tick" tick :: IO () diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-impent-omitted.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-impent-omitted.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-impent-omitted.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportImpentOmitted where +foreign import ccall c_atoi :: String -> IO Int diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-dynamic-name.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-dynamic-name.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-dynamic-name.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportStaticDynamicName where +foreign import ccall "static dynamic" dynamicFn :: IO Int diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-header-cid.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-header-cid.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-header-cid.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportStaticHeaderCid where +foreign import ccall "static math.h sin" c_sin :: Double -> Double diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-header-default-cid.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-header-default-cid.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-header-default-cid.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportStaticHeaderDefaultCid where +foreign import ccall "static math.h" c_cos :: Double -> Double diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-wrapper-name.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-wrapper-name.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-static-wrapper-name.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportStaticWrapperName where +foreign import ccall "static wrapper" wrapperFn :: IO Int diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-stdcall-basic.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-stdcall-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-stdcall-basic.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module FfiS8ImportStdcallBasic where +foreign import stdcall "puts" s_puts :: String -> IO Int diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-wrapper.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-wrapper.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-import-wrapper.hs @@ -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)) diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-lexical-identifiers.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-lexical-identifiers.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-lexical-identifiers.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module FfiS8LexicalIdentifiers where +ccall = 1 +stdcall = 2 +foreignName = ccall + stdcall diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-mixed-import-export.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-mixed-import-export.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-mixed-import-export.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/ffi/s8-multiple-foreign-decls.hs b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-multiple-foreign-decls.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/ffi/s8-multiple-foreign-decls.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/identifiers/by-varid.hs b/test/Test/Fixtures/oracle/haskell2010/identifiers/by-varid.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/identifiers/by-varid.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +module ByVarId where + +by :: () +by = () + +useBy :: () +useBy = by diff --git a/test/Test/Fixtures/oracle/haskell2010/identifiers/pattern-comprehensive.hs b/test/Test/Fixtures/oracle/haskell2010/identifiers/pattern-comprehensive.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/identifiers/pattern-comprehensive.hs @@ -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` diff --git a/test/Test/Fixtures/oracle/haskell2010/identifiers/pattern-keyword.hs b/test/Test/Fixtures/oracle/haskell2010/identifiers/pattern-keyword.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/identifiers/pattern-keyword.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module PatternAsIdentifier where + +pattern :: Int -> Int +pattern x = x diff --git a/test/Test/Fixtures/oracle/haskell2010/identifiers/unicode-lowercase.hs b/test/Test/Fixtures/oracle/haskell2010/identifiers/unicode-lowercase.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/identifiers/unicode-lowercase.hs @@ -0,0 +1,11 @@ +{- ORACLE_TEST pass -} +module Main where + +αβγ :: Int +αβγ = 42 + +café :: String +café = "hello" + +naïve :: Bool +naïve = True diff --git a/test/Test/Fixtures/oracle/haskell2010/identifiers/unicode-uppercase.hs b/test/Test/Fixtures/oracle/haskell2010/identifiers/unicode-uppercase.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/identifiers/unicode-uppercase.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module Main where + +data Σthing = Σthing Int diff --git a/test/Test/Fixtures/oracle/haskell2010/identifiers/using-varid.hs b/test/Test/Fixtures/oracle/haskell2010/identifiers/using-varid.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/identifiers/using-varid.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +module UsingVarId where + +using :: () +using = () + +useUsing :: () +useUsing = using diff --git a/test/Test/Fixtures/oracle/haskell2010/layout/do-where-if-then-do-nested.hs b/test/Test/Fixtures/oracle/haskell2010/layout/do-where-if-then-do-nested.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/layout/do-where-if-then-do-nested.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/layout/do-where-layout-multi.hs b/test/Test/Fixtures/oracle/haskell2010/layout/do-where-layout-multi.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/layout/do-where-layout-multi.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/layout/do-where-layout.hs b/test/Test/Fixtures/oracle/haskell2010/layout/do-where-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/layout/do-where-layout.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/layout/let-layout.hs b/test/Test/Fixtures/oracle/haskell2010/layout/let-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/layout/let-layout.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module L1 where +x = + let a = 1 + b = 2 + in a + b diff --git a/test/Test/Fixtures/oracle/haskell2010/layout/where-layout.hs b/test/Test/Fixtures/oracle/haskell2010/layout/where-layout.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/layout/where-layout.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module L2 where +x n = a + b + where + a = n + 1 + b = n + 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/lexical/block-comments.hs b/test/Test/Fixtures/oracle/haskell2010/lexical/block-comments.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/lexical/block-comments.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module K1 where +{- block + comment -} +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/lexical/chars-escape-sequences.hs b/test/Test/Fixtures/oracle/haskell2010/lexical/chars-escape-sequences.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/lexical/chars-escape-sequences.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module K2 where + +x = '\SOH' +y = '\137' +z = '\CAN' diff --git a/test/Test/Fixtures/oracle/haskell2010/lexical/numeric-literals.hs b/test/Test/Fixtures/oracle/haskell2010/lexical/numeric-literals.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/lexical/numeric-literals.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module K3 where +x = 10 +y = 0x10 +z = 3.14 diff --git a/test/Test/Fixtures/oracle/haskell2010/lexical/operators.hs b/test/Test/Fixtures/oracle/haskell2010/lexical/operators.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/lexical/operators.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module K4 where +x = (1 + 2) * 3 +y = 3 `div` 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/lexical/strings-chars.hs b/test/Test/Fixtures/oracle/haskell2010/lexical/strings-chars.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/lexical/strings-chars.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module K2 where +x = "hello" +y = 'a' diff --git a/test/Test/Fixtures/oracle/haskell2010/lexical/strings-escape-sequences.hs b/test/Test/Fixtures/oracle/haskell2010/lexical/strings-escape-sequences.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/lexical/strings-escape-sequences.hs @@ -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." diff --git a/test/Test/Fixtures/oracle/haskell2010/lexical/strings-multiline.hs b/test/Test/Fixtures/oracle/haskell2010/lexical/strings-multiline.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/lexical/strings-multiline.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module K2 where + +x = "This string spans\ + \ multiple lines." diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/application.hs b/test/Test/Fixtures/oracle/haskell2010/modules/application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/application.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module App where +f = g x +h = g (k 2) diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/astack.hs b/test/Test/Fixtures/oracle/haskell2010/modules/astack.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/astack.hs @@ -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 +} diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/comments.hs b/test/Test/Fixtures/oracle/haskell2010/modules/comments.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/comments.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module C where +-- comment +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/deprecated-roundtrip.hs b/test/Test/Fixtures/oracle/haskell2010/modules/deprecated-roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/deprecated-roundtrip.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module DeprecatedRoundtrip + {-# DEPRECATED "Use SomethingElse instead" #-} + where + +y = 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/empty-source.hs b/test/Test/Fixtures/oracle/haskell2010/modules/empty-source.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/empty-source.hs @@ -0,0 +1,1 @@ +{- ORACLE_TEST pass -} diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/export-var-operator.hs b/test/Test/Fixtures/oracle/haskell2010/modules/export-var-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/export-var-operator.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module Test (()) where +() = undefined diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/exports.hs b/test/Test/Fixtures/oracle/haskell2010/modules/exports.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/exports.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module E (x, T(..)) where +x = 1 +data T = A | B diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/implicit.hs b/test/Test/Fixtures/oracle/haskell2010/modules/implicit.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/implicit.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +x = 1 +y = x diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/import-as.hs b/test/Test/Fixtures/oracle/haskell2010/modules/import-as.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/import-as.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module IA where +import Data.Maybe as M +x = M.fromMaybe 0 Nothing diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/import-hiding.hs b/test/Test/Fixtures/oracle/haskell2010/modules/import-hiding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/import-hiding.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module IH where +import Data.List hiding (map) +x = foldr (+) 0 [1,2,3] diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/import-only.hs b/test/Test/Fixtures/oracle/haskell2010/modules/import-only.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/import-only.hs @@ -0,0 +1,2 @@ +{- ORACLE_TEST pass -} +import Data.List diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/import-operator.hs b/test/Test/Fixtures/oracle/haskell2010/modules/import-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/import-operator.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TypeOperators #-} +module ImportOperator where +import Data.Type.Equality ((:~~:)(..)) diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/import-qualified.hs b/test/Test/Fixtures/oracle/haskell2010/modules/import-qualified.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/import-qualified.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module IQ where +import qualified Data.List as L +x = L.length [] diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/import-var-operator.hs b/test/Test/Fixtures/oracle/haskell2010/modules/import-var-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/import-var-operator.hs @@ -0,0 +1,2 @@ +{- ORACLE_TEST pass -} +import Control.Applicative ((<$>)) diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/minimal.hs b/test/Test/Fixtures/oracle/haskell2010/modules/minimal.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/minimal.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module M where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/multi-imports.hs b/test/Test/Fixtures/oracle/haskell2010/modules/multi-imports.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/multi-imports.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module IM where +import Data.Maybe +import Data.List +x = fromMaybe 0 (listToMaybe [1,2]) diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-export-list-items-split.hs b/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-export-list-items-split.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-export-list-items-split.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +module MultilineDefinitionExportListItemsSplit + ( x + , T(..) + ) + where + +x = 1 +data T = A | B diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-export-list-split.hs b/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-export-list-split.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-export-list-split.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +module + MultilineDefinitionExportListSplit + (x, T(..)) +where + +x = 1 +data T = A | B diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-module-split.hs b/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-module-split.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-module-split.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module + MultilineDefinitionModuleSplit where + +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-where-split.hs b/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-where-split.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition-where-split.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module MultilineDefinitionWhereSplit + where + +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition.hs b/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/multiline-definition.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module + MultilineDefinition +where + +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-mixed-comments-multi-above-single-below.hs b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-mixed-comments-multi-above-single-below.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-mixed-comments-multi-above-single-below.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-mixed-comments-single-above-multi-below.hs b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-mixed-comments-single-above-multi-below.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-mixed-comments-single-above-multi-below.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiline-comment-above-below.hs b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiline-comment-above-below.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiline-comment-above-below.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiline-comment-above.hs b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiline-comment-above.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiline-comment-above.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{- a + multi-line comment before pragma -} +{-# LANGUAGE ForeignFunctionInterface #-} +module DemoMultiLineAbove where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiline-comment-below.hs b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiline-comment-below.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiline-comment-below.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +{- a + multi-line comment below pragma -} +module DemoMultiLineBelow where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiple-multiline-comments.hs b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiple-multiline-comments.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiple-multiline-comments.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{- before first pragma -} +{-# LANGUAGE ForeignFunctionInterface #-} +{- between pragmas -} +{-# LANGUAGE ScopedTypeVariables #-} +{- after second pragma -} +module DemoMultiplePragmasMultiLineComments where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiple-singleline-comments.hs b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiple-singleline-comments.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiple-singleline-comments.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +-- before first pragma +{-# LANGUAGE ForeignFunctionInterface #-} +-- between pragmas +{-# LANGUAGE ScopedTypeVariables #-} +-- after second pragma +module DemoMultiplePragmasSingleLineComments where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiple.hs b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiple.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-multiple.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} +module DemoMultiplePragmas where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-singleline-comment-above-below.hs b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-singleline-comment-above-below.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-singleline-comment-above-below.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-singleline-comment-above.hs b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-singleline-comment-above.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-singleline-comment-above.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +-- a single-line comment before pragma +{-# LANGUAGE ForeignFunctionInterface #-} +module DemoSingleLineAbove where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-singleline-comment-below.hs b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-singleline-comment-below.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma-singleline-comment-below.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +-- a single-line comment below pragma +module DemoSingleLineBelow where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma.hs b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/pre-module-language-pragma.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE ForeignFunctionInterface #-} +module Demo where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-module-modid.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-module-modid.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-module-modid.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ExportModuleModid (module Data.Maybe, x) where +import Data.Maybe +x = fromMaybe 0 Nothing diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycls-abstract.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycls-abstract.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycls-abstract.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module S5ExportQtyClsAbstract (Eq) where +x = True diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycls-all.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycls-all.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycls-all.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module S5ExportQtyClsAll (Eq(..)) where +x = True diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycls-methods.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycls-methods.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycls-methods.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module S5ExportQtyClsMethods (Ord(compare)) where +x = EQ diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycon-abstract.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycon-abstract.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycon-abstract.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module S5ExportQtyConAbstract (Maybe) where +x = Just 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycon-all.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycon-all.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycon-all.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module S5ExportQtyConAll (Maybe(..)) where +x = Just 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycon-cnames.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycon-cnames.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qtycon-cnames.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module S5ExportQtyConCNames (Maybe(Nothing, Just)) where +x = Just 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qvar-operator.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qvar-operator.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qvar-operator.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module S5ExportQVarOperator (()) where +() = const diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qvar.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qvar.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-export-qvar.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module S5ExportQVar (x) where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-as-explicit-list.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-as-explicit-list.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-as-explicit-list.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportAsExplicitList where +import Data.Maybe as M (fromMaybe) +x = M.fromMaybe 0 Nothing diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-as-hiding.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-as-hiding.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-as-hiding.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportAsHiding where +import Data.Maybe as M hiding (fromMaybe) +x = M.isNothing Nothing diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-as.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-as.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-as.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportAs where +import Data.Maybe as M +x = M.fromMaybe 0 Nothing diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-empty-list.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-empty-list.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-empty-list.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportEmptyList where +import Data.Maybe () +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycls-all.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycls-all.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycls-all.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportExplicitTyClsAll where +import Prelude (Ord(..)) +x = EQ diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycls-methods.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycls-methods.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycls-methods.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportExplicitTyClsMethods where +import Prelude (Ord(compare)) +x = compare 1 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycls.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycls.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycls.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportExplicitTyCls where +import Prelude (Ord) +x = EQ diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycon-all.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycon-all.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycon-all.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportExplicitTyConAll where +import Data.Maybe (Maybe(..)) +x = Just 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycon-cnames.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycon-cnames.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycon-cnames.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportExplicitTyConCNames where +import Data.Maybe (Maybe(Nothing, Just)) +x = Just 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycon.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycon.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-tycon.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportExplicitTyCon where +import Data.Maybe (Maybe) +x = Just 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-var.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-var.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-explicit-var.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportExplicitVar where +import Data.Maybe (maybe) +x = maybe 0 id (Just 1) diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-hiding-empty.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-hiding-empty.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-hiding-empty.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportHidingEmpty where +import Data.Maybe hiding () +x = fromMaybe 0 Nothing diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-hiding-var.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-hiding-var.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-hiding-var.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportHidingVar where +import Data.Maybe hiding (maybe) +x = fromMaybe 0 Nothing diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-plain.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-plain.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-plain.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportPlain where +import Data.Maybe +x = fromMaybe 0 Nothing diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-qualified-as.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-qualified-as.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-qualified-as.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportQualifiedAs where +import qualified Data.Maybe as M +x = M.fromMaybe 0 Nothing diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-qualified-hiding-var.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-qualified-hiding-var.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-qualified-hiding-var.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportQualifiedHidingVar where +import qualified Data.Maybe hiding (fromMaybe) +x = Data.Maybe.isJust Nothing diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-qualified.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-qualified.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-qualified.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportQualified where +import qualified Data.Maybe +x = Data.Maybe.fromMaybe 0 Nothing diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-trailing-comma.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-trailing-comma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-import-trailing-comma.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module S5ImportTrailingComma where +import Foreign.Ptr (Ptr, ) +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-body-impdecls-topdecls-braces.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-body-impdecls-topdecls-braces.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-body-impdecls-topdecls-braces.hs @@ -0,0 +1,2 @@ +{- ORACLE_TEST pass -} +{ import Data.Maybe ; x = 1 } diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-body-imports-only-braces.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-body-imports-only-braces.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-body-imports-only-braces.hs @@ -0,0 +1,2 @@ +{- ORACLE_TEST pass -} +{ import Data.Maybe } diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-body-topdecls-only-braces.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-body-topdecls-only-braces.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-body-topdecls-only-braces.hs @@ -0,0 +1,2 @@ +{- ORACLE_TEST pass -} +{ x = 1 } diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-empty-exports.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-empty-exports.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-empty-exports.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module S5ModuleEmptyExports () where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-explicit-no-exports.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-explicit-no-exports.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-explicit-no-exports.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module S5ModuleExplicitNoExports where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-exports-trailing-comma.hs b/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-exports-trailing-comma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/s5-module-exports-trailing-comma.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module S5ModuleExportsTrailingComma (x,) where +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/warning-roundtrip.hs b/test/Test/Fixtures/oracle/haskell2010/modules/warning-roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/warning-roundtrip.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module WarningRoundtrip + {-# WARNING "This is a test warning" #-} + where + +x = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/modules/whitespace-source.hs b/test/Test/Fixtures/oracle/haskell2010/modules/whitespace-source.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/modules/whitespace-source.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} + + + diff --git a/test/Test/Fixtures/oracle/haskell2010/patterns/as-pattern.hs b/test/Test/Fixtures/oracle/haskell2010/patterns/as-pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/patterns/as-pattern.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module P3 where +x s@(h:_) = (h, s) +x [] = ('_', []) diff --git a/test/Test/Fixtures/oracle/haskell2010/patterns/constructor.hs b/test/Test/Fixtures/oracle/haskell2010/patterns/constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/patterns/constructor.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module P1 where +data T = A Int | B +x (A n) = n +x B = 0 diff --git a/test/Test/Fixtures/oracle/haskell2010/patterns/contexts.hs b/test/Test/Fixtures/oracle/haskell2010/patterns/contexts.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/patterns/contexts.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/patterns/guards.hs b/test/Test/Fixtures/oracle/haskell2010/patterns/guards.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/patterns/guards.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module P5 where +x n + | n < 0 = -1 + | n == 0 = 0 + | otherwise = 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/patterns/infix-constructor.hs b/test/Test/Fixtures/oracle/haskell2010/patterns/infix-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/patterns/infix-constructor.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module P6 where + +headOrZero (x : _) = x +headOrZero [] = 0 diff --git a/test/Test/Fixtures/oracle/haskell2010/patterns/irrefutable.hs b/test/Test/Fixtures/oracle/haskell2010/patterns/irrefutable.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/patterns/irrefutable.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module P4 where +x ~(a,b) = a + b diff --git a/test/Test/Fixtures/oracle/haskell2010/patterns/labeled.hs b/test/Test/Fixtures/oracle/haskell2010/patterns/labeled.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/patterns/labeled.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/patterns/literal-wildcard-parenthesized.hs b/test/Test/Fixtures/oracle/haskell2010/patterns/literal-wildcard-parenthesized.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/patterns/literal-wildcard-parenthesized.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +module P9 where + +isA 'a' = True +isA _ = False + +unwrap ((x)) = x diff --git a/test/Test/Fixtures/oracle/haskell2010/patterns/negative-literal.hs b/test/Test/Fixtures/oracle/haskell2010/patterns/negative-literal.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/patterns/negative-literal.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +module P7 where + +intSign (-1) = 0 +intSign n = n + +floatSign (-1.0) = 0.0 +floatSign x = x diff --git a/test/Test/Fixtures/oracle/haskell2010/patterns/nested-record.hs b/test/Test/Fixtures/oracle/haskell2010/patterns/nested-record.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/patterns/nested-record.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module PatternNestedRecord where + +delete (HKey k@(HKey' f _)) (HSet xs count) = () diff --git a/test/Test/Fixtures/oracle/haskell2010/patterns/tuple-list.hs b/test/Test/Fixtures/oracle/haskell2010/patterns/tuple-list.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/patterns/tuple-list.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module P2 where +x (a,b) = a + b +y (h:t) = h + length t +y [] = 0 diff --git a/test/Test/Fixtures/oracle/haskell2010/types/context-multi-vars.hs b/test/Test/Fixtures/oracle/haskell2010/types/context-multi-vars.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/context-multi-vars.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module T5 where +f, g :: Num a => a -> a +f x = x + 1 +g x = x * 2 diff --git a/test/Test/Fixtures/oracle/haskell2010/types/context.hs b/test/Test/Fixtures/oracle/haskell2010/types/context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/context.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/haskell2010/types/empty-list-type-constructor.hs b/test/Test/Fixtures/oracle/haskell2010/types/empty-list-type-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/empty-list-type-constructor.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module EmptyListTypeConstructor where + +type T = [] diff --git a/test/Test/Fixtures/oracle/haskell2010/types/function-type-constructor-partial.hs b/test/Test/Fixtures/oracle/haskell2010/types/function-type-constructor-partial.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/function-type-constructor-partial.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module T15 where +toMaybe :: (->) a (Maybe a) +toMaybe x = Just x diff --git a/test/Test/Fixtures/oracle/haskell2010/types/function-type-constructor.hs b/test/Test/Fixtures/oracle/haskell2010/types/function-type-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/function-type-constructor.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module T14 where +apply :: (->) a b -> a -> b +apply f x = f x diff --git a/test/Test/Fixtures/oracle/haskell2010/types/guard-inline-signature.hs b/test/Test/Fixtures/oracle/haskell2010/types/guard-inline-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/guard-inline-signature.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module T11 where +choose :: Bool -> Bool +choose b + | (not b :: Bool) = True + | otherwise = False diff --git a/test/Test/Fixtures/oracle/haskell2010/types/inline-signature-basic.hs b/test/Test/Fixtures/oracle/haskell2010/types/inline-signature-basic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/inline-signature-basic.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module T7 where +value :: Int +value = (1 + 2 :: Int) diff --git a/test/Test/Fixtures/oracle/haskell2010/types/inline-signature-context.hs b/test/Test/Fixtures/oracle/haskell2010/types/inline-signature-context.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/inline-signature-context.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module T8 where +inc :: Int -> Int +inc = ((+ 1) :: Num a => a -> a) diff --git a/test/Test/Fixtures/oracle/haskell2010/types/inline-signature-lambda.hs b/test/Test/Fixtures/oracle/haskell2010/types/inline-signature-lambda.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/inline-signature-lambda.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module T9 where +idInt :: Int -> Int +idInt = (\x -> x :: Int) diff --git a/test/Test/Fixtures/oracle/haskell2010/types/let-signature.hs b/test/Test/Fixtures/oracle/haskell2010/types/let-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/let-signature.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +module T10 where +f :: Int -> Int +f n = + let y :: Int + y = n + 1 + in y diff --git a/test/Test/Fixtures/oracle/haskell2010/types/list-type-constructor.hs b/test/Test/Fixtures/oracle/haskell2010/types/list-type-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/list-type-constructor.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module T12 where +idList :: [a] -> [a] +idList xs = xs diff --git a/test/Test/Fixtures/oracle/haskell2010/types/maybe-type-constructor.hs b/test/Test/Fixtures/oracle/haskell2010/types/maybe-type-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/maybe-type-constructor.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/types/multi-vars-signature.hs b/test/Test/Fixtures/oracle/haskell2010/types/multi-vars-signature.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/multi-vars-signature.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module T4 where +f, g :: Int -> Int +f x = x + 1 +g x = x - 1 diff --git a/test/Test/Fixtures/oracle/haskell2010/types/nested-maybe-list.hs b/test/Test/Fixtures/oracle/haskell2010/types/nested-maybe-list.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/nested-maybe-list.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module T17 where +normalize :: Maybe [a] -> [a] +normalize mx = case mx of + Just xs -> xs + Nothing -> [] diff --git a/test/Test/Fixtures/oracle/haskell2010/types/newtype-record-field-multiline-application.hs b/test/Test/Fixtures/oracle/haskell2010/types/newtype-record-field-multiline-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/newtype-record-field-multiline-application.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +newtype X = X { field :: Maybe + Int } diff --git a/test/Test/Fixtures/oracle/haskell2010/types/newtype-record-function-type.hs b/test/Test/Fixtures/oracle/haskell2010/types/newtype-record-function-type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/newtype-record-function-type.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module M where +newtype IOMcn a b = IOMcn { getIOMcn :: a -> IO b } diff --git a/test/Test/Fixtures/oracle/haskell2010/types/newtype-record-layout-application.hs b/test/Test/Fixtures/oracle/haskell2010/types/newtype-record-layout-application.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/newtype-record-layout-application.hs @@ -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 + } diff --git a/test/Test/Fixtures/oracle/haskell2010/types/newtype-record.hs b/test/Test/Fixtures/oracle/haskell2010/types/newtype-record.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/newtype-record.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module T3 where +newtype UserId = UserId { unUserId :: Int } diff --git a/test/Test/Fixtures/oracle/haskell2010/types/signature-where.hs b/test/Test/Fixtures/oracle/haskell2010/types/signature-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/signature-where.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/haskell2010/types/tuple-list-types.hs b/test/Test/Fixtures/oracle/haskell2010/types/tuple-list-types.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/tuple-list-types.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module T2 where +f :: [Int] -> (Int, Int) +f xs = (length xs, sum xs) diff --git a/test/Test/Fixtures/oracle/haskell2010/types/tuple-type-constructor-prefix.hs b/test/Test/Fixtures/oracle/haskell2010/types/tuple-type-constructor-prefix.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/tuple-type-constructor-prefix.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module M where +f :: (,) a b -> Int +f = undefined diff --git a/test/Test/Fixtures/oracle/haskell2010/types/tuple-type-constructor.hs b/test/Test/Fixtures/oracle/haskell2010/types/tuple-type-constructor.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/haskell2010/types/tuple-type-constructor.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module T16 where +pair :: (,) a b -> (a, b) +pair x = x diff --git a/test/Test/Fixtures/oracle/negation-infix-chain-in-parens.hs b/test/Test/Fixtures/oracle/negation-infix-chain-in-parens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/negation-infix-chain-in-parens.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module A where +f x = (-x + 1) diff --git a/test/Test/Fixtures/oracle/negation-infix-chain-top-level.hs b/test/Test/Fixtures/oracle/negation-infix-chain-top-level.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/negation-infix-chain-top-level.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module A where +f x = - x + 1 diff --git a/test/Test/Fixtures/oracle/negation-multi-operator-chain-in-parens.hs b/test/Test/Fixtures/oracle/negation-multi-operator-chain-in-parens.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/negation-multi-operator-chain-in-parens.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module A where +f x y z = (-x * y + z) diff --git a/test/Test/Fixtures/oracle/negation-multi-operator-chain-top-level.hs b/test/Test/Fixtures/oracle/negation-multi-operator-chain-top-level.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/negation-multi-operator-chain-top-level.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module A where +f = - 1 * 2 + 3 diff --git a/test/Test/Fixtures/oracle/negation-of-parenthesized-expr.hs b/test/Test/Fixtures/oracle/negation-of-parenthesized-expr.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/negation-of-parenthesized-expr.hs @@ -0,0 +1,3 @@ +{- ORACLE_TEST pass -} +module A where +f x y = (-(x + y)) diff --git a/test/Test/Fixtures/oracle/pragma/CompletePragmas.hs b/test/Test/Fixtures/oracle/pragma/CompletePragmas.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/CompletePragmas.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/pragma/DeclWarnings.hs b/test/Test/Fixtures/oracle/pragma/DeclWarnings.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/DeclWarnings.hs @@ -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" #-} diff --git a/test/Test/Fixtures/oracle/pragma/ExportWarningsModuleReexport.hs b/test/Test/Fixtures/oracle/pragma/ExportWarningsModuleReexport.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/ExportWarningsModuleReexport.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +module ExportWarningsModuleReexport + ( {-# DEPRECATED "This declaration has moved to ExportWarningsModuleSource" #-} + module ExportWarningsModuleSource + ) where + +import ExportWarningsModuleSource diff --git a/test/Test/Fixtures/oracle/pragma/ExportWarningsReexport.hs b/test/Test/Fixtures/oracle/pragma/ExportWarningsReexport.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/ExportWarningsReexport.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module ExportWarningsReexport + ( {-# DEPRECATED "Import g from ExportWarningsImport instead" #-} g + ) where + +import ExportWarningsImport (g) diff --git a/test/Test/Fixtures/oracle/pragma/FileHeaderPragmas.hs b/test/Test/Fixtures/oracle/pragma/FileHeaderPragmas.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/FileHeaderPragmas.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/pragma/InlinablePragmas.hs b/test/Test/Fixtures/oracle/pragma/InlinablePragmas.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/InlinablePragmas.hs @@ -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 #-} diff --git a/test/Test/Fixtures/oracle/pragma/InlinablePragmasInInstance.hs b/test/Test/Fixtures/oracle/pragma/InlinablePragmasInInstance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/InlinablePragmasInInstance.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/pragma/InlinePragmas.hs b/test/Test/Fixtures/oracle/pragma/InlinePragmas.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/InlinePragmas.hs @@ -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) diff --git a/test/Test/Fixtures/oracle/pragma/InlinePragmasAfterBindingInInstance.hs b/test/Test/Fixtures/oracle/pragma/InlinePragmasAfterBindingInInstance.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/InlinePragmasAfterBindingInInstance.hs @@ -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 #-}; + } diff --git a/test/Test/Fixtures/oracle/pragma/InstanceWarnings.hs b/test/Test/Fixtures/oracle/pragma/InstanceWarnings.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/InstanceWarnings.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/pragma/LineColumnPragmas.hs b/test/Test/Fixtures/oracle/pragma/LineColumnPragmas.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/LineColumnPragmas.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +module LineColumnPragmas where + +{-# LINE 42 "GeneratedFrom.dsl" #-} + +lineTagged :: Int +lineTagged = + do {-# COLUMN 17 #-} + pure 1 diff --git a/test/Test/Fixtures/oracle/pragma/MinimalPragma.hs b/test/Test/Fixtures/oracle/pragma/MinimalPragma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/MinimalPragma.hs @@ -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 #-} diff --git a/test/Test/Fixtures/oracle/pragma/ModuleDeprecated.hs b/test/Test/Fixtures/oracle/pragma/ModuleDeprecated.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/ModuleDeprecated.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module ModuleDeprecated {-# DEPRECATED "Use New.ModuleDeprecated instead" #-} where + +deprecatedValue :: Int +deprecatedValue = 2 diff --git a/test/Test/Fixtures/oracle/pragma/ModuleWarning.hs b/test/Test/Fixtures/oracle/pragma/ModuleWarning.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/ModuleWarning.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module ModuleWarning {-# WARNING "This module is intentionally unstable" #-} where + +warningValue :: Int +warningValue = 1 diff --git a/test/Test/Fixtures/oracle/pragma/NoInlinePragmas.hs b/test/Test/Fixtures/oracle/pragma/NoInlinePragmas.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/NoInlinePragmas.hs @@ -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 #-} diff --git a/test/Test/Fixtures/oracle/pragma/NoUnpackPragma.hs b/test/Test/Fixtures/oracle/pragma/NoUnpackPragma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/NoUnpackPragma.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module NoUnpackPragma where + +data NoUnpack = NoUnpack {-# NOUNPACK #-} !(Int, Int) diff --git a/test/Test/Fixtures/oracle/pragma/OpaquePragma.hs b/test/Test/Fixtures/oracle/pragma/OpaquePragma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/OpaquePragma.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module OpaquePragma where + +opaqueFun :: Int -> Int +opaqueFun x = x + 1 +{-# OPAQUE opaqueFun #-} diff --git a/test/Test/Fixtures/oracle/pragma/OverlapPragmas.hs b/test/Test/Fixtures/oracle/pragma/OverlapPragmas.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/OverlapPragmas.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/pragma/RulesPragma.hs b/test/Test/Fixtures/oracle/pragma/RulesPragma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/RulesPragma.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/pragma/SourceLoopA.hs b/test/Test/Fixtures/oracle/pragma/SourceLoopA.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/SourceLoopA.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/pragma/SourceLoopB.hs b/test/Test/Fixtures/oracle/pragma/SourceLoopB.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/SourceLoopB.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/pragma/SpecializeImportedDef.hs b/test/Test/Fixtures/oracle/pragma/SpecializeImportedDef.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/SpecializeImportedDef.hs @@ -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 #-} diff --git a/test/Test/Fixtures/oracle/pragma/SpecializeImportedUse.hs b/test/Test/Fixtures/oracle/pragma/SpecializeImportedUse.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/SpecializeImportedUse.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/pragma/SpecializeInstancePragma.hs b/test/Test/Fixtures/oracle/pragma/SpecializeInstancePragma.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/SpecializeInstancePragma.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/pragma/SpecializePragmas.hs b/test/Test/Fixtures/oracle/pragma/SpecializePragmas.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/SpecializePragmas.hs @@ -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 #-} diff --git a/test/Test/Fixtures/oracle/pragma/UnpackPragmaVariants.hs b/test/Test/Fixtures/oracle/pragma/UnpackPragmaVariants.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/UnpackPragmaVariants.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/pragma/UnpackPragmas.hs b/test/Test/Fixtures/oracle/pragma/UnpackPragmas.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/UnpackPragmas.hs @@ -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 diff --git a/test/Test/Fixtures/oracle/pragma/declaration-warning.hs b/test/Test/Fixtures/oracle/pragma/declaration-warning.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/declaration-warning.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +module DeclarationWarning where + +x = () +{-# WARNING x "w" #-} diff --git a/test/Test/Fixtures/oracle/pragma/deprecated-addFileExtension.hs b/test/Test/Fixtures/oracle/pragma/deprecated-addFileExtension.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/deprecated-addFileExtension.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module PragmaDeprecatedAddFileExtension where + +addFileExtension :: () +{-# DEPRECATED addFileExtension "Please use addExtension instead." #-} +addFileExtension = () diff --git a/test/Test/Fixtures/oracle/pragma/deprecated-prime-name.hs b/test/Test/Fixtures/oracle/pragma/deprecated-prime-name.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/deprecated-prime-name.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module PragmaDeprecatedPrimeName where + +ioMemo' :: () +{-# DEPRECATED ioMemo' "Please just call the action directly." #-} +ioMemo' = () diff --git a/test/Test/Fixtures/oracle/pragma/export-warnings-reexport-lowercase.hs b/test/Test/Fixtures/oracle/pragma/export-warnings-reexport-lowercase.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/export-warnings-reexport-lowercase.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module ExportWarningsReexportLowercase + ( {-# deprecated "Import g from ExportWarningsImport instead" #-} g + ) where + +import ExportWarningsImport (g) diff --git a/test/Test/Fixtures/oracle/pragma/inline-pragma-lowercase.hs b/test/Test/Fixtures/oracle/pragma/inline-pragma-lowercase.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/inline-pragma-lowercase.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module InlinePragmaLowercase where + +fn :: Int -> Int +fn x = x + 1 +{-#inline fn#-} diff --git a/test/Test/Fixtures/oracle/pragma/instance-deprecated-pragma-lowercase.hs b/test/Test/Fixtures/oracle/pragma/instance-deprecated-pragma-lowercase.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/instance-deprecated-pragma-lowercase.hs @@ -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" diff --git a/test/Test/Fixtures/oracle/pragma/multiple-multiline.hs b/test/Test/Fixtures/oracle/pragma/multiple-multiline.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/multiple-multiline.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE BangPatterns, + GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Demo where +x = 1 diff --git a/test/Test/Fixtures/oracle/pragma/scc-expression.hs b/test/Test/Fixtures/oracle/pragma/scc-expression.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/scc-expression.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} + +module SCCPragmaExpression where + +mapL f lx = cachedLatch ({-# SCC mapL #-} f <$> getValueL lx) diff --git a/test/Test/Fixtures/oracle/pragma/source-import-lowercase.hs b/test/Test/Fixtures/oracle/pragma/source-import-lowercase.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/source-import-lowercase.hs @@ -0,0 +1,4 @@ +{- ORACLE_TEST pass -} +module SourceImportLowercase where + +import {-# source #-} SourceLoopA diff --git a/test/Test/Fixtures/oracle/pragma/unpack-pragma-lowercase.hs b/test/Test/Fixtures/oracle/pragma/unpack-pragma-lowercase.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/pragma/unpack-pragma-lowercase.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +module UnpackPragmaLowercase where + +data Inner = Inner !Int + +data Nested = Nested {-# unpack #-} !Inner diff --git a/test/Test/Fixtures/performance/module/deeply-nested-type.yaml b/test/Test/Fixtures/performance/module/deeply-nested-type.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/performance/module/deeply-nested-type.yaml @@ -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 ())))))))))))))))) diff --git a/test/Test/Fixtures/performance/module/nested-constructor-pattern.yaml b/test/Test/Fixtures/performance/module/nested-constructor-pattern.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/performance/module/nested-constructor-pattern.yaml @@ -0,0 +1,3 @@ +extensions: [] +input: | + fn (A(A(A(A(A(A(A(A(A(A(A))))))))))) = 10 diff --git a/test/Test/HackageTester/Suite.hs b/test/Test/HackageTester/Suite.hs new file mode 100644 --- /dev/null +++ b/test/Test/HackageTester/Suite.hs @@ -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\nB\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 diff --git a/test/Test/Lexer/Suite.hs b/test/Test/Lexer/Suite.hs new file mode 100644 --- /dev/null +++ b/test/Test/Lexer/Suite.hs @@ -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" + ] diff --git a/test/Test/Oracle/Suite.hs b/test/Test/Oracle/Suite.hs new file mode 100644 --- /dev/null +++ b/test/Test/Oracle/Suite.hs @@ -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) + ] diff --git a/test/Test/Parser/Suite.hs b/test/Test/Parser/Suite.hs new file mode 100644 --- /dev/null +++ b/test/Test/Parser/Suite.hs @@ -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" + ] diff --git a/test/Test/Performance/Suite.hs b/test/Test/Performance/Suite.hs new file mode 100644 --- /dev/null +++ b/test/Test/Performance/Suite.hs @@ -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) <> ")" diff --git a/test/Test/Properties/Arb/Decl.hs b/test/Test/Properties/Arb/Decl.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/Arb/Decl.hs @@ -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 + ] diff --git a/test/Test/Properties/Arb/Expr.hs b/test/Test/Properties/Arb/Expr.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/Arb/Expr.hs @@ -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 diff --git a/test/Test/Properties/Arb/Expr.hs-boot b/test/Test/Properties/Arb/Expr.hs-boot new file mode 100644 --- /dev/null +++ b/test/Test/Properties/Arb/Expr.hs-boot @@ -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] diff --git a/test/Test/Properties/Arb/Identifiers.hs b/test/Test/Properties/Arb/Identifiers.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/Arb/Identifiers.hs @@ -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)] diff --git a/test/Test/Properties/Arb/Module.hs b/test/Test/Properties/Arb/Module.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/Arb/Module.hs @@ -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] diff --git a/test/Test/Properties/Arb/Pattern.hs b/test/Test/Properties/Arb/Pattern.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/Arb/Pattern.hs @@ -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 + ] diff --git a/test/Test/Properties/Arb/Type.hs b/test/Test/Properties/Arb/Type.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/Arb/Type.hs @@ -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] diff --git a/test/Test/Properties/Arb/Type.hs-boot b/test/Test/Properties/Arb/Type.hs-boot new file mode 100644 --- /dev/null +++ b/test/Test/Properties/Arb/Type.hs-boot @@ -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] diff --git a/test/Test/Properties/Arb/Utils.hs b/test/Test/Properties/Arb/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/Arb/Utils.hs @@ -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 + ] diff --git a/test/Test/Properties/Coverage.hs b/test/Test/Properties/Coverage.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/Coverage.hs @@ -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 diff --git a/test/Test/Properties/DeclRoundTrip.hs b/test/Test/Properties/DeclRoundTrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/DeclRoundTrip.hs @@ -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) diff --git a/test/Test/Properties/ExprRoundTrip.hs b/test/Test/Properties/ExprRoundTrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/ExprRoundTrip.hs @@ -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) diff --git a/test/Test/Properties/MinimalParentheses.hs b/test/Test/Properties/MinimalParentheses.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/MinimalParentheses.hs @@ -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 diff --git a/test/Test/Properties/ModuleRoundTrip.hs b/test/Test/Properties/ModuleRoundTrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/ModuleRoundTrip.hs @@ -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 "" (Just source) errs) False + +prop_moduleValidator :: Module -> Property +prop_moduleValidator modu = + let source = renderStrict (layoutPretty defaultLayoutOptions (pretty modu)) + mbErr = validateParser "" 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 + } diff --git a/test/Test/Properties/NoExceptions.hs b/test/Test/Properties/NoExceptions.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/NoExceptions.hs @@ -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 "" tokens)) + +prop_exprParserArbitraryTokensNoExceptions :: Property +prop_exprParserArbitraryTokensNoExceptions = + forAllShrink genTokenStream shrinkTokenStream $ \tokens -> + ioProperty (noExceptionProperty "parseExprFromTokens" (parseExprFromTokens "" tokens)) + +prop_typeParserArbitraryTokensNoExceptions :: Property +prop_typeParserArbitraryTokensNoExceptions = + forAllShrink genTokenStream shrinkTokenStream $ \tokens -> + ioProperty (noExceptionProperty "parseTypeFromTokens" (parseTypeFromTokens "" tokens)) + +prop_patternParserArbitraryTokensNoExceptions :: Property +prop_patternParserArbitraryTokensNoExceptions = + forAllShrink genTokenStream shrinkTokenStream $ \tokens -> + ioProperty (noExceptionProperty "parsePatternFromTokens" (parsePatternFromTokens "" tokens)) + +prop_declParserArbitraryTokensNoExceptions :: Property +prop_declParserArbitraryTokensNoExceptions = + forAllShrink genTokenStream shrinkTokenStream $ \tokens -> + ioProperty (noExceptionProperty "parseDeclFromTokens" (parseDeclFromTokens "" tokens)) + +prop_importDeclParserArbitraryTokensNoExceptions :: Property +prop_importDeclParserArbitraryTokensNoExceptions = + forAllShrink genTokenStream shrinkTokenStream $ \tokens -> + ioProperty (noExceptionProperty "parseImportDeclFromTokens" (parseImportDeclFromTokens "" tokens)) + +prop_moduleHeaderParserArbitraryTokensNoExceptions :: Property +prop_moduleHeaderParserArbitraryTokensNoExceptions = + forAllShrink genTokenStream shrinkTokenStream $ \tokens -> + ioProperty (noExceptionProperty "parseModuleHeaderFromTokens" (parseModuleHeaderFromTokens "" 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 ["", "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' + ] diff --git a/test/Test/Properties/ParensIdempotency.hs b/test/Test/Properties/ParensIdempotency.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/ParensIdempotency.hs @@ -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) diff --git a/test/Test/Properties/PatternRoundTrip.hs b/test/Test/Properties/PatternRoundTrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/PatternRoundTrip.hs @@ -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) diff --git a/test/Test/Properties/ShorthandSubset.hs b/test/Test/Properties/ShorthandSubset.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/ShorthandSubset.hs @@ -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 _ [] = ([], []) diff --git a/test/Test/Properties/TypeRoundTrip.hs b/test/Test/Properties/TypeRoundTrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Properties/TypeRoundTrip.hs @@ -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) diff --git a/test/Test/StackageProgress/Summary.hs b/test/Test/StackageProgress/Summary.hs new file mode 100644 --- /dev/null +++ b/test/Test/StackageProgress/Summary.hs @@ -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 = [] + }