diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +# Change log + +Scrod follows the [Package Versioning Policy](https://pvp.haskell.org). +You can find release notes [on GitHub](https://github.com/tfausak/scrod/releases). diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,76 @@ +# Contributing + +## Setup + +After cloning the repo, install Git hooks: + +```bash +hooky install +``` + +## Build Commands + +```bash +cabal build # build library + CLI +cabal build --flags=pedantic # build with -Werror (used in CI) +cabal test --test-options='--hide-successes' # run test suite +cabal run scrod # run CLI (reads stdin, outputs JSON by default) +cabal run scrod -- --format html # output HTML instead of JSON +``` + +### Running a single test or test group + +Tests use Tasty, so you can filter with `-p`: + +```bash +cabal test --test-options='--hide-successes -p "integration"' # run integration tests only +cabal test --test-options='--hide-successes -p "/mkDecimal/"' # run a specific test group +``` + +The pattern matches against the test path hierarchy (group names joined by `.`). + +### WASM build (requires Nix devshell) + +```bash +nix develop --command extra/wasm/build.hs +``` + +### VSCode extension build + +You must run the WASM build first. + +```bash +nix develop --command extra/vscode/build.sh # produces a .vsix file +``` + +### Linting and formatting (CI checks all of these) + +If you have Hooky configured (`hooky install`), you can fix all linting and formatting at once: + +```bash +hooky fix +``` + +To run individual checks manually: + +```bash +hlint source/ # lint Haskell +ormolu --mode check $(find source -name "*.hs") # check formatting +ormolu --mode inplace $(find source -name "*.hs") # fix formatting +cabal-gild --input scrod.cabal --mode check # check .cabal formatting +cabal-gild --io scrod.cabal --mode format # fix .cabal formatting +cabal check # validate .cabal file +``` + +## Code Conventions + +- **Haskell2010** with extensions enabled per-file via pragmas +- **Qualified imports everywhere** (e.g., `import qualified Data.Text as Text`) +- **Formatting:** Ormolu (enforced in CI) +- **Warnings:** `-Weverything` with specific exclusions; `-Werror` under `--flags=pedantic` +- **HLint config:** `.hlint.yaml` — enables dollar/future/generalise groups; ignores "Use infix", "Use list comprehension", "Use tuple-section" +- **No external dependencies** for JSON/HTML generation — uses custom in-tree implementations (`Scrod.Json.*`, `Scrod.Xml.*`) + +## Git Conventions + +- **Never amend commits or force push.** Always create new commits. diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,14 @@ +BSD Zero Clause License + +Copyright (c) 2026 Taylor Fausak + +Permission to use, copy, modify, and/or distribute this software for any +purpose with or without fee is hereby granted. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY +AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM +LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR +OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,72 @@ +# Scrod + +[![CI](https://github.com/tfausak/scrod/actions/workflows/ci.yml/badge.svg?branch=main)](https://github.com/tfausak/scrod/actions/workflows/ci.yml) + +:fish: Worse Haskell documentation. + +## Summary + +Scrod is a documentation generator for Haskell modules, similar to [Haddock](https://haskell-haddock.readthedocs.io). + +- Produces JSON or HTML output +- Supports Literate Haskell (Bird and LaTeX style), Backpack signatures, and CPP +- Uses GHC and Haddock (the library) behind the scenes +- Only parses the module; it doesn't rename or type check, so it's fast but limited + +You can try it out in the browser at [scrod.fyi](https://scrod.fyi). + +## Installation + +Download the latest release from [GitHub Releases](https://github.com/tfausak/scrod/releases). Each release includes: + +| Asset | Description | +| --- | --- | +| `scrod-*-linux.tar.gz` | Linux binary | +| `scrod-*-darwin.tar.gz` | macOS binary | +| `scrod-*-win32.tar.gz` | Windows binary | +| `scrod-*.vsix` | VSCode extension for live documentation preview | +| `scrod-*-wasm.tar.gz` | WASM build (for use in browsers) | +| `scrod-*-wasi.tar.gz` | WASI build (for use with runtimes like Wasmtime) | +| `scrod-*-schema.json` | JSON schema for the JSON output format | +| `scrod-*.tar.gz` | Source tarball | + +Or build from source with [GHC](https://www.haskell.org/ghc/) 9.14 and [Cabal](https://www.haskell.org/cabal/): + +```sh +cabal install scrod +``` + +## Usage + +Scrod reads from stdin and writes to stdout: + +```sh +scrod < MyModule.hs # JSON output (default) +scrod --format html < MyModule.hs # HTML output +``` + +### Options + +``` +$ scrod --help +scrod version 0.2026.2.18 + + + -h[BOOL] --help[=BOOL] Shows the help. + --version[=BOOL] Shows the version. + --format=FORMAT Sets the output format (json or html). + --ghc-option=OPTION Sets a GHC option (e.g. -XOverloadedStrings). + --literate[=BOOL] Treats the input as Literate Haskell. + --schema[=BOOL] Shows the JSON output schema. + --signature[=BOOL] Treats the input as a Backpack signature. +``` + +- **`-h`, `--help`**: Prints the help then exits. +- **`--version`**: Prints the version then exits. +- **`--format`**: Sets the output format. Either `json` (the default) or `html`. +- **`--ghc-option`**: Passes an option to the GHC parser (e.g. `-XOverloadedStrings`). Can be given multiple times. +- **`--literate`**: Treats the input as literate Haskell, either Bird or LaTeX style. +- **`--schema`**: Prints the JSON output schema then exits. +- **`--signature`**: Treats the input as a Backpack signature. + +Boolean flags accept an optional `=BOOL` argument (`True` or `False`). Without the argument, the flag is set to `True`. This lets you override earlier flags, e.g. `--literate --literate=False`. diff --git a/scrod.cabal b/scrod.cabal new file mode 100644 --- /dev/null +++ b/scrod.cabal @@ -0,0 +1,254 @@ +cabal-version: 3.12 +name: scrod +version: 0.2026.2.21 +synopsis: Worse Haskell documentation +description: + Scrod generates documentation for Haskell modules, similar to Haddock. Unlike + Haddock, it only parses the input rather than requiring a full build. This + makes it faster but less accurate. + +category: Documentation +homepage: https://scrod.fyi +license: 0BSD +license-file: LICENSE.txt +maintainer: Taylor Fausak +extra-doc-files: + CHANGELOG.md + CONTRIBUTING.md + README.md + +source-repository head + location: https://github.com/tfausak/scrod + type: git + +flag pedantic + default: False + manual: True + +flag wasm + default: False + manual: True + +common library + build-depends: base ^>=4.22.0 + default-language: Haskell2010 + ghc-options: + -fmax-relevant-binds=0 + -fno-show-error-context + -funclutter-valid-hole-fits + -Weverything + -Wno-all-missed-specialisations + -Wno-implicit-prelude + -Wno-missed-specialisations + -Wno-missing-deriving-strategies + -Wno-missing-export-lists + -Wno-missing-kind-signatures + -Wno-missing-role-annotations + -Wno-missing-safe-haskell-mode + -Wno-prepositive-qualified-module + -Wno-safe + -Wno-unsafe + + if flag(pedantic) + ghc-options: -Werror + +common executable + import: library + build-depends: scrod + ghc-options: + -rtsopts + -threaded + +common wasm + import: library + build-depends: scrod + ghc-options: + "-optl-Wl,--strip-debug" + "-optl-Wl,--compress-relocations" + + if !flag(wasm) + buildable: False + +library + import: library + autogen-modules: PackageInfo_scrod + build-depends: + Cabal-syntax ^>=3.16.0, + bytestring ^>=0.12.2, + containers ^>=0.8, + exceptions ^>=0.10.11, + ghc ^>=9.14.1, + ghc-boot-th ^>=9.14.1, + haddock-library ^>=1.11.0, + parsec ^>=3.1.18, + template-haskell ^>=2.24.0, + text ^>=2.1.3, + transformers ^>=0.6.1, + + -- cabal-gild: discover source/library + exposed-modules: + Scrod + Scrod.Cabal + Scrod.Convert.FromGhc + Scrod.Convert.FromGhc.CompleteParents + Scrod.Convert.FromGhc.Constructors + Scrod.Convert.FromGhc.Doc + Scrod.Convert.FromGhc.ExportOrdering + Scrod.Convert.FromGhc.Exports + Scrod.Convert.FromGhc.FamilyInstanceParents + Scrod.Convert.FromGhc.FixityParents + Scrod.Convert.FromGhc.InlineParents + Scrod.Convert.FromGhc.InstanceParents + Scrod.Convert.FromGhc.Internal + Scrod.Convert.FromGhc.ItemKind + Scrod.Convert.FromGhc.KindSigParents + Scrod.Convert.FromGhc.Merge + Scrod.Convert.FromGhc.Names + Scrod.Convert.FromGhc.ParentAssociation + Scrod.Convert.FromGhc.RoleParents + Scrod.Convert.FromGhc.SigArguments + Scrod.Convert.FromGhc.SpecialiseParents + Scrod.Convert.FromGhc.Visibility + Scrod.Convert.FromGhc.WarningParents + Scrod.Convert.FromHaddock + Scrod.Convert.ToHtml + Scrod.Convert.ToJsonSchema + Scrod.Core.Category + Scrod.Core.Column + Scrod.Core.Definition + Scrod.Core.Doc + Scrod.Core.Example + Scrod.Core.Export + Scrod.Core.ExportIdentifier + Scrod.Core.ExportName + Scrod.Core.ExportNameKind + Scrod.Core.Extension + Scrod.Core.Header + Scrod.Core.Hyperlink + Scrod.Core.Identifier + Scrod.Core.Import + Scrod.Core.Item + Scrod.Core.ItemKey + Scrod.Core.ItemKind + Scrod.Core.ItemName + Scrod.Core.Language + Scrod.Core.Level + Scrod.Core.Line + Scrod.Core.Located + Scrod.Core.Location + Scrod.Core.ModLink + Scrod.Core.Module + Scrod.Core.ModuleName + Scrod.Core.Namespace + Scrod.Core.NumberedItem + Scrod.Core.PackageName + Scrod.Core.Picture + Scrod.Core.Section + Scrod.Core.Since + Scrod.Core.Subordinates + Scrod.Core.Table + Scrod.Core.TableCell + Scrod.Core.Version + Scrod.Core.Visibility + Scrod.Core.Warning + Scrod.Cpp + Scrod.Cpp.Directive + Scrod.Cpp.Expr + Scrod.Decimal + Scrod.Executable.Config + Scrod.Executable.Flag + Scrod.Executable.Format + Scrod.Executable.Main + Scrod.Extra.Builder + Scrod.Extra.Either + Scrod.Extra.Maybe + Scrod.Extra.Monoid + Scrod.Extra.Ord + Scrod.Extra.Parsec + Scrod.Extra.Read + Scrod.Extra.Semigroup + Scrod.Ghc.ArchOS + Scrod.Ghc.DynFlags + Scrod.Ghc.FileSettings + Scrod.Ghc.GhcNameVersion + Scrod.Ghc.OnOff + Scrod.Ghc.Parse + Scrod.Ghc.ParserOpts + Scrod.Ghc.Platform + Scrod.Ghc.PlatformMisc + Scrod.Ghc.ToolSettings + Scrod.Ghc.Uninitialized + Scrod.Ghc.UnitId + Scrod.Ghc.UnitSettings + Scrod.Json.Array + Scrod.Json.Boolean + Scrod.Json.Null + Scrod.Json.Number + Scrod.Json.Object + Scrod.Json.Pair + Scrod.Json.String + Scrod.Json.ToJson + Scrod.Json.Value + Scrod.JsonPointer.Evaluate + Scrod.JsonPointer.Pointer + Scrod.JsonPointer.Token + Scrod.Schema + Scrod.Spec + Scrod.TestSuite.All + Scrod.TestSuite.Integration + Scrod.Unlit + Scrod.Xml.Attribute + Scrod.Xml.Comment + Scrod.Xml.Content + Scrod.Xml.Declaration + Scrod.Xml.Document + Scrod.Xml.Element + Scrod.Xml.Instruction + Scrod.Xml.Misc + Scrod.Xml.Name + Scrod.Xml.Text + + hs-source-dirs: source/library + other-modules: PackageInfo_scrod + +benchmark scrod-benchmark + import: executable + build-depends: + bytestring ^>=0.12.2, + tasty-bench ^>=0.5, + + hs-source-dirs: source/benchmark + main-is: Main.hs + type: exitcode-stdio-1.0 + +test-suite scrod-test-suite + import: executable + build-depends: + tasty ^>=1.5.3, + tasty-hunit ^>=0.10.2, + transformers ^>=0.6.1, + + hs-source-dirs: source/test-suite + main-is: Main.hs + type: exitcode-stdio-1.0 + +executable scrod + import: executable + hs-source-dirs: source/executables/scrod + main-is: Main.hs + +executable scrod-wasm + import: wasm + build-depends: ghc-experimental ^>=9.1401.0 + ghc-options: + -no-hs-main + -optl-mexec-model=reactor + + hs-source-dirs: source/executables/scrod-wasm + main-is: Main.hs + +executable scrod-wasi + import: wasm + ghc-options: -optl-mexec-model=command + hs-source-dirs: source/executables/scrod-wasi + main-is: Main.hs diff --git a/source/benchmark/Main.hs b/source/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/source/benchmark/Main.hs @@ -0,0 +1,17 @@ +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LazyByteString +import qualified Scrod.Executable.Main as Main +import qualified Test.Tasty.Bench as Bench + +main :: IO () +main = + Bench.defaultMain + [ Bench.bench "empty input" . Bench.nfIO $ run + ] + +run :: IO LazyByteString.ByteString +run = do + result <- Main.mainWith "bench" [] (pure "") + case result of + Left e -> fail e + Right b -> pure $ Builder.toLazyByteString b diff --git a/source/executables/scrod-wasi/Main.hs b/source/executables/scrod-wasi/Main.hs new file mode 100644 --- /dev/null +++ b/source/executables/scrod-wasi/Main.hs @@ -0,0 +1,5 @@ +import qualified GHC.Stack as Stack +import qualified Scrod + +main :: (Stack.HasCallStack) => IO () +main = Scrod.defaultMain diff --git a/source/executables/scrod-wasm/Main.hs b/source/executables/scrod-wasm/Main.hs new file mode 100644 --- /dev/null +++ b/source/executables/scrod-wasm/Main.hs @@ -0,0 +1,25 @@ +import qualified GHC.Wasm.Prim as Wasm +import qualified Scrod +import qualified Scrod.Extra.Builder as Builder + +main :: IO () +main = error "required by ghc but ignored by wasm" + +foreign export javascript "scrod" + scrod :: Wasm.JSVal -> Wasm.JSString -> IO Wasm.JSString + +scrod :: Wasm.JSVal -> Wasm.JSString -> IO Wasm.JSString +scrod rawArguments input = do + size <- jsArrayLength rawArguments + arguments <- traverse (fmap Wasm.fromJSString . jsArrayIndex rawArguments) [0 .. size - 1] + result <- + Scrod.mainWith "scrod-wasm" arguments + . pure + $ Wasm.fromJSString input + either fail (pure . Wasm.toJSString . Builder.toString) result + +foreign import javascript unsafe "$1.length" + jsArrayLength :: Wasm.JSVal -> IO Int + +foreign import javascript unsafe "$1[$2]" + jsArrayIndex :: Wasm.JSVal -> Int -> IO Wasm.JSString diff --git a/source/executables/scrod/Main.hs b/source/executables/scrod/Main.hs new file mode 100644 --- /dev/null +++ b/source/executables/scrod/Main.hs @@ -0,0 +1,5 @@ +import qualified GHC.Stack as Stack +import qualified Scrod + +main :: (Stack.HasCallStack) => IO () +main = Scrod.defaultMain diff --git a/source/library/Scrod.hs b/source/library/Scrod.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod.hs @@ -0,0 +1,9 @@ +module Scrod + ( Scrod.Executable.Main.defaultMain, + Scrod.Executable.Main.mainWith, + Scrod.TestSuite.All.spec, + ) +where + +import qualified Scrod.Executable.Main +import qualified Scrod.TestSuite.All diff --git a/source/library/Scrod/Cabal.hs b/source/library/Scrod/Cabal.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Cabal.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | Parse Cabal script headers to discover extensions. +-- +-- Cabal scripts can specify @default-extensions@ in a block comment header +-- of the form: +-- +-- > {- cabal: +-- > default-extensions: TemplateHaskell +-- > -} +-- +-- This module extracts and parses that header using @Cabal-syntax@ to +-- discover extension names, which are then used during GHC parsing. +-- +-- The extraction logic mirrors @extractScriptBlock@ from +-- @cabal-install@'s @Distribution.Client.ScriptUtils@: both the +-- @{- cabal:@ start marker and the @-}@ end marker must appear on +-- their own lines (trailing whitespace is tolerated). +module Scrod.Cabal where + +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Distribution.Fields as Fields +import qualified Scrod.Spec as Spec + +-- | Discover extension names from a Cabal script header, if present. +-- Returns extension names like @["TemplateHaskell", "GADTs"]@. +discoverExtensions :: String -> [String] +discoverExtensions source = + foldMap parseDefaultExtensions (extractHeader source) + +-- | Extract the content of a @{- cabal: ... -}@ block. +-- +-- Matches @cabal-install@'s @extractScriptBlock@: the start marker +-- @{- cabal:@ and end marker @-}@ must each appear on their own line +-- (with optional trailing whitespace). Lines before the start marker +-- are skipped, so shebangs are handled naturally. +extractHeader :: String -> Maybe String +extractHeader input = + let stripTrailingSpace = List.dropWhileEnd Char.isSpace + isStartMarker = (== "{- cabal:") . stripTrailingSpace + isEndMarker = (== "-}") . stripTrailingSpace + findStart xs = case xs of + [] -> Nothing + l : ls + | isStartMarker l -> collectBody [] ls + | otherwise -> findStart ls + collectBody acc xs = case xs of + [] -> Nothing + l : ls + | isEndMarker l -> Just . unlines $ reverse acc + | otherwise -> collectBody (l : acc) ls + in findStart (lines input) + +-- | Parse @default-extensions@ values from Cabal field content. +parseDefaultExtensions :: String -> [String] +parseDefaultExtensions content = + let getWords :: Fields.FieldLine pos -> [String] + getWords (Fields.FieldLine _ bs) = + filter (not . null) + . words + . fmap (\c -> if c == ',' then ' ' else c) + $ Char8.unpack bs + getExtensions :: Fields.Field pos -> [String] + getExtensions field = case field of + Fields.Field (Fields.Name _ name) fieldLines + | Char8.map Char.toLower name == Char8.pack "default-extensions" -> + concatMap getWords fieldLines + _ -> [] + in case Fields.readFields (Char8.pack content) of + Left _ -> [] + Right fields -> concatMap getExtensions fields + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'discoverExtensions $ do + Spec.it s "returns empty for no header" $ do + Spec.assertEq s (discoverExtensions "module Foo where") [] + + Spec.it s "returns empty for non-cabal block comment" $ do + Spec.assertEq s (discoverExtensions "{- not cabal -}\nmodule Foo where") [] + + Spec.it s "discovers a single extension" $ do + Spec.assertEq + s + (discoverExtensions "{- cabal:\ndefault-extensions: TemplateHaskell\n-}") + ["TemplateHaskell"] + + Spec.it s "discovers multiple extensions on separate lines" $ do + Spec.assertEq + s + ( discoverExtensions + "{- cabal:\ndefault-extensions:\n TemplateHaskell\n GADTs\n-}" + ) + ["TemplateHaskell", "GADTs"] + + Spec.it s "discovers comma-separated extensions" $ do + Spec.assertEq + s + (discoverExtensions "{- cabal:\ndefault-extensions: TemplateHaskell, GADTs\n-}") + ["TemplateHaskell", "GADTs"] + + Spec.it s "handles shebang line" $ do + Spec.assertEq + s + ( discoverExtensions + "#!/usr/bin/env cabal\n{- cabal:\ndefault-extensions: TemplateHaskell\n-}" + ) + ["TemplateHaskell"] + + Spec.it s "returns empty when markers are not on their own lines" $ do + Spec.assertEq + s + (discoverExtensions "{- cabal: default-extensions: TemplateHaskell -}") + [] + + Spec.it s "tolerates trailing whitespace on markers" $ do + Spec.assertEq + s + (discoverExtensions "{- cabal: \ndefault-extensions: TemplateHaskell\n-} ") + ["TemplateHaskell"] + + Spec.named s 'extractHeader $ do + Spec.it s "returns Nothing for no header" $ do + Spec.assertEq s (extractHeader "module Foo where") Nothing + + Spec.it s "returns Nothing for non-cabal block comment" $ do + Spec.assertEq s (extractHeader "{- not cabal -}") Nothing + + Spec.it s "extracts header content" $ do + Spec.assertEq s (extractHeader "{- cabal:\nbuild-depends: base\n-}") (Just "build-depends: base\n") + + Spec.it s "handles shebang" $ do + Spec.assertEq s (extractHeader "#!/usr/bin/env cabal\n{- cabal:\nx\n-}") (Just "x\n") + + Spec.it s "returns Nothing for unclosed block" $ do + Spec.assertEq s (extractHeader "{- cabal:\nbuild-depends: base") Nothing + + Spec.it s "skips non-marker lines before the header" $ do + Spec.assertEq s (extractHeader "-- a comment\n{- cabal:\nx\n-}") (Just "x\n") diff --git a/source/library/Scrod/Convert/FromGhc.hs b/source/library/Scrod/Convert/FromGhc.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc.hs @@ -0,0 +1,1003 @@ +-- | Convert a parsed GHC AST into Scrod's core representation. +-- +-- This module provides the main 'fromGhc' entry point and the +-- declaration dispatch logic. The actual conversion of individual +-- declaration types is delegated to submodules under +-- @Scrod.Convert.FromGhc.*@. +module Scrod.Convert.FromGhc where + +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Traversable as Traversable +import qualified Data.Tuple as Tuple +import qualified Data.Version +import qualified GHC.Data.FastString as FastString +import qualified GHC.Driver.DynFlags as DynFlags +import qualified GHC.Driver.Session as Session +import qualified GHC.Hs as Hs +import qualified GHC.Hs.Doc as HsDoc +import qualified GHC.Hs.DocString as DocString +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.LanguageExtensions.Type as GhcExtension +import qualified GHC.Parser.Annotation as Annotation +import qualified GHC.Types.Basic as Basic +import qualified GHC.Types.PkgQual as PkgQual +import qualified GHC.Types.SourceText as SourceText +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified GHC.Utils.Outputable as Outputable +import qualified Language.Haskell.Syntax as Syntax +import qualified Language.Haskell.Syntax.Basic as SyntaxBasic +import qualified PackageInfo_scrod as PackageInfo +import qualified Scrod.Convert.FromGhc.CompleteParents as CompleteParents +import qualified Scrod.Convert.FromGhc.Constructors as Constructors +import qualified Scrod.Convert.FromGhc.Doc as GhcDoc +import qualified Scrod.Convert.FromGhc.ExportOrdering as ExportOrdering +import qualified Scrod.Convert.FromGhc.Exports as Exports +import qualified Scrod.Convert.FromGhc.FamilyInstanceParents as FamilyInstanceParents +import qualified Scrod.Convert.FromGhc.FixityParents as FixityParents +import qualified Scrod.Convert.FromGhc.InlineParents as InlineParents +import qualified Scrod.Convert.FromGhc.InstanceParents as InstanceParents +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Convert.FromGhc.ItemKind as ItemKindFrom +import qualified Scrod.Convert.FromGhc.KindSigParents as KindSigParents +import qualified Scrod.Convert.FromGhc.Merge as Merge +import qualified Scrod.Convert.FromGhc.Names as Names +import qualified Scrod.Convert.FromGhc.ParentAssociation as ParentAssociation +import qualified Scrod.Convert.FromGhc.RoleParents as RoleParents +import qualified Scrod.Convert.FromGhc.SigArguments as SigArguments +import qualified Scrod.Convert.FromGhc.SpecialiseParents as SpecialiseParents +import qualified Scrod.Convert.FromGhc.Visibility as Visibility +import qualified Scrod.Convert.FromGhc.WarningParents as WarningParents +import qualified Scrod.Core.Category as Category +import qualified Scrod.Core.Doc as Doc +import qualified Scrod.Core.Export as Export +import qualified Scrod.Core.Extension as Extension +import qualified Scrod.Core.Header as Header +import qualified Scrod.Core.Import as Import +import qualified Scrod.Core.Item as Item +import qualified Scrod.Core.ItemKey as ItemKey +import qualified Scrod.Core.ItemKind as ItemKind +import qualified Scrod.Core.ItemName as ItemName +import qualified Scrod.Core.Language as Language +import qualified Scrod.Core.Level as Level +import qualified Scrod.Core.Located as Located +import qualified Scrod.Core.Module as Module +import qualified Scrod.Core.ModuleName as ModuleName +import qualified Scrod.Core.PackageName as PackageName +import qualified Scrod.Core.Since as Since +import qualified Scrod.Core.Version as Version +import qualified Scrod.Core.Warning as Warning +import qualified Scrod.Ghc.OnOff as OnOff + +-- | Convert a parsed GHC module to the internal 'Module' type. +fromGhc :: + Bool -> + ( (Maybe Session.Language, [DynFlags.OnOff GhcExtension.Extension]), + SrcLoc.Located (Hs.HsModule Ghc.GhcPs) + ) -> + Either String Module.Module +fromGhc isSignature ((language, extensions), lHsModule) = do + version <- maybe (Left "invalid version") Right $ versionFromBase PackageInfo.version + let (moduleDocumentation, moduleSince) = extractModuleDocAndSince lHsModule + namedDocChunks = extractNamedDocChunks lHsModule + rawExports = Exports.extractModuleExports lHsModule + referencedChunkNames = extractReferencedChunkNames rawExports + resolvedExports = resolveNamedDocExports namedDocChunks <$> rawExports + Right + Module.MkModule + { Module.version = version, + Module.language = languageFromGhc <$> language, + Module.extensions = extensionsToMap extensions, + Module.documentation = moduleDocumentation, + Module.since = moduleSince, + Module.signature = isSignature, + Module.name = extractModuleName lHsModule, + Module.warning = extractModuleWarning lHsModule, + Module.imports = extractModuleImports lHsModule, + Module.items = + ExportOrdering.reorderByExports resolvedExports + . Visibility.computeVisibility resolvedExports + . extractItems referencedChunkNames + $ lHsModule + } + +-- | Convert base version to our 'Version' type. +versionFromBase :: Data.Version.Version -> Maybe Version.Version +versionFromBase v = case Data.Version.versionBranch v of + [] -> Nothing + x : xs -> (Just . Version.MkVersion) . fmap fromIntegral $ x NonEmpty.:| xs + +-- | Convert GHC language to our 'Language' type. +languageFromGhc :: Session.Language -> Language.Language +languageFromGhc lang = + Language.MkLanguage . Text.pack $ case lang of + Session.Haskell98 -> "Haskell98" + Session.Haskell2010 -> "Haskell2010" + Session.GHC2021 -> "GHC2021" + Session.GHC2024 -> "GHC2024" + +-- | Convert GHC extension to our 'Extension' type. +extensionFromGhc :: GhcExtension.Extension -> Extension.Extension +extensionFromGhc = + Extension.MkExtension + . Text.pack + . Outputable.showSDocUnsafe + . Outputable.ppr + +-- | Convert list of 'OnOff' extensions to a 'Map'. +extensionsToMap :: + [DynFlags.OnOff GhcExtension.Extension] -> + Map.Map Extension.Extension Bool +extensionsToMap = + Map.fromListWith (\_ x -> x) + . fmap (Tuple.swap . fmap extensionFromGhc . OnOff.onOff ((,) True) ((,) False)) + +-- | Extract module name from the parsed module. +extractModuleName :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Maybe (Located.Located ModuleName.ModuleName) +extractModuleName lHsModule = do + let hsModule = SrcLoc.unLoc lHsModule + lModuleName <- Syntax.hsmodName hsModule + let srcSpan = Annotation.getLocA lModuleName + moduleName = Internal.moduleNameFromGhc $ SrcLoc.unLoc lModuleName + Internal.locatedFromGhc $ SrcLoc.L srcSpan moduleName + +-- | Extract module documentation and @since information from the parsed module. +extractModuleDocAndSince :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + (Doc.Doc, Maybe Since.Since) +extractModuleDocAndSince lHsModule = + maybe (Doc.Empty, Nothing) GhcDoc.parseDoc (extractRawDocString lHsModule) + +-- | Extract raw documentation string from the module header. +extractRawDocString :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Maybe String +extractRawDocString lHsModule = do + let hsModule = SrcLoc.unLoc lHsModule + xModulePs = Syntax.hsmodExt hsModule + lHsDoc <- Hs.hsmodHaddockModHeader xModulePs + let hsDoc = SrcLoc.unLoc lHsDoc + hsDocString = HsDoc.hsDocString hsDoc + Just $ DocString.renderHsDocString hsDocString + +-- | Extract module deprecation warning. +extractModuleWarning :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Maybe Warning.Warning +extractModuleWarning lHsModule = do + let hsModule = SrcLoc.unLoc lHsModule + xModulePs = Syntax.hsmodExt hsModule + lWarningTxt <- Hs.hsmodDeprecMessage xModulePs + let warningTxt = SrcLoc.unLoc lWarningTxt + Just $ Internal.warningTxtToWarning warningTxt + +-- | Extract module imports. +extractModuleImports :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + [Import.Import] +extractModuleImports lHsModule = + let hsModule = SrcLoc.unLoc lHsModule + in convertImportDecl <$> Syntax.hsmodImports hsModule + +-- | Convert a GHC import declaration to our 'Import' type. +convertImportDecl :: + SrcLoc.GenLocated l (Syntax.ImportDecl Ghc.GhcPs) -> + Import.Import +convertImportDecl lImportDecl = + let importDecl = SrcLoc.unLoc lImportDecl + in Import.MkImport + { Import.name = Internal.moduleNameFromGhc . SrcLoc.unLoc $ Syntax.ideclName importDecl, + Import.package = packageFromPkgQual $ Syntax.ideclPkgQual importDecl, + Import.alias = Internal.moduleNameFromGhc . SrcLoc.unLoc <$> Syntax.ideclAs importDecl + } + +-- | Convert a GHC package qualifier to our 'PackageName' type. +packageFromPkgQual :: PkgQual.RawPkgQual -> Maybe PackageName.PackageName +packageFromPkgQual pkgQual = case pkgQual of + PkgQual.NoRawPkgQual -> Nothing + PkgQual.RawPkgQual sl -> + Just . PackageName.MkPackageName . Text.pack . FastString.unpackFS $ SourceText.sl_fs sl + +-- | Extract items from the module. +extractItems :: + Set.Set Text.Text -> + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + [Located.Located Item.Item] +extractItems referencedChunkNames lHsModule = + let rawItems = Internal.runConvert $ extractItemsM referencedChunkNames lHsModule + argNameMap = buildArgNameMap lHsModule + patchedItems = patchArgumentNames argNameMap rawItems + instanceHeadTypes = InstanceParents.extractInstanceHeadTypeNames lHsModule + instanceClassNames = InstanceParents.extractInstanceClassNames lHsModule + parentedItems = InstanceParents.associateInstanceParents instanceHeadTypes instanceClassNames patchedItems + -- Parent-association passes: associate pragma/annotation items + -- (warning, fixity, inline, specialise, type role) and family + -- instance items with their target declarations by matching names. + -- These run before merging so that 'mergeItemsByName' can remap + -- already-established child 'parentKey's to the merged declaration key. + warningLocations = WarningParents.extractWarningLocations lHsModule + fixityLocations = FixityParents.extractFixityLocations lHsModule + inlineLocations = InlineParents.extractInlineLocations lHsModule + specialiseLocations = SpecialiseParents.extractSpecialiseLocations lHsModule + roleLocations = RoleParents.extractRoleLocations lHsModule + allPragmaLocations = Set.unions [warningLocations, fixityLocations, inlineLocations, specialiseLocations, roleLocations] + warningParentedItems = ParentAssociation.associateParents allPragmaLocations warningLocations parentedItems + fixityParentedItems = ParentAssociation.associateParents allPragmaLocations fixityLocations warningParentedItems + inlineParentedItems = ParentAssociation.associateParents allPragmaLocations inlineLocations fixityParentedItems + specialiseParentedItems = ParentAssociation.associateParents allPragmaLocations specialiseLocations inlineParentedItems + roleParentedItems = ParentAssociation.associateParents allPragmaLocations roleLocations specialiseParentedItems + familyInstanceNames = FamilyInstanceParents.extractFamilyInstanceNames lHsModule + familyParentedItems = FamilyInstanceParents.associateFamilyInstanceParents familyInstanceNames roleParentedItems + mergedItems = Merge.mergeItemsByName familyParentedItems + -- Standalone kind signature merging runs after term-level + -- merging so that type signatures and bindings are merged first. + -- This merges standalone kind signatures into their corresponding + -- declarations (see 'KindSigParents'). + kindSigParentedItems = KindSigParents.associateKindSigParents mergedItems + -- COMPLETE pragma association runs after merging and uses inverted + -- semantics: pattern synonyms are parented to the COMPLETE pragma + -- (not the pragma to the patterns). This is because COMPLETE + -- pragmas group patterns together rather than annotating a single + -- declaration. It must run after merging because pattern synonyms + -- are merged with their type signatures first. + completeNames = CompleteParents.extractCompleteNames lHsModule + in CompleteParents.associateCompleteParents completeNames kindSigParentedItems + +-- | Build a map from function name to argument names extracted from +-- 'FunBind' patterns. Each function maps to a list of 'Maybe Text' +-- with one entry per argument position. +buildArgNameMap :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Map.Map ItemName.ItemName [Maybe Text.Text] +buildArgNameMap lHsModule = + let hsModule = SrcLoc.unLoc lHsModule + decls = Syntax.hsmodDecls hsModule + in Map.fromList + [ (name, argNames) + | lDecl <- decls, + Syntax.ValD _ bind <- [SrcLoc.unLoc lDecl], + let argNames = Names.extractBindArgNames bind, + not (null argNames), + Just name <- [Names.extractBindName bind] + ] + +-- | Patch argument names from function bindings into 'Argument' items. +-- +-- For each 'Function' item whose name appears in the map, finds its +-- child 'Argument' items (by matching 'parentKey') and sets their +-- 'name' field from the corresponding position in the argument name +-- list. +patchArgumentNames :: + Map.Map ItemName.ItemName [Maybe Text.Text] -> + [Located.Located Item.Item] -> + [Located.Located Item.Item] +patchArgumentNames argNameMap items = + let -- Map from function key to arg names + funcKeyToArgNames = + Map.fromList + [ (Item.key val, names) + | locItem <- items, + let val = Located.value locItem, + Item.kind val == ItemKind.Function || Item.kind val == ItemKind.Operator, + Just itemName <- [Item.name val], + Just names <- [Map.lookup itemName argNameMap] + ] + -- Group argument items by parent key, preserving order + argsByParent = + Map.fromListWith + (flip (<>)) + [ (pk, [locItem]) + | locItem <- items, + let val = Located.value locItem, + Item.kind val == ItemKind.Argument, + Just pk <- [Item.parentKey val] + ] + -- Build update map: item key -> updated item + updates = + Map.fromList + [ (Item.key (Located.value updated), updated) + | (funcKey, names) <- Map.toList funcKeyToArgNames, + Just argItems <- [Map.lookup funcKey argsByParent], + updated <- zipWith setArgName (names <> repeat Nothing) argItems + ] + in fmap (\item -> Maybe.fromMaybe item $ Map.lookup (Item.key (Located.value item)) updates) items + +-- | Set the name of an argument item if a name is provided. +setArgName :: Maybe Text.Text -> Located.Located Item.Item -> Located.Located Item.Item +setArgName mName locItem = case mName of + Nothing -> locItem + Just name -> + locItem + { Located.value = + (Located.value locItem) + { Item.name = Just $ ItemName.MkItemName name + } + } + +-- | Extract items in the conversion monad. +extractItemsM :: + Set.Set Text.Text -> + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Internal.ConvertM [Located.Located Item.Item] +extractItemsM referencedChunkNames lHsModule = do + let hsModule = SrcLoc.unLoc lHsModule + decls = Syntax.hsmodDecls hsModule + declsWithDocs = GhcDoc.associateDocs referencedChunkNames decls + concat <$> traverse (\(doc, docSince, lDecl) -> convertDeclWithDocMaybeM doc docSince lDecl) declsWithDocs + +-- | Convert a declaration with documentation. +convertDeclWithDocMaybeM :: + Doc.Doc -> + Maybe Since.Since -> + Syntax.LHsDecl Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertDeclWithDocMaybeM doc docSince lDecl = case SrcLoc.unLoc lDecl of + Syntax.TyClD _ tyClDecl -> convertTyClDeclWithDocM doc docSince lDecl tyClDecl + Syntax.RuleD _ ruleDecls -> convertRuleDeclsM ruleDecls + Syntax.DocD _ (Hs.DocCommentNamed name lNamedDoc) -> + let chunkName = Just . ItemName.MkItemName . Text.pack $ '$' : name + chunkDoc = GhcDoc.convertExportDoc lNamedDoc + in Maybe.maybeToList <$> Internal.mkItemM (Annotation.getLocA lDecl) Nothing chunkName (Internal.appendDoc doc chunkDoc) docSince Nothing ItemKind.DocumentationChunk + Syntax.DocD _ (Hs.DocGroup level lGroupDoc) -> + let groupDoc = Doc.Header Header.MkHeader {Header.level = Level.fromInt level, Header.title = GhcDoc.convertExportDoc lGroupDoc} + in Maybe.maybeToList <$> Internal.mkItemM (Annotation.getLocA lDecl) Nothing Nothing (Internal.appendDoc doc groupDoc) docSince Nothing ItemKind.DocumentationChunk + Syntax.DocD {} -> Maybe.maybeToList <$> convertDeclSimpleM lDecl + Syntax.SigD _ sig -> convertSigDeclM doc docSince lDecl sig + Syntax.KindSigD _ kindSig -> + let sig = Just $ Names.extractKindSigSignature kindSig + in Maybe.maybeToList <$> convertDeclWithDocM Nothing doc docSince (Just $ Names.extractStandaloneKindSigName kindSig) sig lDecl + Syntax.InstD _ inst -> convertInstDeclWithDocM doc docSince lDecl inst + Syntax.ForD _ foreignDecl -> + let name = Just $ Names.extractForeignDeclName foreignDecl + sig = Just $ Names.extractForeignDeclSignature foreignDecl + in Maybe.maybeToList <$> convertDeclWithDocM Nothing doc docSince name sig lDecl + Syntax.SpliceD _ spliceDecl -> + let sig = Just . Text.pack . Internal.showSDocShort . Outputable.ppr $ spliceDecl + in Maybe.maybeToList <$> convertDeclWithDocM Nothing doc docSince Nothing sig lDecl + Syntax.WarningD _ warnDecls -> convertWarnDeclsM warnDecls + Syntax.RoleAnnotD _ roleAnnotDecl -> Maybe.maybeToList <$> convertRoleAnnotM roleAnnotDecl + Syntax.DefD _ defaultDecl -> convertDefaultDeclM doc docSince lDecl defaultDecl + Syntax.DerivD _ derivDecl -> + let strategy = extractDerivStrategy $ Syntax.deriv_strategy derivDecl + in Maybe.maybeToList <$> convertDeclWithDocM Nothing doc docSince (Names.extractDeclName lDecl) strategy lDecl + _ -> Maybe.maybeToList <$> convertDeclWithDocM Nothing doc docSince (Names.extractDeclName lDecl) Nothing lDecl + +-- | Convert a type/class declaration with documentation. +convertTyClDeclWithDocM :: + Doc.Doc -> + Maybe Since.Since -> + Syntax.LHsDecl Ghc.GhcPs -> + Syntax.TyClDecl Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertTyClDeclWithDocM doc docSince lDecl tyClDecl = case tyClDecl of + Syntax.FamDecl _ famDecl -> case Syntax.fdInfo famDecl of + Syntax.ClosedTypeFamily (Just eqns) -> do + parentItem <- convertDeclWithDocM Nothing doc docSince (Names.extractTyClDeclName tyClDecl) Nothing lDecl + let parentKey = fmap (Item.key . Located.value) parentItem + eqnItems <- convertTyFamInstEqnsM parentKey eqns + pure $ Maybe.maybeToList parentItem <> eqnItems + _ -> Maybe.maybeToList <$> convertDeclWithDocM Nothing doc docSince (Names.extractTyClDeclName tyClDecl) Nothing lDecl + Syntax.DataDecl _ _ _ _ dataDefn -> do + parentItem <- convertDeclWithDocM Nothing doc docSince (Names.extractTyClDeclName tyClDecl) (Names.extractTyClDeclTyVars tyClDecl) lDecl + let parentKey = fmap (Item.key . Located.value) parentItem + parentType = Names.extractParentTypeText tyClDecl + childItems <- convertDataDefnM parentKey parentType dataDefn + pure $ Maybe.maybeToList parentItem <> childItems + Syntax.ClassDecl {Syntax.tcdSigs = sigs, Syntax.tcdATs = ats, Syntax.tcdDocs = docs} -> do + parentItem <- convertDeclWithDocM Nothing doc docSince (Names.extractTyClDeclName tyClDecl) Nothing lDecl + let parentKey = fmap (Item.key . Located.value) parentItem + methodItems <- convertClassSigsWithDocsM parentKey sigs docs + defaultSigItems <- convertDefaultSigsM methodItems sigs docs + minimalItems <- convertMinimalSigsM parentKey sigs + familyItems <- convertFamilyDeclsM parentKey ats + pure $ Maybe.maybeToList parentItem <> methodItems <> defaultSigItems <> minimalItems <> familyItems + Syntax.SynDecl {} -> Maybe.maybeToList <$> convertDeclWithDocM Nothing doc docSince (Names.extractTyClDeclName tyClDecl) (Names.extractSynDeclSignature tyClDecl) lDecl + +-- | Convert an instance declaration with documentation. +convertInstDeclWithDocM :: + Doc.Doc -> + Maybe Since.Since -> + Syntax.LHsDecl Ghc.GhcPs -> + Syntax.InstDecl Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertInstDeclWithDocM doc docSince lDecl inst = case inst of + Syntax.DataFamInstD _ dataFamInst -> do + parentItem <- convertDeclWithDocM Nothing doc docSince (Names.extractInstDeclName inst) Nothing lDecl + let parentKey = fmap (Item.key . Located.value) parentItem + eqn = Syntax.dfid_eqn dataFamInst + parentType = + Just . Text.pack . Internal.showSDocShort $ + Outputable.hsep (Outputable.ppr (Syntax.feqn_tycon eqn) : (pprHsTypeArg <$> Syntax.feqn_pats eqn)) + childItems <- convertDataDefnM parentKey parentType (Syntax.feqn_rhs eqn) + pure $ Maybe.maybeToList parentItem <> childItems + _ -> Maybe.maybeToList <$> convertDeclWithDocM Nothing doc docSince (Names.extractInstDeclName inst) Nothing lDecl + +-- | Convert a signature declaration. +convertSigDeclM :: + Doc.Doc -> + Maybe Since.Since -> + Syntax.LHsDecl Ghc.GhcPs -> + Syntax.Sig Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertSigDeclM doc docSince lDecl sig = case sig of + Syntax.TypeSig _ names _ -> + let sigText = Names.extractSigSignature sig + (args, retType) = SigArguments.extractSigArguments sig + in fmap concat . Traversable.for names $ \lName -> do + parentResult <- + Internal.mkItemWithKeyM + (Annotation.getLocA lName) + Nothing + (Just $ Internal.extractIdPName lName) + doc + docSince + sigText + (ItemKindFrom.functionOrOperator lName) + case parentResult of + Nothing -> pure [] + Just (parentItem, parentKey) -> do + argItems <- convertArguments (Just parentKey) (Annotation.getLocA lName) args + retItem <- convertReturnType (Just parentKey) (Annotation.getLocA lName) retType + pure $ [parentItem] <> argItems <> retItem + Syntax.PatSynSig _ names _ -> + let sigText = Names.extractSigSignature sig + (args, retType) = SigArguments.extractSigArguments sig + in fmap concat . Traversable.for names $ \lName -> do + parentResult <- + Internal.mkItemWithKeyM + (Annotation.getLocA lName) + Nothing + (Just $ Internal.extractIdPName lName) + doc + docSince + sigText + ItemKind.PatternSynonym + case parentResult of + Nothing -> pure [] + Just (parentItem, parentKey) -> do + argItems <- convertArguments (Just parentKey) (Annotation.getLocA lName) args + retItem <- convertReturnType (Just parentKey) (Annotation.getLocA lName) retType + pure $ [parentItem] <> argItems <> retItem + Syntax.FixSig _ (Syntax.FixitySig _ names (SyntaxBasic.Fixity prec dir)) -> + let fixityDoc = Doc.Paragraph . Doc.String $ fixityDirectionToText dir <> Text.pack (" " <> show prec) + combinedDoc = combineDoc doc fixityDoc + in Maybe.catMaybes <$> traverse (convertFixityNameM combinedDoc) names + Syntax.InlineSig _ lName inlinePragma -> + let sigText = Just $ inlinePragmaToText inlinePragma + in Maybe.maybeToList <$> convertInlineNameM doc docSince sigText lName + Syntax.SpecSig _ lName sigTypes _ -> + let sigText = Just . Text.pack . Internal.showSDocShort $ Outputable.hsep (Outputable.punctuate (Outputable.text ",") (fmap Outputable.ppr sigTypes)) + in Maybe.maybeToList <$> convertSpecialiseNameM doc docSince sigText lName + Syntax.SpecSigE _ _ lExpr _ -> convertSpecSigEM doc docSince lExpr + Syntax.CompleteMatchSig _ names mTyCon -> + let namesSig = Outputable.hsep (Outputable.punctuate (Outputable.text ",") (fmap Outputable.ppr names)) + sigText = Just . Text.pack . Internal.showSDocShort $ case mTyCon of + Nothing -> namesSig + Just tyCon -> Outputable.hsep [namesSig, Outputable.text "::", Outputable.ppr tyCon] + in Maybe.maybeToList <$> Internal.mkItemM (Annotation.getLocA lDecl) Nothing Nothing doc docSince sigText ItemKind.CompletePragma + _ -> Maybe.maybeToList <$> convertDeclWithDocM Nothing doc docSince (Names.extractSigName sig) Nothing lDecl + +-- | Convert extracted argument data into child Argument items. +-- Returns no items if none of the arguments have documentation. +convertArguments :: + Maybe ItemKey.ItemKey -> + SrcLoc.SrcSpan -> + [(Text.Text, Maybe (HsDoc.LHsDoc Ghc.GhcPs))] -> + Internal.ConvertM [Located.Located Item.Item] +convertArguments parentKey srcSpan args + | any (Maybe.isJust . snd) args = + Maybe.catMaybes <$> traverse (convertOneArgument parentKey srcSpan) args + | otherwise = pure [] + +-- | Convert a single argument to an Argument item. +convertOneArgument :: + Maybe ItemKey.ItemKey -> + SrcLoc.SrcSpan -> + (Text.Text, Maybe (HsDoc.LHsDoc Ghc.GhcPs)) -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertOneArgument parentKey srcSpan (sigText, mDoc) = + let (argDoc, argSince) = maybe (Doc.Empty, Nothing) GhcDoc.convertLHsDoc mDoc + in Internal.mkItemM srcSpan parentKey Nothing argDoc argSince (Just sigText) ItemKind.Argument + +-- | Convert an optional return type into a ReturnType item. +convertReturnType :: + Maybe ItemKey.ItemKey -> + SrcLoc.SrcSpan -> + Maybe (Text.Text, Maybe (HsDoc.LHsDoc Ghc.GhcPs)) -> + Internal.ConvertM [Located.Located Item.Item] +convertReturnType parentKey srcSpan mRet = case mRet of + Nothing -> pure [] + Just (sigText, mDoc) -> + let (retDoc, retSince) = maybe (Doc.Empty, Nothing) GhcDoc.convertLHsDoc mDoc + in Maybe.maybeToList <$> Internal.mkItemM srcSpan parentKey Nothing retDoc retSince (Just sigText) ItemKind.ReturnType + +-- | Convert a single name from a fixity signature. +convertFixityNameM :: + Doc.Doc -> + Syntax.LIdP Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertFixityNameM fixityDoc lName = + Internal.mkItemM (Annotation.getLocA lName) Nothing (Just $ Internal.extractIdPName lName) fixityDoc Nothing Nothing ItemKind.FixitySignature + +-- | Convert a single name from an inline signature. +convertInlineNameM :: + Doc.Doc -> + Maybe Since.Since -> + Maybe Text.Text -> + Syntax.LIdP Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertInlineNameM doc docSince sig lName = + Internal.mkItemM (Annotation.getLocA lName) Nothing (Just $ Internal.extractIdPName lName) doc docSince sig ItemKind.InlineSignature + +-- | Convert a single name from a SPECIALIZE signature. +convertSpecialiseNameM :: + Doc.Doc -> + Maybe Since.Since -> + Maybe Text.Text -> + Syntax.LIdP Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertSpecialiseNameM doc docSince sig lName = + Internal.mkItemM (Annotation.getLocA lName) Nothing (Just $ Internal.extractIdPName lName) doc docSince sig ItemKind.SpecialiseSignature + +-- | Convert a SpecSigE expression to items. +convertSpecSigEM :: + Doc.Doc -> + Maybe Since.Since -> + Syntax.LHsExpr Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertSpecSigEM doc docSince lExpr = case SrcLoc.unLoc lExpr of + Syntax.ExprWithTySig _ body sigWcType -> + let sigText = Just . Text.pack . Internal.showSDocShort . Outputable.ppr $ sigWcType + in case SrcLoc.unLoc body of + Syntax.HsVar _ lName -> + Maybe.maybeToList <$> convertSpecialiseNameM doc docSince sigText lName + _ -> + Maybe.maybeToList <$> Internal.mkItemM (Annotation.getLocA lExpr) Nothing Nothing doc docSince sigText ItemKind.SpecialiseSignature + _ -> + Maybe.maybeToList <$> Internal.mkItemM (Annotation.getLocA lExpr) Nothing Nothing doc docSince Nothing ItemKind.SpecialiseSignature + +-- | Combine a user-written doc with a synthesized doc. If the user doc +-- is empty, just use the synthesized one; otherwise append both. +combineDoc :: Doc.Doc -> Doc.Doc -> Doc.Doc +combineDoc user synth = case user of + Doc.Empty -> synth + _ -> Doc.Append [user, synth] + +-- | Convert a fixity direction to text. +fixityDirectionToText :: SyntaxBasic.FixityDirection -> Text.Text +fixityDirectionToText dir = case dir of + SyntaxBasic.InfixL -> Text.pack "infixl" + SyntaxBasic.InfixR -> Text.pack "infixr" + SyntaxBasic.InfixN -> Text.pack "infix" + +-- | Convert a GHC 'InlinePragma' to text, including the keyword, +-- CONLIKE modifier, and phase activation. +inlinePragmaToText :: Basic.InlinePragma -> Text.Text +inlinePragmaToText pragma = + let keyword = case Basic.inl_inline pragma of + Basic.Inline {} -> Text.pack "INLINE" + Basic.Inlinable {} -> Text.pack "INLINABLE" + Basic.NoInline {} -> Text.pack "NOINLINE" + Basic.Opaque {} -> Text.pack "OPAQUE" + Basic.NoUserInlinePrag -> Text.pack "INLINE" + conlike = case Basic.inl_rule pragma of + Basic.ConLike -> Text.pack " CONLIKE" + Basic.FunLike -> Text.empty + phase = case Basic.inl_act pragma of + Basic.AlwaysActive -> Text.empty + Basic.ActiveAfter _ n -> Text.pack $ " [" <> show n <> "]" + Basic.ActiveBefore _ n -> Text.pack $ " [~" <> show n <> "]" + Basic.FinalActive -> Text.empty + Basic.NeverActive -> Text.empty + in keyword <> conlike <> phase + +-- | Convert a default declaration. Named defaults (e.g. +-- @default Cls (Typ)@) produce an item; unnamed defaults (e.g. +-- @default (Int)@) are skipped since they don't contribute to +-- documentation. +convertDefaultDeclM :: + Doc.Doc -> + Maybe Since.Since -> + Syntax.LHsDecl Ghc.GhcPs -> + Syntax.DefaultDecl Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertDefaultDeclM doc docSince lDecl defaultDecl = case Syntax.defd_class defaultDecl of + Nothing -> pure [] + Just lName -> + let name = Just $ Internal.extractIdPName lName + sig = case Syntax.defd_defaults defaultDecl of + [] -> Nothing + types -> + Just . Text.pack . Internal.showSDocShort $ + Outputable.hsep (Outputable.punctuate (Outputable.text ",") (fmap Outputable.ppr types)) + in Maybe.maybeToList <$> convertDeclWithDocM Nothing doc docSince name sig lDecl + +-- | Convert a simple declaration without special handling. +convertDeclSimpleM :: + Syntax.LHsDecl Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertDeclSimpleM = convertDeclWithDocM Nothing Doc.Empty Nothing Nothing Nothing + +-- | Convert a declaration with documentation. +convertDeclWithDocM :: + Maybe ItemKey.ItemKey -> + Doc.Doc -> + Maybe Since.Since -> + Maybe ItemName.ItemName -> + Maybe Text.Text -> + Syntax.LHsDecl Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertDeclWithDocM parentKey doc docSince itemName sig lDecl = + let itemKind = ItemKindFrom.itemKindFromDecl $ SrcLoc.unLoc lDecl + in Internal.mkItemM (Annotation.getLocA lDecl) parentKey itemName doc docSince sig itemKind + +-- | Convert rule declarations. +convertRuleDeclsM :: + Syntax.RuleDecls Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertRuleDeclsM (Syntax.HsRules _ rules) = Maybe.catMaybes <$> traverse convertRuleDeclM rules + +-- | Convert a single rule declaration. +convertRuleDeclM :: + Syntax.LRuleDecl Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertRuleDeclM lRuleDecl = + let ruleDecl = SrcLoc.unLoc lRuleDecl + name = Just . ItemName.MkItemName . Text.pack . FastString.unpackFS . SrcLoc.unLoc $ Syntax.rd_name ruleDecl + sig = + Just . Text.pack . Internal.showSDocShort $ + Outputable.hsep + [ Outputable.ppr (Syntax.rd_bndrs ruleDecl), + Outputable.ppr (Syntax.rd_lhs ruleDecl), + Outputable.text "=", + Outputable.ppr (Syntax.rd_rhs ruleDecl) + ] + in Internal.mkItemM (Annotation.getLocA lRuleDecl) Nothing name Doc.Empty Nothing sig ItemKind.Rule + +-- | Convert a role annotation declaration. +convertRoleAnnotM :: + Syntax.RoleAnnotDecl Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertRoleAnnotM (Syntax.RoleAnnotDecl _ lName roles) = + let sig = Just . Text.intercalate (Text.pack " ") $ fmap (roleToText . SrcLoc.unLoc) roles + in Internal.mkItemM (Annotation.getLocA lName) Nothing (Just $ Internal.extractIdPName lName) Doc.Empty Nothing sig ItemKind.RoleAnnotation + +-- | Convert a Maybe Role to its textual representation. +roleToText :: Maybe SyntaxBasic.Role -> Text.Text +roleToText r = case r of + Nothing -> Text.pack "_" + Just SyntaxBasic.Nominal -> Text.pack "nominal" + Just SyntaxBasic.Representational -> Text.pack "representational" + Just SyntaxBasic.Phantom -> Text.pack "phantom" + +-- | Convert warning declarations. +convertWarnDeclsM :: + Syntax.WarnDecls Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertWarnDeclsM (Syntax.Warnings _ warnDecls) = + concat <$> traverse convertWarnDeclM warnDecls + +-- | Convert a single warning declaration. +convertWarnDeclM :: + Syntax.LWarnDecl Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertWarnDeclM lWarnDecl = case SrcLoc.unLoc lWarnDecl of + Syntax.Warning _ names warningTxt -> + let warning = Internal.warningTxtToWarning warningTxt + in Maybe.catMaybes <$> traverse (convertWarnNameM warning) names + +-- | Convert a single name from a warning declaration. +convertWarnNameM :: + Warning.Warning -> + Syntax.LIdP Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertWarnNameM warning lName = + let doc = Doc.Paragraph . Doc.String $ Warning.value warning + sig = Just . Category.unwrap $ Warning.category warning + in Internal.mkItemM (Annotation.getLocA lName) Nothing (Just $ Internal.extractIdPName lName) doc Nothing sig ItemKind.Warning + +-- | Convert class signatures with associated documentation. +convertClassSigsWithDocsM :: + Maybe ItemKey.ItemKey -> + [Syntax.LSig Ghc.GhcPs] -> + [Hs.LDocDecl Ghc.GhcPs] -> + Internal.ConvertM [Located.Located Item.Item] +convertClassSigsWithDocsM parentKey sigs docs = + let classOpSigs = filter isClassOpSig sigs + sigDecls = fmap (fmap (Syntax.SigD Hs.noExtField)) classOpSigs + docDecls = fmap (fmap (Syntax.DocD Hs.noExtField)) docs + allDecls = List.sortBy (\a b -> SrcLoc.leftmost_smallest (Annotation.getLocA a) (Annotation.getLocA b)) (sigDecls <> docDecls) + sigsWithDocs = GhcDoc.associateDocs Set.empty allDecls + in concat <$> traverse (\(doc, docSince, lDecl) -> convertClassDeclWithDocM parentKey doc docSince lDecl) sigsWithDocs + where + isClassOpSig :: Syntax.LSig Ghc.GhcPs -> Bool + isClassOpSig lSig = case SrcLoc.unLoc lSig of + Syntax.ClassOpSig _ False _ _ -> True + _ -> False + +-- | Convert a class body declaration with associated documentation. +convertClassDeclWithDocM :: + Maybe ItemKey.ItemKey -> + Doc.Doc -> + Maybe Since.Since -> + Syntax.LHsDecl Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertClassDeclWithDocM parentKey doc docSince lDecl = case SrcLoc.unLoc lDecl of + Syntax.SigD _ sig -> case sig of + Syntax.ClassOpSig _ _ names _ -> + let sigText = Names.extractSigSignature sig + (args, retType) = SigArguments.extractSigArguments sig + in fmap concat . Traversable.for names $ \lName -> do + parentResult <- + Internal.mkItemWithKeyM + (Annotation.getLocA lName) + parentKey + (Just $ Internal.extractIdPName lName) + doc + docSince + sigText + ItemKind.ClassMethod + case parentResult of + Nothing -> pure [] + Just (methodItem, methodKey) -> do + argItems <- convertArguments (Just methodKey) (Annotation.getLocA lName) args + retItem <- convertReturnType (Just methodKey) (Annotation.getLocA lName) retType + pure $ [methodItem] <> argItems <> retItem + _ -> pure [] + _ -> pure [] + +-- | Convert default method signatures within a class, parenting them to the +-- corresponding class method. +convertDefaultSigsM :: + [Located.Located Item.Item] -> + [Syntax.LSig Ghc.GhcPs] -> + [Hs.LDocDecl Ghc.GhcPs] -> + Internal.ConvertM [Located.Located Item.Item] +convertDefaultSigsM methodItems sigs docs = + let nameToKey = + Map.fromList + [ (name, Item.key item) + | Located.MkLocated _ item <- methodItems, + Just name <- [Item.name item] + ] + defaultSigs = filter isDefaultSig sigs + sigDecls = fmap (fmap (Syntax.SigD Hs.noExtField)) defaultSigs + docDecls = fmap (fmap (Syntax.DocD Hs.noExtField)) docs + allDecls = List.sortBy (\a b -> SrcLoc.leftmost_smallest (Annotation.getLocA a) (Annotation.getLocA b)) (sigDecls <> docDecls) + sigsWithDocs = GhcDoc.associateDocs Set.empty allDecls + in concat <$> traverse (\(doc, docSince, lDecl) -> convertDefaultSigDeclM nameToKey doc docSince lDecl) sigsWithDocs + where + isDefaultSig :: Syntax.LSig Ghc.GhcPs -> Bool + isDefaultSig lSig = case SrcLoc.unLoc lSig of + Syntax.ClassOpSig _ True _ _ -> True + _ -> False + +-- | Convert a single default method signature declaration with documentation. +convertDefaultSigDeclM :: + Map.Map ItemName.ItemName ItemKey.ItemKey -> + Doc.Doc -> + Maybe Since.Since -> + Syntax.LHsDecl Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertDefaultSigDeclM nameToKey doc docSince lDecl = case SrcLoc.unLoc lDecl of + Syntax.SigD _ (Syntax.ClassOpSig _ True names sigTy) -> + let sig = Just . Text.pack . Internal.showSDocShort $ Outputable.ppr sigTy + in Maybe.catMaybes <$> traverse (convertDefaultSigNameM nameToKey doc docSince sig) names + _ -> pure [] + +-- | Convert a single name from a default method signature. +convertDefaultSigNameM :: + Map.Map ItemName.ItemName ItemKey.ItemKey -> + Doc.Doc -> + Maybe Since.Since -> + Maybe Text.Text -> + Syntax.LIdP Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertDefaultSigNameM nameToKey doc docSince sig lName = + let name = Internal.extractIdPName lName + parentKey = Map.lookup name nameToKey + in Internal.mkItemM (Annotation.getLocA lName) parentKey (Just name) doc docSince sig ItemKind.DefaultMethodSignature + +-- | Convert MINIMAL pragma signatures inside a class. +convertMinimalSigsM :: + Maybe ItemKey.ItemKey -> + [Syntax.LSig Ghc.GhcPs] -> + Internal.ConvertM [Located.Located Item.Item] +convertMinimalSigsM parentKey = fmap Maybe.catMaybes . traverse (convertMinimalSigM parentKey) + +-- | Convert a single MINIMAL pragma signature. +convertMinimalSigM :: + Maybe ItemKey.ItemKey -> + Syntax.LSig Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertMinimalSigM parentKey lSig = case SrcLoc.unLoc lSig of + Syntax.MinimalSig _ lBooleanFormula -> + let sig = Just . Text.pack . Internal.showSDocShort . Outputable.ppr $ SrcLoc.unLoc lBooleanFormula + in Internal.mkItemM (Annotation.getLocA lSig) parentKey Nothing Doc.Empty Nothing sig ItemKind.MinimalPragma + _ -> pure Nothing + +-- | Convert family declarations. +convertFamilyDeclsM :: + Maybe ItemKey.ItemKey -> + [Syntax.LFamilyDecl Ghc.GhcPs] -> + Internal.ConvertM [Located.Located Item.Item] +convertFamilyDeclsM parentKey = fmap Maybe.catMaybes . traverse (convertFamilyDeclM parentKey) + +-- | Convert a single family declaration. +convertFamilyDeclM :: + Maybe ItemKey.ItemKey -> + Syntax.LFamilyDecl Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertFamilyDeclM parentKey lFamilyDecl = + let famDecl = SrcLoc.unLoc lFamilyDecl + itemKind = ItemKindFrom.itemKindFromFamilyDecl famDecl + in Internal.mkItemM + (Annotation.getLocA lFamilyDecl) + parentKey + (Just $ Names.extractFamilyDeclName famDecl) + Doc.Empty + Nothing + Nothing + itemKind + +-- | Convert type family instance equations. +convertTyFamInstEqnsM :: + Maybe ItemKey.ItemKey -> + [Syntax.LTyFamInstEqn Ghc.GhcPs] -> + Internal.ConvertM [Located.Located Item.Item] +convertTyFamInstEqnsM parentKey = fmap Maybe.catMaybes . traverse (convertTyFamInstEqnM parentKey) + +-- | Convert a single type family instance equation. +convertTyFamInstEqnM :: + Maybe ItemKey.ItemKey -> + Syntax.LTyFamInstEqn Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertTyFamInstEqnM parentKey lEqn = + let eqn = SrcLoc.unLoc lEqn + sig = Just . Text.pack . Internal.showSDocShort $ extractTyFamInstEqnSig eqn + in Internal.mkItemM (Annotation.getLocA lEqn) parentKey Nothing Doc.Empty Nothing sig ItemKind.TypeFamilyInstance + +-- | Pretty-print a type family instance equation. +extractTyFamInstEqnSig :: Syntax.TyFamInstEqn Ghc.GhcPs -> Outputable.SDoc +extractTyFamInstEqnSig eqn = + Outputable.hsep + [ Outputable.ppr (Syntax.feqn_tycon eqn), + Outputable.hsep (pprHsTypeArg <$> Syntax.feqn_pats eqn), + Outputable.text "=", + Outputable.ppr (Syntax.feqn_rhs eqn) + ] + +-- | Pretty-print a type argument, stripping the 'HsArg' wrapper. +pprHsTypeArg :: Syntax.LHsTypeArg Ghc.GhcPs -> Outputable.SDoc +pprHsTypeArg arg = case arg of + Syntax.HsValArg _ ty -> Outputable.ppr ty + Syntax.HsTypeArg _ ki -> Outputable.hcat [Outputable.text "@", Outputable.ppr ki] + Syntax.HsArgPar _ -> Outputable.empty + +-- | Convert data definition constructors and deriving clauses. +convertDataDefnM :: + Maybe ItemKey.ItemKey -> + Maybe Text.Text -> + Syntax.HsDataDefn Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertDataDefnM parentKey parentType dataDefn = do + conItems <- concat <$> (traverse (Constructors.convertConDeclM parentKey parentType) . dataDefnConsList $ Syntax.dd_cons dataDefn) + derivItems <- convertDerivingClausesM parentKey $ Syntax.dd_derivs dataDefn + pure $ conItems <> derivItems + +-- | Convert DataDefnCons to a list. +dataDefnConsList :: Syntax.DataDefnCons a -> [a] +dataDefnConsList ddc = case ddc of + Syntax.NewTypeCon con -> [con] + Syntax.DataTypeCons _ cons -> cons + +-- | Convert deriving clauses. +convertDerivingClausesM :: + Maybe ItemKey.ItemKey -> + Syntax.HsDeriving Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertDerivingClausesM parentKey = fmap concat . traverse (convertDerivingClauseM parentKey) + +-- | Convert a single deriving clause. +convertDerivingClauseM :: + Maybe ItemKey.ItemKey -> + Syntax.LHsDerivingClause Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertDerivingClauseM parentKey lClause = do + let clause = SrcLoc.unLoc lClause + strategy = extractDerivStrategy $ Syntax.deriv_clause_strategy clause + derivClauseTys = SrcLoc.unLoc $ Syntax.deriv_clause_tys clause + convertDerivClauseTysM parentKey strategy derivClauseTys + +-- | Convert deriving clause types. +convertDerivClauseTysM :: + Maybe ItemKey.ItemKey -> + Maybe Text.Text -> + Syntax.DerivClauseTys Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertDerivClauseTysM parentKey strategy dct = case dct of + Syntax.DctSingle _ lSigTy -> Maybe.maybeToList <$> convertDerivedTypeM parentKey strategy lSigTy + Syntax.DctMulti _ lSigTys -> Maybe.catMaybes <$> traverse (convertDerivedTypeM parentKey strategy) lSigTys + +-- | Convert a derived type to an item. +convertDerivedTypeM :: + Maybe ItemKey.ItemKey -> + Maybe Text.Text -> + Syntax.LHsSigType Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertDerivedTypeM parentKey strategy lSigTy = + let (doc, docSince) = extractDerivedTypeDocAndSince lSigTy + in Internal.mkItemM (Annotation.getLocA lSigTy) parentKey (extractDerivedTypeName lSigTy) doc docSince strategy ItemKind.DerivedInstance + +-- | Extract name from a derived type. +extractDerivedTypeName :: Syntax.LHsSigType Ghc.GhcPs -> Maybe ItemName.ItemName +extractDerivedTypeName lSigTy = + let sigTy = SrcLoc.unLoc lSigTy + bodyTy = SrcLoc.unLoc $ Syntax.sig_body sigTy + ty = case bodyTy of + Syntax.HsDocTy _ lTy _ -> SrcLoc.unLoc lTy + _ -> bodyTy + in Just . ItemName.MkItemName . Text.pack . Outputable.showSDocUnsafe . Outputable.ppr $ ty + +-- | Extract documentation and @since from a derived type. +extractDerivedTypeDocAndSince :: Syntax.LHsSigType Ghc.GhcPs -> (Doc.Doc, Maybe Since.Since) +extractDerivedTypeDocAndSince lSigTy = + let sigTy = SrcLoc.unLoc lSigTy + bodyTy = SrcLoc.unLoc $ Syntax.sig_body sigTy + in case bodyTy of + Syntax.HsDocTy _ _ lDoc -> GhcDoc.convertLHsDoc lDoc + _ -> (Doc.Empty, Nothing) + +-- | Extract deriving strategy text from a deriving clause. +extractDerivStrategy :: + Maybe (Syntax.LDerivStrategy Ghc.GhcPs) -> + Maybe Text.Text +extractDerivStrategy = + Just . maybe (Text.pack "derived") (Text.pack . Outputable.showSDocUnsafe . Outputable.ppr . SrcLoc.unLoc) + +-- | Extract named documentation chunks from module declarations. +extractNamedDocChunks :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Map.Map Text.Text Doc.Doc +extractNamedDocChunks lHsModule = + let hsModule = SrcLoc.unLoc lHsModule + decls = Syntax.hsmodDecls hsModule + in Map.fromList $ Maybe.mapMaybe extractNamedDocChunk decls + +-- | Extract a named doc chunk from a declaration, if applicable. +extractNamedDocChunk :: + Syntax.LHsDecl Ghc.GhcPs -> + Maybe (Text.Text, Doc.Doc) +extractNamedDocChunk lDecl = case SrcLoc.unLoc lDecl of + Syntax.DocD _ (Hs.DocCommentNamed name lDoc) -> + Just (Text.pack name, GhcDoc.convertExportDoc lDoc) + _ -> Nothing + +-- | Extract the set of named chunk names referenced in an export list. +extractReferencedChunkNames :: Maybe [Export.Export] -> Set.Set Text.Text +extractReferencedChunkNames Nothing = Set.empty +extractReferencedChunkNames (Just exports) = + Set.fromList [name | Export.DocNamed name <- exports] + +-- | Resolve named documentation chunk references in an export list. +resolveNamedDocExports :: + Map.Map Text.Text Doc.Doc -> + [Export.Export] -> + [Export.Export] +resolveNamedDocExports namedChunks = fmap (resolveNamedDocExport namedChunks) + +-- | Resolve a single named documentation chunk reference. +resolveNamedDocExport :: + Map.Map Text.Text Doc.Doc -> + Export.Export -> + Export.Export +resolveNamedDocExport namedChunks export = case export of + Export.DocNamed name -> + maybe export Export.Doc (Map.lookup name namedChunks) + _ -> export diff --git a/source/library/Scrod/Convert/FromGhc/CompleteParents.hs b/source/library/Scrod/Convert/FromGhc/CompleteParents.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/CompleteParents.hs @@ -0,0 +1,88 @@ +-- | Resolve COMPLETE pragma parent relationships. +-- +-- Associates pattern synonym items with their COMPLETE pragma when +-- those patterns are listed in a @COMPLETE@ pragma in the same module. +-- Unlike other parent associations (where a pragma is parented to its +-- target), here the targets (pattern synonyms) are parented to the +-- pragma, so they are grouped under it in the output. +module Scrod.Convert.FromGhc.CompleteParents where + +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Parser.Annotation as Annotation +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified Language.Haskell.Syntax as Syntax +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Item as Item +import qualified Scrod.Core.ItemKey as ItemKey +import qualified Scrod.Core.ItemKind as ItemKind +import qualified Scrod.Core.ItemName as ItemName +import qualified Scrod.Core.Located as Located +import qualified Scrod.Core.Location as Location + +-- | Extract a mapping from pattern names referenced in COMPLETE pragmas +-- to the source location of the COMPLETE pragma that references them. +extractCompleteNames :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Map.Map ItemName.ItemName Location.Location +extractCompleteNames lHsModule = + let hsModule = SrcLoc.unLoc lHsModule + decls = Syntax.hsmodDecls hsModule + in Map.fromList $ concatMap extractDeclCompleteNames decls + +-- | Extract pattern name to COMPLETE pragma location pairs from a +-- single declaration. +extractDeclCompleteNames :: + Syntax.LHsDecl Ghc.GhcPs -> + [(ItemName.ItemName, Location.Location)] +extractDeclCompleteNames lDecl = case SrcLoc.unLoc lDecl of + Syntax.SigD _ (Syntax.CompleteMatchSig _ names _) -> + case Internal.locationFromSrcSpan (Annotation.getLocA lDecl) of + Nothing -> [] + Just loc -> fmap (\lName -> (Internal.extractIdPName lName, loc)) names + _ -> [] + +-- | Associate pattern synonym items with their COMPLETE pragma parent. +associateCompleteParents :: + Map.Map ItemName.ItemName Location.Location -> + [Located.Located Item.Item] -> + [Located.Located Item.Item] +associateCompleteParents completeNames items = + let locationToKey = buildLocationToKeyMap items + in fmap (resolveCompleteParent completeNames locationToKey) items + +-- | Build a map from COMPLETE pragma item locations to their keys. +buildLocationToKeyMap :: + [Located.Located Item.Item] -> + Map.Map Location.Location ItemKey.ItemKey +buildLocationToKeyMap = + Map.fromList . Maybe.mapMaybe getLocationAndKey + where + getLocationAndKey locItem = + let val = Located.value locItem + in case Item.kind val of + ItemKind.CompletePragma -> + Just (Located.location locItem, Item.key val) + _ -> Nothing + +-- | Set the parentKey on a pattern synonym item if its name appears +-- in a COMPLETE pragma. +resolveCompleteParent :: + Map.Map ItemName.ItemName Location.Location -> + Map.Map Location.Location ItemKey.ItemKey -> + Located.Located Item.Item -> + Located.Located Item.Item +resolveCompleteParent completeNames locationToKey locItem = + let val = Located.value locItem + in case Item.name val of + Nothing -> locItem + Just name -> + if Maybe.isJust (Item.parentKey val) + then locItem + else case Map.lookup name completeNames of + Nothing -> locItem + Just loc -> case Map.lookup loc locationToKey of + Nothing -> locItem + Just parentKey -> + Internal.setParentKey parentKey locItem diff --git a/source/library/Scrod/Convert/FromGhc/Constructors.hs b/source/library/Scrod/Convert/FromGhc/Constructors.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/Constructors.hs @@ -0,0 +1,316 @@ +-- | Convert constructor declarations and record fields. +-- +-- Handles both H98-style and GADT constructor declarations, including +-- signature extraction, documentation stripping, and record field +-- conversion. +module Scrod.Convert.FromGhc.Constructors where + +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Maybe as Maybe +import qualified Data.Text as Text +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Parser.Annotation as Annotation +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified GHC.Utils.Outputable as Outputable +import qualified Language.Haskell.Syntax as Syntax +import qualified Language.Haskell.Syntax.Basic as SyntaxBasic +import qualified Scrod.Convert.FromGhc.Doc as GhcDoc +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Convert.FromGhc.Names as Names +import qualified Scrod.Core.Doc as Doc +import qualified Scrod.Core.Item as Item +import qualified Scrod.Core.ItemKey as ItemKey +import qualified Scrod.Core.ItemKind as ItemKind +import qualified Scrod.Core.ItemName as ItemName +import qualified Scrod.Core.Located as Located +import qualified Scrod.Core.Since as Since + +-- | Convert a constructor declaration. +-- GADT constructors can declare multiple names (e.g. @A, B :: Int -> T@), +-- so this emits one item per constructor name. +convertConDeclM :: + Maybe ItemKey.ItemKey -> + Maybe Text.Text -> + Syntax.LConDecl Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertConDeclM parentKey parentType lConDecl = do + let conDecl = SrcLoc.unLoc lConDecl + (conDoc, conSince) = extractConDeclDocAndSince conDecl + conSig = extractConDeclSignature parentType conDecl + conKind = constructorKind conDecl + conNames = Names.extractConDeclNames conDecl + fmap concat + . traverse (convertOneConNameM (Annotation.getLocA lConDecl) parentKey conDoc conSince conSig conKind conDecl) + $ NonEmpty.toList conNames + +-- | Create items for a single constructor name, plus any record fields. +convertOneConNameM :: + SrcLoc.SrcSpan -> + Maybe ItemKey.ItemKey -> + Doc.Doc -> + Maybe Since.Since -> + Maybe Text.Text -> + ItemKind.ItemKind -> + Syntax.ConDecl Ghc.GhcPs -> + ItemName.ItemName -> + Internal.ConvertM [Located.Located Item.Item] +convertOneConNameM srcSpan parentKey conDoc conSince conSig conKind conDecl conName = do + result <- + Internal.mkItemWithKeyM + srcSpan + parentKey + (Just conName) + conDoc + conSince + conSig + conKind + case result of + Nothing -> pure [] + Just (constructorItem, key) -> do + fieldItems <- extractFieldsFromConDeclM (Just key) conDecl + pure $ [constructorItem] <> fieldItems + +-- | Determine constructor kind. +constructorKind :: Syntax.ConDecl Ghc.GhcPs -> ItemKind.ItemKind +constructorKind conDecl = case conDecl of + Syntax.ConDeclH98 {} -> ItemKind.DataConstructor + Syntax.ConDeclGADT {} -> ItemKind.GADTConstructor + +-- | Extract documentation and @since from a constructor declaration. +extractConDeclDocAndSince :: Syntax.ConDecl Ghc.GhcPs -> (Doc.Doc, Maybe Since.Since) +extractConDeclDocAndSince conDecl = case conDecl of + Syntax.ConDeclH98 {Syntax.con_doc = mDoc} -> + maybe (Doc.Empty, Nothing) GhcDoc.convertLHsDoc mDoc + Syntax.ConDeclGADT {Syntax.con_doc = mDoc} -> + maybe (Doc.Empty, Nothing) GhcDoc.convertLHsDoc mDoc + +-- | Extract signature from a constructor declaration. +-- Returns only the type portion (no constructor name or @::@). +extractConDeclSignature :: Maybe Text.Text -> Syntax.ConDecl Ghc.GhcPs -> Maybe Text.Text +extractConDeclSignature mParentType conDecl = case conDecl of + Syntax.ConDeclH98 + { Syntax.con_forall = hasForall, + Syntax.con_ex_tvs = exTvs, + Syntax.con_mb_cxt = mbCxt, + Syntax.con_args = args + } -> + case mParentType of + Nothing -> + Just . Text.pack . Internal.showSDocShort . Outputable.ppr $ + conDecl + { Syntax.con_doc = Nothing, + Syntax.con_args = stripH98DetailsDocs args + } + Just parentType -> + let forallDoc = + if hasForall && not (null exTvs) + then + Outputable.hcat + [ Outputable.hsep (Outputable.text "forall" : fmap Outputable.ppr exTvs), + Outputable.text "." + ] + else Outputable.empty + cxtDoc = case mbCxt of + Nothing -> Outputable.empty + Just ctx -> case SrcLoc.unLoc ctx of + [] -> Outputable.empty + [c] -> Outputable.hsep [Outputable.ppr c, Outputable.text "=>"] + cs -> + Outputable.hsep + [ Outputable.parens + (Outputable.hsep (Outputable.punctuate (Outputable.text ",") (fmap Outputable.ppr cs))), + Outputable.text "=>" + ] + argsDoc = h98ArgsToDoc (stripH98DetailsDocs args) + bodyDoc = case argsDoc of + Nothing -> Outputable.text (Text.unpack parentType) + Just ad -> Outputable.hsep [ad, Outputable.text "->", Outputable.text (Text.unpack parentType)] + in Just . Text.pack . Internal.showSDocShort $ + Outputable.hsep [forallDoc, cxtDoc, bodyDoc] + c@Syntax.ConDeclGADT {Syntax.con_g_args = gArgs} -> + let full = + Text.pack . Internal.showSDocShort . Outputable.ppr $ + c + { Syntax.con_doc = Nothing, + Syntax.con_g_args = stripGADTDetailsDocs gArgs + } + sep = Text.pack " :: " + (_, rest) = Text.breakOn sep full + in Just $ if Text.null rest then full else Text.drop (Text.length sep) rest + +-- | Convert H98 constructor arguments to an arrow-separated SDoc. +h98ArgsToDoc :: + Syntax.HsConDeclH98Details Ghc.GhcPs -> + Maybe Outputable.SDoc +h98ArgsToDoc details = case details of + Syntax.PrefixCon [] -> Nothing + Syntax.PrefixCon fields -> + Just + . Outputable.hsep + . List.intersperse (Outputable.text "->") + $ fmap (Outputable.ppr . Syntax.cdf_type) fields + Syntax.InfixCon l r -> + Just $ + Outputable.hsep + [ Outputable.ppr (Syntax.cdf_type l), + Outputable.text "->", + Outputable.ppr (Syntax.cdf_type r) + ] + Syntax.RecCon lFields -> + let fields = SrcLoc.unLoc lFields + in Just $ case fields of + [f] -> + Outputable.hsep [Outputable.text "{", Outputable.ppr f, Outputable.text "}"] + (f : fs) -> + Outputable.vcat $ + [Outputable.hsep [Outputable.text "{", Outputable.ppr f]] + <> fmap (\fld -> Outputable.hsep [Outputable.text ",", Outputable.ppr fld]) fs + <> [Outputable.text "}"] + [] -> + Outputable.text "{}" + +-- | Strip documentation from H98 constructor details. +stripH98DetailsDocs :: + Syntax.HsConDeclH98Details Ghc.GhcPs -> + Syntax.HsConDeclH98Details Ghc.GhcPs +stripH98DetailsDocs details = case details of + Syntax.PrefixCon fields -> Syntax.PrefixCon (fmap stripFieldDoc fields) + Syntax.InfixCon l r -> Syntax.InfixCon (stripFieldDoc l) (stripFieldDoc r) + Syntax.RecCon lFields -> Syntax.RecCon (fmap (fmap (fmap stripRecFieldDoc)) lFields) + +-- | Strip documentation from GADT constructor details. +stripGADTDetailsDocs :: + Syntax.HsConDeclGADTDetails Ghc.GhcPs -> + Syntax.HsConDeclGADTDetails Ghc.GhcPs +stripGADTDetailsDocs details = case details of + Syntax.PrefixConGADT x fields -> Syntax.PrefixConGADT x (fmap stripFieldDoc fields) + Syntax.RecConGADT x lFields -> Syntax.RecConGADT x (fmap (fmap (fmap stripRecFieldDoc)) lFields) + +-- | Strip documentation from a constructor field. +stripFieldDoc :: Syntax.HsConDeclField Ghc.GhcPs -> Syntax.HsConDeclField Ghc.GhcPs +stripFieldDoc f@Syntax.CDF {} = f {Syntax.cdf_doc = Nothing} + +-- | Strip documentation from a record field. +stripRecFieldDoc :: + Syntax.HsConDeclRecField Ghc.GhcPs -> + Syntax.HsConDeclRecField Ghc.GhcPs +stripRecFieldDoc f@Syntax.HsConDeclRecField {} = + f {Syntax.cdrf_spec = stripFieldDoc (Syntax.cdrf_spec f)} + +-- | Extract fields from a constructor declaration. +extractFieldsFromConDeclM :: + Maybe ItemKey.ItemKey -> + Syntax.ConDecl Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +extractFieldsFromConDeclM parentKey conDecl = case conDecl of + Syntax.ConDeclH98 {Syntax.con_args = args} -> + extractFieldsFromH98DetailsM parentKey args + Syntax.ConDeclGADT {Syntax.con_g_args = gArgs} -> + extractFieldsFromGADTDetailsM parentKey gArgs + +-- | Extract fields from H98-style constructor details. +extractFieldsFromH98DetailsM :: + Maybe ItemKey.ItemKey -> + Syntax.HsConDeclH98Details Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +extractFieldsFromH98DetailsM parentKey details = case details of + Syntax.PrefixCon fields -> convertPrefixArgsM parentKey fields + Syntax.InfixCon l r -> convertPrefixArgsM parentKey [l, r] + Syntax.RecCon lFields -> convertConDeclFieldsM parentKey (SrcLoc.unLoc lFields) + +-- | Extract fields from GADT-style constructor details. +extractFieldsFromGADTDetailsM :: + Maybe ItemKey.ItemKey -> + Syntax.HsConDeclGADTDetails Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +extractFieldsFromGADTDetailsM parentKey details = case details of + Syntax.PrefixConGADT _ fields -> convertPrefixArgsM parentKey fields + Syntax.RecConGADT _ lFields -> convertConDeclFieldsM parentKey (SrcLoc.unLoc lFields) + +-- | Convert prefix constructor arguments to Argument items. +convertPrefixArgsM :: + Maybe ItemKey.ItemKey -> + [Syntax.HsConDeclField Ghc.GhcPs] -> + Internal.ConvertM [Located.Located Item.Item] +convertPrefixArgsM parentKey = fmap Maybe.catMaybes . traverse (convertPrefixArgM parentKey) + +-- | Convert a single prefix constructor argument to an Argument item. +convertPrefixArgM :: + Maybe ItemKey.ItemKey -> + Syntax.HsConDeclField Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertPrefixArgM parentKey field = + let (argDoc, argSince) = maybe (Doc.Empty, Nothing) GhcDoc.convertLHsDoc $ Syntax.cdf_doc field + sig = + Just . Text.pack . Internal.showSDocShort $ + Outputable.hcat + [ unpackednessDoc (Syntax.cdf_unpack field), + strictnessDoc (Syntax.cdf_bang field), + Outputable.ppr (Syntax.cdf_type field) + ] + in Internal.mkItemM + (Annotation.getLocA (Syntax.cdf_type field)) + parentKey + Nothing + argDoc + argSince + sig + ItemKind.Argument + +-- | Convert a list of record fields. +convertConDeclFieldsM :: + Maybe ItemKey.ItemKey -> + [Syntax.LHsConDeclRecField Ghc.GhcPs] -> + Internal.ConvertM [Located.Located Item.Item] +convertConDeclFieldsM parentKey = fmap concat . traverse (convertConDeclFieldM parentKey) + +-- | Convert a single record field declaration to items (one per field name). +convertConDeclFieldM :: + Maybe ItemKey.ItemKey -> + Syntax.LHsConDeclRecField Ghc.GhcPs -> + Internal.ConvertM [Located.Located Item.Item] +convertConDeclFieldM parentKey lField = + let recField = SrcLoc.unLoc lField + fieldSpec = Syntax.cdrf_spec recField + (doc, docSince) = maybe (Doc.Empty, Nothing) GhcDoc.convertLHsDoc $ Syntax.cdf_doc fieldSpec + sig = + Just . Text.pack . Internal.showSDocShort $ + Outputable.hcat + [ unpackednessDoc (Syntax.cdf_unpack fieldSpec), + strictnessDoc (Syntax.cdf_bang fieldSpec), + Outputable.ppr (Syntax.cdf_type fieldSpec) + ] + in Maybe.catMaybes <$> traverse (convertFieldNameM parentKey doc docSince sig) (Syntax.cdrf_names recField) + +-- | Convert a single field name to an item. +convertFieldNameM :: + Maybe ItemKey.ItemKey -> + Doc.Doc -> + Maybe Since.Since -> + Maybe Text.Text -> + Syntax.LFieldOcc Ghc.GhcPs -> + Internal.ConvertM (Maybe (Located.Located Item.Item)) +convertFieldNameM parentKey doc docSince sig lFieldOcc = + Internal.mkItemM + (Annotation.getLocA lFieldOcc) + parentKey + (Just $ Internal.extractFieldOccName lFieldOcc) + doc + docSince + sig + ItemKind.RecordField + +-- | Convert source unpackedness to its textual representation. +unpackednessDoc :: SyntaxBasic.SrcUnpackedness -> Outputable.SDoc +unpackednessDoc u = case u of + SyntaxBasic.SrcUnpack -> Outputable.text "{-# UNPACK #-} " + SyntaxBasic.SrcNoUnpack -> Outputable.text "{-# NOUNPACK #-} " + SyntaxBasic.NoSrcUnpack -> Outputable.empty + +-- | Convert source strictness to its textual representation. +strictnessDoc :: SyntaxBasic.SrcStrictness -> Outputable.SDoc +strictnessDoc s = case s of + SyntaxBasic.SrcLazy -> Outputable.text "~" + SyntaxBasic.SrcStrict -> Outputable.text "!" + SyntaxBasic.NoSrcStrict -> Outputable.empty diff --git a/source/library/Scrod/Convert/FromGhc/Doc.hs b/source/library/Scrod/Convert/FromGhc/Doc.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/Doc.hs @@ -0,0 +1,122 @@ +-- | Documentation comment association and doc string parsing. +-- +-- Associates @DocCommentNext@ and @DocCommentPrev@ comments with their +-- target declarations, and converts Haddock doc strings into Scrod's +-- 'Doc.Doc' type via the Haddock parser. +module Scrod.Convert.FromGhc.Doc where + +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Documentation.Haddock.Parser as Haddock +import qualified Documentation.Haddock.Types as Haddock +import qualified GHC.Hs as Hs +import qualified GHC.Hs.Doc as HsDoc +import qualified GHC.Hs.DocString as DocString +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified Language.Haskell.Syntax as Syntax +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Convert.FromHaddock as FromHaddock +import qualified Scrod.Core.Doc as Doc +import qualified Scrod.Core.Since as Since + +-- | Convert export documentation (doc only, discards @since). +convertExportDoc :: + SrcLoc.GenLocated l (HsDoc.WithHsDocIdentifiers DocString.HsDocString Ghc.GhcPs) -> + Doc.Doc +convertExportDoc = fst . convertLHsDoc + +-- | Convert a located HsDoc to our 'Doc' type and optional @since. +convertLHsDoc :: + SrcLoc.GenLocated l (HsDoc.WithHsDocIdentifiers DocString.HsDocString Ghc.GhcPs) -> + (Doc.Doc, Maybe Since.Since) +convertLHsDoc lDoc = + let hsDoc = SrcLoc.unLoc lDoc + hsDocString = HsDoc.hsDocString hsDoc + rendered = DocString.renderHsDocString hsDocString + in parseDoc rendered + +-- | Parse documentation string to our 'Doc' type and optional @since. +parseDoc :: String -> (Doc.Doc, Maybe Since.Since) +parseDoc input = + let metaDoc :: Haddock.MetaDoc m Haddock.Identifier + metaDoc = Haddock.parseParas Nothing input + doc = FromHaddock.fromHaddock $ Haddock._doc metaDoc + itemSince = Haddock._metaSince (Haddock._meta metaDoc) >>= Internal.metaSinceToSince + in (doc, itemSince) + +-- | Associate documentation comments with their target declarations. +-- +-- Named doc chunks whose name appears in @referencedChunkNames@ (i.e. they +-- are referenced in the export list) are skipped so they don't create items. +-- Unreferenced named chunks pass through as declarations so they become +-- top-level items. +associateDocs :: + Set.Set Text.Text -> + [Syntax.LHsDecl Ghc.GhcPs] -> + [(Doc.Doc, Maybe Since.Since, Syntax.LHsDecl Ghc.GhcPs)] +associateDocs referencedChunkNames decls = + let withNextDocs = associateNextDocs referencedChunkNames decls + withAllDocs = associatePrevDocs withNextDocs + in withAllDocs + +-- | Associate DocCommentNext with the following declaration. +associateNextDocs :: + Set.Set Text.Text -> + [Syntax.LHsDecl Ghc.GhcPs] -> + [(Doc.Doc, Maybe Since.Since, Syntax.LHsDecl Ghc.GhcPs)] +associateNextDocs referencedChunkNames = associateNextDocsLoop referencedChunkNames Doc.Empty Nothing + +-- | Recursive helper for associating next-doc comments. +associateNextDocsLoop :: + Set.Set Text.Text -> + Doc.Doc -> + Maybe Since.Since -> + [Syntax.LHsDecl Ghc.GhcPs] -> + [(Doc.Doc, Maybe Since.Since, Syntax.LHsDecl Ghc.GhcPs)] +associateNextDocsLoop referencedChunkNames pendingDoc pendingSince decls = case decls of + [] -> [] + lDecl : rest -> case SrcLoc.unLoc lDecl of + Syntax.DocD _ (Hs.DocCommentNext lDoc) -> + let (newDoc, newSince) = convertLHsDoc lDoc + in associateNextDocsLoop referencedChunkNames (Internal.appendDoc pendingDoc newDoc) (Internal.appendSince pendingSince newSince) rest + Syntax.DocD _ (Hs.DocCommentPrev _) -> + (Doc.Empty, Nothing, lDecl) : associateNextDocsLoop referencedChunkNames Doc.Empty Nothing rest + Syntax.DocD _ (Hs.DocCommentNamed name _) + | Set.member (Text.pack name) referencedChunkNames -> + associateNextDocsLoop referencedChunkNames Doc.Empty Nothing rest + | otherwise -> + (Doc.Empty, Nothing, lDecl) : associateNextDocsLoop referencedChunkNames Doc.Empty Nothing rest + _ -> + (pendingDoc, pendingSince, lDecl) : associateNextDocsLoop referencedChunkNames Doc.Empty Nothing rest + +-- | Associate DocCommentPrev with the preceding declaration. +associatePrevDocs :: + [(Doc.Doc, Maybe Since.Since, Syntax.LHsDecl Ghc.GhcPs)] -> + [(Doc.Doc, Maybe Since.Since, Syntax.LHsDecl Ghc.GhcPs)] +associatePrevDocs = reverse . associatePrevDocsLoop . reverse + +-- | Recursive helper for associating prev-doc comments. +associatePrevDocsLoop :: + [(Doc.Doc, Maybe Since.Since, Syntax.LHsDecl Ghc.GhcPs)] -> + [(Doc.Doc, Maybe Since.Since, Syntax.LHsDecl Ghc.GhcPs)] +associatePrevDocsLoop triples = case triples of + [] -> [] + (doc, docSince, lDecl) : rest -> case SrcLoc.unLoc lDecl of + Syntax.DocD _ (Hs.DocCommentPrev lDoc) -> + let (prevDoc, prevSince) = convertLHsDoc lDoc + in applyPrevDoc prevDoc prevSince $ associatePrevDocsLoop rest + _ -> + (doc, docSince, lDecl) : associatePrevDocsLoop rest + +-- | Apply a prev-doc comment to the nearest preceding non-doc declaration. +applyPrevDoc :: + Doc.Doc -> + Maybe Since.Since -> + [(Doc.Doc, Maybe Since.Since, Syntax.LHsDecl Ghc.GhcPs)] -> + [(Doc.Doc, Maybe Since.Since, Syntax.LHsDecl Ghc.GhcPs)] +applyPrevDoc prevDoc prevSince triples = case triples of + [] -> [] + (existingDoc, existingSince, lDecl) : rest -> case SrcLoc.unLoc lDecl of + Syntax.DocD {} -> (existingDoc, existingSince, lDecl) : applyPrevDoc prevDoc prevSince rest + _ -> (Internal.appendDoc existingDoc prevDoc, Internal.appendSince existingSince prevSince, lDecl) : rest diff --git a/source/library/Scrod/Convert/FromGhc/ExportOrdering.hs b/source/library/Scrod/Convert/FromGhc/ExportOrdering.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/ExportOrdering.hs @@ -0,0 +1,310 @@ +-- | Reorder items according to the module's export list. +-- +-- When an export list is present, items are reordered so that exported +-- items come first (in export-list order), followed by implicit items, +-- then unexported items. Export-list-only entries (section headings, +-- inline docs, re-exports with no matching declaration) become +-- synthetic items. +-- +-- When no export list is present, items are returned unchanged. +module Scrod.Convert.FromGhc.ExportOrdering (reorderByExports) where + +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Numeric.Natural as Natural +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Category as Category +import qualified Scrod.Core.Column as Column +import qualified Scrod.Core.Doc as Doc +import qualified Scrod.Core.Export as Export +import qualified Scrod.Core.ExportIdentifier as ExportIdentifier +import qualified Scrod.Core.ExportName as ExportName +import qualified Scrod.Core.ExportNameKind as ExportNameKind +import qualified Scrod.Core.Item as Item +import qualified Scrod.Core.ItemKey as ItemKey +import qualified Scrod.Core.ItemKind as ItemKind +import qualified Scrod.Core.ItemName as ItemName +import qualified Scrod.Core.Line as Line +import qualified Scrod.Core.Located as Located +import qualified Scrod.Core.Location as Location +import qualified Scrod.Core.Section as Section +import qualified Scrod.Core.Visibility as Visibility +import qualified Scrod.Core.Warning as Warning + +-- | Reorder items according to the module's export list. +-- +-- When @Nothing@, return items unchanged. When @Just exports@, +-- reorder items to match the export list and create synthetic items +-- for export-list-only entries (sections, docs, re-exports). +reorderByExports :: + Maybe [Export.Export] -> + [Located.Located Item.Item] -> + [Located.Located Item.Item] +reorderByExports mExports items = case mExports of + Nothing -> items + Just [] -> items + Just exports -> + let nameMap = topLevelNameMap items + nextKey = nextItemKey items + (exportedItems, usedKeys, _) = walkExports exports nameMap Set.empty nextKey + implicitItems = collectImplicit usedKeys items + usedKeys2 = foldr (Set.insert . Item.key . Located.value) usedKeys implicitItems + unexportedItems = collectUnexported usedKeys2 items + usedKeys3 = foldr (Set.insert . Item.key . Located.value) usedKeys2 unexportedItems + remainingItems = collectRemaining usedKeys3 items + usedKeys4 = foldr (Set.insert . Item.key . Located.value) usedKeys3 remainingItems + childItems = + filter + ( \li -> + let v = Located.value li + in Maybe.isJust (Item.parentKey v) + && not (Set.member (Item.key v) usedKeys4) + ) + items + in exportedItems <> implicitItems <> unexportedItems <> remainingItems <> childItems + +-- | Build a map from top-level item names to located items. +-- For items whose names contain type variables (indicated by a space), +-- both the full name and the base name (first word) are indexed. +-- Pattern synonyms are included even when they have a parent key +-- (e.g. from a COMPLETE pragma), since they are still independently +-- exportable. +topLevelNameMap :: [Located.Located Item.Item] -> Map.Map Text.Text (Located.Located Item.Item) +topLevelNameMap items = + Map.fromList + [ entry + | li <- items, + isTopLevelOrExportable (Located.value li), + Just n <- [Item.name (Located.value li)], + let full = ItemName.unwrap n, + entry <- (full, li) : [(base, li) | Just base <- [Internal.baseItemName full]] + ] + where + isTopLevelOrExportable val = + Maybe.isNothing (Item.parentKey val) + || Item.kind val == ItemKind.PatternSynonym + +-- | Compute the next available item key (one past the maximum). +nextItemKey :: [Located.Located Item.Item] -> Natural.Natural +nextItemKey items = case items of + [] -> 0 + _ -> 1 + maximum (fmap (ItemKey.unwrap . Item.key . Located.value) items) + +-- | Walk the export list, emitting items in export order. The @used@ +-- set tracks item keys already emitted to avoid duplicates. Returns +-- the emitted items, the final used set, and the next available +-- synthetic key. +walkExports :: + [Export.Export] -> + Map.Map Text.Text (Located.Located Item.Item) -> + Set.Set ItemKey.ItemKey -> + Natural.Natural -> + ([Located.Located Item.Item], Set.Set ItemKey.ItemKey, Natural.Natural) +walkExports exports nameMap used nextKey = case exports of + [] -> ([], used, nextKey) + e : es -> case e of + Export.Identifier ident -> + let name = ExportName.name (ExportIdentifier.name ident) + in case Map.lookup name nameMap of + Just li + | not (Set.member (Item.key (Located.value li)) used) -> + let meta = exportMetadataItems ident nextKey + nextKey2 = nextKey + fromIntegral (length meta) + used2 = Set.insert (Item.key (Located.value li)) used + (rest, used3, nextKey3) = walkExports es nameMap used2 nextKey2 + in (li : meta <> rest, used3, nextKey3) + Just _ -> + -- Duplicate export: emit only metadata, skip the item. + let meta = exportMetadataItems ident nextKey + nextKey2 = nextKey + fromIntegral (length meta) + (rest, used2, nextKey3) = walkExports es nameMap used nextKey2 + in (meta <> rest, used2, nextKey3) + Nothing -> + let (unresolvedItem, nextKey2) = mkUnresolvedExport ident nextKey + meta = exportMetadataItems ident nextKey2 + nextKey3 = nextKey2 + fromIntegral (length meta) + (rest, used2, nextKey4) = walkExports es nameMap used nextKey3 + in (unresolvedItem : meta <> rest, used2, nextKey4) + Export.Group section -> + let (sectionItem, nextKey2) = mkSectionItem section nextKey + (rest, used2, nextKey3) = walkExports es nameMap used nextKey2 + in (sectionItem : rest, used2, nextKey3) + Export.Doc doc -> + let (docItem, nextKey2) = mkDocItem doc nextKey + (rest, used2, nextKey3) = walkExports es nameMap used nextKey2 + in (docItem : rest, used2, nextKey3) + Export.DocNamed name -> + let (docItem, nextKey2) = mkDocNamedItem name nextKey + (rest, used2, nextKey3) = walkExports es nameMap used nextKey2 + in (docItem : rest, used2, nextKey3) + +-- | Collect implicit items that haven't been used yet. +collectImplicit :: + Set.Set ItemKey.ItemKey -> + [Located.Located Item.Item] -> + [Located.Located Item.Item] +collectImplicit usedKeys = + filter + ( \li -> + let item = Located.value li + in Maybe.isNothing (Item.parentKey item) + && Item.visibility item == Visibility.Implicit + && not (Set.member (Item.key item) usedKeys) + ) + +-- | Collect unexported top-level items that haven't been used. +collectUnexported :: + Set.Set ItemKey.ItemKey -> + [Located.Located Item.Item] -> + [Located.Located Item.Item] +collectUnexported usedKeys = + filter + ( \li -> + let item = Located.value li + in Maybe.isNothing (Item.parentKey item) + && Item.visibility item == Visibility.Unexported + && not (Set.member (Item.key item) usedKeys) + ) + +-- | Catch-all for any top-level items not captured by the above +-- collectors. This cannot happen in practice today, but guards against +-- future drift between Visibility and ExportOrdering. +collectRemaining :: + Set.Set ItemKey.ItemKey -> + [Located.Located Item.Item] -> + [Located.Located Item.Item] +collectRemaining usedKeys = + filter + ( \li -> + let item = Located.value li + in Maybe.isNothing (Item.parentKey item) + && not (Set.member (Item.key item) usedKeys) + ) + +-- | Create synthetic items for export-level doc and/or warning metadata +-- on an identifier. +exportMetadataItems :: ExportIdentifier.ExportIdentifier -> Natural.Natural -> [Located.Located Item.Item] +exportMetadataItems ident startKey = + let warningItems = case ExportIdentifier.warning ident of + Nothing -> [] + Just w -> + [ mkSyntheticItem + startKey + Nothing + (warningToDoc w) + Nothing + ItemKind.DocumentationChunk + ] + warningCount :: Natural.Natural + warningCount = fromIntegral (length warningItems) + docItems = case ExportIdentifier.doc ident of + Nothing -> [] + Just d -> + [ mkSyntheticItem + (startKey + warningCount) + Nothing + d + Nothing + ItemKind.DocumentationChunk + ] + in warningItems <> docItems + +-- | Convert a warning to a doc paragraph for inline display. +warningToDoc :: Warning.Warning -> Doc.Doc +warningToDoc w = + Doc.Paragraph + . Doc.Bold + . Doc.Append + $ [ Doc.String (Text.pack "Warning"), + Doc.String (Text.pack " ("), + Doc.String (Category.unwrap (Warning.category w)), + Doc.String (Text.pack "): "), + Doc.String (Warning.value w) + ] + +-- | Create an item for an unresolved export (no matching declaration). +mkUnresolvedExport :: + ExportIdentifier.ExportIdentifier -> + Natural.Natural -> + (Located.Located Item.Item, Natural.Natural) +mkUnresolvedExport ident nextKey = + let exportName = ExportIdentifier.name ident + name = ExportName.name exportName + namespaceSig = case ExportName.kind exportName of + Just ExportNameKind.Module -> Just (Text.pack "module") + Just ExportNameKind.Pattern -> Just (Text.pack "pattern") + Just ExportNameKind.Type -> Just (Text.pack "type") + Nothing -> Nothing + in ( mkSyntheticItem + nextKey + (Just (ItemName.MkItemName name)) + Doc.Empty + namespaceSig + ItemKind.UnresolvedExport, + nextKey + 1 + ) + +-- | Create a section heading item from an export group. +mkSectionItem :: + Section.Section -> + Natural.Natural -> + (Located.Located Item.Item, Natural.Natural) +mkSectionItem section nextKey = + let hdr = Section.header section + doc = Doc.Header hdr + in ( mkSyntheticItem nextKey Nothing doc Nothing ItemKind.DocumentationChunk, + nextKey + 1 + ) + +-- | Create a documentation item from an inline export doc. +mkDocItem :: + Doc.Doc -> + Natural.Natural -> + (Located.Located Item.Item, Natural.Natural) +mkDocItem doc nextKey = + ( mkSyntheticItem nextKey Nothing doc Nothing ItemKind.DocumentationChunk, + nextKey + 1 + ) + +-- | Create a documentation item from an unresolved named doc reference. +mkDocNamedItem :: + Text.Text -> + Natural.Natural -> + (Located.Located Item.Item, Natural.Natural) +mkDocNamedItem name nextKey = + ( mkSyntheticItem nextKey chunkName Doc.Empty Nothing ItemKind.DocumentationChunk, + nextKey + 1 + ) + where + chunkName = Just . ItemName.MkItemName $ Text.pack "$" <> name + +-- | Create a synthetic item with a given key, not tied to any source +-- location. +mkSyntheticItem :: + Natural.Natural -> + Maybe ItemName.ItemName -> + Doc.Doc -> + Maybe Text.Text -> + ItemKind.ItemKind -> + Located.Located Item.Item +mkSyntheticItem key itemName doc sig kind = + Located.MkLocated + { Located.location = + Location.MkLocation + { Location.line = Line.MkLine 0, + Location.column = Column.MkColumn 0 + }, + Located.value = + Item.MkItem + { Item.key = ItemKey.MkItemKey key, + Item.kind = kind, + Item.parentKey = Nothing, + Item.name = itemName, + Item.documentation = doc, + Item.since = Nothing, + Item.signature = sig, + Item.visibility = Visibility.Exported + } + } diff --git a/source/library/Scrod/Convert/FromGhc/Exports.hs b/source/library/Scrod/Convert/FromGhc/Exports.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/Exports.hs @@ -0,0 +1,151 @@ +-- | Convert the GHC module export list into Scrod's 'Export.Export' type. +-- +-- Handles all 'IE' (import\/export) variants: identifiers (with optional +-- subordinates and wildcards), module re-exports, section groups, +-- documentation comments, and named documentation chunks. +module Scrod.Convert.FromGhc.Exports where + +import qualified Data.Text as Text +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Hs.ImpExp as ImpExp +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified GHC.Unit.Module.Warnings as Warnings +import qualified Language.Haskell.Syntax as Syntax +import qualified Scrod.Convert.FromGhc.Doc as GhcDoc +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Export as Export +import qualified Scrod.Core.ExportIdentifier as ExportIdentifier +import qualified Scrod.Core.ExportName as ExportName +import qualified Scrod.Core.ExportNameKind as ExportNameKind +import qualified Scrod.Core.Header as Header +import qualified Scrod.Core.Level as Level +import qualified Scrod.Core.ModuleName as ModuleName +import qualified Scrod.Core.Section as Section +import qualified Scrod.Core.Subordinates as Subordinates +import qualified Scrod.Core.Warning as Warning + +-- | Extract module export list. +extractModuleExports :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Maybe [Export.Export] +extractModuleExports lHsModule = do + let hsModule = SrcLoc.unLoc lHsModule + lExports <- Syntax.hsmodExports hsModule + let exports = SrcLoc.unLoc lExports + Just $ fmap convertIE exports + +-- | Convert an IE (import/export) entry to our 'Export' type. +convertIE :: + SrcLoc.GenLocated l (Syntax.IE Ghc.GhcPs) -> + Export.Export +convertIE lIe = case SrcLoc.unLoc lIe of + Syntax.IEVar mLWarning lName mDoc -> + Export.Identifier + ExportIdentifier.MkExportIdentifier + { ExportIdentifier.name = convertWrappedName lName, + ExportIdentifier.subordinates = Nothing, + ExportIdentifier.warning = convertExportWarning mLWarning, + ExportIdentifier.doc = GhcDoc.convertExportDoc <$> mDoc + } + Syntax.IEThingAbs mLWarning lName mDoc -> + Export.Identifier + ExportIdentifier.MkExportIdentifier + { ExportIdentifier.name = convertWrappedName lName, + ExportIdentifier.subordinates = Nothing, + ExportIdentifier.warning = convertExportWarning mLWarning, + ExportIdentifier.doc = GhcDoc.convertExportDoc <$> mDoc + } + Syntax.IEThingAll (mLWarning, _) lName mDoc -> + Export.Identifier + ExportIdentifier.MkExportIdentifier + { ExportIdentifier.name = convertWrappedName lName, + ExportIdentifier.subordinates = + Just + Subordinates.MkSubordinates + { Subordinates.wildcard = True, + Subordinates.explicit = [] + }, + ExportIdentifier.warning = convertExportWarning mLWarning, + ExportIdentifier.doc = GhcDoc.convertExportDoc <$> mDoc + } + Syntax.IEThingWith (mLWarning, _) lName wildcard children mDoc -> + Export.Identifier + ExportIdentifier.MkExportIdentifier + { ExportIdentifier.name = convertWrappedName lName, + ExportIdentifier.subordinates = + Just + Subordinates.MkSubordinates + { Subordinates.wildcard = hasWildcard wildcard, + Subordinates.explicit = fmap convertWrappedName children + }, + ExportIdentifier.warning = convertExportWarning mLWarning, + ExportIdentifier.doc = GhcDoc.convertExportDoc <$> mDoc + } + Syntax.IEModuleContents (mLWarning, _) lModName -> + Export.Identifier + ExportIdentifier.MkExportIdentifier + { ExportIdentifier.name = + ExportName.MkExportName + { ExportName.kind = Just ExportNameKind.Module, + ExportName.name = ModuleName.unwrap . Internal.moduleNameFromGhc $ SrcLoc.unLoc lModName + }, + ExportIdentifier.subordinates = Nothing, + ExportIdentifier.warning = convertExportWarning mLWarning, + ExportIdentifier.doc = Nothing + } + Syntax.IEGroup _ level lDoc -> + Export.Group + Section.MkSection + { Section.header = + Header.MkHeader + { Header.level = Level.fromInt level, + Header.title = GhcDoc.convertExportDoc lDoc + } + } + Syntax.IEDoc _ lDoc -> + Export.Doc $ GhcDoc.convertExportDoc lDoc + Syntax.IEDocNamed _ name -> + Export.DocNamed $ Text.pack name + +-- | Check if an IE wildcard is present. +hasWildcard :: ImpExp.IEWildcard -> Bool +hasWildcard wildcard = case wildcard of + ImpExp.NoIEWildcard -> False + ImpExp.IEWildcard _ -> True + +-- | Convert export warning. +convertExportWarning :: + Maybe (SrcLoc.GenLocated l (Warnings.WarningTxt Ghc.GhcPs)) -> + Maybe Warning.Warning +convertExportWarning = fmap (Internal.warningTxtToWarning . SrcLoc.unLoc) + +-- | Convert a wrapped name to our 'ExportName' type. +convertWrappedName :: + SrcLoc.GenLocated l (ImpExp.IEWrappedName Ghc.GhcPs) -> + ExportName.ExportName +convertWrappedName lWrapped = case SrcLoc.unLoc lWrapped of + ImpExp.IEName _ lId -> + ExportName.MkExportName + { ExportName.kind = Nothing, + ExportName.name = Internal.extractRdrName lId + } + ImpExp.IEPattern _ lId -> + ExportName.MkExportName + { ExportName.kind = Just ExportNameKind.Pattern, + ExportName.name = Internal.extractRdrName lId + } + ImpExp.IEType _ lId -> + ExportName.MkExportName + { ExportName.kind = Just ExportNameKind.Type, + ExportName.name = Internal.extractRdrName lId + } + ImpExp.IEDefault _ lId -> + ExportName.MkExportName + { ExportName.kind = Nothing, + ExportName.name = Internal.extractRdrName lId + } + ImpExp.IEData _ lId -> + ExportName.MkExportName + { ExportName.kind = Nothing, + ExportName.name = Internal.extractRdrName lId + } diff --git a/source/library/Scrod/Convert/FromGhc/FamilyInstanceParents.hs b/source/library/Scrod/Convert/FromGhc/FamilyInstanceParents.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/FamilyInstanceParents.hs @@ -0,0 +1,94 @@ +-- | Resolve family instance parent relationships. +-- +-- Associates type family instance and data family instance items with +-- their corresponding family declarations when both are defined in the +-- same module. +module Scrod.Convert.FromGhc.FamilyInstanceParents where + +import qualified Data.Map as Map +import GHC.Hs () +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Parser.Annotation as Annotation +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified Language.Haskell.Syntax as Syntax +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Item as Item +import qualified Scrod.Core.ItemKey as ItemKey +import qualified Scrod.Core.ItemKind as ItemKind +import qualified Scrod.Core.ItemName as ItemName +import qualified Scrod.Core.Located as Located +import qualified Scrod.Core.Location as Location + +-- | Extract a map from source locations of family instance declarations +-- to the family name they reference. +extractFamilyInstanceNames :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Map.Map Location.Location ItemName.ItemName +extractFamilyInstanceNames lHsModule = + let hsModule = SrcLoc.unLoc lHsModule + decls = Syntax.hsmodDecls hsModule + in Map.fromList $ concatMap extractDeclFamilyInstanceName decls + +-- | Extract family instance name from a single declaration. +extractDeclFamilyInstanceName :: + Syntax.LHsDecl Ghc.GhcPs -> + [(Location.Location, ItemName.ItemName)] +extractDeclFamilyInstanceName lDecl = case SrcLoc.unLoc lDecl of + Syntax.InstD _ (Syntax.TyFamInstD _ tyFamInst) -> + let eqn = Syntax.tfid_eqn tyFamInst + familyName = Internal.extractIdPName $ Syntax.feqn_tycon eqn + in foldMap (\loc -> [(loc, familyName)]) $ + Internal.locationFromSrcSpan (Annotation.getLocA lDecl) + Syntax.InstD _ (Syntax.DataFamInstD _ dataFamInst) -> + let eqn = Syntax.dfid_eqn dataFamInst + familyName = Internal.extractIdPName $ Syntax.feqn_tycon eqn + in foldMap (\loc -> [(loc, familyName)]) $ + Internal.locationFromSrcSpan (Annotation.getLocA lDecl) + _ -> [] + +-- | Associate family instance items with their family declarations. +associateFamilyInstanceParents :: + Map.Map Location.Location ItemName.ItemName -> + [Located.Located Item.Item] -> + [Located.Located Item.Item] +associateFamilyInstanceParents familyInstanceNames items = + let familyNameToKey = buildFamilyNameToKeyMap items + in fmap (resolveFamilyInstanceParent familyInstanceNames familyNameToKey) items + +-- | Build a map from family names to their keys. +buildFamilyNameToKeyMap :: + [Located.Located Item.Item] -> + Map.Map ItemName.ItemName ItemKey.ItemKey +buildFamilyNameToKeyMap = + Map.fromList . concatMap getFamilyNameAndKey + where + getFamilyNameAndKey locItem = + let val = Located.value locItem + in case Item.name val of + Nothing -> [] + Just name -> + if isFamilyKind (Item.kind val) + then [(name, Item.key val)] + else [] + +-- | Check if an item kind represents a family declaration. +isFamilyKind :: ItemKind.ItemKind -> Bool +isFamilyKind k = case k of + ItemKind.OpenTypeFamily -> True + ItemKind.DataFamily -> True + _ -> False + +-- | Set the parentKey on a family instance item by looking up the family name. +resolveFamilyInstanceParent :: + Map.Map Location.Location ItemName.ItemName -> + Map.Map ItemName.ItemName ItemKey.ItemKey -> + Located.Located Item.Item -> + Located.Located Item.Item +resolveFamilyInstanceParent familyInstanceNames familyNameToKey locItem = + case Map.lookup (Located.location locItem) familyInstanceNames of + Nothing -> locItem + Just familyName -> + case Map.lookup familyName familyNameToKey of + Nothing -> locItem + Just parentKey -> + Internal.setParentKey parentKey locItem diff --git a/source/library/Scrod/Convert/FromGhc/FixityParents.hs b/source/library/Scrod/Convert/FromGhc/FixityParents.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/FixityParents.hs @@ -0,0 +1,30 @@ +-- | Resolve fixity parent relationships. +-- +-- Associates fixity signature items with their target declarations when +-- those declarations are defined in the same module. Uses the shared +-- parent association logic from 'Scrod.Convert.FromGhc.ParentAssociation'. +module Scrod.Convert.FromGhc.FixityParents where + +import qualified Data.Set as Set +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Parser.Annotation as Annotation +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified Language.Haskell.Syntax as Syntax +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Location as Location + +-- | Extract the set of source locations that correspond to names inside +-- fixity signature declarations. +extractFixityLocations :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Set.Set Location.Location +extractFixityLocations = Internal.extractDeclLocations extractDeclFixityLocations + +-- | Extract fixity name locations from a single declaration. +extractDeclFixityLocations :: + Syntax.LHsDecl Ghc.GhcPs -> + [Location.Location] +extractDeclFixityLocations lDecl = case SrcLoc.unLoc lDecl of + Syntax.SigD _ (Syntax.FixSig _ (Syntax.FixitySig _ names _)) -> + concatMap (foldMap pure . Internal.locationFromSrcSpan . Annotation.getLocA) names + _ -> [] diff --git a/source/library/Scrod/Convert/FromGhc/InlineParents.hs b/source/library/Scrod/Convert/FromGhc/InlineParents.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/InlineParents.hs @@ -0,0 +1,30 @@ +-- | Resolve inline pragma parent relationships. +-- +-- Associates inline signature items with their target declarations when +-- those declarations are defined in the same module. Uses the shared +-- parent association logic from 'Scrod.Convert.FromGhc.ParentAssociation'. +module Scrod.Convert.FromGhc.InlineParents where + +import qualified Data.Set as Set +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Parser.Annotation as Annotation +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified Language.Haskell.Syntax as Syntax +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Location as Location + +-- | Extract the set of source locations that correspond to names inside +-- inline signature declarations. +extractInlineLocations :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Set.Set Location.Location +extractInlineLocations = Internal.extractDeclLocations extractDeclInlineLocations + +-- | Extract inline name locations from a single declaration. +extractDeclInlineLocations :: + Syntax.LHsDecl Ghc.GhcPs -> + [Location.Location] +extractDeclInlineLocations lDecl = case SrcLoc.unLoc lDecl of + Syntax.SigD _ (Syntax.InlineSig _ lName _) -> + foldMap pure $ Internal.locationFromSrcSpan (Annotation.getLocA lName) + _ -> [] diff --git a/source/library/Scrod/Convert/FromGhc/InstanceParents.hs b/source/library/Scrod/Convert/FromGhc/InstanceParents.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/InstanceParents.hs @@ -0,0 +1,192 @@ +-- | Resolve instance parent relationships. +-- +-- Associates class instances and standalone deriving declarations with +-- their parent types or classes when those are defined in the same +-- module. For @instance C T@, if @T@ is defined locally, the instance +-- is parented under @T@. Otherwise, if @C@ is defined locally, the +-- instance is parented under @C@. +module Scrod.Convert.FromGhc.InstanceParents where + +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import GHC.Hs () +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Parser.Annotation as Annotation +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified Language.Haskell.Syntax as Syntax +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Item as Item +import qualified Scrod.Core.ItemKey as ItemKey +import qualified Scrod.Core.ItemKind as ItemKind +import qualified Scrod.Core.ItemName as ItemName +import qualified Scrod.Core.Located as Located +import qualified Scrod.Core.Location as Location + +-- | Extract the head type name for each instance or standalone deriving +-- declaration, keyed by source location. +extractInstanceHeadTypeNames :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Map.Map Location.Location ItemName.ItemName +extractInstanceHeadTypeNames lHsModule = + let hsModule = SrcLoc.unLoc lHsModule + decls = Syntax.hsmodDecls hsModule + in Map.fromList $ Maybe.mapMaybe extractDeclInstanceHeadType decls + +-- | Extract the class name for each instance or standalone deriving +-- declaration, keyed by source location. +extractInstanceClassNames :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Map.Map Location.Location ItemName.ItemName +extractInstanceClassNames lHsModule = + let hsModule = SrcLoc.unLoc lHsModule + decls = Syntax.hsmodDecls hsModule + in Map.fromList $ Maybe.mapMaybe extractDeclInstanceClass decls + +-- | Extract the class name from a single declaration, if it is an +-- instance or standalone deriving declaration. +extractDeclInstanceClass :: + Syntax.LHsDecl Ghc.GhcPs -> + Maybe (Location.Location, ItemName.ItemName) +extractDeclInstanceClass lDecl = case SrcLoc.unLoc lDecl of + Syntax.InstD _ inst -> case inst of + Syntax.ClsInstD _ clsInst -> do + location <- Internal.locationFromSrcSpan (Annotation.getLocA lDecl) + className <- extractClassName . Syntax.sig_body . SrcLoc.unLoc $ Syntax.cid_poly_ty clsInst + Just (location, className) + _ -> Nothing + Syntax.DerivD _ derivDecl -> do + location <- Internal.locationFromSrcSpan (Annotation.getLocA lDecl) + className <- extractClassName . Syntax.sig_body . SrcLoc.unLoc . Syntax.hswc_body $ Syntax.deriv_type derivDecl + Just (location, className) + _ -> Nothing + +-- | Extract the head type name from a single declaration, if it is an +-- instance or standalone deriving declaration. +extractDeclInstanceHeadType :: + Syntax.LHsDecl Ghc.GhcPs -> + Maybe (Location.Location, ItemName.ItemName) +extractDeclInstanceHeadType lDecl = case SrcLoc.unLoc lDecl of + Syntax.InstD _ inst -> case inst of + Syntax.ClsInstD _ clsInst -> do + location <- Internal.locationFromSrcSpan (Annotation.getLocA lDecl) + headType <- extractHeadTypeName . Syntax.sig_body . SrcLoc.unLoc $ Syntax.cid_poly_ty clsInst + Just (location, headType) + _ -> Nothing + Syntax.DerivD _ derivDecl -> do + location <- Internal.locationFromSrcSpan (Annotation.getLocA lDecl) + headType <- extractHeadTypeName . Syntax.sig_body . SrcLoc.unLoc . Syntax.hswc_body $ Syntax.deriv_type derivDecl + Just (location, headType) + _ -> Nothing + +-- | Extract the head type constructor name from the last argument of a +-- type application. For @C T@ this returns @T@; for @C (Maybe a)@ this +-- returns @Maybe@. +extractHeadTypeName :: Syntax.LHsType Ghc.GhcPs -> Maybe ItemName.ItemName +extractHeadTypeName lTy = case SrcLoc.unLoc lTy of + Syntax.HsAppTy _ _ arg -> extractOutermostTyCon arg + Syntax.HsQualTy _ _ body -> extractHeadTypeName body + Syntax.HsForAllTy _ _ body -> extractHeadTypeName body + Syntax.HsParTy _ inner -> extractHeadTypeName inner + _ -> Nothing + +-- | Extract the class name from an instance head. For @C T@ this +-- returns @C@; for @Functor F@ this returns @Functor@. For nullary +-- classes (e.g., @instance C@) this returns @C@. +extractClassName :: Syntax.LHsType Ghc.GhcPs -> Maybe ItemName.ItemName +extractClassName lTy = case SrcLoc.unLoc lTy of + Syntax.HsAppTy _ fun _ -> extractOutermostTyCon fun + Syntax.HsAppKindTy _ fun _ -> extractOutermostTyCon fun + Syntax.HsTyVar {} -> extractOutermostTyCon lTy + Syntax.HsQualTy _ _ body -> extractClassName body + Syntax.HsForAllTy _ _ body -> extractClassName body + Syntax.HsParTy _ inner -> extractClassName inner + _ -> Nothing + +-- | Extract the outermost type constructor name from a type. For @T@ +-- this returns @T@; for @Maybe a@ this returns @Maybe@. +extractOutermostTyCon :: Syntax.LHsType Ghc.GhcPs -> Maybe ItemName.ItemName +extractOutermostTyCon lTy = case SrcLoc.unLoc lTy of + Syntax.HsTyVar _ _ lName -> Just . ItemName.MkItemName $ Internal.extractRdrName lName + Syntax.HsAppTy _ fun _ -> extractOutermostTyCon fun + Syntax.HsAppKindTy _ fun _ -> extractOutermostTyCon fun + Syntax.HsParTy _ inner -> extractOutermostTyCon inner + _ -> Nothing + +-- | Associate instances and standalone deriving declarations with their +-- parent types or classes when those are defined in the same module. +associateInstanceParents :: + Map.Map Location.Location ItemName.ItemName -> + Map.Map Location.Location ItemName.ItemName -> + [Located.Located Item.Item] -> + [Located.Located Item.Item] +associateInstanceParents headTypeNames classNames items = + let typeNameToKey = buildTypeNameToKeyMap items + in fmap (resolveInstanceParent headTypeNames classNames typeNameToKey) items + +-- | Build a map from type/class names to their item keys. +-- For items whose names contain type variables (indicated by a space), +-- both the full name and the base name (first word) are indexed. +buildTypeNameToKeyMap :: + [Located.Located Item.Item] -> + Map.Map ItemName.ItemName ItemKey.ItemKey +buildTypeNameToKeyMap = + Map.fromList . concatMap getTypeNameAndKey + where + getTypeNameAndKey locItem = + let val = Located.value locItem + in case Item.parentKey val of + Just _ -> [] + Nothing -> + if isTypeOrClassKind (Item.kind val) + then case Item.name val of + Nothing -> [] + Just n -> + let k = Item.key val + full = ItemName.unwrap n + in (n, k) : [(ItemName.MkItemName base, k) | Just base <- [Internal.baseItemName full]] + else [] + +-- | Check if an item kind represents a type or class definition. +isTypeOrClassKind :: ItemKind.ItemKind -> Bool +isTypeOrClassKind kind = case kind of + ItemKind.DataType -> True + ItemKind.Newtype -> True + ItemKind.TypeData -> True + ItemKind.TypeSynonym -> True + ItemKind.Class -> True + _ -> False + +-- | Try to resolve an instance's parent from the head type maps. +-- First tries the head type name (e.g., @T@ from @instance C T@), +-- then falls back to the class name (e.g., @C@). +resolveInstanceParent :: + Map.Map Location.Location ItemName.ItemName -> + Map.Map Location.Location ItemName.ItemName -> + Map.Map ItemName.ItemName ItemKey.ItemKey -> + Located.Located Item.Item -> + Located.Located Item.Item +resolveInstanceParent headTypeNames classNames typeNameToKey locItem = + let val = Located.value locItem + in case Item.parentKey val of + Just _ -> locItem + Nothing -> + if Item.kind val == ItemKind.ClassInstance || Item.kind val == ItemKind.StandaloneDeriving + then case lookupParentKey (Located.location locItem) headTypeNames typeNameToKey of + Just parentKey -> + Internal.setParentKey parentKey locItem + Nothing -> case lookupParentKey (Located.location locItem) classNames typeNameToKey of + Just parentKey -> + Internal.setParentKey parentKey locItem + Nothing -> locItem + else locItem + +-- | Look up a parent key by first resolving a location to a name, +-- then resolving that name to a key. +lookupParentKey :: + Location.Location -> + Map.Map Location.Location ItemName.ItemName -> + Map.Map ItemName.ItemName ItemKey.ItemKey -> + Maybe ItemKey.ItemKey +lookupParentKey location nameMap keyMap = do + name <- Map.lookup location nameMap + Map.lookup name keyMap diff --git a/source/library/Scrod/Convert/FromGhc/Internal.hs b/source/library/Scrod/Convert/FromGhc/Internal.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/Internal.hs @@ -0,0 +1,243 @@ +-- | Shared types and utilities for the GHC-to-Scrod conversion. +-- +-- Provides the 'ConvertM' state monad, item creation primitives, +-- location conversion, name extraction, warning conversion, and +-- document append. Every other @Scrod.Convert.FromGhc.*@ submodule +-- imports this module. +module Scrod.Convert.FromGhc.Internal where + +import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Documentation.Haddock.Types as Haddock +import qualified GHC.Data.FastString as FastString +import qualified GHC.Hs.Doc as HsDoc +import qualified GHC.Hs.Extension as Ghc +import GHC.Hs.Type () +import qualified GHC.Types.Name.Reader as Reader +import qualified GHC.Types.SourceText as SourceText +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified GHC.Unit.Module.Warnings as Warnings +import qualified GHC.Utils.Outputable as Outputable +import qualified Language.Haskell.Syntax as Syntax +import qualified Numeric.Natural as Natural +import qualified Scrod.Core.Category as Category +import qualified Scrod.Core.Column as Column +import qualified Scrod.Core.Doc as Doc +import qualified Scrod.Core.Item as Item +import qualified Scrod.Core.ItemKey as ItemKey +import qualified Scrod.Core.ItemKind as ItemKind +import qualified Scrod.Core.ItemName as ItemName +import qualified Scrod.Core.Line as Line +import qualified Scrod.Core.Located as Located +import qualified Scrod.Core.Location as Location +import qualified Scrod.Core.ModuleName as ModuleName +import qualified Scrod.Core.PackageName as PackageName +import qualified Scrod.Core.Since as Since +import qualified Scrod.Core.Version as Version +import qualified Scrod.Core.Visibility as Visibility +import qualified Scrod.Core.Warning as Warning + +-- | State for tracking item keys during conversion. +newtype ConversionState = MkConversionState + { nextKey :: Natural.Natural + } + +-- | Initial conversion state. +initialState :: ConversionState +initialState = MkConversionState {nextKey = 0} + +-- | Allocate a new key from the state. +allocateKey :: ConversionState -> (ItemKey.ItemKey, ConversionState) +allocateKey s = + let k = nextKey s + in (ItemKey.MkItemKey k, s {nextKey = k + 1}) + +-- | Monad for item conversion with auto-incrementing keys. +type ConvertM a = State.State ConversionState a + +-- | Allocate a new unique key. +allocateKeyM :: ConvertM ItemKey.ItemKey +allocateKeyM = State.state allocateKey + +-- | Run the conversion monad and extract the result. +runConvert :: ConvertM a -> a +runConvert = flip State.evalState initialState + +-- | Convert GHC module name to our 'ModuleName' type. +moduleNameFromGhc :: Syntax.ModuleName -> ModuleName.ModuleName +moduleNameFromGhc = + ModuleName.MkModuleName + . Text.pack + . Syntax.moduleNameString + +-- | Convert GHC Located to our 'Located' type. +locatedFromGhc :: SrcLoc.Located a -> Maybe (Located.Located a) +locatedFromGhc (SrcLoc.L srcSpan a) = do + location <- locationFromSrcSpan srcSpan + Just + Located.MkLocated + { Located.location = location, + Located.value = a + } + +-- | Convert SrcSpan to our 'Location' type. +locationFromSrcSpan :: SrcLoc.SrcSpan -> Maybe Location.Location +locationFromSrcSpan srcSpan = case srcSpan of + SrcLoc.RealSrcSpan realSrcSpan _ -> + Just + Location.MkLocation + { Location.line = Line.MkLine . fromIntegral $ SrcLoc.srcSpanStartLine realSrcSpan, + Location.column = Column.MkColumn . fromIntegral $ SrcLoc.srcSpanStartCol realSrcSpan + } + SrcLoc.UnhelpfulSpan _ -> Nothing + +-- | Convert GHC WarningTxt to our 'Warning' type. +warningTxtToWarning :: Warnings.WarningTxt Ghc.GhcPs -> Warning.Warning +warningTxtToWarning warningTxt = + Warning.MkWarning + { Warning.category = categoryFromGhc $ Warnings.warningTxtCategory warningTxt, + Warning.value = + Text.intercalate (Text.singleton '\n') + . fmap extractMessage + $ Warnings.warningTxtMessage warningTxt + } + +-- | Render an SDoc with a short line length to encourage line breaks. +showSDocShort :: Outputable.SDoc -> String +showSDocShort = + Outputable.renderWithContext + Outputable.defaultSDocContext {Outputable.sdocLineLength = 40} + +-- | Convert GHC WarningCategory to our 'Category' type. +categoryFromGhc :: Warnings.WarningCategory -> Category.Category +categoryFromGhc = + Category.MkCategory + . Text.pack + . Outputable.showSDocUnsafe + . Outputable.ppr + +-- | Extract message text from a located doc string. +extractMessage :: + SrcLoc.GenLocated l (HsDoc.WithHsDocIdentifiers SourceText.StringLiteral Ghc.GhcPs) -> + Text.Text +extractMessage = + Text.pack + . FastString.unpackFS + . SourceText.sl_fs + . HsDoc.hsDocString + . SrcLoc.unLoc + +-- | Extract name from RdrName. +extractRdrName :: SrcLoc.GenLocated l Reader.RdrName -> Text.Text +extractRdrName = + Text.pack + . Outputable.showSDocUnsafe + . Outputable.ppr + . SrcLoc.unLoc + +-- | Extract name from an identifier. +extractIdPName :: Syntax.LIdP Ghc.GhcPs -> ItemName.ItemName +extractIdPName = ItemName.MkItemName . extractRdrName + +-- | Extract name from a field occurrence. +extractFieldOccName :: Syntax.LFieldOcc Ghc.GhcPs -> ItemName.ItemName +extractFieldOccName lFieldOcc = case SrcLoc.unLoc lFieldOcc of + Syntax.FieldOcc _ lbl -> ItemName.MkItemName $ extractRdrName lbl + +-- | Append two 'Doc' values. +appendDoc :: Doc.Doc -> Doc.Doc -> Doc.Doc +appendDoc Doc.Empty d = d +appendDoc d Doc.Empty = d +appendDoc d1 d2 = Doc.Append [d1, d2] + +-- | Combine two 'Maybe Since.Since' values, preferring the first. +appendSince :: Maybe Since.Since -> Maybe Since.Since -> Maybe Since.Since +appendSince a b = case a of + Just _ -> a + Nothing -> b + +-- | Convert a Haddock MetaSince to our 'Since'. +metaSinceToSince :: Haddock.MetaSince -> Maybe Since.Since +metaSinceToSince metaSince = do + versionNE <- NonEmpty.nonEmpty $ Haddock.sinceVersion metaSince + Just + Since.MkSince + { Since.package = + PackageName.MkPackageName . Text.pack + <$> Haddock.sincePackage metaSince, + Since.version = + Version.MkVersion $ fmap (fromIntegral :: Int -> Natural.Natural) versionNE + } + +-- | Extract the base name (first word) from an item name that contains +-- type variables. Returns 'Nothing' if the name is a single word (no +-- type variables) or empty. +baseItemName :: Text.Text -> Maybe Text.Text +baseItemName t = case Text.words t of + (w : _ : _) -> Just w + _ -> Nothing + +-- | Set the parent key on a located item. +setParentKey :: ItemKey.ItemKey -> Located.Located Item.Item -> Located.Located Item.Item +setParentKey pk li = + li {Located.value = (Located.value li) {Item.parentKey = Just pk}} + +-- | Create an Item from a source span with the given properties. +mkItemM :: + SrcLoc.SrcSpan -> + Maybe ItemKey.ItemKey -> + Maybe ItemName.ItemName -> + Doc.Doc -> + Maybe Since.Since -> + Maybe Text.Text -> + ItemKind.ItemKind -> + ConvertM (Maybe (Located.Located Item.Item)) +mkItemM srcSpan parentKey itemName doc itemSince sig itemKind = + fmap fst <$> mkItemWithKeyM srcSpan parentKey itemName doc itemSince sig itemKind + +-- | Extract source locations from module declarations using the given +-- per-declaration extractor. Common skeleton for pragma location extraction. +extractDeclLocations :: + (Syntax.LHsDecl Ghc.GhcPs -> [Location.Location]) -> + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Set.Set Location.Location +extractDeclLocations extractFromDecl lHsModule = + let hsModule = SrcLoc.unLoc lHsModule + decls = Syntax.hsmodDecls hsModule + in Set.fromList $ concatMap extractFromDecl decls + +-- | Create an Item and return both the item and its allocated key. +mkItemWithKeyM :: + SrcLoc.SrcSpan -> + Maybe ItemKey.ItemKey -> + Maybe ItemName.ItemName -> + Doc.Doc -> + Maybe Since.Since -> + Maybe Text.Text -> + ItemKind.ItemKind -> + ConvertM (Maybe (Located.Located Item.Item, ItemKey.ItemKey)) +mkItemWithKeyM srcSpan parentKey itemName doc itemSince sig itemKind = + case locationFromSrcSpan srcSpan of + Nothing -> pure Nothing + Just location -> do + key <- allocateKeyM + pure $ + Just + ( Located.MkLocated + { Located.location = location, + Located.value = + Item.MkItem + { Item.key = key, + Item.kind = itemKind, + Item.parentKey = parentKey, + Item.name = itemName, + Item.documentation = doc, + Item.since = itemSince, + Item.signature = sig, + Item.visibility = Visibility.Exported + } + }, + key + ) diff --git a/source/library/Scrod/Convert/FromGhc/ItemKind.hs b/source/library/Scrod/Convert/FromGhc/ItemKind.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/ItemKind.hs @@ -0,0 +1,98 @@ +-- | Map GHC declaration types to Scrod's 'ItemKind.ItemKind'. +-- +-- Pure functions that inspect GHC AST nodes and return the +-- corresponding 'ItemKind' value. No monadic state or internal +-- dependencies. +module Scrod.Convert.FromGhc.ItemKind where + +import GHC.Hs () +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Types.Name.Occurrence as Occurrence +import qualified GHC.Types.Name.Reader as Reader +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified Language.Haskell.Syntax as Syntax +import qualified Scrod.Core.ItemKind as ItemKind + +-- | Determine the ItemKind from a declaration. +itemKindFromDecl :: Syntax.HsDecl Ghc.GhcPs -> ItemKind.ItemKind +itemKindFromDecl decl = case decl of + Syntax.TyClD _ tyClDecl -> itemKindFromTyClDecl tyClDecl + Syntax.ValD _ bind -> itemKindFromBind bind + Syntax.SigD _ sig -> itemKindFromSig sig + Syntax.InstD _ inst -> itemKindFromInstDecl inst + Syntax.KindSigD {} -> ItemKind.StandaloneKindSig + Syntax.DefD {} -> ItemKind.Default + Syntax.ForD _ foreignDecl -> itemKindFromForeignDecl foreignDecl + Syntax.WarningD {} -> ItemKind.Warning + Syntax.AnnD {} -> ItemKind.Annotation + Syntax.RuleD {} -> ItemKind.Rule + Syntax.SpliceD {} -> ItemKind.Splice + Syntax.DocD {} -> ItemKind.Function -- Doc comment + Syntax.RoleAnnotD {} -> ItemKind.RoleAnnotation + Syntax.DerivD {} -> ItemKind.StandaloneDeriving + +-- | Determine ItemKind from a type/class declaration. +itemKindFromTyClDecl :: Syntax.TyClDecl Ghc.GhcPs -> ItemKind.ItemKind +itemKindFromTyClDecl tyClDecl = case tyClDecl of + Syntax.FamDecl _ famDecl -> itemKindFromFamilyDecl famDecl + Syntax.SynDecl {} -> ItemKind.TypeSynonym + Syntax.DataDecl _ _ _ _ dataDefn -> itemKindFromDataDefn dataDefn + Syntax.ClassDecl {} -> ItemKind.Class + +-- | Determine ItemKind from a data definition. +itemKindFromDataDefn :: Syntax.HsDataDefn Ghc.GhcPs -> ItemKind.ItemKind +itemKindFromDataDefn dataDefn = case Syntax.dd_cons dataDefn of + Syntax.NewTypeCon {} -> ItemKind.Newtype + Syntax.DataTypeCons isTypeData _ -> + if isTypeData + then ItemKind.TypeData + else ItemKind.DataType + +-- | Determine ItemKind from a family declaration. +itemKindFromFamilyDecl :: Syntax.FamilyDecl Ghc.GhcPs -> ItemKind.ItemKind +itemKindFromFamilyDecl famDecl = case Syntax.fdInfo famDecl of + Syntax.DataFamily -> ItemKind.DataFamily + Syntax.OpenTypeFamily -> ItemKind.OpenTypeFamily + Syntax.ClosedTypeFamily {} -> ItemKind.ClosedTypeFamily + +-- | Determine ItemKind from a binding. +itemKindFromBind :: Syntax.HsBindLR Ghc.GhcPs Ghc.GhcPs -> ItemKind.ItemKind +itemKindFromBind bind = case bind of + Syntax.FunBind {Syntax.fun_id = lName} -> functionOrOperator lName + Syntax.PatBind {} -> ItemKind.PatternBinding + Syntax.VarBind {} -> ItemKind.Function + Syntax.PatSynBind {} -> ItemKind.PatternSynonym + +-- | Determine ItemKind from a signature. +itemKindFromSig :: Syntax.Sig Ghc.GhcPs -> ItemKind.ItemKind +itemKindFromSig sig = case sig of + Syntax.TypeSig {} -> ItemKind.Function + Syntax.PatSynSig {} -> ItemKind.PatternSynonym + Syntax.ClassOpSig {} -> ItemKind.ClassMethod + Syntax.FixSig {} -> ItemKind.FixitySignature + Syntax.InlineSig {} -> ItemKind.InlineSignature + Syntax.SpecSig {} -> ItemKind.SpecialiseSignature + Syntax.SpecSigE {} -> ItemKind.SpecialiseSignature + Syntax.MinimalSig {} -> ItemKind.MinimalPragma + Syntax.CompleteMatchSig {} -> ItemKind.CompletePragma + _ -> ItemKind.Function + +-- | Determine ItemKind from an instance declaration. +itemKindFromInstDecl :: Syntax.InstDecl Ghc.GhcPs -> ItemKind.ItemKind +itemKindFromInstDecl inst = case inst of + Syntax.ClsInstD {} -> ItemKind.ClassInstance + Syntax.DataFamInstD {} -> ItemKind.DataFamilyInstance + Syntax.TyFamInstD {} -> ItemKind.TypeFamilyInstance + +-- | Return 'Operator' if the name is symbolic, 'Function' otherwise. +functionOrOperator :: Syntax.LIdP Ghc.GhcPs -> ItemKind.ItemKind +functionOrOperator lName = + if Occurrence.isSymOcc . Reader.rdrNameOcc $ SrcLoc.unLoc lName + then ItemKind.Operator + else ItemKind.Function + +-- | Determine ItemKind from a foreign declaration. +itemKindFromForeignDecl :: Syntax.ForeignDecl Ghc.GhcPs -> ItemKind.ItemKind +itemKindFromForeignDecl foreignDecl = case foreignDecl of + Syntax.ForeignImport {} -> ItemKind.ForeignImport + Syntax.ForeignExport {} -> ItemKind.ForeignExport diff --git a/source/library/Scrod/Convert/FromGhc/KindSigParents.hs b/source/library/Scrod/Convert/FromGhc/KindSigParents.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/KindSigParents.hs @@ -0,0 +1,156 @@ +-- | Merge standalone kind signatures into their declarations. +-- +-- When a standalone kind signature (@type T :: ...@) and a matching +-- declaration (data, newtype, class, type synonym, type family, or +-- data family) share the same name, the kind signature is merged +-- into the declaration: the kind signature's text becomes the +-- declaration's signature, and their documentation and \@since\@ +-- annotations are combined. The standalone kind signature item is +-- then removed from the output. This runs after merging so that +-- type signatures and bindings are merged first. +module Scrod.Convert.FromGhc.KindSigParents where + +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Item as Item +import qualified Scrod.Core.ItemKind as ItemKind +import qualified Scrod.Core.ItemName as ItemName +import qualified Scrod.Core.Located as Located + +-- | Merge standalone kind signatures into their matching declarations. +associateKindSigParents :: + [Located.Located Item.Item] -> + [Located.Located Item.Item] +associateKindSigParents items = + let kindSigMap = buildKindSigMap items + declNames = buildDeclNameSet items + in Maybe.mapMaybe (mergeOrRemoveKindSig kindSigMap declNames) items + +-- | Build a map from standalone kind signature names to their items. +buildKindSigMap :: + [Located.Located Item.Item] -> + Map.Map ItemName.ItemName (Located.Located Item.Item) +buildKindSigMap = + Map.fromList . Maybe.mapMaybe getKindSigEntry + where + getKindSigEntry locItem = + let val = Located.value locItem + in case (Item.kind val, Item.name val) of + (ItemKind.StandaloneKindSig, Just name) -> + Just (name, locItem) + _ -> Nothing + +-- | Collect names of top-level declarations that are not standalone +-- kind signatures. Used to decide whether a kind signature has a +-- matching declaration and should be consumed. +-- For items whose names contain type variables (indicated by a space), +-- both the full name and the base name (first word) are indexed. +buildDeclNameSet :: + [Located.Located Item.Item] -> + Set.Set ItemName.ItemName +buildDeclNameSet = + Set.fromList . concatMap getDeclNames + where + getDeclNames locItem = + let val = Located.value locItem + in if Item.kind val /= ItemKind.StandaloneKindSig + && Maybe.isNothing (Item.parentKey val) + then case Item.name val of + Nothing -> [] + Just n -> + let full = ItemName.unwrap n + in n : [ItemName.MkItemName base | Just base <- [Internal.baseItemName full]] + else [] + +-- | For each item, either merge a matching kind signature into it, +-- remove a consumed kind signature, or pass it through unchanged. +-- When looking up kind signatures, both the full name and the base +-- name (first word) are tried, to support names with type variables. +mergeOrRemoveKindSig :: + Map.Map ItemName.ItemName (Located.Located Item.Item) -> + Set.Set ItemName.ItemName -> + Located.Located Item.Item -> + Maybe (Located.Located Item.Item) +mergeOrRemoveKindSig kindSigMap declNames locItem = + let val = Located.value locItem + in case Item.name val of + Nothing -> Just locItem + Just name + | Item.kind val == ItemKind.StandaloneKindSig -> + if Set.member name declNames + then Nothing + else Just locItem + | Maybe.isJust (Item.parentKey val) -> + Just locItem + | otherwise -> + case lookupWithBaseName name kindSigMap of + Nothing -> Just locItem + Just kindSigItem -> + Just $ mergeKindSigInto kindSigItem locItem + where + lookupWithBaseName :: ItemName.ItemName -> Map.Map ItemName.ItemName (Located.Located Item.Item) -> Maybe (Located.Located Item.Item) + lookupWithBaseName name m = + case Map.lookup name m of + Just x -> Just x + Nothing -> + let full = ItemName.unwrap name + in case Internal.baseItemName full of + Just w -> Map.lookup (ItemName.MkItemName w) m + Nothing -> Nothing + +-- | Merge a standalone kind signature's metadata into a declaration. +-- The kind signature's signature text and \@since\@ annotation take +-- precedence when present, and documentation is combined (kind +-- signature first, then declaration). The earlier source location of +-- the two items is used. +-- +-- When the kind signature provides a signature and the declaration +-- had type variables in its signature (e.g. @data A b@ has signature +-- @"b"@), the type variables are folded into the declaration's name +-- (producing @"A b"@) so they are not lost. +mergeKindSigInto :: + Located.Located Item.Item -> + Located.Located Item.Item -> + Located.Located Item.Item +mergeKindSigInto kindSigItem declItem = + let kindSigVal = Located.value kindSigItem + declVal = Located.value declItem + hasTypeVarsInSig = case Item.kind declVal of + ItemKind.DataType -> True + ItemKind.Newtype -> True + ItemKind.TypeData -> True + _ -> False + (mergedName, mergedSig) = case Item.signature kindSigVal of + Just s + | hasTypeVarsInSig -> + -- For data/newtype/type-data, fold type variables into the name + let nameWithVars = case (Item.name declVal, Item.signature declVal) of + (Just n, Just vars) -> + Just . ItemName.MkItemName $ ItemName.unwrap n <> Text.pack " " <> vars + _ -> Item.name declVal + in (nameWithVars, Just s) + Just s -> (Item.name declVal, Just s) + Nothing -> (Item.name declVal, Item.signature declVal) + mergedDoc = + Internal.appendDoc + (Item.documentation kindSigVal) + (Item.documentation declVal) + mergedSince = + Internal.appendSince + (Item.since kindSigVal) + (Item.since declVal) + mergedLocation = + min (Located.location kindSigItem) (Located.location declItem) + in declItem + { Located.location = mergedLocation, + Located.value = + declVal + { Item.name = mergedName, + Item.signature = mergedSig, + Item.documentation = mergedDoc, + Item.since = mergedSince + } + } diff --git a/source/library/Scrod/Convert/FromGhc/Merge.hs b/source/library/Scrod/Convert/FromGhc/Merge.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/Merge.hs @@ -0,0 +1,139 @@ +-- | Merge items that share the same name. +-- +-- When a declaration has both a type signature and a binding (or +-- multiple clauses), the GHC AST produces separate items for each. +-- This module merges them into a single item, combining their +-- documentation and signatures, and remaps child parent keys +-- accordingly. +module Scrod.Convert.FromGhc.Merge where + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Doc as Doc +import qualified Scrod.Core.Item as Item +import qualified Scrod.Core.ItemKey as ItemKey +import qualified Scrod.Core.ItemKind as ItemKind +import qualified Scrod.Core.ItemName as ItemName +import qualified Scrod.Core.Located as Located + +-- | Merge items that share the same name. +mergeItemsByName :: [Located.Located Item.Item] -> [Located.Located Item.Item] +mergeItemsByName items = + let mergeMap = buildMergeMap items + keyRemapping = buildKeyRemapping items mergeMap + in Maybe.mapMaybe (applyMerge mergeMap keyRemapping) items + +-- | Build a map from item name to the merged item for that name. +buildMergeMap :: + [Located.Located Item.Item] -> + Map.Map ItemName.ItemName (Located.Located Item.Item) +buildMergeMap items = + let namedCandidates = + Maybe.mapMaybe + (\item -> fmap (\n -> (n, item NonEmpty.:| [])) . Item.name $ Located.value item) + (filter isMergeCandidate items) + groups = Map.fromListWith (<>) namedCandidates + in Map.map mergeItemGroup groups + +-- | Check if an item is eligible for merging. +-- +-- Standalone kind signatures are excluded because they are merged +-- into their corresponding declarations in a separate pass (see +-- 'KindSigParents'). +isMergeCandidate :: Located.Located Item.Item -> Bool +isMergeCandidate item = + let val = Located.value item + in Maybe.isNothing (Item.parentKey val) + && Maybe.isJust (Item.name val) + && Item.kind val /= ItemKind.StandaloneKindSig + +-- | Merge a group of items sharing the same name into a single item. +mergeItemGroup :: NonEmpty.NonEmpty (Located.Located Item.Item) -> Located.Located Item.Item +mergeItemGroup (single NonEmpty.:| []) = single +mergeItemGroup group = + let sorted = NonEmpty.sortWith Located.location group + firstItem = NonEmpty.head sorted + combinedDoc = foldr (Internal.appendDoc . Item.documentation . Located.value) Doc.Empty sorted + combinedSince = + Maybe.listToMaybe . Maybe.mapMaybe (Item.since . Located.value) $ NonEmpty.toList sorted + combinedSig = + Maybe.listToMaybe . Maybe.mapMaybe (Item.signature . Located.value) $ NonEmpty.toList sorted + mergedItem = + (Located.value firstItem) + { Item.documentation = combinedDoc, + Item.since = combinedSince, + Item.signature = combinedSig + } + in firstItem {Located.value = mergedItem} + +-- | Build a mapping from old item keys to new merged item keys. +buildKeyRemapping :: + [Located.Located Item.Item] -> + Map.Map ItemName.ItemName (Located.Located Item.Item) -> + Map.Map ItemKey.ItemKey ItemKey.ItemKey +buildKeyRemapping items mergeMap = + Map.fromList $ concatMap (findRemapping mergeMap) items + +-- | Find key remappings for a single item. +findRemapping :: + Map.Map ItemName.ItemName (Located.Located Item.Item) -> + Located.Located Item.Item -> + [(ItemKey.ItemKey, ItemKey.ItemKey)] +findRemapping mergeMap item = + let val = Located.value item + itemKey = Item.key val + in case Item.name val of + Nothing -> [] + Just name -> + case Map.lookup name mergeMap of + Nothing -> [] + Just merged -> + let mergedKey = Item.key $ Located.value merged + in if itemKey /= mergedKey && isMergeCandidate item + then [(itemKey, mergedKey)] + else [] + +-- | Apply merge: either drop (remapped away) or replace with merged version. +applyMerge :: + Map.Map ItemName.ItemName (Located.Located Item.Item) -> + Map.Map ItemKey.ItemKey ItemKey.ItemKey -> + Located.Located Item.Item -> + Maybe (Located.Located Item.Item) +applyMerge mergeMap keyRemapping item = + let val = Located.value item + itemKey = Item.key val + in if Map.member itemKey keyRemapping + then Nothing + else + let updatedItem = updateParentKey keyRemapping item + in case Item.name val of + Nothing -> Just updatedItem + Just name -> + if not (isMergeCandidate item) + then Just updatedItem + else case Map.lookup name mergeMap of + Nothing -> Just updatedItem + Just merged -> + if Item.key (Located.value merged) == itemKey + then Just merged + else Just updatedItem + +-- | Update an item's parent key according to the remapping. +updateParentKey :: + Map.Map ItemKey.ItemKey ItemKey.ItemKey -> + Located.Located Item.Item -> + Located.Located Item.Item +updateParentKey keyRemapping locatedItem = + let val = Located.value locatedItem + in case Item.parentKey val of + Nothing -> locatedItem + Just pk -> + case Map.lookup pk keyRemapping of + Nothing -> locatedItem + Just newPk -> + locatedItem + { Located.value = + val {Item.parentKey = Just newPk} + } diff --git a/source/library/Scrod/Convert/FromGhc/Names.hs b/source/library/Scrod/Convert/FromGhc/Names.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/Names.hs @@ -0,0 +1,227 @@ +-- | Name and signature extraction from GHC AST nodes. +-- +-- Provides functions to extract declaration names, type signatures, +-- and related metadata from the various GHC declaration types. Used +-- by the main conversion module and by 'Scrod.Convert.FromGhc.Constructors'. +module Scrod.Convert.FromGhc.Names where + +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Maybe as Maybe +import qualified Data.Text as Text +import GHC.Hs () +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified GHC.Utils.Outputable as Outputable +import qualified Language.Haskell.Syntax as Syntax +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Convert.FromGhc.SigArguments as SigArguments +import qualified Scrod.Core.ItemName as ItemName + +-- | Extract declaration name. +extractDeclName :: Syntax.LHsDecl Ghc.GhcPs -> Maybe ItemName.ItemName +extractDeclName lDecl = case SrcLoc.unLoc lDecl of + Syntax.TyClD _ tyClDecl -> extractTyClDeclName tyClDecl + Syntax.ValD _ bind -> extractBindName bind + Syntax.SigD _ sig -> extractSigName sig + Syntax.InstD _ inst -> extractInstDeclName inst + Syntax.DerivD _ derivDecl -> extractDerivDeclName derivDecl + Syntax.KindSigD _ kindSig -> Just $ extractStandaloneKindSigName kindSig + Syntax.ForD _ foreignDecl -> Just $ extractForeignDeclName foreignDecl + _ -> Nothing + +-- | Extract name from a standalone kind signature. +extractStandaloneKindSigName :: Syntax.StandaloneKindSig Ghc.GhcPs -> ItemName.ItemName +extractStandaloneKindSigName (Syntax.StandaloneKindSig _ lName _) = Internal.extractIdPName lName + +-- | Extract signature from a standalone kind signature. +-- Only returns the kind type, not the name. +-- For example, @type X :: a -> a@ produces @"a -> a"@. +extractKindSigSignature :: Syntax.StandaloneKindSig Ghc.GhcPs -> Text.Text +extractKindSigSignature (Syntax.StandaloneKindSig _ _ lSigType) = + Text.pack . Internal.showSDocShort . Outputable.ppr $ lSigType + +-- | Extract name from a type/class declaration. +-- For class declarations, this includes type variables in the name +-- (e.g., @class C a@ produces @"C a"@). +extractTyClDeclName :: Syntax.TyClDecl Ghc.GhcPs -> Maybe ItemName.ItemName +extractTyClDeclName tyClDecl = case tyClDecl of + Syntax.FamDecl _ famDecl -> Just $ extractFamilyDeclName famDecl + Syntax.SynDecl {Syntax.tcdLName = lName} -> Just $ Internal.extractIdPName lName + Syntax.DataDecl {Syntax.tcdLName = lName} -> Just $ Internal.extractIdPName lName + Syntax.ClassDecl {Syntax.tcdLName = lName, Syntax.tcdTyVars = tyVars} -> + Just . ItemName.MkItemName . Text.pack . Outputable.showSDocUnsafe $ case Syntax.hsQTvExplicit tyVars of + [] -> Outputable.ppr lName + tvs -> Outputable.hsep (Outputable.ppr lName : fmap Outputable.ppr tvs) + +-- | Extract the fully applied parent type text from a data declaration. +-- For @data Maybe a@, this produces @"Maybe a"@. +extractParentTypeText :: Syntax.TyClDecl Ghc.GhcPs -> Maybe Text.Text +extractParentTypeText tyClDecl = case tyClDecl of + Syntax.DataDecl {Syntax.tcdLName = lName, Syntax.tcdTyVars = tyVars} -> + Just . Text.pack . Internal.showSDocShort $ case Syntax.hsQTvExplicit tyVars of + [] -> Outputable.ppr lName + tvs -> Outputable.hsep (Outputable.ppr lName : fmap Outputable.ppr tvs) + _ -> Nothing + +-- | Extract type variable bindings from a type\/class declaration. +-- For @data T a b@, this produces @Just "a b"@. +-- For @class C a@, this produces @Just "a"@. +-- Returns 'Nothing' if there are no type variables. +extractTyClDeclTyVars :: Syntax.TyClDecl Ghc.GhcPs -> Maybe Text.Text +extractTyClDeclTyVars tyClDecl = case tyClDecl of + Syntax.DataDecl {Syntax.tcdTyVars = tyVars} -> tyVarsToText tyVars + _ -> Nothing + +-- | Pretty-print explicit type variable binders as text. +-- Returns 'Nothing' if the list is empty. +tyVarsToText :: Syntax.LHsQTyVars Ghc.GhcPs -> Maybe Text.Text +tyVarsToText tyVars = case Syntax.hsQTvExplicit tyVars of + [] -> Nothing + tvs -> Just . Text.pack . Internal.showSDocShort $ Outputable.hsep (fmap Outputable.ppr tvs) + +-- | Extract the signature for a type synonym declaration. +-- For @type T = ()@, this produces @Just "= ()"@. +-- For @type T a = [a]@, this produces @Just "a = [a]"@. +extractSynDeclSignature :: Syntax.TyClDecl Ghc.GhcPs -> Maybe Text.Text +extractSynDeclSignature tyClDecl = case tyClDecl of + Syntax.SynDecl {Syntax.tcdTyVars = tyVars, Syntax.tcdRhs = rhs} -> + let rhsText = Text.pack . Internal.showSDocShort $ Outputable.ppr rhs + in Just $ maybe (Text.pack "= " <> rhsText) (\tvs -> tvs <> Text.pack " = " <> rhsText) (tyVarsToText tyVars) + _ -> Nothing + +-- | Extract name from a family declaration. +extractFamilyDeclName :: Syntax.FamilyDecl Ghc.GhcPs -> ItemName.ItemName +extractFamilyDeclName famDecl = Internal.extractIdPName $ Syntax.fdLName famDecl + +-- | Extract name from a foreign declaration. +extractForeignDeclName :: Syntax.ForeignDecl Ghc.GhcPs -> ItemName.ItemName +extractForeignDeclName foreignDecl = Internal.extractIdPName $ Syntax.fd_name foreignDecl + +-- | Extract signature from a foreign declaration. +extractForeignDeclSignature :: Syntax.ForeignDecl Ghc.GhcPs -> Text.Text +extractForeignDeclSignature foreignDecl = + Text.pack . Internal.showSDocShort . Outputable.ppr $ Syntax.fd_sig_ty foreignDecl + +-- | Extract name from a binding. +extractBindName :: Syntax.HsBindLR Ghc.GhcPs Ghc.GhcPs -> Maybe ItemName.ItemName +extractBindName bind = case bind of + Syntax.FunBind {Syntax.fun_id = lId} -> Just $ Internal.extractIdPName lId + Syntax.PatBind {} -> Nothing + Syntax.VarBind {} -> Nothing + Syntax.PatSynBind _ patSyn -> Just $ extractPatSynName patSyn + +-- | Extract name from a pattern synonym binding. +extractPatSynName :: Syntax.PatSynBind Ghc.GhcPs Ghc.GhcPs -> ItemName.ItemName +extractPatSynName patSyn = Internal.extractIdPName $ Syntax.psb_id patSyn + +-- | Extract argument names from a function binding's patterns. +-- +-- For each argument position, scans across all equations and picks +-- the first variable pattern name found (skipping wildcards, +-- constructor patterns, and literals). Returns one entry per +-- argument position; 'Nothing' when no variable name was found. +extractBindArgNames :: Syntax.HsBindLR Ghc.GhcPs Ghc.GhcPs -> [Maybe Text.Text] +extractBindArgNames bind = case bind of + Syntax.FunBind {Syntax.fun_matches = mg} -> + let lMatches = SrcLoc.unLoc (Syntax.mg_alts mg) + patNameLists = fmap extractMatchPatNames lMatches + in mergePatNames patNameLists + _ -> [] + +-- | Extract the variable name (if any) from each pattern in a match. +extractMatchPatNames :: + SrcLoc.GenLocated l (Syntax.Match Ghc.GhcPs body) -> + [Maybe Text.Text] +extractMatchPatNames lMatch = + let match = SrcLoc.unLoc lMatch + in fmap (extractPatVarName . SrcLoc.unLoc) (SrcLoc.unLoc (Syntax.m_pats match)) + +-- | Extract a variable name from a pattern, unwrapping wrapper nodes. +-- +-- Handles 'VarPat' directly, and recurses through 'AsPat' (using the +-- as-binding name), 'BangPat', 'LazyPat', 'ParPat', and 'SigPat'. +-- Returns 'Nothing' for wildcards, constructor patterns, literals, etc. +extractPatVarName :: Syntax.Pat Ghc.GhcPs -> Maybe Text.Text +extractPatVarName pat = case pat of + Syntax.VarPat _ lId -> Just $ Internal.extractRdrName lId + Syntax.AsPat _ lId _ -> Just $ Internal.extractRdrName lId + Syntax.BangPat _ lPat -> extractPatVarName $ SrcLoc.unLoc lPat + Syntax.LazyPat _ lPat -> extractPatVarName $ SrcLoc.unLoc lPat + Syntax.ParPat _ lPat -> extractPatVarName $ SrcLoc.unLoc lPat + Syntax.SigPat _ lPat _ -> extractPatVarName $ SrcLoc.unLoc lPat + _ -> Nothing + +-- | Merge pattern names across multiple equations. +-- +-- For each argument position, takes the first 'Just' name found +-- across the equations. This handles cases like: +-- +-- @ +-- or True _ = True +-- or _ x = x +-- @ +-- +-- where position 0 yields 'Nothing' (no variable in either equation) +-- and position 1 yields @Just "x"@ (from the second equation). +mergePatNames :: [[Maybe Text.Text]] -> [Maybe Text.Text] +mergePatNames patNameLists = case patNameLists of + [] -> [] + _ -> + let maxLen = maximum (fmap length patNameLists) + padded = fmap (\ns -> ns <> replicate (maxLen - length ns) Nothing) patNameLists + in fmap (Maybe.listToMaybe . Maybe.catMaybes) (List.transpose padded) + +-- | Extract name from a signature. +extractSigName :: Syntax.Sig Ghc.GhcPs -> Maybe ItemName.ItemName +extractSigName sig = case sig of + Syntax.TypeSig _ (lName : _) _ -> Just $ Internal.extractIdPName lName + Syntax.PatSynSig _ (lName : _) _ -> Just $ Internal.extractIdPName lName + Syntax.ClassOpSig _ _ (lName : _) _ -> Just $ Internal.extractIdPName lName + _ -> Nothing + +-- | Extract signature text from a Sig. Only returns the type part, not the +-- name. For example, @x :: Int@ produces @"Int"@. +-- Strips 'HsDocTy' nodes so that embedded doc comments do not appear in the +-- pretty-printed output. +extractSigSignature :: Syntax.Sig Ghc.GhcPs -> Maybe Text.Text +extractSigSignature sig = case sig of + Syntax.TypeSig _ _ ty -> + Just . Text.pack . Internal.showSDocShort . Outputable.ppr $ SigArguments.stripHsSigWcType ty + Syntax.PatSynSig _ _ ty -> + Just . Text.pack . Internal.showSDocShort . Outputable.ppr $ SigArguments.stripHsSigType ty + Syntax.ClassOpSig _ _ _ ty -> + Just . Text.pack . Internal.showSDocShort . Outputable.ppr $ SigArguments.stripHsSigType ty + _ -> Nothing + +-- | Extract name from an instance declaration. +extractInstDeclName :: Syntax.InstDecl Ghc.GhcPs -> Maybe ItemName.ItemName +extractInstDeclName inst = Just $ case inst of + Syntax.ClsInstD _ clsInst -> + ItemName.MkItemName . Text.pack . Internal.showSDocShort . Outputable.ppr $ + Syntax.cid_poly_ty clsInst + Syntax.DataFamInstD _ dataFamInst -> + ItemName.MkItemName . Text.pack . Internal.showSDocShort . Outputable.ppr $ + dataFamInst + Syntax.TyFamInstD _ tyFamInst -> + ItemName.MkItemName . Text.pack . Internal.showSDocShort . Outputable.ppr $ + tyFamInst + +-- | Extract name from a standalone deriving declaration. +extractDerivDeclName :: Syntax.DerivDecl Ghc.GhcPs -> Maybe ItemName.ItemName +extractDerivDeclName = + Just + . ItemName.MkItemName + . Text.pack + . Internal.showSDocShort + . Outputable.ppr + . Syntax.hswc_body + . Syntax.deriv_type + +-- | Extract names from a constructor declaration. +-- GADT constructors can declare multiple names (e.g. @A, B :: Int -> T@). +extractConDeclNames :: Syntax.ConDecl Ghc.GhcPs -> NonEmpty.NonEmpty ItemName.ItemName +extractConDeclNames conDecl = case conDecl of + Syntax.ConDeclH98 {Syntax.con_name = lName} -> pure $ Internal.extractIdPName lName + Syntax.ConDeclGADT {Syntax.con_names = lNames} -> + fmap Internal.extractIdPName lNames diff --git a/source/library/Scrod/Convert/FromGhc/ParentAssociation.hs b/source/library/Scrod/Convert/FromGhc/ParentAssociation.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/ParentAssociation.hs @@ -0,0 +1,69 @@ +-- | Shared logic for associating pragma items with their target declarations. +-- +-- Multiple pragma types (fixity, inline, specialise, warning, role) follow +-- the same pattern: items at known pragma locations are parented to the +-- declaration with the matching name. This module provides a generic +-- implementation of that pattern. +module Scrod.Convert.FromGhc.ParentAssociation where + +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Item as Item +import qualified Scrod.Core.ItemKey as ItemKey +import qualified Scrod.Core.ItemName as ItemName +import qualified Scrod.Core.Located as Located +import qualified Scrod.Core.Location as Location + +-- | Associate pragma items with their target declarations by name. +-- +-- The first set contains all pragma locations (used to exclude pragmas +-- from the name-to-key map). The second set contains only the locations +-- for the specific pragma type being resolved. +associateParents :: + Set.Set Location.Location -> + Set.Set Location.Location -> + [Located.Located Item.Item] -> + [Located.Located Item.Item] +associateParents allPragmaLocations pragmaLocations items = + let nameToKey = buildNameToKeyMap allPragmaLocations items + in fmap (resolveParent pragmaLocations nameToKey) items + +-- | Build a map from item names to their keys, excluding pragma items +-- and child items. Only top-level declarations (those with no parentKey) +-- are eligible parents, so that @data T = T@ maps to the type +-- declaration rather than the constructor. +buildNameToKeyMap :: + Set.Set Location.Location -> + [Located.Located Item.Item] -> + Map.Map ItemName.ItemName ItemKey.ItemKey +buildNameToKeyMap allPragmaLocations = + Map.fromList . concatMap getNameAndKey + where + getNameAndKey locItem = + let val = Located.value locItem + in case Item.name val of + Nothing -> [] + Just name -> + if Set.member (Located.location locItem) allPragmaLocations + || Maybe.isJust (Item.parentKey val) + then [] + else [(name, Item.key val)] + +-- | Set the parentKey on a pragma item by looking up its name. +resolveParent :: + Set.Set Location.Location -> + Map.Map ItemName.ItemName ItemKey.ItemKey -> + Located.Located Item.Item -> + Located.Located Item.Item +resolveParent pragmaLocations nameToKey locItem = + if Set.member (Located.location locItem) pragmaLocations + then case Item.name (Located.value locItem) of + Nothing -> locItem + Just name -> + case Map.lookup name nameToKey of + Nothing -> locItem + Just parentKey -> + Internal.setParentKey parentKey locItem + else locItem diff --git a/source/library/Scrod/Convert/FromGhc/RoleParents.hs b/source/library/Scrod/Convert/FromGhc/RoleParents.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/RoleParents.hs @@ -0,0 +1,30 @@ +-- | Resolve role annotation parent relationships. +-- +-- Associates role annotation items with their target type declarations +-- when those declarations are defined in the same module. Uses the shared +-- parent association logic from 'Scrod.Convert.FromGhc.ParentAssociation'. +module Scrod.Convert.FromGhc.RoleParents where + +import qualified Data.Set as Set +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Parser.Annotation as Annotation +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified Language.Haskell.Syntax as Syntax +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Location as Location + +-- | Extract the set of source locations that correspond to role annotation +-- declaration names. +extractRoleLocations :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Set.Set Location.Location +extractRoleLocations = Internal.extractDeclLocations extractDeclRoleLocations + +-- | Extract role annotation name locations from a single declaration. +extractDeclRoleLocations :: + Syntax.LHsDecl Ghc.GhcPs -> + [Location.Location] +extractDeclRoleLocations lDecl = case SrcLoc.unLoc lDecl of + Syntax.RoleAnnotD _ (Syntax.RoleAnnotDecl _ lName _) -> + foldMap pure $ Internal.locationFromSrcSpan (Annotation.getLocA lName) + _ -> [] diff --git a/source/library/Scrod/Convert/FromGhc/SigArguments.hs b/source/library/Scrod/Convert/FromGhc/SigArguments.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/SigArguments.hs @@ -0,0 +1,112 @@ +-- | Argument and return-type extraction from GHC type signatures. +-- +-- Provides functions to walk the 'HsFunTy' chain of a type signature, +-- collecting each argument's pretty-printed type text and its optional +-- Haddock documentation. Also provides utilities to strip 'HsDocTy' +-- wrappers from types before pretty-printing. +module Scrod.Convert.FromGhc.SigArguments where + +import qualified Data.Text as Text +import GHC.Hs () +import qualified GHC.Hs.Doc as HsDoc +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified GHC.Utils.Outputable as Outputable +import qualified Language.Haskell.Syntax as Syntax +import qualified Scrod.Convert.FromGhc.Internal as Internal + +-- | Extract argument types and their optional doc comments from a type +-- signature. Walks the 'HsFunTy' chain, collecting each argument's +-- pretty-printed type text and its 'LHsDoc' (if the argument was wrapped +-- in 'HsDocTy'). The return type is included only when it has documentation. +-- +-- Returns a pair of (arguments, optional return type). +-- +-- Handles 'TypeSig' (unwrap via 'hswc_body'), 'PatSynSig', and +-- 'ClassOpSig' (unwrap via 'sig_body' on 'HsSigType'). +extractSigArguments :: + Syntax.Sig Ghc.GhcPs -> + ( [(Text.Text, Maybe (HsDoc.LHsDoc Ghc.GhcPs))], + Maybe (Text.Text, Maybe (HsDoc.LHsDoc Ghc.GhcPs)) + ) +extractSigArguments sig = case sig of + Syntax.TypeSig _ _ wc -> + extractArgsFromBody . Syntax.sig_body . SrcLoc.unLoc $ Syntax.hswc_body wc + Syntax.PatSynSig _ _ lSigType -> + extractArgsFromBody . Syntax.sig_body $ SrcLoc.unLoc lSigType + Syntax.ClassOpSig _ _ _ lSigType -> + extractArgsFromBody . Syntax.sig_body $ SrcLoc.unLoc lSigType + _ -> ([], Nothing) + +-- | Skip through 'HsForAllTy' and 'HsQualTy' to reach the arrow chain, +-- then extract arguments from the 'HsFunTy' chain. Returns the arguments +-- and the optional documented return type separately. +extractArgsFromBody :: + Syntax.LHsType Ghc.GhcPs -> + ( [(Text.Text, Maybe (HsDoc.LHsDoc Ghc.GhcPs))], + Maybe (Text.Text, Maybe (HsDoc.LHsDoc Ghc.GhcPs)) + ) +extractArgsFromBody lTy = case SrcLoc.unLoc lTy of + Syntax.HsForAllTy _ _ body -> extractArgsFromBody body + Syntax.HsQualTy _ _ body -> extractArgsFromBody body + Syntax.HsFunTy _ _ arg res -> + let (args, ret) = extractArgsFromBody res + in (extractArg arg : args, ret) + Syntax.HsDocTy _ inner _doc -> case SrcLoc.unLoc inner of + Syntax.HsFunTy _ _ arg res -> + let (args, ret) = extractArgsFromBody res + in (extractArg arg : args, ret) + _ -> ([], Just (extractArg lTy)) + _ -> ([], Nothing) + +-- | Extract the type text and optional doc comment from a single argument. +-- If the argument is wrapped in 'HsDocTy', the doc is extracted and the +-- inner type is pretty-printed (with any nested doc annotations stripped). +-- Otherwise, the argument is pretty-printed as-is with no doc. +extractArg :: + Syntax.LHsType Ghc.GhcPs -> (Text.Text, Maybe (HsDoc.LHsDoc Ghc.GhcPs)) +extractArg lTy = case SrcLoc.unLoc lTy of + Syntax.HsDocTy _ inner doc -> + ( Text.pack . Internal.showSDocShort . Outputable.ppr $ stripHsDocTy inner, + Just doc + ) + _ -> + ( Text.pack . Internal.showSDocShort . Outputable.ppr $ stripHsDocTy lTy, + Nothing + ) + +-- | Strip 'HsDocTy' wrappers from a wildcard-wrapped signature type. +stripHsSigWcType :: + Syntax.LHsSigWcType Ghc.GhcPs -> Syntax.LHsSigWcType Ghc.GhcPs +stripHsSigWcType wc = + wc {Syntax.hswc_body = stripHsSigType (Syntax.hswc_body wc)} + +-- | Strip 'HsDocTy' wrappers from a signature type. +stripHsSigType :: Syntax.LHsSigType Ghc.GhcPs -> Syntax.LHsSigType Ghc.GhcPs +stripHsSigType lSigType = case SrcLoc.unLoc lSigType of + Syntax.HsSig {Syntax.sig_ext = ext, Syntax.sig_bndrs = bndrs, Syntax.sig_body = body} -> + let stripped = stripHsDocTy body + in SrcLoc.L + (SrcLoc.getLoc lSigType) + Syntax.HsSig + { Syntax.sig_ext = ext, + Syntax.sig_bndrs = bndrs, + Syntax.sig_body = stripped + } + +-- | Recursively strip 'HsDocTy' wrappers from a located type. +-- Recurses into 'HsFunTy', 'HsForAllTy', 'HsQualTy', and 'HsParTy' to +-- ensure all embedded doc comments are removed. +stripHsDocTy :: Syntax.LHsType Ghc.GhcPs -> Syntax.LHsType Ghc.GhcPs +stripHsDocTy lTy = case lTy of + SrcLoc.L ann hsType -> case hsType of + Syntax.HsDocTy _ inner _ -> stripHsDocTy inner + Syntax.HsFunTy x mult arg res -> + SrcLoc.L ann $ Syntax.HsFunTy x mult (stripHsDocTy arg) (stripHsDocTy res) + Syntax.HsForAllTy x tele body -> + SrcLoc.L ann $ Syntax.HsForAllTy x tele (stripHsDocTy body) + Syntax.HsQualTy x ctx body -> + SrcLoc.L ann $ Syntax.HsQualTy x ctx (stripHsDocTy body) + Syntax.HsParTy x inner -> + SrcLoc.L ann $ Syntax.HsParTy x (stripHsDocTy inner) + _ -> lTy diff --git a/source/library/Scrod/Convert/FromGhc/SpecialiseParents.hs b/source/library/Scrod/Convert/FromGhc/SpecialiseParents.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/SpecialiseParents.hs @@ -0,0 +1,43 @@ +-- | Resolve specialise parent relationships. +-- +-- Associates specialise signature items with their target declarations when +-- those declarations are defined in the same module. Uses the shared +-- parent association logic from 'Scrod.Convert.FromGhc.ParentAssociation'. +module Scrod.Convert.FromGhc.SpecialiseParents where + +import qualified Data.Set as Set +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Parser.Annotation as Annotation +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified Language.Haskell.Syntax as Syntax +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Location as Location + +-- | Extract the set of source locations that correspond to names inside +-- specialise signature declarations. +extractSpecialiseLocations :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Set.Set Location.Location +extractSpecialiseLocations = Internal.extractDeclLocations extractDeclSpecialiseLocations + +-- | Extract specialise name locations from a single declaration. +extractDeclSpecialiseLocations :: + Syntax.LHsDecl Ghc.GhcPs -> + [Location.Location] +extractDeclSpecialiseLocations lDecl = case SrcLoc.unLoc lDecl of + Syntax.SigD _ (Syntax.SpecSig _ lName _ _) -> + foldMap pure $ Internal.locationFromSrcSpan (Annotation.getLocA lName) + Syntax.SigD _ (Syntax.SpecSigE _ _ lExpr _) -> + extractExprNameLocations lExpr + _ -> [] + +-- | Extract name locations from a SpecSigE expression. +extractExprNameLocations :: + Syntax.LHsExpr Ghc.GhcPs -> + [Location.Location] +extractExprNameLocations lExpr = case SrcLoc.unLoc lExpr of + Syntax.ExprWithTySig _ body _ -> case SrcLoc.unLoc body of + Syntax.HsVar _ lName -> + foldMap pure . Internal.locationFromSrcSpan $ Annotation.getLocA lName + _ -> [] + _ -> [] diff --git a/source/library/Scrod/Convert/FromGhc/Visibility.hs b/source/library/Scrod/Convert/FromGhc/Visibility.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/Visibility.hs @@ -0,0 +1,179 @@ +-- | Compute visibility for each item based on the module's export list. +module Scrod.Convert.FromGhc.Visibility (computeVisibility) where + +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Export as Export +import qualified Scrod.Core.ExportIdentifier as ExportIdentifier +import qualified Scrod.Core.ExportName as ExportName +import qualified Scrod.Core.Item as Item +import qualified Scrod.Core.ItemKey as ItemKey +import qualified Scrod.Core.ItemKind as ItemKind +import qualified Scrod.Core.ItemName as ItemName +import qualified Scrod.Core.Located as Located +import qualified Scrod.Core.Subordinates as Subordinates +import qualified Scrod.Core.Visibility as Visibility + +-- | Whether an item kind is always visible regardless of the export list. +isAlwaysVisible :: ItemKind.ItemKind -> Bool +isAlwaysVisible k = case k of + ItemKind.ClassInstance -> True + ItemKind.CompletePragma -> True + ItemKind.StandaloneDeriving -> True + ItemKind.DerivedInstance -> True + ItemKind.Rule -> True + ItemKind.Default -> True + ItemKind.Annotation -> True + ItemKind.Splice -> True + _ -> False + +-- | Compute visibility for each item based on the module's export list. +computeVisibility :: + Maybe [Export.Export] -> + [Located.Located Item.Item] -> + [Located.Located Item.Item] +computeVisibility Nothing items = fmap setImplicit items +computeVisibility (Just exports) items = + let exportedNames = extractExportedNames exports + wildcardParentKeys = extractWildcardParentKeys exports items + exportedParentSubs = extractExportedParentSubs exports items + in fmap (classifyItem exportedNames wildcardParentKeys exportedParentSubs) items + where + classifyItem :: + Set.Set Text.Text -> + Set.Set ItemKey.ItemKey -> + Map.Map ItemKey.ItemKey (Maybe Subordinates.Subordinates) -> + Located.Located Item.Item -> + Located.Located Item.Item + classifyItem exportedNames wildcardKeys parentSubs li = + let item = Located.value li + in if isAlwaysVisible (Item.kind item) + then setVisibility Visibility.Implicit li + else case Item.parentKey item of + Just pk + | Set.member pk wildcardKeys -> + setVisibility Visibility.Exported li + | Just subs <- Map.lookup pk parentSubs -> + classifyChild subs item li + _ -> + case Item.name item of + Just n + | nameIsExported (ItemName.unwrap n) exportedNames -> + setVisibility Visibility.Exported li + _ -> setVisibility Visibility.Unexported li + + -- Check if a name (possibly containing type variables) matches + -- an exported name. Tries the full name first, then the base + -- name (first word) for names with type variables. + nameIsExported :: Text.Text -> Set.Set Text.Text -> Bool + nameIsExported full names = + Set.member full names + || maybe False (`Set.member` names) (Internal.baseItemName full) + + -- Classify a child of an exported parent based on subordinate + -- restrictions. Non-traditional subordinates (e.g. associated type + -- families) are always exported. Traditional subordinates + -- (constructors, record fields, class methods) follow the export + -- list's subordinate restrictions. + classifyChild :: + Maybe Subordinates.Subordinates -> + Item.Item -> + Located.Located Item.Item -> + Located.Located Item.Item + classifyChild subs item li + | not (ItemKind.isTraditionalSubordinate (Item.kind item)) = + setVisibility Visibility.Exported li + | otherwise = case subs of + Nothing -> setVisibility Visibility.Unexported li + Just (Subordinates.MkSubordinates True _) -> + setVisibility Visibility.Exported li + Just (Subordinates.MkSubordinates False explicit) -> + case Item.name item of + Just n + | Set.member (ItemName.unwrap n) explicitNames -> + setVisibility Visibility.Exported li + where + explicitNames = Set.fromList $ fmap ExportName.name explicit + _ -> setVisibility Visibility.Unexported li + +-- | When there is no export list, tag implicit items and leave everything +-- else as 'Exported' (the default set by 'mkItemM'). +setImplicit :: Located.Located Item.Item -> Located.Located Item.Item +setImplicit li = + let item = Located.value li + in if isAlwaysVisible (Item.kind item) + then setVisibility Visibility.Implicit li + else li + +-- | Set the visibility field on a located item. +setVisibility :: Visibility.Visibility -> Located.Located Item.Item -> Located.Located Item.Item +setVisibility v li = + li {Located.value = (Located.value li) {Item.visibility = v}} + +-- | Extract the set of names that are directly exported (including +-- explicitly named subordinates like @Foo(Bar, Baz)@). +extractExportedNames :: [Export.Export] -> Set.Set Text.Text +extractExportedNames = foldMap go + where + go :: Export.Export -> Set.Set Text.Text + go (Export.Identifier ident) = + let name = ExportName.name (ExportIdentifier.name ident) + explicitSubs = case ExportIdentifier.subordinates ident of + Nothing -> Set.empty + Just (Subordinates.MkSubordinates _ explicit) -> + Set.fromList $ fmap ExportName.name explicit + in Set.insert name explicitSubs + go _ = Set.empty + +-- | Extract the set of parent item keys whose children are exported via +-- a @(..)@ wildcard. +extractWildcardParentKeys :: + [Export.Export] -> + [Located.Located Item.Item] -> + Set.Set ItemKey.ItemKey +extractWildcardParentKeys exports items = + let wildcardNames = + Set.fromList + [ ExportName.name (ExportIdentifier.name ident) + | Export.Identifier ident <- exports, + Just (Subordinates.MkSubordinates True _) <- [ExportIdentifier.subordinates ident] + ] + in Set.fromList + . Maybe.mapMaybe (\n -> Map.lookup n (topLevelNameToKey items)) + $ Set.toList wildcardNames + +-- | Extract a map from exported parent item keys to their subordinate +-- restrictions. The value is 'Nothing' when the parent is exported with +-- no subordinates at all (e.g. @Foo@), or 'Just' when subordinates are +-- present (e.g. @Foo(..)@ or @Foo(Bar)@). +extractExportedParentSubs :: + [Export.Export] -> + [Located.Located Item.Item] -> + Map.Map ItemKey.ItemKey (Maybe Subordinates.Subordinates) +extractExportedParentSubs exports items = + let exportSubs = + [ (ExportName.name (ExportIdentifier.name ident), ExportIdentifier.subordinates ident) + | Export.Identifier ident <- exports + ] + nk = topLevelNameToKey items + in Map.fromList + . Maybe.mapMaybe (\(n, subs) -> (\k -> (k, subs)) <$> Map.lookup n nk) + $ exportSubs + +-- | Build a map from top-level item names to their keys. +-- For items whose names contain type variables (indicated by a space), +-- both the full name and the base name (first word) are indexed. +topLevelNameToKey :: [Located.Located Item.Item] -> Map.Map Text.Text ItemKey.ItemKey +topLevelNameToKey items = + Map.fromList + [ entry + | li <- items, + Maybe.isNothing (Item.parentKey (Located.value li)), + Just n <- [Item.name (Located.value li)], + let full = ItemName.unwrap n, + let k = Item.key (Located.value li), + entry <- (full, k) : [(base, k) | Just base <- [Internal.baseItemName full]] + ] diff --git a/source/library/Scrod/Convert/FromGhc/WarningParents.hs b/source/library/Scrod/Convert/FromGhc/WarningParents.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromGhc/WarningParents.hs @@ -0,0 +1,39 @@ +-- | Resolve warning parent relationships. +-- +-- Associates warning pragma items with their target declarations when +-- those declarations are defined in the same module. Uses the shared +-- parent association logic from 'Scrod.Convert.FromGhc.ParentAssociation'. +module Scrod.Convert.FromGhc.WarningParents where + +import qualified Data.Set as Set +import GHC.Hs.Decls () +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.Parser.Annotation as Annotation +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified Language.Haskell.Syntax as Syntax +import qualified Scrod.Convert.FromGhc.Internal as Internal +import qualified Scrod.Core.Location as Location + +-- | Extract the set of source locations that correspond to names inside +-- warning\/deprecated pragma declarations. +extractWarningLocations :: + SrcLoc.Located (Syntax.HsModule Ghc.GhcPs) -> + Set.Set Location.Location +extractWarningLocations = Internal.extractDeclLocations extractDeclWarningLocations + +-- | Extract warning name locations from a single declaration. +extractDeclWarningLocations :: + Syntax.LHsDecl Ghc.GhcPs -> + [Location.Location] +extractDeclWarningLocations lDecl = case SrcLoc.unLoc lDecl of + Syntax.WarningD _ (Syntax.Warnings _ warnDecls) -> + concatMap extractWarnDeclLocations warnDecls + _ -> [] + +-- | Extract name locations from a single warning declaration. +extractWarnDeclLocations :: + Syntax.LWarnDecl Ghc.GhcPs -> + [Location.Location] +extractWarnDeclLocations lWarnDecl = case SrcLoc.unLoc lWarnDecl of + Syntax.Warning _ names _ -> + concatMap (foldMap pure . Internal.locationFromSrcSpan . Annotation.getLocA) names diff --git a/source/library/Scrod/Convert/FromHaddock.hs b/source/library/Scrod/Convert/FromHaddock.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/FromHaddock.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | Convert Haddock's documentation AST (@DocH@) into Scrod's 'Doc.Doc' type. +-- +-- The Haddock parser produces @DocH Void Identifier@ nodes; this module +-- maps each node kind (paragraphs, code blocks, identifiers, hyperlinks, +-- examples, tables, etc.) to the corresponding @Scrod.Core.*@ constructors. +module Scrod.Convert.FromHaddock where + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text as Text +import qualified Data.Void as Void +import qualified Documentation.Haddock.Parser as Haddock +import qualified Documentation.Haddock.Types as Haddock +import qualified Scrod.Core.Definition as Definition +import qualified Scrod.Core.Doc as Doc +import qualified Scrod.Core.Example as Example +import qualified Scrod.Core.Header as Header +import qualified Scrod.Core.Hyperlink as Hyperlink +import qualified Scrod.Core.Identifier as Identifier +import qualified Scrod.Core.Level as Level +import qualified Scrod.Core.ModLink as ModLink +import qualified Scrod.Core.ModuleName as ModuleName +import qualified Scrod.Core.Namespace as Namespace +import qualified Scrod.Core.NumberedItem as NumberedItem +import qualified Scrod.Core.Picture as Picture +import qualified Scrod.Core.Table as Table +import qualified Scrod.Core.TableCell as TableCell +import qualified Scrod.Spec as Spec + +fromHaddock :: Haddock.DocH Void.Void Haddock.Identifier -> Doc.Doc +fromHaddock = convertDoc . Haddock.overIdentifier convertIdentifier + +convertIdentifier :: Haddock.Namespace -> String -> Maybe Identifier.Identifier +convertIdentifier ns str = + Just + Identifier.MkIdentifier + { Identifier.namespace = convertNamespace ns, + Identifier.value = stripQualifier $ Text.pack str + } + +-- | Strips the module qualifier from an identifier. For example, @A.b@ +-- becomes @b@ and @Data.List.map@ becomes @map@. +stripQualifier :: Text.Text -> Text.Text +stripQualifier t = + let (_, name) = Text.breakOnEnd (Text.singleton '.') t + in if Text.null name then t else name + +convertNamespace :: Haddock.Namespace -> Maybe Namespace.Namespace +convertNamespace ns = case ns of + Haddock.Value -> Just Namespace.Value + Haddock.Type -> Just Namespace.Type + Haddock.None -> Nothing + +convertDoc :: Haddock.DocH Void.Void Identifier.Identifier -> Doc.Doc +convertDoc doc = case doc of + Haddock.DocEmpty -> Doc.Empty + Haddock.DocAppend a b -> Doc.Append [convertDoc a, convertDoc b] + Haddock.DocString s -> Doc.String $ Text.pack s + Haddock.DocParagraph d -> Doc.Paragraph $ convertDoc d + Haddock.DocIdentifier i -> Doc.Identifier i + Haddock.DocModule ml -> + Doc.Module + ModLink.MkModLink + { ModLink.name = ModuleName.MkModuleName . Text.pack $ Haddock.modLinkName ml, + ModLink.label = convertDoc <$> Haddock.modLinkLabel ml + } + Haddock.DocWarning _ -> Doc.Empty -- `DocWarning` is never found in markup. + Haddock.DocEmphasis d -> Doc.Emphasis $ convertDoc d + Haddock.DocMonospaced d -> Doc.Monospaced $ convertDoc d + Haddock.DocBold d -> Doc.Bold $ convertDoc d + Haddock.DocUnorderedList ds -> Doc.UnorderedList $ fmap convertDoc ds + Haddock.DocOrderedList items -> Doc.OrderedList $ fmap (\(n, d) -> NumberedItem.MkNumberedItem {NumberedItem.index = n, NumberedItem.item = convertDoc d}) items + Haddock.DocDefList defs -> Doc.DefList $ fmap (\(t, d) -> Definition.MkDefinition {Definition.term = convertDoc t, Definition.definition = convertDoc d}) defs + Haddock.DocCodeBlock d -> Doc.CodeBlock $ convertDoc d + Haddock.DocHyperlink h -> + Doc.Hyperlink + Hyperlink.MkHyperlink + { Hyperlink.url = Text.pack $ Haddock.hyperlinkUrl h, + Hyperlink.label = convertDoc <$> Haddock.hyperlinkLabel h + } + Haddock.DocPic p -> + Doc.Pic + Picture.MkPicture + { Picture.uri = Text.pack $ Haddock.pictureUri p, + Picture.title = Text.pack <$> Haddock.pictureTitle p + } + Haddock.DocMathInline s -> Doc.MathInline $ Text.pack s + Haddock.DocMathDisplay s -> Doc.MathDisplay $ Text.pack s + Haddock.DocAName s -> Doc.AName $ Text.pack s + Haddock.DocProperty s -> Doc.Property $ Text.pack s + Haddock.DocExamples es -> + Doc.Examples . NonEmpty.fromList $ + fmap + ( \e -> + Example.MkExample + { Example.expression = Text.pack $ Haddock.exampleExpression e, + Example.result = Text.pack <$> Haddock.exampleResult e + } + ) + es + Haddock.DocHeader h -> + Doc.Header + Header.MkHeader + { Header.level = Level.fromInt $ Haddock.headerLevel h, + Header.title = convertDoc $ Haddock.headerTitle h + } + Haddock.DocTable t -> + Doc.Table + Table.MkTable + { Table.headerRows = convertTableRow <$> Haddock.tableHeaderRows t, + Table.bodyRows = convertTableRow <$> Haddock.tableBodyRows t + } + +convertTableRow :: Haddock.TableRow (Haddock.DocH Void.Void Identifier.Identifier) -> [TableCell.Cell Doc.Doc] +convertTableRow = fmap convertTableCell . Haddock.tableRowCells + +convertTableCell :: Haddock.TableCell (Haddock.DocH Void.Void Identifier.Identifier) -> TableCell.Cell Doc.Doc +convertTableCell cell = + TableCell.MkCell + { TableCell.colspan = fromIntegral $ Haddock.tableCellColspan cell, + TableCell.rowspan = fromIntegral $ Haddock.tableCellRowspan cell, + TableCell.contents = convertDoc $ Haddock.tableCellContents cell + } + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'fromHaddock $ do + Spec.it s "works with empty" $ do + Spec.assertEq s (fromHaddock Haddock.DocEmpty) Doc.Empty + + Spec.it s "works with append" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocAppend (Haddock.DocString "a") (Haddock.DocString "b") + let expected = Doc.Append [Doc.String $ Text.pack "a", Doc.String $ Text.pack "b"] + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with string" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocString "hello" + Spec.assertEq s (fromHaddock input) (Doc.String $ Text.pack "hello") + + Spec.it s "works with paragraph" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocParagraph (Haddock.DocString "text") + let expected = Doc.Paragraph (Doc.String $ Text.pack "text") + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with identifier" $ do + Spec.assertEq s (fromHaddock . Haddock._doc $ Haddock.parseParas Nothing "'x'") . Doc.Paragraph . Doc.Identifier . Identifier.MkIdentifier Nothing $ Text.pack "x" + + Spec.it s "works with value identifier" $ do + Spec.assertEq s (fromHaddock . Haddock._doc $ Haddock.parseParas Nothing "v'y'") . Doc.Paragraph . Doc.Identifier . Identifier.MkIdentifier (Just Namespace.Value) $ Text.pack "y" + + Spec.it s "works with type identifier" $ do + Spec.assertEq s (fromHaddock . Haddock._doc $ Haddock.parseParas Nothing "t'z'") . Doc.Paragraph . Doc.Identifier . Identifier.MkIdentifier (Just Namespace.Type) $ Text.pack "z" + + Spec.it s "strips module qualifier from identifier" $ do + Spec.assertEq s (fromHaddock . Haddock._doc $ Haddock.parseParas Nothing "'A.b'") . Doc.Paragraph . Doc.Identifier . Identifier.MkIdentifier Nothing $ Text.pack "b" + + Spec.it s "strips deep module qualifier from identifier" $ do + Spec.assertEq s (fromHaddock . Haddock._doc $ Haddock.parseParas Nothing "'Data.List.map'") . Doc.Paragraph . Doc.Identifier . Identifier.MkIdentifier Nothing $ Text.pack "map" + + Spec.it s "works with module" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocModule Haddock.ModLink {Haddock.modLinkName = "Data.List", Haddock.modLinkLabel = Nothing} + let expected = Doc.Module ModLink.MkModLink {ModLink.name = ModuleName.MkModuleName $ Text.pack "Data.List", ModLink.label = Nothing} + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with emphasis" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocEmphasis (Haddock.DocString "em") + let expected = Doc.Emphasis (Doc.String $ Text.pack "em") + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with monospaced" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocMonospaced (Haddock.DocString "code") + let expected = Doc.Monospaced (Doc.String $ Text.pack "code") + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with bold" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocBold (Haddock.DocString "strong") + let expected = Doc.Bold (Doc.String $ Text.pack "strong") + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with unordered list" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocUnorderedList [Haddock.DocString "item1", Haddock.DocString "item2"] + let expected = Doc.UnorderedList [Doc.String $ Text.pack "item1", Doc.String $ Text.pack "item2"] + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with ordered list" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocOrderedList [(1, Haddock.DocString "first"), (2, Haddock.DocString "second")] + let expected = + Doc.OrderedList + [ NumberedItem.MkNumberedItem {NumberedItem.index = 1, NumberedItem.item = Doc.String $ Text.pack "first"}, + NumberedItem.MkNumberedItem {NumberedItem.index = 2, NumberedItem.item = Doc.String $ Text.pack "second"} + ] + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with definition list" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocDefList [(Haddock.DocString "term", Haddock.DocString "def")] + let expected = + Doc.DefList + [Definition.MkDefinition {Definition.term = Doc.String $ Text.pack "term", Definition.definition = Doc.String $ Text.pack "def"}] + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with code block" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocCodeBlock (Haddock.DocString "x = 1") + let expected = Doc.CodeBlock (Doc.String $ Text.pack "x = 1") + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with hyperlink" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocHyperlink Haddock.Hyperlink {Haddock.hyperlinkUrl = "https://example.com", Haddock.hyperlinkLabel = Nothing} + let expected = Doc.Hyperlink Hyperlink.MkHyperlink {Hyperlink.url = Text.pack "https://example.com", Hyperlink.label = Nothing} + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with picture" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocPic Haddock.Picture {Haddock.pictureUri = "image.png", Haddock.pictureTitle = Just "title"} + let expected = Doc.Pic Picture.MkPicture {Picture.uri = Text.pack "image.png", Picture.title = Just $ Text.pack "title"} + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with math inline" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocMathInline "x^2" + Spec.assertEq s (fromHaddock input) (Doc.MathInline $ Text.pack "x^2") + + Spec.it s "works with math display" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocMathDisplay "\\sum" + Spec.assertEq s (fromHaddock input) (Doc.MathDisplay $ Text.pack "\\sum") + + Spec.it s "works with anchor name" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocAName "anchor" + Spec.assertEq s (fromHaddock input) (Doc.AName $ Text.pack "anchor") + + Spec.it s "works with property" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocProperty "prop> x + y" + Spec.assertEq s (fromHaddock input) (Doc.Property $ Text.pack "prop> x + y") + + Spec.it s "works with examples" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocExamples [Haddock.Example {Haddock.exampleExpression = "1 + 1", Haddock.exampleResult = ["2"]}] + let expected = Doc.Examples (Example.MkExample {Example.expression = Text.pack "1 + 1", Example.result = [Text.pack "2"]} NonEmpty.:| []) + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with header" $ do + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocHeader Haddock.Header {Haddock.headerLevel = 2, Haddock.headerTitle = Haddock.DocString "Section"} + let expected = Doc.Header Header.MkHeader {Header.level = Level.Two, Header.title = Doc.String $ Text.pack "Section"} + Spec.assertEq s (fromHaddock input) expected + + Spec.it s "works with table" $ do + let cell :: Haddock.TableCell (Haddock.DocH Void.Void Haddock.Identifier) + cell = Haddock.TableCell {Haddock.tableCellColspan = 1, Haddock.tableCellRowspan = 1, Haddock.tableCellContents = Haddock.DocString "data"} + let row :: Haddock.TableRow (Haddock.DocH Void.Void Haddock.Identifier) + row = Haddock.TableRow [cell] + let input :: Haddock.DocH Void.Void Haddock.Identifier + input = Haddock.DocTable Haddock.Table {Haddock.tableHeaderRows = [], Haddock.tableBodyRows = [row]} + let expectedCell = TableCell.MkCell {TableCell.colspan = 1, TableCell.rowspan = 1, TableCell.contents = Doc.String $ Text.pack "data"} + let expected = Doc.Table Table.MkTable {Table.headerRows = [], Table.bodyRows = [[expectedCell]]} + Spec.assertEq s (fromHaddock input) expected diff --git a/source/library/Scrod/Convert/ToHtml.hs b/source/library/Scrod/Convert/ToHtml.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/ToHtml.hs @@ -0,0 +1,886 @@ +{-# LANGUAGE MultilineStrings #-} + +-- | Render a 'Module.Module' as a self-contained HTML document. +-- +-- Produces a complete @\@ document with Bootstrap 5 and KaTeX +-- loaded from CDNs. The output uses the custom XML types in +-- @Scrod.Xml.*@ and can be serialized with 'Xml.encodeHtml'. +module Scrod.Convert.ToHtml (toHtml) where + +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Text as Text +import qualified Scrod.Core.Category as Category +import qualified Scrod.Core.Column as Column +import qualified Scrod.Core.Definition as Definition +import qualified Scrod.Core.Doc as Doc +import qualified Scrod.Core.Example as Example +import qualified Scrod.Core.Extension as Extension +import qualified Scrod.Core.Header as Header +import qualified Scrod.Core.Hyperlink as Hyperlink +import qualified Scrod.Core.Identifier as Identifier +import qualified Scrod.Core.Import as Import +import qualified Scrod.Core.Item as Item +import qualified Scrod.Core.ItemKey as ItemKey +import qualified Scrod.Core.ItemKind as ItemKind +import qualified Scrod.Core.ItemName as ItemName +import qualified Scrod.Core.Language as Language +import qualified Scrod.Core.Level as Level +import qualified Scrod.Core.Line as Line +import qualified Scrod.Core.Located as Located +import qualified Scrod.Core.Location as Location +import qualified Scrod.Core.ModLink as ModLink +import qualified Scrod.Core.Module as Module +import qualified Scrod.Core.ModuleName as ModuleName +import qualified Scrod.Core.Namespace as Namespace +import qualified Scrod.Core.NumberedItem as NumberedItem +import qualified Scrod.Core.PackageName as PackageName +import qualified Scrod.Core.Picture as Picture +import qualified Scrod.Core.Since as Since +import qualified Scrod.Core.Table as Table +import qualified Scrod.Core.TableCell as TableCell +import qualified Scrod.Core.Version as Version +import qualified Scrod.Core.Visibility as Visibility +import qualified Scrod.Core.Warning as Warning +import qualified Scrod.Xml.Content as Content +import qualified Scrod.Xml.Declaration as XmlDeclaration +import qualified Scrod.Xml.Document as Xml +import qualified Scrod.Xml.Element as Element +import qualified Scrod.Xml.Misc as Misc +import qualified Scrod.Xml.Name as XmlName + +t :: String -> Text.Text +t = Text.pack + +element :: + String -> + [(String, String)] -> + [Content.Content Element.Element] -> + Content.Content Element.Element +element x ys = Content.Element . Xml.element x (fmap (uncurry Xml.attribute) ys) + +-- | Convert a Module to a complete HTML document. +toHtml :: Module.Module -> Xml.Document +toHtml x = + Xml.MkDocument + { Xml.prolog = + [ Misc.Declaration . XmlDeclaration.MkDeclaration (XmlName.MkName $ t "doctype") $ t "html" + ], + Xml.root = + Xml.element + "html" + [] + [ headElement x, + bodyElement x + ] + } + +headElement :: Module.Module -> Content.Content Element.Element +headElement x = + element + "head" + [] + [ element "meta" [("charset", "utf-8")] [], + element + "meta" + [ ("name", "viewport"), + ("content", "width=device-width, initial-scale=1") + ] + [], + element "title" [] [Xml.text $ moduleTitle x], + element + "link" + [ ("rel", "stylesheet"), + ("href", "https://esm.sh/bootstrap@5.3.8/dist/css/bootstrap.min.css"), + ("integrity", "sha384-sRIl4kxILFvY47J16cr9ZwB07vP4J8+LH7qKQnuqkuIAvNWLzeN8tE5YBujZqJLB"), + ("crossorigin", "anonymous") + ] + [], + element + "link" + [ ("rel", "stylesheet"), + ("href", "https://esm.sh/katex@0.16.22/dist/katex.min.css"), + ("integrity", "sha384-5TcZemv2l/9On385z///+d7MSYlvIEw9FuZTIdZ14vJLqWphw7e7ZPuOiCHJcFCP"), + ("crossorigin", "anonymous") + ] + [], + element + "link" + [ ("rel", "modulepreload"), + ("href", "https://esm.sh/katex@0.16.22/dist/contrib/auto-render.min.js"), + ("integrity", "sha384-PV5j9Y/tL/HYr0HSxUY3afWRVHizeuTKLWTR+OwVlGHOBcN8jOZvCAS79+ULHoEU"), + ("crossorigin", "anonymous") + ] + [], + element + "script" + [] + [ Xml.raw . t $ + """ + const dark = matchMedia('(prefers-color-scheme: dark)'); + const setTheme = (x) => document.documentElement.dataset.bsTheme = x.matches ? 'dark' : 'light'; + setTheme(dark); + dark.addEventListener('change', setTheme); + import('https://esm.sh/katex@0.16.22/dist/contrib/auto-render.min.js').then((x) => x.default(document.body)); + """ + ] + ] + +moduleTitle :: Module.Module -> Text.Text +moduleTitle = + maybe (t "Documentation") (ModuleName.unwrap . Located.value) + . Module.name + +bodyElement :: Module.Module -> Content.Content Element.Element +bodyElement x = + element + "body" + [] + [ element + "div" + [("class", "container py-5")] + ( [element "h1" [("class", "mb-3 text-break")] [Xml.text $ moduleTitle x]] + <> foldMap (List.singleton . warningContent) (Module.warning x) + <> foldMap (List.singleton . sinceContent) (Module.since x) + <> docContents (Module.documentation x) + <> ( if Maybe.isNothing (Module.language x) && Map.null (Module.extensions x) + then [] + else [element "section" [("class", "my-3")] . extensionsContents (Module.language x) $ Module.extensions x] + ) + <> ( if null (Module.imports x) + then [] + else [element "section" [("class", "my-3")] . importsContents $ Module.imports x] + ) + <> [element "section" [("class", "my-3")] $ declarationsContents (Module.items x)] + <> [footerContent x] + ) + ] + +warningContent :: Warning.Warning -> Content.Content Element.Element +warningContent x = + element + "div" + [ ("class", "alert alert-warning"), + ("role", "alert") + ] + [ element "strong" [] [Xml.string "Warning"], + Xml.string " (", + element "span" [("class", "text-break")] [Xml.text . Category.unwrap $ Warning.category x], + Xml.string "): ", + element "span" [("class", "text-break")] [Xml.text $ Warning.value x] + ] + +sinceContent :: Since.Since -> Content.Content Element.Element +sinceContent x = + element + "div" + [ ("class", "alert alert-info"), + ("role", "alert") + ] + [ element "strong" [] [Xml.string "Since"], + Xml.string ": ", + element "span" [("class", "text-break")] [Xml.text $ sinceToText x] + ] + +versionToText :: Version.Version -> Text.Text +versionToText = t . List.intercalate "." . NonEmpty.toList . fmap show . Version.unwrap + +sinceToText :: Since.Since -> Text.Text +sinceToText x = + foldMap ((<> t "-") . PackageName.unwrap) (Since.package x) + <> versionToText (Since.version x) + +-- Footer section + +footerContent :: Module.Module -> Content.Content Element.Element +footerContent m = + element + "footer" + [("class", "text-secondary")] + [ Xml.string "Generated by ", + element + "a" + [("href", "https://github.com/tfausak/scrod")] + [Xml.string "Scrod"], + Xml.string " version ", + element "span" [("class", "text-break")] [Xml.text . versionToText $ Module.version m], + Xml.string "." + ] + +-- Imports section + +importsContents :: [Import.Import] -> [Content.Content Element.Element] +importsContents imports = + [ element "h2" [] [Xml.string "Imports"], + case length imports of + 0 -> Xml.string "None." + count -> + element + "details" + [] + [ element + "summary" + [] + [ Xml.string "Show/hide ", + Xml.string $ pluralize count "import", + Xml.string "." + ], + element "ul" [] . fmap importContent $ List.sortOn Import.name imports + ] + ] + +importContent :: Import.Import -> Content.Content Element.Element +importContent x = + element + "li" + [] + [ element "span" [("class", "text-break")] [Xml.text . ModuleName.unwrap $ Import.name x], + case Import.package x of + Nothing -> Xml.string "" + Just p -> + element + "span" + [("class", "text-body-secondary")] + [ Xml.string " from ", + element "span" [("class", "text-break")] [Xml.text $ PackageName.unwrap p] + ], + case Import.alias x of + Nothing -> Xml.string "" + Just a -> + element + "span" + [("class", "text-body-secondary")] + [ Xml.string " as ", + element "span" [("class", "text-break")] [Xml.text $ ModuleName.unwrap a] + ] + ] + +-- Extensions section + +extensionsContents :: + Maybe Language.Language -> + Map.Map Extension.Extension Bool -> + [Content.Content Element.Element] +extensionsContents language extensions = + [ element "h2" [] [Xml.string "Extensions"], + case length language + length extensions of + 0 -> Xml.string "None." + count -> + element + "details" + [] + [ element + "summary" + [] + [ Xml.string "Show/hide ", + Xml.string $ pluralize count "extension", + Xml.string "." + ], + element "ul" [] + . fmap (uncurry extensionContent) + $ foldMap (\x -> [(Language.unwrap x, True)]) language + <> Map.toList (Map.mapKeys Extension.unwrap extensions) + ] + ] + +extensionContent :: Text.Text -> Bool -> Content.Content Element.Element +extensionContent x y = + element + "li" + [] + [ element + "a" + [ ("class", "link-underline link-underline-opacity-25 text-break"), + ("href", extensionUrl x) + ] + [ Xml.string $ if y then "" else "No", + Xml.text x + ] + ] + +pluralize :: Int -> String -> String +pluralize count singular = pluralizeWith count singular (singular <> "s") + +pluralizeWith :: Int -> String -> String -> String +pluralizeWith count singular plural = + show count <> " " <> if count == 1 then singular else plural + +extensionUrl :: Text.Text -> String +extensionUrl name = + ghcUserGuideBaseUrl <> Map.findWithDefault "exts/table.html" name extensionUrlPaths + +ghcUserGuideBaseUrl :: String +ghcUserGuideBaseUrl = "https://downloads.haskell.org/ghc/latest/docs/users_guide/" + +extensionUrlPaths :: Map.Map Text.Text String +extensionUrlPaths = + Map.mapKeys t . Map.fromList $ + [ ("AllowAmbiguousTypes", "exts/ambiguous_types.html#extension-AllowAmbiguousTypes"), + ("ApplicativeDo", "exts/applicative_do.html#extension-ApplicativeDo"), + ("Arrows", "exts/arrows.html#extension-Arrows"), + ("BangPatterns", "exts/strict.html#extension-BangPatterns"), + ("BinaryLiterals", "exts/binary_literals.html#extension-BinaryLiterals"), + ("BlockArguments", "exts/block_arguments.html#extension-BlockArguments"), + ("CApiFFI", "exts/ffi.html#extension-CApiFFI"), + ("ConstrainedClassMethods", "exts/constrained_class_methods.html#extension-ConstrainedClassMethods"), + ("ConstraintKinds", "exts/constraint_kind.html#extension-ConstraintKinds"), + ("Cpp", "phases.html#extension-CPP"), + ("CUSKs", "exts/poly_kinds.html#extension-CUSKs"), + ("DataKinds", "exts/data_kinds.html#extension-DataKinds"), + ("DatatypeContexts", "exts/datatype_contexts.html#extension-DatatypeContexts"), + ("DeepSubsumption", "exts/rank_polymorphism.html#extension-DeepSubsumption"), + ("DefaultSignatures", "exts/default_signatures.html#extension-DefaultSignatures"), + ("DeriveAnyClass", "exts/derive_any_class.html#extension-DeriveAnyClass"), + ("DeriveDataTypeable", "exts/deriving_extra.html#extension-DeriveDataTypeable"), + ("DeriveFoldable", "exts/deriving_extra.html#extension-DeriveFoldable"), + ("DeriveFunctor", "exts/deriving_extra.html#extension-DeriveFunctor"), + ("DeriveGeneric", "exts/generics.html#extension-DeriveGeneric"), + ("DeriveLift", "exts/deriving_extra.html#extension-DeriveLift"), + ("DeriveTraversable", "exts/deriving_extra.html#extension-DeriveTraversable"), + ("DerivingStrategies", "exts/deriving_strategies.html#extension-DerivingStrategies"), + ("DerivingVia", "exts/deriving_via.html#extension-DerivingVia"), + ("DisambiguateRecordFields", "exts/disambiguate_record_fields.html#extension-DisambiguateRecordFields"), + ("DoAndIfThenElse", "exts/doandifthenelse.html#extension-DoAndIfThenElse"), + ("DuplicateRecordFields", "exts/duplicate_record_fields.html#extension-DuplicateRecordFields"), + ("EmptyCase", "exts/empty_case.html#extension-EmptyCase"), + ("EmptyDataDecls", "exts/nullary_types.html#extension-EmptyDataDecls"), + ("EmptyDataDeriving", "exts/empty_data_deriving.html#extension-EmptyDataDeriving"), + ("ExistentialQuantification", "exts/existential_quantification.html#extension-ExistentialQuantification"), + ("ExplicitForAll", "exts/explicit_forall.html#extension-ExplicitForAll"), + ("ExplicitLevelImports", "exts/template_haskell.html#extension-ExplicitLevelImports"), + ("ExplicitNamespaces", "exts/explicit_namespaces.html#extension-ExplicitNamespaces"), + ("ExtendedDefaultRules", "ghci.html#extension-ExtendedDefaultRules"), + ("ExtendedLiterals", "exts/extended_literals.html#extension-ExtendedLiterals"), + ("FieldSelectors", "exts/field_selectors.html#extension-FieldSelectors"), + ("FlexibleContexts", "exts/flexible_contexts.html#extension-FlexibleContexts"), + ("FlexibleInstances", "exts/instances.html#extension-FlexibleInstances"), + ("ForeignFunctionInterface", "exts/ffi.html#extension-ForeignFunctionInterface"), + ("FunctionalDependencies", "exts/functional_dependencies.html#extension-FunctionalDependencies"), + ("GADTs", "exts/gadt.html#extension-GADTs"), + ("GADTSyntax", "exts/gadt_syntax.html#extension-GADTSyntax"), + ("GeneralisedNewtypeDeriving", "exts/newtype_deriving.html#extension-GeneralisedNewtypeDeriving"), + ("GHC2021", "exts/control.html#extension-GHC2021"), + ("GHC2024", "exts/control.html#extension-GHC2024"), + ("GHCForeignImportPrim", "exts/ffi.html#extension-GHCForeignImportPrim"), + ("Haskell2010", "exts/control.html#extension-Haskell2010"), + ("Haskell98", "exts/control.html#extension-Haskell98"), + ("HexFloatLiterals", "exts/hex_float_literals.html#extension-HexFloatLiterals"), + ("ImplicitParams", "exts/implicit_parameters.html#extension-ImplicitParams"), + ("ImplicitPrelude", "exts/rebindable_syntax.html#extension-ImplicitPrelude"), + ("ImplicitStagePersistence", "exts/template_haskell.html#extension-ImplicitStagePersistence"), + ("ImportQualifiedPost", "exts/import_qualified_post.html#extension-ImportQualifiedPost"), + ("ImpredicativeTypes", "exts/impredicative_types.html#extension-ImpredicativeTypes"), + ("IncoherentInstances", "exts/instances.html#extension-IncoherentInstances"), + ("InstanceSigs", "exts/instances.html#extension-InstanceSigs"), + ("InterruptibleFFI", "exts/ffi.html#extension-InterruptibleFFI"), + ("KindSignatures", "exts/kind_signatures.html#extension-KindSignatures"), + ("LambdaCase", "exts/lambda_case.html#extension-LambdaCase"), + ("LexicalNegation", "exts/lexical_negation.html#extension-LexicalNegation"), + ("LiberalTypeSynonyms", "exts/liberal_type_synonyms.html#extension-LiberalTypeSynonyms"), + ("LinearTypes", "exts/linear_types.html#extension-LinearTypes"), + ("ListTuplePuns", "exts/data_kinds.html#extension-ListTuplePuns"), + ("MagicHash", "exts/magic_hash.html#extension-MagicHash"), + ("MonadComprehensions", "exts/monad_comprehensions.html#extension-MonadComprehensions"), + ("MonoLocalBinds", "exts/let_generalisation.html#extension-MonoLocalBinds"), + ("MonomorphismRestriction", "exts/monomorphism.html#extension-MonomorphismRestriction"), + ("MultilineStrings", "exts/multiline_strings.html#extension-MultilineStrings"), + ("MultiParamTypeClasses", "exts/multi_param_type_classes.html#extension-MultiParamTypeClasses"), + ("MultiWayIf", "exts/multiway_if.html#extension-MultiWayIf"), + ("NamedDefaults", "exts/named_defaults.html#extension-NamedDefaults"), + ("NamedFieldPuns", "exts/record_puns.html#extension-NamedFieldPuns"), + ("NamedWildCards", "exts/partial_type_signatures.html#extension-NamedWildCards"), + ("NegativeLiterals", "exts/negative_literals.html#extension-NegativeLiterals"), + ("NondecreasingIndentation", "bugs.html#extension-NondecreasingIndentation"), + ("NPlusKPatterns", "exts/nk_patterns.html#extension-NPlusKPatterns"), + ("NullaryTypeClasses", "exts/multi_param_type_classes.html#extension-NullaryTypeClasses"), + ("NumDecimals", "exts/num_decimals.html#extension-NumDecimals"), + ("NumericUnderscores", "exts/numeric_underscores.html#extension-NumericUnderscores"), + ("OrPatterns", "exts/or_patterns.html#extension-OrPatterns"), + ("OverlappingInstances", "exts/instances.html#extension-OverlappingInstances"), + ("OverloadedLabels", "exts/overloaded_labels.html#extension-OverloadedLabels"), + ("OverloadedLists", "exts/overloaded_lists.html#extension-OverloadedLists"), + ("OverloadedRecordDot", "exts/overloaded_record_dot.html#extension-OverloadedRecordDot"), + ("OverloadedRecordUpdate", "exts/overloaded_record_update.html#extension-OverloadedRecordUpdate"), + ("OverloadedStrings", "exts/overloaded_strings.html#extension-OverloadedStrings"), + ("PackageImports", "exts/package_qualified_imports.html#extension-PackageImports"), + ("ParallelListComp", "exts/parallel_list_comprehensions.html#extension-ParallelListComp"), + ("PartialTypeSignatures", "exts/partial_type_signatures.html#extension-PartialTypeSignatures"), + ("PatternGuards", "exts/pattern_guards.html#extension-PatternGuards"), + ("PatternSynonyms", "exts/pattern_synonyms.html#extension-PatternSynonyms"), + ("PolyKinds", "exts/poly_kinds.html#extension-PolyKinds"), + ("PostfixOperators", "exts/rebindable_syntax.html#extension-PostfixOperators"), + ("QualifiedDo", "exts/qualified_do.html#extension-QualifiedDo"), + ("QuantifiedConstraints", "exts/quantified_constraints.html#extension-QuantifiedConstraints"), + ("QuasiQuotes", "exts/template_haskell.html#extension-QuasiQuotes"), + ("Rank2Types", "exts/rank_polymorphism.html#extension-Rank2Types"), + ("RankNTypes", "exts/rank_polymorphism.html#extension-RankNTypes"), + ("RebindableSyntax", "exts/rebindable_syntax.html#extension-RebindableSyntax"), + ("RecordWildCards", "exts/record_wildcards.html#extension-RecordWildCards"), + ("RecursiveDo", "exts/recursive_do.html#extension-RecursiveDo"), + ("RequiredTypeArguments", "exts/required_type_arguments.html#extension-RequiredTypeArguments"), + ("RoleAnnotations", "exts/roles.html#extension-RoleAnnotations"), + ("Safe", "exts/safe_haskell.html#extension-Safe"), + ("ScopedTypeVariables", "exts/scoped_type_variables.html#extension-ScopedTypeVariables"), + ("StandaloneDeriving", "exts/standalone_deriving.html#extension-StandaloneDeriving"), + ("StandaloneKindSignatures", "exts/poly_kinds.html#extension-StandaloneKindSignatures"), + ("StarIsType", "exts/poly_kinds.html#extension-StarIsType"), + ("StaticPointers", "exts/static_pointers.html#extension-StaticPointers"), + ("Strict", "exts/strict.html#extension-Strict"), + ("StrictData", "exts/strict.html#extension-StrictData"), + ("TemplateHaskell", "exts/template_haskell.html#extension-TemplateHaskell"), + ("TemplateHaskellQuotes", "exts/template_haskell.html#extension-TemplateHaskellQuotes"), + ("TraditionalRecordSyntax", "exts/traditional_record_syntax.html#extension-TraditionalRecordSyntax"), + ("TransformListComp", "exts/generalised_list_comprehensions.html#extension-TransformListComp"), + ("Trustworthy", "exts/safe_haskell.html#extension-Trustworthy"), + ("TupleSections", "exts/tuple_sections.html#extension-TupleSections"), + ("TypeAbstractions", "exts/type_abstractions.html#extension-TypeAbstractions"), + ("TypeApplications", "exts/type_applications.html#extension-TypeApplications"), + ("TypeData", "exts/type_data.html#extension-TypeData"), + ("TypeFamilies", "exts/type_families.html#extension-TypeFamilies"), + ("TypeFamilyDependencies", "exts/type_families.html#extension-TypeFamilyDependencies"), + ("TypeInType", "exts/poly_kinds.html#extension-TypeInType"), + ("TypeOperators", "exts/type_operators.html#extension-TypeOperators"), + ("TypeSynonymInstances", "exts/instances.html#extension-TypeSynonymInstances"), + ("UnboxedSums", "exts/primitives.html#extension-UnboxedSums"), + ("UnboxedTuples", "exts/primitives.html#extension-UnboxedTuples"), + ("UndecidableInstances", "exts/instances.html#extension-UndecidableInstances"), + ("UndecidableSuperClasses", "exts/undecidable_super_classes.html#extension-UndecidableSuperClasses"), + ("UnicodeSyntax", "exts/unicode_syntax.html#extension-UnicodeSyntax"), + ("UnliftedDatatypes", "exts/primitives.html#extension-UnliftedDatatypes"), + ("UnliftedFFITypes", "exts/ffi.html#extension-UnliftedFFITypes"), + ("UnliftedNewtypes", "exts/primitives.html#extension-UnliftedNewtypes"), + ("Unsafe", "exts/safe_haskell.html#extension-Unsafe"), + ("ViewPatterns", "exts/view_patterns.html#extension-ViewPatterns") + ] + +-- Declarations section + +declarationsContents :: [Located.Located Item.Item] -> [Content.Content Element.Element] +declarationsContents items = + let isNonUnexported li = Item.visibility (Located.value li) /= Visibility.Unexported + addChild li acc = case Item.parentKey (Located.value li) of + Nothing -> acc + Just pk -> Map.insertWith (<>) (ItemKey.unwrap pk) [li] acc + childrenMap = foldr addChild Map.empty items + topLevelItems = filter (Maybe.isNothing . Item.parentKey . Located.value) items + itemNatKey = ItemKey.unwrap . Item.key . Located.value + isInlineDocChunk li = + let item = Located.value li + in Item.kind item == ItemKind.DocumentationChunk + && Maybe.isNothing (Item.name item) + renderUnresolvedExport li = + let item = Located.value li + namePrefix = maybe "" ((<> " ") . Text.unpack) (Item.signature item) + badge = case Item.signature item of + Just sig + | sig == Text.pack "module" -> + [ element + "div" + [("class", "mx-1")] + [element "span" [("class", "badge text-bg-secondary")] [Xml.string "re-export"]] + ] + _ -> [] + name = foldMap ItemName.unwrap (Item.name item) + in [ element + "div" + [("class", "card my-3")] + [ element + "div" + [("class", "card-header")] + $ element "code" [("class", "text-break")] [Xml.string namePrefix, Xml.text name] + : badge + ] + ] + renderItemWithChildren li = + let children = Map.findWithDefault [] (itemNatKey li) childrenMap + visibleChildren = + if Item.visibility (Located.value li) == Visibility.Unexported + then children + else filter (\c -> Item.visibility (Located.value c) /= Visibility.Unexported) children + isArgument c = Item.kind (Located.value c) == ItemKind.Argument + (argChildren, otherChildren) = List.partition isArgument visibleChildren + in [ itemContent + li + (foldMap renderItemWithChildren argChildren) + (foldMap renderItemWithChildren otherChildren) + ] + -- Render a top-level item. DocumentationChunk items without a + -- name render their documentation inline (for section headings and + -- export docs). UnresolvedExport items render with a namespace + -- prefix and optional re-export badge. All other items render as + -- cards. + renderTopLevelItem li + | isInlineDocChunk li = docContents (Item.documentation (Located.value li)) + | Item.kind (Located.value li) == ItemKind.UnresolvedExport = renderUnresolvedExport li + | otherwise = renderItemWithChildren li + in element "h2" [] [Xml.string "Declarations"] + : if null topLevelItems + then [Xml.string "None."] + else + let (nonUnexported, unexported) = List.partition isNonUnexported topLevelItems + in foldMap renderTopLevelItem nonUnexported + <> if null unexported + then [] + else + element "h3" [] [Xml.string "Unexported"] + : foldMap renderTopLevelItem unexported + +itemContent :: Located.Located Item.Item -> [Content.Content Element.Element] -> [Content.Content Element.Element] -> Content.Content Element.Element +itemContent item argChildren otherChildren = + let kind = Item.kind $ Located.value item + isEarly = case kind of + ItemKind.DataType -> True + ItemKind.Newtype -> True + ItemKind.TypeData -> True + ItemKind.TypeSynonym -> True + ItemKind.Class -> True + _ -> False + prefix = t $ if isEarly then "" else ":: " + signature = case Item.signature $ Located.value item of + Nothing -> [] + Just sig -> + [ element + "div" + [("class", "mx-2"), ("style", "min-width: 0")] + [ element + "code" + [("class", "text-break text-secondary"), ("style", "white-space: pre-wrap")] + [Xml.text $ prefix <> sig] + ] + ] + earlySignature = + if isEarly then signature else [] + lateSignature = + if isEarly || kind == ItemKind.Warning then [] else signature + badgeColor = case kind of + ItemKind.Annotation -> "text-bg-info" + ItemKind.CompletePragma -> "text-bg-info" + ItemKind.DefaultMethodSignature -> "text-bg-info" + ItemKind.FixitySignature -> "text-bg-info" + ItemKind.InlineSignature -> "text-bg-info" + ItemKind.MinimalPragma -> "text-bg-info" + ItemKind.Rule -> "text-bg-info" + ItemKind.SpecialiseSignature -> "text-bg-info" + ItemKind.Warning -> "text-bg-warning" + _ -> "text-bg-secondary" + cardBody = + let contents = case kind of + ItemKind.Warning -> + let category = Maybe.fromMaybe (Text.pack "deprecations") (Item.signature $ Located.value item) + in [ element + "div" + [ ("class", "alert alert-warning mb-0"), + ("role", "alert") + ] + [ element "strong" [] [Xml.string "Warning"], + Xml.string " (", + element "span" [("class", "text-break")] [Xml.text category], + Xml.string "): ", + element "span" [("class", "text-break")] (docContents (Item.documentation $ Located.value item)) + ] + ] + _ -> + foldMap (List.singleton . sinceContent) (Item.since $ Located.value item) + <> argChildren + <> docContents (Item.documentation $ Located.value item) + <> otherChildren + in if all Content.isEmpty contents + then [] + else + [ element + "div" + [("class", "card-body")] + contents + ] + in element + "div" + [ ("class", "card my-3"), + ("id", "item-" <> (show . ItemKey.unwrap . Item.key $ Located.value item)) + ] + $ [ element + "div" + [("class", "align-items-start card-header d-flex")] + $ [ element + "div" + [] + ( case Item.name $ Located.value item of + Nothing -> [] + Just n -> [element "code" [("class", "text-break")] [Xml.text $ ItemName.unwrap n]] + ) + ] + <> earlySignature + <> [ element + "div" + [("class", "mx-1")] + [ element "span" [("class", "badge " <> badgeColor)] [Xml.string $ kindToString kind] + ] + ] + <> lateSignature + <> [ element + "div" + [("class", "ms-auto")] + [ element + "button" + [ ("class", "btn btn-outline-secondary btn-sm"), + ("data-col", show . Column.unwrap . Location.column $ Located.location item), + ("data-line", show . Line.unwrap . Location.line $ Located.location item), + ("type", "button") + ] + [ Xml.string . show . Line.unwrap . Location.line $ Located.location item, + Xml.string ":", + Xml.string . show . Column.unwrap . Location.column $ Located.location item + ] + ] + ] + ] + <> cardBody + +kindToString :: ItemKind.ItemKind -> String +kindToString x = case x of + ItemKind.Annotation -> "annotation" + ItemKind.Argument -> "argument" + ItemKind.Class -> "class" + ItemKind.ClassInstance -> "instance" + ItemKind.ClassMethod -> "method" + ItemKind.ClosedTypeFamily -> "type family" + ItemKind.CompletePragma -> "complete" + ItemKind.DataConstructor -> "constructor" + ItemKind.DataFamily -> "data family" + ItemKind.DataFamilyInstance -> "data instance" + ItemKind.DataType -> "data" + ItemKind.Default -> "default" + ItemKind.DefaultMethodSignature -> "default" + ItemKind.DerivedInstance -> "instance" + ItemKind.DocumentationChunk -> "doc chunk" + ItemKind.FixitySignature -> "fixity" + ItemKind.ForeignExport -> "foreign export" + ItemKind.ForeignImport -> "foreign import" + ItemKind.Function -> "function" + ItemKind.Operator -> "operator" + ItemKind.GADTConstructor -> "constructor" + ItemKind.InlineSignature -> "inline" + ItemKind.MinimalPragma -> "minimal" + ItemKind.Newtype -> "newtype" + ItemKind.OpenTypeFamily -> "type family" + ItemKind.PatternBinding -> "pattern" + ItemKind.PatternSynonym -> "pattern" + ItemKind.RecordField -> "field" + ItemKind.ReturnType -> "return" + ItemKind.RoleAnnotation -> "role" + ItemKind.Rule -> "rule" + ItemKind.SpecialiseSignature -> "specialise" + ItemKind.Splice -> "splice" + ItemKind.StandaloneDeriving -> "instance" + ItemKind.StandaloneKindSig -> "kind" + ItemKind.TypeData -> "type data" + ItemKind.TypeFamilyInstance -> "type instance" + ItemKind.TypeSynonym -> "type" + ItemKind.UnresolvedExport -> "export" + ItemKind.Warning -> "warning" + +-- Doc to HTML conversion + +docContents :: Doc.Doc -> [Content.Content Element.Element] +docContents doc = case doc of + Doc.Empty -> [] + Doc.Append xs -> foldMap docContents xs + Doc.String x -> [element "span" [("class", "text-break")] [Xml.text x]] + Doc.Paragraph x -> [element "p" [] $ docContents x] + Doc.Identifier x -> [identifierContent x] + Doc.Module x -> [modLinkContent x] + Doc.Emphasis x -> [element "em" [] $ docContents x] + Doc.Monospaced x -> [element "code" [] $ docContents x] + Doc.Bold x -> [element "strong" [] $ docContents x] + Doc.UnorderedList xs -> [element "ul" [] $ fmap (element "li" [] . docContents) xs] + Doc.OrderedList xs -> [element "ol" [] $ fmap orderedListItemContent xs] + Doc.DefList xs -> [element "dl" [] $ foldMap definitionContents xs] + Doc.CodeBlock x -> [codeBlockContent x] + Doc.Hyperlink x -> hyperlinkContents x + Doc.Pic x -> [pictureContent x] + Doc.MathInline x -> [Xml.string "\\(", Xml.text x, Xml.string "\\)"] + Doc.MathDisplay x -> [Xml.string "\\[", Xml.text x, Xml.string "\\]"] + Doc.AName x -> [element "a" [("id", Text.unpack x)] []] + Doc.Property x -> [propertyContent x] + Doc.Examples xs -> exampleContent <$> NonEmpty.toList xs + Doc.Header x -> [headerContent x] + Doc.Table x -> [tableContent x] + +definitionContents :: Definition.Definition Doc.Doc -> [Content.Content Element.Element] +definitionContents x = + [ element "dt" [] . docContents $ Definition.term x, + element "dd" [] . docContents $ Definition.definition x + ] + +codeBlockContent :: Doc.Doc -> Content.Content Element.Element +codeBlockContent x = + element + "div" + [("class", "card my-3")] + [ element + "div" + [("class", "card-body")] + [ element + "pre" + [("class", "mb-0")] + [ element "code" [] $ docContents x + ] + ] + ] + +orderedListItemContent :: NumberedItem.NumberedItem Doc.Doc -> Content.Content Element.Element +orderedListItemContent x = element "li" [("value", show $ NumberedItem.index x)] . docContents $ NumberedItem.item x + +propertyContent :: Text.Text -> Content.Content Element.Element +propertyContent x = + element + "div" + [("class", "card my-3")] + [ element + "div" + [("class", "card-header")] + [ element "strong" [] [Xml.string "Property"] + ], + element + "div" + [("class", "card-body")] + [ element + "pre" + [("class", "mb-0")] + [ element "code" [("class", "text-break")] [Xml.text $ Text.stripEnd x] + ] + ] + ] + +identifierContent :: Identifier.Identifier -> Content.Content Element.Element +identifierContent x = + element + "span" + [] + [ element "code" [("class", "text-break")] [Xml.text $ Identifier.value x], + case Identifier.namespace x of + Nothing -> Xml.string "" + Just ns -> + element + "span" + [("class", "text-body-secondary")] + [ Xml.string " (", + Xml.string $ case ns of + Namespace.Value -> "value" + Namespace.Type -> "type", + Xml.string ")" + ] + ] + +modLinkContent :: ModLink.ModLink Doc.Doc -> Content.Content Element.Element +modLinkContent x = + element "code" [("class", "text-break")] + . maybe [Xml.text . ModuleName.unwrap $ ModLink.name x] docContents + $ ModLink.label x + +hyperlinkContents :: Hyperlink.Hyperlink Doc.Doc -> [Content.Content Element.Element] +hyperlinkContents x = + if isSafeUrl (Hyperlink.url x) + then + [ element + "a" + [ ("class", "text-break"), + ("href", Text.unpack $ Hyperlink.url x), + ("rel", "nofollow") + ] + . maybe [Xml.text $ Hyperlink.url x] docContents + $ Hyperlink.label x + ] + else + let url = + element + "code" + [("class", "text-break")] + [ Xml.string "<", + Xml.text $ Hyperlink.url x, + Xml.string ">" + ] + in case Hyperlink.label x of + Nothing -> [url] + Just doc -> docContents doc <> [Xml.string " ", url] + +isSafeUrl :: Text.Text -> Bool +isSafeUrl url = + let lower = Text.toLower url + in any + (`Text.isPrefixOf` lower) + [ t "https:", + t "http:", + t "mailto:", + t "//", + t "#" + ] + +pictureContent :: Picture.Picture -> Content.Content Element.Element +pictureContent x = + element + "img" + ( ("alt", maybe "" Text.unpack $ Picture.title x) + : ("src", Text.unpack $ Picture.uri x) + : foldMap (List.singleton . (,) "title" . Text.unpack) (Picture.title x) + ) + [] + +exampleContent :: Example.Example -> Content.Content Element.Element +exampleContent x = + element + "div" + [("class", "card my-3")] + [ element + "div" + [("class", "card-header")] + [ element "strong" [] [Xml.string "Example"] + ], + element + "div" + [("class", "card-body")] + [ element + "pre" + [("class", "mb-0")] + [ element + "code" + [("class", "text-break")] + [ Xml.string ">>> ", + element "strong" [] [Xml.text $ Example.expression x], + Xml.text . foldMap (t "\n" <>) $ Example.result x + ] + ] + ] + ] + +headerContent :: Header.Header Doc.Doc -> Content.Content Element.Element +headerContent x = + element (levelToName $ Header.level x) [] . docContents $ Header.title x + +levelToName :: Level.Level -> String +levelToName x = case x of + Level.One -> "h1" + Level.Two -> "h2" + Level.Three -> "h3" + Level.Four -> "h4" + Level.Five -> "h5" + Level.Six -> "h6" + +tableContent :: Table.Table Doc.Doc -> Content.Content Element.Element +tableContent tbl = + let tr n = element "tr" [] . fmap (td n) + td n c = + element + n + [ ("colspan", show $ TableCell.colspan c), + ("rowspan", show $ TableCell.rowspan c) + ] + . docContents + $ TableCell.contents c + in element + "table" + [("class", "my-3 table table-bordered table-striped")] + [ element "thead" [] . fmap (tr "th") $ Table.headerRows tbl, + element "tbody" [] . fmap (tr "td") $ Table.bodyRows tbl + ] diff --git a/source/library/Scrod/Convert/ToJsonSchema.hs b/source/library/Scrod/Convert/ToJsonSchema.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Convert/ToJsonSchema.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | Generate a JSON Schema describing the output of 'ToJson.toJson'. +-- +-- Produces a JSON Schema (2020-12) as a 'Json.Value'. The root schema is +-- generated from the 'ToSchema.ToSchema' type class instance for +-- 'Module.Module', with root-level metadata and accumulated @$defs@ +-- prepended and appended. +module Scrod.Convert.ToJsonSchema where + +import qualified Data.Proxy as Proxy +import qualified Scrod.Core.Module as Module +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Parsec as Parsec +import qualified Scrod.Json.Object as Object +import qualified Scrod.Json.Value as Json +import qualified Scrod.JsonPointer.Evaluate as Pointer +import qualified Scrod.JsonPointer.Pointer as Pointer +import qualified Scrod.Schema as ToSchema +import qualified Scrod.Spec as Spec + +-- | Schema for the top-level module object. +-- +-- Runs the 'ToSchema.ToSchema' instance for 'Module.Module' in +-- 'ToSchema.SchemaM', extracts the resulting object schema, and wraps +-- it with JSON Schema metadata (@$schema@, @$id@, @title@, +-- @description@) and any accumulated @$defs@. +toJsonSchema :: Json.Value +toJsonSchema = + let (schema, defs) = + ToSchema.runSchemaM $ + ToSchema.toSchema + (Proxy.Proxy :: Proxy.Proxy Module.Module) + in case ToSchema.unwrap schema of + Json.Object (Object.MkObject bodyPairs) -> + Json.Object . Object.MkObject $ + [ Json.pair "$schema" (Json.string "https://json-schema.org/draft/2020-12/schema"), + Json.pair "$id" (Json.string "https://scrod.fyi/schema.json"), + Json.pair "title" (Json.string "Scrod"), + Json.pair "description" (Json.string "JSON output of the Scrod Haskell documentation tool.") + ] + <> bodyPairs + <> [Json.pair "$defs" (Json.object defs)] + _ -> Json.null + +-- * Tests + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'toJsonSchema $ do + Spec.it s "round-trips through JSON encode/decode" $ do + let encoded = Builder.toString $ Json.encode toJsonSchema + Spec.assertNe s (Parsec.parseString Json.decode encoded) Nothing + + Spec.it s "has the expected $schema" $ do + at s "/$schema" $ Json.string "https://json-schema.org/draft/2020-12/schema" + + Spec.it s "has the expected title" $ do + at s "/title" $ Json.string "Scrod" + + Spec.it s "has type object" $ do + at s "/type" $ Json.string "object" + + Spec.it s "defines doc" $ do + at s "/$defs/doc/oneOf" Json.null + + Spec.it s "has version property" $ do + at s "/properties/version/type" $ Json.string "array" + + Spec.it s "has items property" $ do + at s "/properties/items/type" $ Json.string "array" + +-- | Assert that a JSON Pointer path resolves to the expected value in the +-- schema. +at :: (Applicative m) => Spec.Spec m n -> String -> Json.Value -> m () +at s path expected = do + let json = toJsonSchema + case Parsec.parseString Pointer.decode path of + Nothing -> Spec.assertFailure s $ "invalid pointer: " <> path + Just pointer -> case Pointer.evaluate pointer json of + Nothing -> Spec.assertFailure s $ "path not found: " <> path + Just actual -> + -- For the $defs check where we just want to confirm existence, we + -- pass null as expected and skip the equality check. + if expected == Json.null + then pure () + else Spec.assertEq s actual expected diff --git a/source/library/Scrod/Core/Category.hs b/source/library/Scrod/Core/Category.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Category.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Category where + +import qualified Data.Text as Text +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +newtype Category = MkCategory + { unwrap :: Text.Text + } + deriving (Eq, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Text.Text diff --git a/source/library/Scrod/Core/Column.hs b/source/library/Scrod/Core/Column.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Column.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Column where + +import qualified Numeric.Natural as Natural +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +newtype Column = MkColumn + { unwrap :: Natural.Natural + } + deriving (Eq, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Natural.Natural diff --git a/source/library/Scrod/Core/Definition.hs b/source/library/Scrod/Core/Definition.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Definition.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Definition where + +import qualified GHC.Generics as Generics +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | An entry in a definition list, pairing a term with its definition. +data Definition doc = MkDefinition + { term :: doc, + definition :: doc + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically (Definition doc) diff --git a/source/library/Scrod/Core/Doc.hs b/source/library/Scrod/Core/Doc.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Doc.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Doc where + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text as Text +import qualified GHC.Generics as Generics +import qualified Scrod.Core.Definition as Definition +import qualified Scrod.Core.Example as Example +import qualified Scrod.Core.Header as Header +import qualified Scrod.Core.Hyperlink as Hyperlink +import qualified Scrod.Core.Identifier as Identifier +import qualified Scrod.Core.ModLink as ModLink +import qualified Scrod.Core.NumberedItem as NumberedItem +import qualified Scrod.Core.Picture as Picture +import qualified Scrod.Core.Table as Table +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | Documentation AST. +data Doc + = Empty + | Append [Doc] + | String Text.Text + | Paragraph Doc + | Identifier Identifier.Identifier + | Module (ModLink.ModLink Doc) + | Emphasis Doc + | Monospaced Doc + | Bold Doc + | UnorderedList [Doc] + | OrderedList [NumberedItem.NumberedItem Doc] + | DefList [Definition.Definition Doc] + | CodeBlock Doc + | Hyperlink (Hyperlink.Hyperlink Doc) + | Pic Picture.Picture + | MathInline Text.Text + | MathDisplay Text.Text + | AName Text.Text + | Property Text.Text + | Examples (NonEmpty.NonEmpty Example.Example) + | Header (Header.Header Doc) + | Table (Table.Table Doc) + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Doc diff --git a/source/library/Scrod/Core/Example.hs b/source/library/Scrod/Core/Example.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Example.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Example where + +import qualified Data.Text as Text +import qualified GHC.Generics as Generics +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | An example expression with its expected result. +data Example = MkExample + { expression :: Text.Text, + result :: [Text.Text] + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Example diff --git a/source/library/Scrod/Core/Export.hs b/source/library/Scrod/Core/Export.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Export.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Export where + +import qualified Data.Text as Text +import qualified GHC.Generics as Generics +import qualified Scrod.Core.Doc as Doc +import qualified Scrod.Core.ExportIdentifier as ExportIdentifier +import qualified Scrod.Core.Section as Section +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | A single entry in a module's export list. +data Export + = -- | A named export: variable, type/class, or module re-export. + Identifier ExportIdentifier.ExportIdentifier + | -- | Section heading: @-- * Section@ + Group Section.Section + | -- | Inline documentation: @-- | Some doc@ + Doc Doc.Doc + | -- | Named doc reference: @-- $chunkName@ + DocNamed Text.Text + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Export diff --git a/source/library/Scrod/Core/ExportIdentifier.hs b/source/library/Scrod/Core/ExportIdentifier.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/ExportIdentifier.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.ExportIdentifier where + +import qualified GHC.Generics as Generics +import qualified Scrod.Core.Doc as Doc +import qualified Scrod.Core.ExportName as ExportName +import qualified Scrod.Core.Subordinates as Subordinates +import qualified Scrod.Core.Warning as Warning +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | A named export: variable, type/class, or module re-export. +data ExportIdentifier = MkExportIdentifier + { name :: ExportName.ExportName, + subordinates :: Maybe Subordinates.Subordinates, + warning :: Maybe Warning.Warning, + doc :: Maybe Doc.Doc + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically ExportIdentifier diff --git a/source/library/Scrod/Core/ExportName.hs b/source/library/Scrod/Core/ExportName.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/ExportName.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.ExportName where + +import qualified Data.Text as Text +import qualified GHC.Generics as Generics +import qualified Scrod.Core.ExportNameKind as ExportNameKind +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | A name in an export list, possibly annotated with @pattern@ or @type@. +data ExportName = MkExportName + { kind :: Maybe ExportNameKind.ExportNameKind, + name :: Text.Text + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically ExportName diff --git a/source/library/Scrod/Core/ExportNameKind.hs b/source/library/Scrod/Core/ExportNameKind.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/ExportNameKind.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.ExportNameKind where + +import qualified GHC.Generics as Generics +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | Namespace annotation for a name in an export list. +data ExportNameKind + = -- | @pattern X@ + Pattern + | -- | @type (:+:)@ + Type + | -- | @module Data.List@ + Module + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically ExportNameKind diff --git a/source/library/Scrod/Core/Extension.hs b/source/library/Scrod/Core/Extension.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Extension.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Extension where + +import qualified Data.Text as Text +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +newtype Extension = MkExtension + { unwrap :: Text.Text + } + deriving (Eq, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Text.Text diff --git a/source/library/Scrod/Core/Header.hs b/source/library/Scrod/Core/Header.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Header.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Header where + +import qualified GHC.Generics as Generics +import qualified Scrod.Core.Level as Level +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | A section header with a level and title. +data Header doc = MkHeader + { level :: Level.Level, + title :: doc + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically (Header doc) diff --git a/source/library/Scrod/Core/Hyperlink.hs b/source/library/Scrod/Core/Hyperlink.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Hyperlink.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Hyperlink where + +import qualified Data.Text as Text +import qualified GHC.Generics as Generics +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | A hyperlink with an optional label. +data Hyperlink doc = MkHyperlink + { url :: Text.Text, + label :: Maybe doc + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically (Hyperlink doc) diff --git a/source/library/Scrod/Core/Identifier.hs b/source/library/Scrod/Core/Identifier.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Identifier.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Identifier where + +import qualified Data.Text as Text +import qualified GHC.Generics as Generics +import qualified Scrod.Core.Namespace as Namespace +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | An identifier reference in documentation. +data Identifier = MkIdentifier + { namespace :: Maybe Namespace.Namespace, + value :: Text.Text + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Identifier diff --git a/source/library/Scrod/Core/Import.hs b/source/library/Scrod/Core/Import.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Import.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Import where + +import qualified GHC.Generics as Generics +import qualified Scrod.Core.ModuleName as ModuleName +import qualified Scrod.Core.PackageName as PackageName +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +data Import = MkImport + { name :: ModuleName.ModuleName, + package :: Maybe PackageName.PackageName, + alias :: Maybe ModuleName.ModuleName + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Import diff --git a/source/library/Scrod/Core/Item.hs b/source/library/Scrod/Core/Item.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Item.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Item where + +import qualified Data.Text as Text +import qualified GHC.Generics as Generics +import qualified Scrod.Core.Doc as Doc +import qualified Scrod.Core.ItemKey as ItemKey +import qualified Scrod.Core.ItemKind as ItemKind +import qualified Scrod.Core.ItemName as ItemName +import qualified Scrod.Core.Since as Since +import qualified Scrod.Core.Visibility as Visibility +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +data Item = MkItem + { key :: ItemKey.ItemKey, + kind :: ItemKind.ItemKind, + parentKey :: Maybe ItemKey.ItemKey, + name :: Maybe ItemName.ItemName, + documentation :: Doc.Doc, + since :: Maybe Since.Since, + signature :: Maybe Text.Text, + visibility :: Visibility.Visibility + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Item diff --git a/source/library/Scrod/Core/ItemKey.hs b/source/library/Scrod/Core/ItemKey.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/ItemKey.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.ItemKey where + +import qualified Numeric.Natural as Natural +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +newtype ItemKey = MkItemKey + { unwrap :: Natural.Natural + } + deriving (Eq, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Natural.Natural diff --git a/source/library/Scrod/Core/ItemKind.hs b/source/library/Scrod/Core/ItemKind.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/ItemKind.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.ItemKind where + +import qualified GHC.Generics as Generics +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | The kind of Haskell declaration an Item represents. +-- +-- This type must remain a simple enumeration: no constructor should +-- carry arguments. Renderers and predicates pattern-match on it +-- exhaustively, and keeping it argument-free avoids coupling the +-- core representation to presentation details. +data ItemKind + = -- | Function binding: @f x = expr@ + Function + | -- | Operator binding: @(+) x y = expr@ + Operator + | -- | Pattern binding: @(x, y) = tuple@ + PatternBinding + | -- | Pattern synonym: @pattern P x = Just x@ + PatternSynonym + | -- | Data type declaration: @data T = C@ + DataType + | -- | Newtype declaration: @newtype T = C@ + Newtype + | -- | Type data declaration: @type data T = C@ + TypeData + | -- | Type synonym: @type T = U@ + TypeSynonym + | -- | Data constructor (Haskell 98 style) + DataConstructor + | -- | GADT constructor + GADTConstructor + | -- | Record field + RecordField + | -- | Type class: @class C a@ + Class + | -- | Class method signature + ClassMethod + | -- | Class instance: @instance C T@ + ClassInstance + | -- | Standalone deriving: @deriving instance C T@ + StandaloneDeriving + | -- | Derived instance from deriving clause + DerivedInstance + | -- | Open type family (standalone or associated) + OpenTypeFamily + | -- | Closed type family + ClosedTypeFamily + | -- | Data family (standalone or associated) + DataFamily + | -- | Type family instance: @type instance F T = U@ + TypeFamilyInstance + | -- | Data family instance: @data instance D T = C@ + DataFamilyInstance + | -- | Foreign import declaration + ForeignImport + | -- | Foreign export declaration + ForeignExport + | -- | Fixity signature: @infixl 6 +@ + FixitySignature + | -- | Inline/noinline signature + InlineSignature + | -- | Specialise signature + SpecialiseSignature + | -- | Standalone kind signature: @type T :: Type@ + StandaloneKindSig + | -- | Rewrite rule: @{-# RULES ... #-}@ + Rule + | -- | Default declaration: @default (Integer, Double)@ + Default + | -- | Annotation: @{-# ANN ... #-}@ + Annotation + | -- | Template Haskell splice or quasi-quote: @$(expr)@ or @[quoter|...|]@ + Splice + | -- | Warning pragma: @{-# WARNING x "msg" #-}@ + Warning + | -- | Minimal pragma: @{-# MINIMAL size #-}@ + MinimalPragma + | -- | Complete pragma: @{-# COMPLETE Nil, Cons #-}@ + CompletePragma + | -- | Default method signature: @default m :: Show a => a -> String@ + DefaultMethodSignature + | -- | Role annotation: @type role T nominal@ + RoleAnnotation + | -- | Named documentation chunk: @-- $name@ + DocumentationChunk + | -- | Positional argument of a function or constructor + Argument + | -- | Return type of a function + ReturnType + | -- | Export list entry with no matching declaration in this module + -- (e.g. a module re-export or an unresolved name). + UnresolvedExport + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically ItemKind + +-- | Whether an item kind is a traditional subordinate that can be +-- filtered by export subordinate restrictions (e.g. @Foo(Bar)@ or +-- @Foo(..)@). +isTraditionalSubordinate :: ItemKind -> Bool +isTraditionalSubordinate k = case k of + DataConstructor -> True + GADTConstructor -> True + RecordField -> True + ClassMethod -> True + DefaultMethodSignature -> True + _ -> False diff --git a/source/library/Scrod/Core/ItemName.hs b/source/library/Scrod/Core/ItemName.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/ItemName.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.ItemName where + +import qualified Data.Text as Text +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +newtype ItemName = MkItemName + { unwrap :: Text.Text + } + deriving (Eq, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Text.Text diff --git a/source/library/Scrod/Core/Language.hs b/source/library/Scrod/Core/Language.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Language.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Language where + +import qualified Data.Text as Text +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +newtype Language = MkLanguage + { unwrap :: Text.Text + } + deriving (Eq, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Text.Text diff --git a/source/library/Scrod/Core/Level.hs b/source/library/Scrod/Core/Level.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Level.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Core.Level where + +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Json.Value as Json +import qualified Scrod.Schema as Schema +import qualified Scrod.Spec as Spec + +-- | A header level from 1 to 6 inclusive. +data Level + = One + | Two + | Three + | Four + | Five + | Six + deriving (Eq, Ord, Show) + +-- | Convert an integer to a 'Level', clamping to the valid range. +fromInt :: Int -> Level +fromInt n + | n <= 1 = One + | n == 2 = Two + | n == 3 = Three + | n == 4 = Four + | n == 5 = Five + | otherwise = Six + +instance ToJson.ToJson Level where + toJson l = Json.integer $ case l of + One -> 1 + Two -> 2 + Three -> 3 + Four -> 4 + Five -> 5 + Six -> 6 + +instance Schema.ToSchema Level where + toSchema _ = + pure . Schema.MkSchema $ + Json.object + [ ("type", Json.string "integer"), + ("minimum", Json.integer 1), + ("maximum", Json.integer 6) + ] + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'fromInt $ do + Spec.it s "maps 1 to One" $ do + Spec.assertEq s (fromInt 1) One + + Spec.it s "maps 2 to Two" $ do + Spec.assertEq s (fromInt 2) Two + + Spec.it s "maps 3 to Three" $ do + Spec.assertEq s (fromInt 3) Three + + Spec.it s "maps 4 to Four" $ do + Spec.assertEq s (fromInt 4) Four + + Spec.it s "maps 5 to Five" $ do + Spec.assertEq s (fromInt 5) Five + + Spec.it s "maps 6 to Six" $ do + Spec.assertEq s (fromInt 6) Six + + Spec.it s "clamps zero to One" $ do + Spec.assertEq s (fromInt 0) One + + Spec.it s "clamps negative to One" $ do + Spec.assertEq s (fromInt (-1)) One + + Spec.it s "clamps 7 to Six" $ do + Spec.assertEq s (fromInt 7) Six + + Spec.it s "clamps large value to Six" $ do + Spec.assertEq s (fromInt 100) Six diff --git a/source/library/Scrod/Core/Line.hs b/source/library/Scrod/Core/Line.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Line.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Line where + +import qualified Numeric.Natural as Natural +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +newtype Line = MkLine + { unwrap :: Natural.Natural + } + deriving (Eq, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Natural.Natural diff --git a/source/library/Scrod/Core/Located.hs b/source/library/Scrod/Core/Located.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Located.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Located where + +import qualified GHC.Generics as Generics +import qualified Scrod.Core.Location as Location +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +data Located a = MkLocated + { location :: Location.Location, + value :: a + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically (Located a) diff --git a/source/library/Scrod/Core/Location.hs b/source/library/Scrod/Core/Location.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Location.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Location where + +import qualified GHC.Generics as Generics +import qualified Scrod.Core.Column as Column +import qualified Scrod.Core.Line as Line +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +data Location = MkLocation + { line :: Line.Line, + column :: Column.Column + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Location diff --git a/source/library/Scrod/Core/ModLink.hs b/source/library/Scrod/Core/ModLink.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/ModLink.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.ModLink where + +import qualified GHC.Generics as Generics +import qualified Scrod.Core.ModuleName as ModuleName +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | A link to a module with an optional label. +data ModLink doc = MkModLink + { name :: ModuleName.ModuleName, + label :: Maybe doc + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically (ModLink doc) diff --git a/source/library/Scrod/Core/Module.hs b/source/library/Scrod/Core/Module.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Module.hs @@ -0,0 +1,104 @@ +module Scrod.Core.Module where + +import qualified Data.Map as Map +import qualified Data.Proxy as Proxy +import qualified Data.Text as Text +import qualified Scrod.Core.Doc as Doc +import qualified Scrod.Core.Extension as Extension +import qualified Scrod.Core.Import as Import +import qualified Scrod.Core.Item as Item +import qualified Scrod.Core.Language as Language +import qualified Scrod.Core.Located as Located +import qualified Scrod.Core.ModuleName as ModuleName +import qualified Scrod.Core.Since as Since +import qualified Scrod.Core.Version as Version +import qualified Scrod.Core.Warning as Warning +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Json.Value as Json +import qualified Scrod.Schema as Schema + +data Module = MkModule + { version :: Version.Version, + language :: Maybe Language.Language, + extensions :: Map.Map Extension.Extension Bool, + documentation :: Doc.Doc, + since :: Maybe Since.Since, + signature :: Bool, + name :: Maybe (Located.Located ModuleName.ModuleName), + warning :: Maybe Warning.Warning, + imports :: [Import.Import], + items :: [Located.Located Item.Item] + } + deriving (Eq, Ord, Show) + +instance ToJson.ToJson Module where + toJson m = + Json.object + . (("$schema", Json.string "https://scrod.fyi/schema.json") :) + . filter (\(_, v) -> v /= Json.null) + $ [ ("version", ToJson.toJson $ version m), + ("language", ToJson.toJson $ language m), + ("extensions", extensionsToJson $ extensions m), + ("documentation", ToJson.toJson $ documentation m), + ("since", ToJson.toJson $ since m), + ("signature", ToJson.toJson $ signature m), + ("name", ToJson.toJson $ name m), + ("warning", ToJson.toJson $ warning m), + ("imports", ToJson.toJson $ imports m), + ("items", ToJson.toJson $ items m) + ] + +extensionsToJson :: Map.Map Extension.Extension Bool -> Json.Value +extensionsToJson = + Json.object + . fmap (\(k, v) -> (Text.unpack $ Extension.unwrap k, ToJson.toJson v)) + . Map.toList + +instance Schema.ToSchema Module where + toSchema _ = do + versionS <- Schema.toSchema (Proxy.Proxy :: Proxy.Proxy Version.Version) + languageS <- Schema.toSchema (Proxy.Proxy :: Proxy.Proxy Language.Language) + extensionsS <- extensionsSchema + documentationS <- Schema.toSchema (Proxy.Proxy :: Proxy.Proxy Doc.Doc) + sinceS <- Schema.toSchema (Proxy.Proxy :: Proxy.Proxy Since.Since) + nameS <- Schema.toSchema (Proxy.Proxy :: Proxy.Proxy (Located.Located ModuleName.ModuleName)) + warningS <- Schema.toSchema (Proxy.Proxy :: Proxy.Proxy Warning.Warning) + importsS <- Schema.toSchema (Proxy.Proxy :: Proxy.Proxy [Import.Import]) + itemsS <- Schema.toSchema (Proxy.Proxy :: Proxy.Proxy [Located.Located Item.Item]) + let allProps = + [ ("$schema", Json.object [("type", Json.string "string"), ("format", Json.string "uri")]), + ("version", Schema.unwrap versionS), + ("language", Schema.unwrap languageS), + ("extensions", Schema.unwrap extensionsS), + ("documentation", Schema.unwrap documentationS), + ("since", Schema.unwrap sinceS), + ("signature", Json.object [("type", Json.string "boolean")]), + ("name", Schema.unwrap nameS), + ("warning", Schema.unwrap warningS), + ("imports", Schema.unwrap importsS), + ("items", Schema.unwrap itemsS) + ] + let reqNames = + [ Json.string "$schema", + Json.string "version", + Json.string "extensions", + Json.string "documentation", + Json.string "signature", + Json.string "imports", + Json.string "items" + ] + pure . Schema.MkSchema $ + Json.object + [ ("type", Json.string "object"), + ("properties", Json.object allProps), + ("required", Json.array reqNames), + ("additionalProperties", Json.boolean False) + ] + +extensionsSchema :: Schema.SchemaM Schema.Schema +extensionsSchema = + pure . Schema.MkSchema $ + Json.object + [ ("type", Json.string "object"), + ("additionalProperties", Json.object [("type", Json.string "boolean")]) + ] diff --git a/source/library/Scrod/Core/ModuleName.hs b/source/library/Scrod/Core/ModuleName.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/ModuleName.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.ModuleName where + +import qualified Data.Text as Text +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +newtype ModuleName = MkModuleName + { unwrap :: Text.Text + } + deriving (Eq, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Text.Text diff --git a/source/library/Scrod/Core/Namespace.hs b/source/library/Scrod/Core/Namespace.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Namespace.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Namespace where + +import qualified GHC.Generics as Generics +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | The namespace qualification for an identifier. +data Namespace + = -- | @v'identifier'@ syntax + Value + | -- | @t'identifier'@ syntax + Type + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Namespace diff --git a/source/library/Scrod/Core/NumberedItem.hs b/source/library/Scrod/Core/NumberedItem.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/NumberedItem.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.NumberedItem where + +import qualified GHC.Generics as Generics +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | An item in an ordered list, with its 1-based index. +data NumberedItem doc = MkNumberedItem + { index :: Int, + item :: doc + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically (NumberedItem doc) diff --git a/source/library/Scrod/Core/PackageName.hs b/source/library/Scrod/Core/PackageName.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/PackageName.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.PackageName where + +import qualified Data.Text as Text +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +newtype PackageName = MkPackageName + { unwrap :: Text.Text + } + deriving (Eq, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Text.Text diff --git a/source/library/Scrod/Core/Picture.hs b/source/library/Scrod/Core/Picture.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Picture.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Picture where + +import qualified Data.Text as Text +import qualified GHC.Generics as Generics +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | A picture/image reference. +data Picture = MkPicture + { uri :: Text.Text, + title :: Maybe Text.Text + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Picture diff --git a/source/library/Scrod/Core/Section.hs b/source/library/Scrod/Core/Section.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Section.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Section where + +import qualified Scrod.Core.Doc as Doc +import qualified Scrod.Core.Header as Header +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | A section heading in an export list. +newtype Section = MkSection + { header :: Header.Header Doc.Doc + } + deriving (Eq, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Header.Header Doc.Doc diff --git a/source/library/Scrod/Core/Since.hs b/source/library/Scrod/Core/Since.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Since.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Since where + +import qualified GHC.Generics as Generics +import qualified Scrod.Core.PackageName as PackageName +import qualified Scrod.Core.Version as Version +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +data Since = MkSince + { package :: Maybe PackageName.PackageName, + version :: Version.Version + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Since diff --git a/source/library/Scrod/Core/Subordinates.hs b/source/library/Scrod/Core/Subordinates.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Subordinates.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Subordinates where + +import qualified GHC.Generics as Generics +import qualified Scrod.Core.ExportName as ExportName +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | Subordinate exports for a type or class. +data Subordinates = MkSubordinates + { -- | Whether a @(..)@ wildcard is present. + wildcard :: Bool, + -- | Explicitly listed children. + explicit :: [ExportName.ExportName] + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Subordinates diff --git a/source/library/Scrod/Core/Table.hs b/source/library/Scrod/Core/Table.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Table.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Table where + +import qualified GHC.Generics as Generics +import qualified Scrod.Core.TableCell as TableCell +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | A table with header and body rows. +data Table doc = MkTable + { headerRows :: [[TableCell.Cell doc]], + bodyRows :: [[TableCell.Cell doc]] + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically (Table doc) diff --git a/source/library/Scrod/Core/TableCell.hs b/source/library/Scrod/Core/TableCell.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/TableCell.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.TableCell where + +import qualified GHC.Generics as Generics +import qualified Numeric.Natural as Natural +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | A table cell with colspan, rowspan, and contents. +data Cell doc = MkCell + { colspan :: Natural.Natural, + rowspan :: Natural.Natural, + contents :: doc + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically (Cell doc) diff --git a/source/library/Scrod/Core/Version.hs b/source/library/Scrod/Core/Version.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Version.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Version where + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Numeric.Natural as Natural +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +newtype Version = MkVersion + { unwrap :: NonEmpty.NonEmpty Natural.Natural + } + deriving (Eq, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via NonEmpty.NonEmpty Natural.Natural diff --git a/source/library/Scrod/Core/Visibility.hs b/source/library/Scrod/Core/Visibility.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Visibility.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Visibility where + +import qualified GHC.Generics as Generics +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +-- | The visibility of an item with respect to the module's export list. +data Visibility + = -- | In the export list (directly named, via subordinates like + -- @Foo(Bar)@, or via wildcard like @Foo(..)@), or every top-level + -- item when there is no export list. + Exported + | -- | Always visible regardless of the export list (class instances, + -- standalone deriving, derived instances, rules, defaults, + -- annotations, splices). + Implicit + | -- | Not in the export list. + Unexported + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Visibility diff --git a/source/library/Scrod/Core/Warning.hs b/source/library/Scrod/Core/Warning.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Core/Warning.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} + +module Scrod.Core.Warning where + +import qualified Data.Text as Text +import qualified GHC.Generics as Generics +import qualified Scrod.Core.Category as Category +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Schema as Schema + +data Warning = MkWarning + { category :: Category.Category, + value :: Text.Text + } + deriving (Eq, Generics.Generic, Ord, Show) + deriving (ToJson.ToJson, Schema.ToSchema) via Generics.Generically Warning diff --git a/source/library/Scrod/Cpp.hs b/source/library/Scrod/Cpp.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Cpp.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | A minimal C preprocessor for Haskell source. +-- +-- Processes @#if@\/@#ifdef@\/@#ifndef@\/@#elif@\/@#else@\/@#endif@, @#define@, +-- and @#undef@. Directive lines are replaced with blank lines to preserve +-- line numbering. Unrecognized directives (e.g., @#include@) are silently +-- blanked out. +module Scrod.Cpp where + +import qualified Data.Map.Strict as Map +import qualified Data.Maybe as Maybe +import qualified Scrod.Cpp.Directive as Directive +import qualified Scrod.Cpp.Expr as Expr +import qualified Scrod.Spec as Spec + +-- | State of a branch in a @#if@\/@#elif@\/@#else@ chain. +-- +-- * 'Active' — this branch's condition was true; output its lines. +-- * 'Inactive' — condition was false; may still activate on a later @#elif@\/@#else@. +-- * 'Done' — a previous branch in this chain already activated; skip the rest. +data Branch + = Active + | Inactive + | Done + deriving (Eq, Ord, Show) + +data State = MkState + { defines :: Map.Map String String, + stack :: [Branch], + seenElse :: [Bool] + } + +initialState :: State +initialState = + MkState + { defines = Map.empty, + stack = [], + seenElse = [] + } + +cpp :: String -> Either String String +cpp input = do + let ls = lines input + outputLines <- go ls initialState [] + Right $ unlines (reverse outputLines) + +go :: [String] -> State -> [String] -> Either String [String] +go ls state acc = case ls of + [] -> + if null (stack state) + then Right acc + else Left "unterminated #if" + line : rest -> + case Directive.parse line of + Nothing -> go rest state (keepOrBlank state line : acc) + Just dir -> do + state' <- processDirective state dir + go rest state' ("" : acc) + +isActive :: State -> Bool +isActive = isActiveStack . stack + +isActiveStack :: [Branch] -> Bool +isActiveStack bs = case bs of + [] -> True + Active : _ -> True + _ -> False + +keepOrBlank :: State -> String -> String +keepOrBlank state line = + if isActive state then line else "" + +processDirective :: State -> Directive.Directive -> Either String State +processDirective state dir = case dir of + Directive.If expr -> do + if isActive state + then do + val <- Expr.evaluate (defines state) expr + let branch = if val /= 0 then Active else Inactive + Right state {stack = branch : stack state, seenElse = False : seenElse state} + else + Right state {stack = Inactive : stack state, seenElse = False : seenElse state} + Directive.Ifdef name -> + processDirective state (Directive.If $ "defined(" <> name <> ")") + Directive.Ifndef name -> + processDirective state (Directive.If $ "!defined(" <> name <> ")") + Directive.Elif expr -> case (stack state, seenElse state) of + ([], _) -> Left "unexpected #elif without matching #if" + (_, True : _) -> Left "unexpected #elif after #else" + (Active : rest, e : es) -> + Right state {stack = Done : rest, seenElse = e : es} + (Inactive : rest, e : es) -> + if isActiveStack rest + then do + val <- Expr.evaluate (defines state) expr + let branch = if val /= 0 then Active else Inactive + Right state {stack = branch : rest, seenElse = e : es} + else Right state {stack = Inactive : rest, seenElse = e : es} + (Done : _, _ : _) -> + Right state + (_, []) -> Left "unexpected #elif without matching #if" + Directive.Else -> case (stack state, seenElse state) of + ([], _) -> Left "unexpected #else without matching #if" + (_, True : _) -> Left "unexpected #else after #else" + (Active : rest, _ : es) -> + Right state {stack = Done : rest, seenElse = True : es} + (Inactive : rest, _ : es) -> + if isActiveStack rest + then Right state {stack = Active : rest, seenElse = True : es} + else Right state {stack = Inactive : rest, seenElse = True : es} + (Done : _, _ : es) -> + Right state {stack = stack state, seenElse = True : es} + (_, []) -> Left "unexpected #else without matching #if" + Directive.Endif -> case (stack state, seenElse state) of + ([], _) -> Left "unexpected #endif without matching #if" + (_ : rest, _ : es) -> Right state {stack = rest, seenElse = es} + (_, []) -> Left "unexpected #endif without matching #if" + Directive.Define name mValue -> + if isActive state + then + let v = Maybe.fromMaybe "1" mValue + in Right state {defines = Map.insert name v (defines state)} + else Right state + Directive.Undef name -> + if isActive state + then Right state {defines = Map.delete name (defines state)} + else Right state + Directive.Other -> Right state + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'cpp $ do + Spec.it s "passes through source without directives" $ do + Spec.assertEq s (cpp "module M where") $ Right "module M where\n" + + Spec.it s "replaces directive lines with blank lines" $ do + Spec.assertEq s (cpp "#define FOO\nmodule M where") $ Right "\nmodule M where\n" + + Spec.it s "keeps active ifdef branch" $ do + Spec.assertEq s (cpp "#define FOO\n#ifdef FOO\nkeep\n#endif") $ Right "\n\nkeep\n\n" + + Spec.it s "removes inactive ifdef branch" $ do + Spec.assertEq s (cpp "#ifdef FOO\nskip\n#endif") $ Right "\n\n\n" + + Spec.it s "handles ifndef" $ do + Spec.assertEq s (cpp "#ifndef FOO\nkeep\n#endif") $ Right "\nkeep\n\n" + + Spec.it s "handles else branch" $ do + Spec.assertEq s (cpp "#ifdef FOO\nskip\n#else\nkeep\n#endif") $ Right "\n\n\nkeep\n\n" + + Spec.it s "handles elif" $ do + Spec.assertEq s (cpp "#if 0\nskip\n#elif 1\nkeep\n#endif") $ Right "\n\n\nkeep\n\n" + + Spec.it s "handles nested if" $ do + Spec.assertEq s (cpp "#if 1\n#if 1\nkeep\n#endif\n#endif") $ Right "\n\nkeep\n\n\n" + + Spec.it s "handles nested if in inactive branch" $ do + Spec.assertEq s (cpp "#if 0\n#if 1\nskip\n#endif\n#endif") $ Right "\n\n\n\n\n" + + Spec.it s "handles undef" $ do + Spec.assertEq s (cpp "#define FOO\n#undef FOO\n#ifdef FOO\nskip\n#endif") $ Right "\n\n\n\n\n" + + Spec.it s "fails with unmatched endif" $ do + Spec.assertEq s (cpp "#endif") $ Left "unexpected #endif without matching #if" + + Spec.it s "fails with unterminated if" $ do + Spec.assertEq s (cpp "#if 1\ncode") $ Left "unterminated #if" + + Spec.it s "fails with else after else" $ do + Spec.assertEq s (cpp "#if 1\n#else\n#else\n#endif") $ Left "unexpected #else after #else" + + Spec.it s "fails with elif after else" $ do + Spec.assertEq s (cpp "#if 0\n#else\n#elif 1\n#endif") $ Left "unexpected #elif after #else" + + Spec.it s "handles else after elif" $ do + Spec.assertEq s (cpp "#if 1\nkeep\n#elif 0\nskip\n#else\nskip\n#endif") $ Right "\nkeep\n\n\n\n\n\n" + + Spec.it s "preserves line count" $ do + Spec.assertEq s (length . lines <$> cpp "#if 1\nline2\nline3\n#endif\nline5") $ Right 5 + + Spec.it s "handles typical Haskell CPP pattern" $ do + Spec.assertEq + s + ( cpp $ + unlines + [ "#ifdef __GLASGOW_HASKELL__", + "import GHC.Specific", + "#else", + "import Data.Old", + "#endif" + ] + ) + ( Right $ + unlines + [ "", + "", + "", + "import Data.Old", + "" + ] + ) + + Spec.it s "handles define then ifdef" $ do + Spec.assertEq + s + ( cpp $ + unlines + [ "#define MY_FLAG", + "#ifdef MY_FLAG", + "import My.Module", + "#endif" + ] + ) + ( Right $ + unlines + [ "", + "", + "import My.Module", + "" + ] + ) + + Spec.it s "handles define with value in if" $ do + Spec.assertEq s (cpp "#define VER 10\n#if VER >= 10\nkeep\n#endif") $ Right "\n\nkeep\n\n" + + Spec.it s "replaces other directives with blank lines" $ do + Spec.assertEq s (cpp "#include \nmodule M where") $ Right "\nmodule M where\n" diff --git a/source/library/Scrod/Cpp/Directive.hs b/source/library/Scrod/Cpp/Directive.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Cpp/Directive.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | Parsing of C preprocessor directives. +-- +-- Recognizes the conditional-compilation directives (@#if@, @#ifdef@, +-- @#ifndef@, @#elif@, @#else@, @#endif@), macro definitions (@#define@, +-- @#undef@), and lumps everything else (e.g., @#include@, @#error@) into +-- 'Other'. Leading whitespace and whitespace between @#@ and the keyword +-- are tolerated. +module Scrod.Cpp.Directive where + +import qualified Control.Monad as Monad +import qualified Scrod.Spec as Spec +import qualified Text.Parsec as Parsec + +data Directive + = If String + | Ifdef String + | Ifndef String + | Elif String + | Else + | Endif + | -- | A @#define@ with a macro name and an optional replacement value. + Define String (Maybe String) + | Undef String + | -- | Any directive not specifically recognized (e.g., @#include@, @#error@). + Other + deriving (Eq, Ord, Show) + +-- | Try to parse a single line as a CPP directive. Returns 'Nothing' if the +-- line does not start with @#@ (after optional whitespace). +parse :: String -> Maybe Directive +parse = either (const Nothing) Just . Parsec.parse directive "" + +space :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Char +space = Parsec.oneOf " \t" + +spaces :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m () +spaces = Parsec.skipMany space + +spaces1 :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m () +spaces1 = Parsec.skipMany1 space + +lexeme :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m a -> Parsec.ParsecT s u m a +lexeme = (<* spaces) + +directive :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Directive +directive = do + spaces + Monad.void . lexeme $ Parsec.char '#' + keyword <- Parsec.many Parsec.letter + case keyword of + "if" -> If <$> rest + "ifdef" -> Ifdef <$> name + "ifndef" -> Ifndef <$> name + "elif" -> Elif <$> rest + "else" -> pure Else + "endif" -> pure Endif + "define" -> Define <$> name <*> value + "undef" -> Undef <$> name + _ -> pure Other + +name :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m String +name = spaces1 *> Parsec.many1 (Parsec.choice [Parsec.alphaNum, Parsec.char '_']) + +rest :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m String +rest = spaces1 *> Parsec.many Parsec.anyChar + +value :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m (Maybe String) +value = Parsec.optionMaybe $ spaces1 *> Parsec.many1 Parsec.anyChar + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'parse $ do + Spec.it s "parses #if" $ do + Spec.assertEq s (parse "#if 1") $ Just (If "1") + + Spec.it s "parses #ifdef" $ do + Spec.assertEq s (parse "#ifdef FOO") $ Just (Ifdef "FOO") + + Spec.it s "parses #ifndef" $ do + Spec.assertEq s (parse "#ifndef FOO") $ Just (Ifndef "FOO") + + Spec.it s "parses #elif" $ do + Spec.assertEq s (parse "#elif 0") $ Just (Elif "0") + + Spec.it s "parses #else" $ do + Spec.assertEq s (parse "#else") $ Just Else + + Spec.it s "parses #endif" $ do + Spec.assertEq s (parse "#endif") $ Just Endif + + Spec.it s "parses #define without value" $ do + Spec.assertEq s (parse "#define FOO") $ Just (Define "FOO" Nothing) + + Spec.it s "parses #define with value" $ do + Spec.assertEq s (parse "#define FOO 42") $ Just (Define "FOO" (Just "42")) + + Spec.it s "parses #undef" $ do + Spec.assertEq s (parse "#undef FOO") $ Just (Undef "FOO") + + Spec.it s "parses #include as Other" $ do + Spec.assertEq s (parse "#include ") $ Just Other + + Spec.it s "parses #error as Other" $ do + Spec.assertEq s (parse "#error msg") $ Just Other + + Spec.it s "handles leading whitespace" $ do + Spec.assertEq s (parse " #if 1") $ Just (If "1") + + Spec.it s "handles whitespace after hash" $ do + Spec.assertEq s (parse "# if 1") $ Just (If "1") + + Spec.it s "fails on non-directive line" $ do + Spec.assertEq s (parse "not a directive") Nothing diff --git a/source/library/Scrod/Cpp/Expr.hs b/source/library/Scrod/Cpp/Expr.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Cpp/Expr.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | Evaluation of C preprocessor @#if@ \/ @#elif@ expressions. +-- +-- Supports integer literals (decimal and hex), arithmetic operators, +-- comparisons, logical operators, the @defined@ operator, macro name +-- lookup, and parenthesized sub-expressions. Undefined identifiers and +-- unrecognized function-like macro calls evaluate to @0@, matching +-- standard CPP behavior. +module Scrod.Cpp.Expr where + +import qualified Data.Bool as Bool +import qualified Data.Map.Strict as Map +import qualified Data.Maybe as Maybe +import qualified Scrod.Cpp.Directive as Directive +import qualified Scrod.Extra.Read as Read +import qualified Scrod.Spec as Spec +import qualified Text.Parsec as Parsec +import qualified Text.Parsec.Expr as Expr + +-- | Evaluate a CPP expression string in the context of a set of @#define@d +-- macros. Returns 'Left' on parse errors or division by zero. +evaluate :: Map.Map String String -> String -> Either String Integer +evaluate defines input = + case Parsec.parse (Directive.spaces *> expression defines <* Parsec.eof) "" input of + Left err -> Left $ show err + Right (Left msg) -> Left msg + Right (Right n) -> Right n + +expression :: (Parsec.Stream s m Char) => Map.Map String String -> Parsec.ParsecT s u m (Either String Integer) +expression = Expr.buildExpressionParser operatorTable . term + +-- | Operator precedence table, from highest to lowest: +-- @*@\/@\/@\/@%@, @+@\/@-@, comparisons, equality, @&&@, @||@. +operatorTable :: (Parsec.Stream s m Char) => Expr.OperatorTable s u m (Either String Integer) +operatorTable = + [ [ infixL "*" $ liftA2 (*), + infixL "/" checkedDiv, + infixL "%" checkedMod + ], + [ infixL "+" $ liftA2 (+), + infixL "-" $ liftA2 (-) + ], + [ infixL "<=" $ liftA2 (boolOp (<=)), + infixL ">=" $ liftA2 (boolOp (>=)), + infixL "<" $ liftA2 (boolOp (<)), + infixL ">" $ liftA2 (boolOp (>)) + ], + [ infixL "==" $ liftA2 (boolOp (==)), + infixL "!=" $ liftA2 (boolOp (/=)) + ], + [ infixL "&&" $ liftA2 (\a b -> boolToInt (a /= 0 && b /= 0)) + ], + [ infixL "||" $ liftA2 (\a b -> boolToInt (a /= 0 || b /= 0)) + ] + ] + +infixL :: + (Parsec.Stream s m Char) => + String -> + (Either String Integer -> Either String Integer -> Either String Integer) -> + Expr.Operator s u m (Either String Integer) +infixL s f = + Expr.Infix + (f <$ Directive.lexeme (Parsec.string' s)) + Expr.AssocLeft + +-- | Parse a term: unary operators (@!@, @-@, @+@), integer literals, +-- @defined@ expressions, identifiers (with optional function-call syntax), +-- or parenthesized sub-expressions. +term :: (Parsec.Stream s m Char) => Map.Map String String -> Parsec.ParsecT s u m (Either String Integer) +term defines = + Parsec.choice + [ do + _ <- Directive.lexeme $ Parsec.char '!' + n <- term defines + pure $ fmap (boolToInt . (== 0)) n, + do + _ <- Directive.lexeme $ Parsec.char '-' + n <- term defines + pure $ fmap negate n, + do + _ <- Directive.lexeme $ Parsec.char '+' + term defines, + Right <$> Directive.lexeme intLiteral, + Right <$> Directive.lexeme (definedExpr defines), + Right <$> Directive.lexeme (identifier defines), + Parsec.between (Directive.lexeme $ Parsec.char '(') (Directive.lexeme $ Parsec.char ')') $ + expression defines + ] + +checkedDiv :: Either String Integer -> Either String Integer -> Either String Integer +checkedDiv a b = case b of + Right 0 -> Left "division by zero in #if" + _ -> liftA2 div a b + +checkedMod :: Either String Integer -> Either String Integer -> Either String Integer +checkedMod a b = case b of + Right 0 -> Left "division by zero in #if" + _ -> liftA2 mod a b + +boolOp :: (Integer -> Integer -> Bool) -> Integer -> Integer -> Integer +boolOp f x = boolToInt . f x + +intLiteral :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Integer +intLiteral = Parsec.choice [Parsec.try hexLiteral, decLiteral] + +hexLiteral :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Integer +hexLiteral = do + _ <- Parsec.char '0' + _ <- Parsec.oneOf "xX" + digits <- Parsec.many1 Parsec.hexDigit + maybe (fail "invalid hexadecimal literal") pure . Read.readM $ "0x" <> digits + +decLiteral :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Integer +decLiteral = do + digits <- Parsec.many1 Parsec.digit + maybe (fail "invalid decimal literal") pure $ Read.readM digits + +-- | Parse a @defined NAME@ or @defined(NAME)@ expression. Returns @1@ if the +-- name is in the defines map, @0@ otherwise. +definedExpr :: (Parsec.Stream s m Char) => Map.Map String String -> Parsec.ParsecT s u m Integer +definedExpr defines = do + _ <- Parsec.try $ Parsec.string "defined" <* Parsec.notFollowedBy (Parsec.choice [Parsec.alphaNum, Parsec.char '_']) + Directive.spaces + n <- + Directive.lexeme $ + Parsec.choice + [ Parsec.try + . Parsec.between + (Directive.lexeme $ Parsec.char '(') + (Parsec.char ')') + $ Directive.lexeme identName, + identName + ] + pure . boolToInt $ Map.member n defines + +identName :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m String +identName = do + c <- Parsec.choice [Parsec.letter, Parsec.char '_'] + cs <- Parsec.many (Parsec.choice [Parsec.alphaNum, Parsec.char '_']) + pure (c : cs) + +-- | Parse an identifier and look up its value in the defines map. If followed +-- by parenthesized arguments (function-like macro call), returns @0@. +-- Undefined or non-numeric identifiers also evaluate to @0@. +identifier :: (Parsec.Stream s m Char) => Map.Map String String -> Parsec.ParsecT s u m Integer +identifier defines = do + n <- identName + -- Handle undefined function-like macro calls: NAME(...) -> 0 + mParen <- Parsec.optionMaybe $ Parsec.char '(' *> consumeBalancedParens 1 + pure $ case mParen of + Just () -> 0 + Nothing -> Maybe.fromMaybe 0 $ do + x <- Map.lookup n defines + Read.readM x + +-- | Skip input until parentheses are balanced. The initial depth should be +-- @1@ (after consuming the opening @(@). +consumeBalancedParens :: (Parsec.Stream s m Char) => Int -> Parsec.ParsecT s u m () +consumeBalancedParens depth = case depth of + 0 -> pure () + _ -> do + c <- Parsec.anyChar + case c of + '(' -> consumeBalancedParens (depth + 1) + ')' -> consumeBalancedParens (depth - 1) + _ -> consumeBalancedParens depth + +boolToInt :: Bool -> Integer +boolToInt = Bool.bool 0 1 + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'evaluate $ do + Spec.it s "evaluates integer literal" $ do + Spec.assertEq s (evaluate Map.empty "42") $ Right 42 + + Spec.it s "evaluates zero" $ do + Spec.assertEq s (evaluate Map.empty "0") $ Right 0 + + Spec.it s "evaluates hexadecimal literal" $ do + Spec.assertEq s (evaluate Map.empty "0x1F") $ Right 31 + + Spec.it s "evaluates undefined name as 0" $ do + Spec.assertEq s (evaluate Map.empty "FOO") $ Right 0 + + Spec.it s "evaluates defined name" $ do + Spec.assertEq s (evaluate (Map.singleton "FOO" "1") "FOO") $ Right 1 + + Spec.it s "evaluates defined name with numeric value" $ do + Spec.assertEq s (evaluate (Map.singleton "FOO" "5") "FOO") $ Right 5 + + Spec.it s "evaluates defined name with non-numeric value as 0" $ do + Spec.assertEq s (evaluate (Map.singleton "FOO" "bar") "FOO") $ Right 0 + + Spec.it s "evaluates defined(NAME) with parens" $ do + Spec.assertEq s (evaluate (Map.singleton "FOO" "1") "defined(FOO)") $ Right 1 + + Spec.it s "evaluates defined(NAME) for undefined" $ do + Spec.assertEq s (evaluate Map.empty "defined(FOO)") $ Right 0 + + Spec.it s "evaluates defined NAME without parens" $ do + Spec.assertEq s (evaluate (Map.singleton "FOO" "1") "defined FOO") $ Right 1 + + Spec.it s "evaluates logical not of zero" $ do + Spec.assertEq s (evaluate Map.empty "!0") $ Right 1 + + Spec.it s "evaluates logical not of nonzero" $ do + Spec.assertEq s (evaluate Map.empty "!5") $ Right 0 + + Spec.it s "evaluates logical or" $ do + Spec.assertEq s (evaluate Map.empty "0 || 1") $ Right 1 + + Spec.it s "evaluates logical and" $ do + Spec.assertEq s (evaluate Map.empty "1 && 0") $ Right 0 + + Spec.it s "evaluates equality" $ do + Spec.assertEq s (evaluate Map.empty "1 == 1") $ Right 1 + + Spec.it s "evaluates inequality" $ do + Spec.assertEq s (evaluate Map.empty "1 != 2") $ Right 1 + + Spec.it s "evaluates less than" $ do + Spec.assertEq s (evaluate Map.empty "2 < 3") $ Right 1 + + Spec.it s "evaluates greater than" $ do + Spec.assertEq s (evaluate Map.empty "3 > 2") $ Right 1 + + Spec.it s "evaluates addition" $ do + Spec.assertEq s (evaluate Map.empty "2 + 3") $ Right 5 + + Spec.it s "evaluates subtraction" $ do + Spec.assertEq s (evaluate Map.empty "5 - 3") $ Right 2 + + Spec.it s "evaluates multiplication" $ do + Spec.assertEq s (evaluate Map.empty "3 * 4") $ Right 12 + + Spec.it s "evaluates parenthesized expression" $ do + Spec.assertEq s (evaluate Map.empty "(1 + 2) * 3") $ Right 9 + + Spec.it s "evaluates complex expression" $ do + Spec.assertEq s (evaluate (Map.singleton "X" "10") "defined(X) && X >= 10") $ Right 1 + + Spec.it s "evaluates unary minus" $ do + Spec.assertEq s (evaluate Map.empty "-1") $ Right (-1) + + Spec.it s "handles undefined function-like macro call" $ do + Spec.assertEq s (evaluate Map.empty "MIN_VERSION_base(4,16,0)") $ Right 0 + + Spec.it s "evaluates addition without spaces" $ do + Spec.assertEq s (evaluate Map.empty "1+2") $ Right 3 + + Spec.it s "evaluates subtraction without spaces" $ do + Spec.assertEq s (evaluate Map.empty "5-3") $ Right 2 + + Spec.it s "fails on division by zero" $ do + case evaluate Map.empty "1/0" of + Left _ -> pure () + Right _ -> Spec.assertFailure s "expected failure on division by zero" + + Spec.it s "fails on modulo by zero" $ do + case evaluate Map.empty "1%0" of + Left _ -> pure () + Right _ -> Spec.assertFailure s "expected failure on modulo by zero" + + Spec.it s "treats identifiers starting with defined as identifiers" $ do + Spec.assertEq s (evaluate (Map.singleton "definedFoo" "5") "definedFoo") $ Right 5 + + Spec.it s "fails on empty expression" $ do + case evaluate Map.empty "" of + Left _ -> pure () + Right _ -> Spec.assertFailure s "expected failure on empty expression" diff --git a/source/library/Scrod/Decimal.hs b/source/library/Scrod/Decimal.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Decimal.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | Normalized decimal numbers represented as mantissa and exponent. +-- +-- A 'Decimal' value represents the number @mantissa * 10 ^ exponent@. +-- The smart constructor 'mkDecimal' ensures a canonical form by stripping +-- trailing zeros from the mantissa (shifting them into the exponent). +module Scrod.Decimal where + +import qualified Data.Function as Function +import qualified Scrod.Spec as Spec + +data Decimal = MkDecimal + { mantissa :: Integer, + exponent :: Integer + } + deriving (Eq, Ord, Show) + +-- | Construct a 'Decimal' in canonical form. Trailing zeros in the mantissa +-- are stripped and absorbed into the exponent. A zero mantissa always yields +-- @MkDecimal 0 0@ regardless of the exponent. +mkDecimal :: Integer -> Integer -> Decimal +mkDecimal = Function.fix $ \rec m e -> + if m == 0 + then MkDecimal 0 0 + else + let (q, r) = quotRem m 10 + in if r == 0 + then rec q (e + 1) + else MkDecimal m e + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'mkDecimal $ do + Spec.it s "normalizes zero mantissa" $ do + Spec.assertEq s (mkDecimal 0 5) $ MkDecimal 0 0 + + Spec.it s "normalizes zero mantissa with zero exponent" $ do + Spec.assertEq s (mkDecimal 0 0) $ MkDecimal 0 0 + + Spec.it s "keeps mantissa without trailing zeros" $ do + Spec.assertEq s (mkDecimal 123 5) $ MkDecimal 123 5 + + Spec.it s "removes one trailing zero" $ do + Spec.assertEq s (mkDecimal 120 5) $ MkDecimal 12 6 + + Spec.it s "removes multiple trailing zeros" $ do + Spec.assertEq s (mkDecimal 12000 5) $ MkDecimal 12 8 + + Spec.it s "normalizes negative mantissa with trailing zeros" $ do + Spec.assertEq s (mkDecimal (-1200) 3) $ MkDecimal (-12) 5 + + Spec.it s "keeps negative mantissa without trailing zeros" $ do + Spec.assertEq s (mkDecimal (-123) 5) $ MkDecimal (-123) 5 + + Spec.it s "works with negative exponent" $ do + Spec.assertEq s (mkDecimal 1200 (-5)) $ MkDecimal 12 (-3) + + Spec.it s "normalizes single digit" $ do + Spec.assertEq s (mkDecimal 5 0) $ MkDecimal 5 0 + + Spec.it s "normalizes mantissa that is all zeros except leading" $ do + Spec.assertEq s (mkDecimal 1000000 0) $ MkDecimal 1 6 diff --git a/source/library/Scrod/Executable/Config.hs b/source/library/Scrod/Executable/Config.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Executable/Config.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | CLI configuration record, built from parsed 'Flag.Flag' values. +module Scrod.Executable.Config where + +import qualified Control.Monad as Monad +import qualified Control.Monad.Catch as Exception +import Data.Sequence ((|>)) +import qualified Data.Sequence as Seq +import qualified GHC.Stack as Stack +import qualified Scrod.Executable.Flag as Flag +import qualified Scrod.Executable.Format as Format +import qualified Scrod.Extra.Read as Read +import qualified Scrod.Spec as Spec + +data Config = MkConfig + { format :: Format.Format, + ghcOptions :: Seq.Seq String, + help :: Bool, + literate :: Bool, + schema :: Bool, + signature :: Bool, + version :: Bool + } + deriving (Eq, Ord, Show) + +fromFlags :: (Stack.HasCallStack, Exception.MonadThrow m) => [Flag.Flag] -> m Config +fromFlags = Monad.foldM applyFlag initial + +applyFlag :: (Stack.HasCallStack, Exception.MonadThrow m) => Config -> Flag.Flag -> m Config +applyFlag config flag = case flag of + Flag.Format string -> do + fmt <- Format.fromString string + pure config {format = fmt} + Flag.GhcOption string -> pure config {ghcOptions = ghcOptions config |> string} + Flag.Help maybeString -> case maybeString of + Nothing -> pure config {help = True} + Just string -> do + bool <- Read.readM string + pure config {help = bool} + Flag.Literate maybeString -> case maybeString of + Nothing -> pure config {literate = True} + Just string -> do + bool <- Read.readM string + pure config {literate = bool} + Flag.Schema maybeString -> case maybeString of + Nothing -> pure config {schema = True} + Just string -> do + bool <- Read.readM string + pure config {schema = bool} + Flag.Signature maybeString -> case maybeString of + Nothing -> pure config {signature = True} + Just string -> do + bool <- Read.readM string + pure config {signature = bool} + Flag.Version maybeString -> case maybeString of + Nothing -> pure config {version = True} + Just string -> do + bool <- Read.readM string + pure config {version = bool} + +initial :: Config +initial = + MkConfig + { format = Format.Json, + ghcOptions = Seq.empty, + help = False, + literate = False, + schema = False, + signature = False, + version = False + } + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'fromFlags $ do + Spec.it s "works with no flags" $ do + Spec.assertEq s (fromFlags []) $ Just initial + + Spec.describe s "format" $ do + Spec.it s "defaults to json" $ do + Spec.assertEq s (fromFlags []) $ Just initial + + Spec.it s "works with json" $ do + Spec.assertEq s (fromFlags [Flag.Format "json"]) $ Just initial + + Spec.it s "works with html" $ do + Spec.assertEq s (fromFlags [Flag.Format "html"]) $ Just initial {format = Format.Html} + + Spec.it s "fails with invalid format" $ do + Spec.assertEq s (fromFlags [Flag.Format "invalid"]) Nothing + + Spec.describe s "literate" $ do + Spec.it s "works with nothing" $ do + Spec.assertEq s (fromFlags [Flag.Literate Nothing]) $ Just initial {literate = True} + + Spec.it s "works with just false" $ do + Spec.assertEq s (fromFlags [Flag.Literate $ Just "False"]) $ Just initial + + Spec.it s "works with just true" $ do + Spec.assertEq s (fromFlags [Flag.Literate $ Just "True"]) $ Just initial {literate = True} + + Spec.it s "fails with just invalid" $ do + Spec.assertEq s (fromFlags [Flag.Literate $ Just "invalid"]) Nothing + + Spec.describe s "schema" $ do + Spec.it s "works with nothing" $ do + Spec.assertEq s (fromFlags [Flag.Schema Nothing]) $ Just initial {schema = True} + + Spec.it s "works with just false" $ do + Spec.assertEq s (fromFlags [Flag.Schema $ Just "False"]) $ Just initial + + Spec.it s "works with just true" $ do + Spec.assertEq s (fromFlags [Flag.Schema $ Just "True"]) $ Just initial {schema = True} + + Spec.it s "fails with just invalid" $ do + Spec.assertEq s (fromFlags [Flag.Schema $ Just "invalid"]) Nothing + + Spec.describe s "signature" $ do + Spec.it s "works with nothing" $ do + Spec.assertEq s (fromFlags [Flag.Signature Nothing]) $ Just initial {signature = True} + + Spec.it s "works with just false" $ do + Spec.assertEq s (fromFlags [Flag.Signature $ Just "False"]) $ Just initial + + Spec.it s "works with just true" $ do + Spec.assertEq s (fromFlags [Flag.Signature $ Just "True"]) $ Just initial {signature = True} + + Spec.it s "fails with just invalid" $ do + Spec.assertEq s (fromFlags [Flag.Signature $ Just "invalid"]) Nothing + + Spec.describe s "help" $ do + Spec.it s "works with nothing" $ do + Spec.assertEq s (fromFlags [Flag.Help Nothing]) $ Just initial {help = True} + + Spec.it s "works with just false" $ do + Spec.assertEq s (fromFlags [Flag.Help $ Just "False"]) $ Just initial + + Spec.it s "works with just true" $ do + Spec.assertEq s (fromFlags [Flag.Help $ Just "True"]) $ Just initial {help = True} + + Spec.it s "picks the last flag" $ do + Spec.assertEq s (fromFlags [Flag.Help $ Just "False", Flag.Help Nothing]) $ Just initial {help = True} + + Spec.it s "fails with just invalid" $ do + Spec.assertEq s (fromFlags [Flag.Help $ Just "invalid"]) Nothing + + Spec.describe s "ghcOptions" $ do + Spec.it s "defaults to empty" $ do + Spec.assertEq s (ghcOptions <$> fromFlags []) $ Just Seq.empty + + Spec.it s "collects one option" $ do + Spec.assertEq s (ghcOptions <$> fromFlags [Flag.GhcOption "-XCPP"]) $ Just (Seq.fromList ["-XCPP"]) + + Spec.it s "collects multiple options in order" $ do + Spec.assertEq s (ghcOptions <$> fromFlags [Flag.GhcOption "-XCPP", Flag.GhcOption "-XGADTs"]) $ Just (Seq.fromList ["-XCPP", "-XGADTs"]) diff --git a/source/library/Scrod/Executable/Flag.hs b/source/library/Scrod/Executable/Flag.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Executable/Flag.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | CLI flag parsing via 'GetOpt'. +module Scrod.Executable.Flag where + +import qualified Control.Monad.Catch as Exception +import qualified GHC.Stack as Stack +import qualified Scrod.Spec as Spec +import qualified System.Console.GetOpt as GetOpt + +data Flag + = Format String + | GhcOption String + | Help (Maybe String) + | Literate (Maybe String) + | Schema (Maybe String) + | Signature (Maybe String) + | Version (Maybe String) + deriving (Eq, Ord, Show) + +fromArguments :: (Stack.HasCallStack, Exception.MonadThrow m) => [String] -> m [Flag] +fromArguments arguments = do + let (flgs, args, opts, errs) = GetOpt.getOpt' GetOpt.Permute optDescrs arguments + mapM_ (Exception.throwM . userError . mappend "invalid option: ") errs + mapM_ (Exception.throwM . userError . mappend "unknown option: ") opts + mapM_ (Exception.throwM . userError . mappend "unexpected argument: ") args + pure flgs + +optDescrs :: [GetOpt.OptDescr Flag] +optDescrs = + -- First help, then version, then everything else in alphabetical order. + [ GetOpt.Option ['h'] ["help"] (GetOpt.OptArg Help "BOOL") "Shows the help.", + GetOpt.Option [] ["version"] (GetOpt.OptArg Version "BOOL") "Shows the version.", + GetOpt.Option [] ["format"] (GetOpt.ReqArg Format "FORMAT") "Sets the output format (json or html).", + GetOpt.Option [] ["ghc-option"] (GetOpt.ReqArg GhcOption "OPTION") "Sets a GHC option (e.g. -XOverloadedStrings).", + GetOpt.Option [] ["literate"] (GetOpt.OptArg Literate "BOOL") "Treats the input as Literate Haskell.", + GetOpt.Option [] ["schema"] (GetOpt.OptArg Schema "BOOL") "Shows the JSON output schema.", + GetOpt.Option [] ["signature"] (GetOpt.OptArg Signature "BOOL") "Treats the input as a Backpack signature." + ] + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'fromArguments $ do + Spec.it s "works with no arguments" $ do + Spec.assertEq s (fromArguments []) $ Just [] + + Spec.it s "fails with an unknown option" $ do + Spec.assertEq s (fromArguments ["-x"]) Nothing + + Spec.it s "fails with an unexpected argument" $ do + Spec.assertEq s (fromArguments ["x"]) Nothing + + Spec.describe s "format" $ do + Spec.it s "works with an argument" $ do + Spec.assertEq s (fromArguments ["--format=json"]) $ Just [Format "json"] + + Spec.it s "works with html" $ do + Spec.assertEq s (fromArguments ["--format=html"]) $ Just [Format "html"] + + Spec.it s "fails with no argument" $ do + Spec.assertEq s (fromArguments ["--format"]) Nothing + + Spec.describe s "help" $ do + Spec.it s "works with no argument" $ do + Spec.assertEq s (fromArguments ["--help"]) $ Just [Help Nothing] + + Spec.it s "works with an argument" $ do + Spec.assertEq s (fromArguments ["--help="]) $ Just [Help $ Just ""] + + Spec.describe s "literate" $ do + Spec.it s "works with no argument" $ do + Spec.assertEq s (fromArguments ["--literate"]) $ Just [Literate Nothing] + + Spec.it s "works with an argument" $ do + Spec.assertEq s (fromArguments ["--literate="]) $ Just [Literate $ Just ""] + + Spec.describe s "schema" $ do + Spec.it s "works with no argument" $ do + Spec.assertEq s (fromArguments ["--schema"]) $ Just [Schema Nothing] + + Spec.it s "works with an argument" $ do + Spec.assertEq s (fromArguments ["--schema="]) $ Just [Schema $ Just ""] + + Spec.describe s "signature" $ do + Spec.it s "works with no argument" $ do + Spec.assertEq s (fromArguments ["--signature"]) $ Just [Signature Nothing] + + Spec.it s "works with an argument" $ do + Spec.assertEq s (fromArguments ["--signature="]) $ Just [Signature $ Just ""] + + Spec.describe s "version" $ do + Spec.it s "works with no argument" $ do + Spec.assertEq s (fromArguments ["--version"]) $ Just [Version Nothing] + + Spec.it s "works with an argument" $ do + Spec.assertEq s (fromArguments ["--version="]) $ Just [Version $ Just ""] + + Spec.describe s "ghc-option" $ do + Spec.it s "works with an argument" $ do + Spec.assertEq s (fromArguments ["--ghc-option=-XOverloadedStrings"]) $ Just [GhcOption "-XOverloadedStrings"] + + Spec.it s "fails with no argument" $ do + Spec.assertEq s (fromArguments ["--ghc-option"]) Nothing + + Spec.it s "works with multiple" $ do + Spec.assertEq s (fromArguments ["--ghc-option=-XCPP", "--ghc-option=-XGADTs"]) $ Just [GhcOption "-XCPP", GhcOption "-XGADTs"] diff --git a/source/library/Scrod/Executable/Format.hs b/source/library/Scrod/Executable/Format.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Executable/Format.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | Output format selection (@html@ or @json@). +module Scrod.Executable.Format where + +import qualified Control.Monad.Catch as Exception +import qualified GHC.Stack as Stack +import qualified Scrod.Spec as Spec + +data Format + = Html + | Json + deriving (Eq, Ord, Show) + +fromString :: (Stack.HasCallStack, Exception.MonadThrow m) => String -> m Format +fromString string = case string of + "html" -> pure Html + "json" -> pure Json + _ -> Exception.throwM . userError $ "invalid format: " <> show string + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'fromString $ do + Spec.it s "parses html" $ do + Spec.assertEq s (fromString "html") $ Just Html + + Spec.it s "parses json" $ do + Spec.assertEq s (fromString "json") $ Just Json + + Spec.it s "fails with invalid input" $ do + Spec.assertEq s (fromString "invalid") Nothing diff --git a/source/library/Scrod/Executable/Main.hs b/source/library/Scrod/Executable/Main.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Executable/Main.hs @@ -0,0 +1,73 @@ +-- | CLI entry point. Reads Haskell source from stdin, parses it via the +-- GHC API, converts to Scrod's core representation, and renders as HTML +-- or JSON to stdout. +module Scrod.Executable.Main where + +import qualified Control.Monad as Monad +import qualified Control.Monad.Catch as Exception +import qualified Control.Monad.Trans.Class as Trans +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Data.Bifunctor as Bifunctor +import qualified Data.ByteString.Builder as Builder +import qualified Data.Foldable as Foldable +import qualified Data.Version as Version +import qualified GHC.Stack as Stack +import qualified PackageInfo_scrod as PackageInfo +import qualified Scrod.Convert.FromGhc as FromGhc +import qualified Scrod.Convert.ToHtml as ToHtml +import qualified Scrod.Convert.ToJsonSchema as ToJsonSchema +import qualified Scrod.Executable.Config as Config +import qualified Scrod.Executable.Flag as Flag +import qualified Scrod.Executable.Format as Format +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Either as Either +import qualified Scrod.Extra.Semigroup as Semigroup +import qualified Scrod.Ghc.Parse as Parse +import qualified Scrod.Json.ToJson as ToJson +import qualified Scrod.Json.Value as Json +import qualified Scrod.Unlit as Unlit +import qualified Scrod.Xml.Document as Xml +import qualified System.Console.GetOpt as GetOpt +import qualified System.Environment as Environment +import qualified System.IO as IO + +defaultMain :: (Stack.HasCallStack) => IO () +defaultMain = do + name <- Environment.getProgName + arguments <- Environment.getArgs + result <- mainWith name arguments getContents + either putStr (Builder.hPutBuilder IO.stdout) result + +mainWith :: + (Stack.HasCallStack, Exception.MonadThrow m) => + String -> + [String] -> + m String -> + m (Either String Builder.Builder) +mainWith name arguments myGetContents = ExceptT.runExceptT $ do + flags <- Trans.lift $ Flag.fromArguments arguments + config <- Trans.lift $ Config.fromFlags flags + let version = Version.showVersion PackageInfo.version + Monad.when (Config.help config) $ do + let header = + unlines + [ unwords [name, "version", version], + Semigroup.around "<" ">" PackageInfo.homepage + ] + ExceptT.throwE $ GetOpt.usageInfo header Flag.optDescrs + Monad.when (Config.version config) . ExceptT.throwE $ version <> "\n" + Monad.when (Config.schema config) . ExceptT.throwE $ + Builder.toString (Json.encode ToJsonSchema.toJsonSchema) <> "\n" + contents <- Trans.lift myGetContents + source <- + if Config.literate config + then Either.throw . Bifunctor.first userError $ Unlit.unlit contents + else pure contents + let isSignature = Config.signature config + let ghcOpts = Foldable.toList (Config.ghcOptions config) + result <- Either.throw . Bifunctor.first userError $ Parse.parse isSignature ghcOpts source + module_ <- Either.throw . Bifunctor.first userError $ FromGhc.fromGhc isSignature result + let convert = case Config.format config of + Format.Json -> Json.encode . ToJson.toJson + Format.Html -> Xml.encodeHtml . ToHtml.toHtml + pure $ convert module_ <> Builder.charUtf8 '\n' diff --git a/source/library/Scrod/Extra/Builder.hs b/source/library/Scrod/Extra/Builder.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Extra/Builder.hs @@ -0,0 +1,71 @@ +{- hlint ignore "Avoid restricted extensions" -} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Extra.Builder where + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy.Char8 as LazyByteString +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Encoding +import qualified Scrod.Spec as Spec + +toByteString :: Builder.Builder -> ByteString.ByteString +toByteString = LazyByteString.toStrict . Builder.toLazyByteString + +toText :: Builder.Builder -> Text.Text +toText = Encoding.decodeUtf8Lenient . toByteString + +toString :: Builder.Builder -> String +toString = Text.unpack . toText + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'toByteString $ do + Spec.it s "works with an empty builder" $ do + Spec.assertEq s (toByteString "") "" + + Spec.it s "works with one byte" $ do + Spec.assertEq s (toByteString " \x0 ") " \x0 " + + Spec.it s "works with two bytes" $ do + Spec.assertEq s (toByteString " \x80 ") " \xc2\x80 " + + Spec.it s "works with three bytes" $ do + Spec.assertEq s (toByteString " \x800 ") " \xe0\xa0\x80 " + + Spec.it s "works with four bytes" $ do + Spec.assertEq s (toByteString " \x10000 ") " \xf0\x90\x80\x80 " + + Spec.named s 'toText $ do + Spec.it s "works with an empty builder" $ do + Spec.assertEq s (toText "") "" + + Spec.it s "works with one byte" $ do + Spec.assertEq s (toText " \x0 ") " \x0 " + + Spec.it s "works with two bytes" $ do + Spec.assertEq s (toText " \x80 ") " \x80 " + + Spec.it s "works with three bytes" $ do + Spec.assertEq s (toText " \x800 ") " \x800 " + + Spec.it s "works with four bytes" $ do + Spec.assertEq s (toText " \x10000 ") " \x10000 " + + Spec.named s 'toString $ do + Spec.it s "works with an empty builder" $ do + Spec.assertEq s (toString "") "" + + Spec.it s "works with one byte" $ do + Spec.assertEq s (toString " \x0 ") " \x0 " + + Spec.it s "works with two bytes" $ do + Spec.assertEq s (toString " \x80 ") " \x80 " + + Spec.it s "works with three bytes" $ do + Spec.assertEq s (toString " \x800 ") " \x800 " + + Spec.it s "works with four bytes" $ do + Spec.assertEq s (toString " \x10000 ") " \x10000 " diff --git a/source/library/Scrod/Extra/Either.hs b/source/library/Scrod/Extra/Either.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Extra/Either.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Extra.Either where + +import qualified Control.Monad.Catch as Exception +import qualified Data.Void as Void +import qualified GHC.Stack as Stack +import qualified Scrod.Spec as Spec + +hush :: Either x a -> Maybe a +hush = either (const Nothing) Just + +throw :: (Stack.HasCallStack, Exception.Exception e, Exception.MonadThrow m) => Either e a -> m a +throw = either Exception.throwM pure + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'hush $ do + Spec.it s "works with left" $ do + Spec.assertEq s (hush (Left () :: Either () Void.Void)) Nothing + + Spec.it s "works with right" $ do + Spec.assertEq s (hush (Right () :: Either Void.Void ())) $ Just () + + Spec.named s 'throw $ do + Spec.it s "works with left" $ do + Spec.assertEq s (throw (Left (userError "") :: Either IOError Void.Void)) Nothing + + Spec.it s "works with right" $ do + Spec.assertEq s (throw (Right () :: Either Void.Void ())) $ Just () diff --git a/source/library/Scrod/Extra/Maybe.hs b/source/library/Scrod/Extra/Maybe.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Extra/Maybe.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Extra.Maybe where + +import qualified Data.Void as Void +import qualified Scrod.Spec as Spec + +note :: e -> Maybe a -> Either e a +note x = maybe (Left x) Right + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'note $ do + Spec.it s "works with nothing" $ do + Spec.assertEq s (note () Nothing) (Left () :: Either () Void.Void) + + Spec.it s "works with just" $ do + Spec.assertEq s (note False $ Just ()) $ Right () diff --git a/source/library/Scrod/Extra/Monoid.hs b/source/library/Scrod/Extra/Monoid.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Extra/Monoid.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Extra.Monoid where + +import qualified Scrod.Spec as Spec + +sepBy :: (Monoid a) => a -> [a] -> a +sepBy s xs = case xs of + [] -> mempty + h : t -> h <> foldMap (s <>) t + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'sepBy $ do + Spec.it s "works with an empty list" $ do + Spec.assertEq s (sepBy "," []) "" + + Spec.it s "works with one element" $ do + Spec.assertEq s (sepBy "," ["a"]) "a" + + Spec.it s "works with two elements" $ do + Spec.assertEq s (sepBy "," ["a", "b"]) "a,b" diff --git a/source/library/Scrod/Extra/Ord.hs b/source/library/Scrod/Extra/Ord.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Extra/Ord.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Extra.Ord where + +import qualified Scrod.Spec as Spec + +between :: (Ord a) => a -> a -> a -> Bool +between lo hi x = lo <= x && x <= hi + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'between $ do + Spec.it s "fails when too low" $ do + Spec.assertEq s (between 'b' 'd' 'a') False + + Spec.it s "succeeds when at the lower bound" $ do + Spec.assertEq s (between 'b' 'd' 'b') True + + Spec.it s "succeeds when in the middle" $ do + Spec.assertEq s (between 'b' 'd' 'c') True + + Spec.it s "succeeds when at the upper bound" $ do + Spec.assertEq s (between 'b' 'd' 'd') True + + Spec.it s "fails when too high" $ do + Spec.assertEq s (between 'b' 'd' 'e') False diff --git a/source/library/Scrod/Extra/Parsec.hs b/source/library/Scrod/Extra/Parsec.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Extra/Parsec.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Extra.Parsec where + +import qualified Scrod.Extra.Either as Either +import qualified Scrod.Spec as Spec +import qualified Text.Parsec as Parsec + +blank :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Char +blank = Parsec.oneOf " \t\n\r" + +parseString :: Parsec.Parsec String () a -> String -> Maybe a +parseString p = Either.hush . Parsec.parse p "" + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'blank $ do + Spec.it s "succeeds with space" $ do + Spec.assertEq s (parseString blank " ") $ Just ' ' + + Spec.it s "succeeds with tab" $ do + Spec.assertEq s (parseString blank "\t") $ Just '\t' + + Spec.it s "succeeds with line feed" $ do + Spec.assertEq s (parseString blank "\n") $ Just '\n' + + Spec.it s "succeeds with carriage return" $ do + Spec.assertEq s (parseString blank "\r") $ Just '\r' + + Spec.it s "fails with anything else" $ do + Spec.assertEq s (parseString blank "x") Nothing + + Spec.named s 'parseString $ do + Spec.it s "succeeds with valid input" $ do + Spec.assertEq s (parseString Parsec.letter "a") $ Just 'a' + + Spec.it s "fails with invalid input" $ do + Spec.assertEq s (parseString Parsec.letter "1") Nothing + + Spec.it s "allows unconsumed input" $ do + Spec.assertEq s (parseString Parsec.letter "b1") $ Just 'b' diff --git a/source/library/Scrod/Extra/Read.hs b/source/library/Scrod/Extra/Read.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Extra/Read.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Extra.Read where + +import qualified Control.Monad.Catch as Exception +import qualified Data.Typeable as Typeable +import qualified GHC.Stack as Stack +import qualified Scrod.Extra.Either as Either +import qualified Scrod.Extra.Maybe as Maybe +import qualified Scrod.Spec as Spec +import qualified Text.Read as Read + +readM :: forall a m. (Stack.HasCallStack, Exception.MonadThrow m, Read a, Typeable.Typeable a) => String -> m a +readM string = + let proxy = Typeable.Proxy :: Typeable.Proxy a + in Either.throw + . Maybe.note (userError $ "invalid " <> show (Typeable.typeRep proxy) <> ": " <> show string) + $ Read.readMaybe string + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'readM $ do + Spec.it s "succeeds with valid input" $ do + Spec.assertEq s (readM "True") $ Just True + + Spec.it s "fails with invalid input" $ do + Spec.assertEq s (readM "invalid") (Nothing :: Maybe Bool) diff --git a/source/library/Scrod/Extra/Semigroup.hs b/source/library/Scrod/Extra/Semigroup.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Extra/Semigroup.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Extra.Semigroup where + +import qualified Scrod.Spec as Spec + +around :: (Semigroup a) => a -> a -> a -> a +around before after = (before <>) . (<> after) + +spec :: (Applicative m) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'around $ do + Spec.it s "works" $ do + Spec.assertEq s (around "<" ">" "html") "" diff --git a/source/library/Scrod/Ghc/ArchOS.hs b/source/library/Scrod/Ghc/ArchOS.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Ghc/ArchOS.hs @@ -0,0 +1,10 @@ +module Scrod.Ghc.ArchOS where + +import qualified GHC.Platform.ArchOS as ArchOS + +empty :: ArchOS.ArchOS +empty = + ArchOS.ArchOS + { ArchOS.archOS_arch = ArchOS.ArchUnknown, + ArchOS.archOS_OS = ArchOS.OSUnknown + } diff --git a/source/library/Scrod/Ghc/DynFlags.hs b/source/library/Scrod/Ghc/DynFlags.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Ghc/DynFlags.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | A minimal 'DynFlags.DynFlags' stub sufficient for parsing. +-- +-- GHC's parser requires a 'DynFlags' value, but most fields are irrelevant +-- for parsing alone. This module constructs one where only the fields +-- actually accessed during parsing (e.g., 'DynFlags.extensions', +-- 'DynFlags.language') have real values; everything else throws +-- 'Uninitialized.Uninitialized' if accessed, which makes it obvious when +-- a new GHC version starts touching an unexpected field. +module Scrod.Ghc.DynFlags where + +import qualified Data.Set as Set +import qualified GHC.Core.Unfold as Unfold +import qualified GHC.Data.EnumSet as EnumSet +import qualified GHC.Driver.Backend as Backend +import qualified GHC.Driver.DynFlags as DynFlags +import qualified GHC.Stack as Stack +import qualified GHC.Types.SafeHaskell as SafeHaskell +import qualified Scrod.Ghc.FileSettings as FileSettings +import qualified Scrod.Ghc.GhcNameVersion as GhcNameVersion +import qualified Scrod.Ghc.Platform as Platform +import qualified Scrod.Ghc.PlatformMisc as PlatformMisc +import qualified Scrod.Ghc.ToolSettings as ToolSettings +import qualified Scrod.Ghc.Uninitialized as Uninitialized +import qualified Scrod.Ghc.UnitSettings as UnitSettings + +empty :: (Stack.HasCallStack) => DynFlags.DynFlags +empty = + DynFlags.DynFlags + { DynFlags.avx = Uninitialized.throw 'DynFlags.avx, + DynFlags.avx2 = Uninitialized.throw 'DynFlags.avx2, + DynFlags.avx512cd = Uninitialized.throw 'DynFlags.avx512cd, + DynFlags.avx512er = Uninitialized.throw 'DynFlags.avx512er, + DynFlags.avx512f = Uninitialized.throw 'DynFlags.avx512f, + DynFlags.avx512pf = Uninitialized.throw 'DynFlags.avx512pf, + DynFlags.backend = Backend.noBackend, + DynFlags.binBlobThreshold = Uninitialized.throw 'DynFlags.binBlobThreshold, + DynFlags.bmiVersion = Uninitialized.throw 'DynFlags.bmiVersion, + DynFlags.callerCcFilters = Uninitialized.throw 'DynFlags.callerCcFilters, + DynFlags.canUseColor = Uninitialized.throw 'DynFlags.canUseColor, + DynFlags.canUseErrorLinks = Uninitialized.throw 'DynFlags.canUseErrorLinks, + DynFlags.cfgWeights = Uninitialized.throw 'DynFlags.cfgWeights, + DynFlags.cmdlineFrameworks = Uninitialized.throw 'DynFlags.cmdlineFrameworks, + DynFlags.cmmProcAlignment = Uninitialized.throw 'DynFlags.cmmProcAlignment, + DynFlags.colScheme = Uninitialized.throw 'DynFlags.colScheme, + DynFlags.customWarningCategories = Uninitialized.throw 'DynFlags.customWarningCategories, + DynFlags.debugLevel = Uninitialized.throw 'DynFlags.debugLevel, + DynFlags.depExcludeMods = Uninitialized.throw 'DynFlags.depExcludeMods, + DynFlags.depIncludeCppDeps = Uninitialized.throw 'DynFlags.depIncludeCppDeps, + DynFlags.depIncludePkgDeps = Uninitialized.throw 'DynFlags.depIncludePkgDeps, + DynFlags.depMakefile = Uninitialized.throw 'DynFlags.depMakefile, + DynFlags.depSuffixes = Uninitialized.throw 'DynFlags.depSuffixes, + DynFlags.deriveViaOnLoc = Uninitialized.throw 'DynFlags.deriveViaOnLoc, + DynFlags.dmdUnboxWidth = 0, + DynFlags.dumpDir = Uninitialized.throw 'DynFlags.dumpDir, + DynFlags.dumpFlags = Uninitialized.throw 'DynFlags.dumpFlags, + DynFlags.dumpPrefix = Uninitialized.throw 'DynFlags.dumpPrefix, + DynFlags.dumpPrefixForce = Uninitialized.throw 'DynFlags.dumpPrefixForce, + DynFlags.dylibInstallName = Uninitialized.throw 'DynFlags.dylibInstallName, + DynFlags.dynamicNow = False, + DynFlags.dynHiSuf_ = Uninitialized.throw 'DynFlags.dynHiSuf_, + DynFlags.dynLibLoader = Uninitialized.throw 'DynFlags.dynLibLoader, + DynFlags.dynObjectSuf_ = Uninitialized.throw 'DynFlags.dynObjectSuf_, + DynFlags.dynOutputFile_ = Uninitialized.throw 'DynFlags.dynOutputFile_, + DynFlags.dynOutputHi = Uninitialized.throw 'DynFlags.dynOutputHi, + DynFlags.enableTimeStats = False, + DynFlags.extensionFlags = EnumSet.empty, + DynFlags.extensions = [], + DynFlags.externalPluginSpecs = Uninitialized.throw 'DynFlags.externalPluginSpecs, + DynFlags.fatalCustomWarningCategories = Uninitialized.throw 'DynFlags.fatalCustomWarningCategories, + DynFlags.fatalWarningFlags = Uninitialized.throw 'DynFlags.fatalWarningFlags, + DynFlags.fileSettings = FileSettings.empty, + DynFlags.floatLamArgs = Uninitialized.throw 'DynFlags.floatLamArgs, + DynFlags.flushOut = Uninitialized.throw 'DynFlags.flushOut, + DynFlags.fma = Uninitialized.throw 'DynFlags.fma, + DynFlags.frameworkPaths = Uninitialized.throw 'DynFlags.frameworkPaths, + DynFlags.frontendPluginOpts = Uninitialized.throw 'DynFlags.frontendPluginOpts, + DynFlags.generalFlags = EnumSet.empty, + DynFlags.ghcHeapSize = Nothing, + DynFlags.ghciBrowserHost = "", + DynFlags.ghciBrowserPlaywrightBrowserType = Nothing, + DynFlags.ghciBrowserPlaywrightLaunchOpts = Nothing, + DynFlags.ghciBrowserPort = 0, + DynFlags.ghciBrowserPuppeteerLaunchOpts = Nothing, + DynFlags.ghciHistSize = Uninitialized.throw 'DynFlags.ghciHistSize, + DynFlags.ghciScripts = Uninitialized.throw 'DynFlags.ghciScripts, + DynFlags.ghcLink = DynFlags.NoLink, + DynFlags.ghcMode = Uninitialized.throw 'DynFlags.ghcMode, + DynFlags.ghcNameVersion = GhcNameVersion.empty, + DynFlags.ghcVersionFile = Uninitialized.throw 'DynFlags.ghcVersionFile, + DynFlags.givensFuel = Uninitialized.throw 'DynFlags.givensFuel, + DynFlags.haddockOptions = Uninitialized.throw 'DynFlags.haddockOptions, + DynFlags.hcSuf = Uninitialized.throw 'DynFlags.hcSuf, + DynFlags.hiddenModules = mempty, + DynFlags.hiDir = Uninitialized.throw 'DynFlags.hiDir, + DynFlags.hieDir = Uninitialized.throw 'DynFlags.hieDir, + DynFlags.hieSuf = Uninitialized.throw 'DynFlags.hieSuf, + DynFlags.historySize = Uninitialized.throw 'DynFlags.historySize, + DynFlags.hiSuf_ = Uninitialized.throw 'DynFlags.hiSuf_, + DynFlags.homeUnitId_ = Uninitialized.throw 'DynFlags.homeUnitId_, + DynFlags.homeUnitInstanceOf_ = Uninitialized.throw 'DynFlags.homeUnitInstanceOf_, + DynFlags.homeUnitInstantiations_ = Uninitialized.throw 'DynFlags.homeUnitInstantiations_, + DynFlags.hpcDir = Uninitialized.throw 'DynFlags.hpcDir, + DynFlags.ifCompression = Uninitialized.throw 'DynFlags.ifCompression, + DynFlags.ignorePackageFlags = Uninitialized.throw 'DynFlags.ignorePackageFlags, + DynFlags.importPaths = Uninitialized.throw 'DynFlags.importPaths, + DynFlags.includePaths = Uninitialized.throw 'DynFlags.includePaths, + DynFlags.incoherentOnLoc = Uninitialized.throw 'DynFlags.incoherentOnLoc, + DynFlags.initialUnique = Uninitialized.throw 'DynFlags.initialUnique, + DynFlags.interactivePrint = Uninitialized.throw 'DynFlags.interactivePrint, + DynFlags.language = Nothing, + DynFlags.ldInputs = Uninitialized.throw 'DynFlags.ldInputs, + DynFlags.liberateCaseThreshold = Uninitialized.throw 'DynFlags.liberateCaseThreshold, + DynFlags.libraryPaths = Uninitialized.throw 'DynFlags.libraryPaths, + DynFlags.liftLamsKnown = Uninitialized.throw 'DynFlags.liftLamsKnown, + DynFlags.liftLamsNonRecArgs = Uninitialized.throw 'DynFlags.liftLamsNonRecArgs, + DynFlags.liftLamsRecArgs = Uninitialized.throw 'DynFlags.liftLamsRecArgs, + DynFlags.llvmOptLevel = 0, + DynFlags.mainFunIs = Uninitialized.throw 'DynFlags.mainFunIs, + DynFlags.mainModuleNameIs = Uninitialized.throw 'DynFlags.mainModuleNameIs, + DynFlags.maxErrors = Uninitialized.throw 'DynFlags.maxErrors, + DynFlags.maxForcedSpecArgs = Uninitialized.throw 'DynFlags.maxForcedSpecArgs, + DynFlags.maxInlineAllocSize = Uninitialized.throw 'DynFlags.maxInlineAllocSize, + DynFlags.maxInlineMemcpyInsns = Uninitialized.throw 'DynFlags.maxInlineMemcpyInsns, + DynFlags.maxInlineMemsetInsns = Uninitialized.throw 'DynFlags.maxInlineMemsetInsns, + DynFlags.maxPmCheckModels = Uninitialized.throw 'DynFlags.maxPmCheckModels, + DynFlags.maxRefHoleFits = Uninitialized.throw 'DynFlags.maxRefHoleFits, + DynFlags.maxRelevantBinds = Uninitialized.throw 'DynFlags.maxRelevantBinds, + DynFlags.maxSimplIterations = Uninitialized.throw 'DynFlags.maxSimplIterations, + DynFlags.maxUncoveredPatterns = Uninitialized.throw 'DynFlags.maxUncoveredPatterns, + DynFlags.maxValidHoleFits = Uninitialized.throw 'DynFlags.maxValidHoleFits, + DynFlags.maxWorkerArgs = Uninitialized.throw 'DynFlags.maxWorkerArgs, + DynFlags.newDerivOnLoc = Uninitialized.throw 'DynFlags.newDerivOnLoc, + DynFlags.objectDir = Uninitialized.throw 'DynFlags.objectDir, + DynFlags.objectSuf_ = Uninitialized.throw 'DynFlags.objectSuf_, + DynFlags.outputFile_ = Uninitialized.throw 'DynFlags.outputFile_, + DynFlags.outputHi = Uninitialized.throw 'DynFlags.outputHi, + DynFlags.overlapInstLoc = Uninitialized.throw 'DynFlags.overlapInstLoc, + DynFlags.packageDBFlags = Uninitialized.throw 'DynFlags.packageDBFlags, + DynFlags.packageEnv = Uninitialized.throw 'DynFlags.packageEnv, + DynFlags.packageFlags = Uninitialized.throw 'DynFlags.packageFlags, + DynFlags.parMakeCount = Uninitialized.throw 'DynFlags.parMakeCount, + DynFlags.pkgTrustOnLoc = Uninitialized.throw 'DynFlags.pkgTrustOnLoc, + DynFlags.platformMisc = PlatformMisc.empty, + DynFlags.pluginModNameOpts = Uninitialized.throw 'DynFlags.pluginModNameOpts, + DynFlags.pluginModNames = Uninitialized.throw 'DynFlags.pluginModNames, + DynFlags.pluginPackageFlags = Uninitialized.throw 'DynFlags.pluginPackageFlags, + DynFlags.pprCols = Uninitialized.throw 'DynFlags.pprCols, + DynFlags.pprUserLength = Uninitialized.throw 'DynFlags.pprUserLength, + DynFlags.profAuto = Uninitialized.throw 'DynFlags.profAuto, + DynFlags.qcsFuel = Uninitialized.throw 'DynFlags.qcsFuel, + DynFlags.rawSettings = Uninitialized.throw 'DynFlags.rawSettings, + DynFlags.reductionDepth = Uninitialized.throw 'DynFlags.reductionDepth, + DynFlags.reexportedModules = [], + DynFlags.refLevelHoleFits = Uninitialized.throw 'DynFlags.refLevelHoleFits, + DynFlags.reverseErrors = Uninitialized.throw 'DynFlags.reverseErrors, + DynFlags.rtsOpts = Uninitialized.throw 'DynFlags.rtsOpts, + DynFlags.rtsOptsEnabled = Uninitialized.throw 'DynFlags.rtsOptsEnabled, + DynFlags.rtsOptsSuggestions = Uninitialized.throw 'DynFlags.rtsOptsSuggestions, + DynFlags.ruleCheck = Uninitialized.throw 'DynFlags.ruleCheck, + DynFlags.safeHaskell = SafeHaskell.Sf_Ignore, + DynFlags.safeInfer = False, + DynFlags.safeInferred = Uninitialized.throw 'DynFlags.safeInferred, + DynFlags.simplPhases = Uninitialized.throw 'DynFlags.simplPhases, + DynFlags.simplTickFactor = Uninitialized.throw 'DynFlags.simplTickFactor, + DynFlags.solverIterations = Uninitialized.throw 'DynFlags.solverIterations, + DynFlags.specConstrCount = Uninitialized.throw 'DynFlags.specConstrCount, + DynFlags.specConstrRecursive = Uninitialized.throw 'DynFlags.specConstrRecursive, + DynFlags.specConstrThreshold = Uninitialized.throw 'DynFlags.specConstrThreshold, + DynFlags.splitInfo = Uninitialized.throw 'DynFlags.splitInfo, + DynFlags.sseVersion = Uninitialized.throw 'DynFlags.sseVersion, + DynFlags.strictnessBefore = Uninitialized.throw 'DynFlags.strictnessBefore, + DynFlags.stubDir = Uninitialized.throw 'DynFlags.stubDir, + DynFlags.targetPlatform = Platform.empty, + DynFlags.targetWays_ = Set.empty, + DynFlags.thisPackageName = Uninitialized.throw 'DynFlags.thisPackageName, + DynFlags.thOnLoc = Uninitialized.throw 'DynFlags.thOnLoc, + DynFlags.tmpDir = Uninitialized.throw 'DynFlags.tmpDir, + DynFlags.toolSettings = ToolSettings.empty, + DynFlags.trustFlags = Uninitialized.throw 'DynFlags.trustFlags, + DynFlags.trustworthyOnLoc = Uninitialized.throw 'DynFlags.trustworthyOnLoc, + DynFlags.unfoldingOpts = Unfold.defaultUnfoldingOpts, + DynFlags.uniqueIncrement = Uninitialized.throw 'DynFlags.uniqueIncrement, + DynFlags.unitSettings = UnitSettings.empty, + DynFlags.useColor = Uninitialized.throw 'DynFlags.useColor, + DynFlags.useErrorLinks = Uninitialized.throw 'DynFlags.useErrorLinks, + DynFlags.useUnicode = Uninitialized.throw 'DynFlags.useUnicode, + DynFlags.verbosity = Uninitialized.throw 'DynFlags.verbosity, + DynFlags.wantedsFuel = Uninitialized.throw 'DynFlags.wantedsFuel, + DynFlags.warningFlags = Uninitialized.throw 'DynFlags.warningFlags, + DynFlags.warnSafeOnLoc = Uninitialized.throw 'DynFlags.warnSafeOnLoc, + DynFlags.warnUnsafeOnLoc = Uninitialized.throw 'DynFlags.warnUnsafeOnLoc, + DynFlags.workingDirectory = Uninitialized.throw 'DynFlags.workingDirectory + } diff --git a/source/library/Scrod/Ghc/FileSettings.hs b/source/library/Scrod/Ghc/FileSettings.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Ghc/FileSettings.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Ghc.FileSettings where + +import qualified GHC.Driver.Session as Session +import qualified GHC.Stack as Stack +import qualified Scrod.Ghc.Uninitialized as Uninitialized + +empty :: (Stack.HasCallStack) => Session.FileSettings +empty = + Session.FileSettings + { Session.fileSettings_ghcUsagePath = Uninitialized.throw 'Session.fileSettings_ghcUsagePath, + Session.fileSettings_ghciUsagePath = Uninitialized.throw 'Session.fileSettings_ghciUsagePath, + Session.fileSettings_globalPackageDatabase = Uninitialized.throw 'Session.fileSettings_globalPackageDatabase, + Session.fileSettings_toolDir = Uninitialized.throw 'Session.fileSettings_toolDir, + Session.fileSettings_topDir = Uninitialized.throw 'Session.fileSettings_topDir + } diff --git a/source/library/Scrod/Ghc/GhcNameVersion.hs b/source/library/Scrod/Ghc/GhcNameVersion.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Ghc/GhcNameVersion.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Ghc.GhcNameVersion where + +import qualified GHC.Driver.Session as Session +import qualified GHC.Stack as Stack +import qualified Scrod.Ghc.Uninitialized as Uninitialized + +empty :: (Stack.HasCallStack) => Session.GhcNameVersion +empty = + Session.GhcNameVersion + { Session.ghcNameVersion_programName = Uninitialized.throw 'Session.ghcNameVersion_programName, + Session.ghcNameVersion_projectVersion = Uninitialized.throw 'Session.ghcNameVersion_projectVersion + } diff --git a/source/library/Scrod/Ghc/OnOff.hs b/source/library/Scrod/Ghc/OnOff.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Ghc/OnOff.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Ghc.OnOff where + +import qualified GHC.Driver.DynFlags as DynFlags +import qualified Scrod.Spec as Spec + +onOff :: (a -> b) -> (a -> b) -> DynFlags.OnOff a -> b +onOff f g x = case x of + DynFlags.On y -> f y + DynFlags.Off y -> g y + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'onOff $ do + Spec.it s "works with On" $ do + Spec.assertEq s (onOff succ pred $ DynFlags.On 'b') 'c' + + Spec.it s "works with Off" $ do + Spec.assertEq s (onOff succ pred $ DynFlags.Off 'b') 'a' diff --git a/source/library/Scrod/Ghc/Parse.hs b/source/library/Scrod/Ghc/Parse.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Ghc/Parse.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | Parse Haskell source into a GHC AST without a full GHC session. +-- +-- Bootstraps a minimal set of GHC internals ('DynFlags.empty', +-- 'ParserOpts.fromExtensions') to run the GHC lexer and parser +-- stand-alone. The pipeline is: +-- +-- 1. Discover @LANGUAGE@ pragmas and extensions from the source. +-- 2. If CPP is enabled, preprocess with 'Cpp.cpp'. +-- 3. Parse into @HsModule GhcPs@ using GHC's parser. +module Scrod.Ghc.Parse where + +import qualified Control.Monad.Catch as Exception +import qualified Data.Bifunctor as Bifunctor +import qualified GHC.Data.EnumSet as EnumSet +import qualified GHC.Data.FastString as FastString +import qualified GHC.Data.StringBuffer as StringBuffer +import qualified GHC.Driver.DynFlags as DynFlags +import qualified GHC.Driver.Flags as Flags +import qualified GHC.Driver.Session as Session +import qualified GHC.Hs.Extension as Ghc +import qualified GHC.LanguageExtensions.Type as Extension +import qualified GHC.Parser as Parser +import qualified GHC.Parser.Header as Header +import qualified GHC.Parser.Lexer as Lexer +import qualified GHC.Types.SourceError as SourceError +import qualified GHC.Types.SrcLoc as SrcLoc +import qualified GHC.Utils.Logger as Logger +import qualified GHC.Utils.Outputable as Outputable +import qualified Language.Haskell.Syntax as Hs +import qualified Scrod.Cabal as Cabal +import qualified Scrod.Cpp as Cpp +import qualified Scrod.Ghc.ArchOS as ArchOS +import qualified Scrod.Ghc.DynFlags as DynFlags +import qualified Scrod.Ghc.OnOff as OnOff +import qualified Scrod.Ghc.ParserOpts as ParserOpts +import qualified Scrod.Spec as Spec +import qualified System.IO.Unsafe as Unsafe + +parse :: + Bool -> + [String] -> + String -> + Either + String + ( (Maybe Session.Language, [DynFlags.OnOff Extension.Extension]), + SrcLoc.Located (Hs.HsModule Ghc.GhcPs) + ) +parse isSignature extraOptions string = do + let originalStringBuffer = StringBuffer.stringToStringBuffer string + let cabalOptions = cabalExtensionOptions string + let options = fmap SrcLoc.noLoc $ extraOptions <> cabalOptions + languageAndExtensions <- Bifunctor.first Exception.displayException $ discoverExtensions options originalStringBuffer + let extensions = uncurry resolveExtensions languageAndExtensions + source <- + if EnumSet.member Extension.Cpp extensions + then Cpp.cpp string + else Right string + let modifiedStringBuffer = StringBuffer.stringToStringBuffer source + let parserOpts = ParserOpts.fromExtensions extensions + let fastString = FastString.fsLit interactiveFilePath + let realSrcLoc = SrcLoc.mkRealSrcLoc fastString 1 1 + let pState = Lexer.initParserState parserOpts modifiedStringBuffer realSrcLoc + let parser = if isSignature then Parser.parseSignature else Parser.parseModule + case Lexer.unP parser pState of + Lexer.PFailed newPState -> Left . Outputable.showSDocUnsafe . Outputable.ppr $ Lexer.getPsErrorMessages newPState + Lexer.POk _ lHsModule -> pure (languageAndExtensions, lHsModule) + +cabalExtensionOptions :: String -> [String] +cabalExtensionOptions = fmap ("-X" <>) . Cabal.discoverExtensions + +discoverExtensions :: + [SrcLoc.Located String] -> + StringBuffer.StringBuffer -> + Either + SourceError.SourceError + (Maybe Flags.Language, [DynFlags.OnOff Extension.Extension]) +discoverExtensions cabalOptions = + Unsafe.unsafePerformIO + . Exception.try + . discoverExtensionsIO cabalOptions + +discoverExtensionsIO :: + [SrcLoc.Located String] -> + StringBuffer.StringBuffer -> + IO (Maybe Flags.Language, [DynFlags.OnOff Extension.Extension]) +discoverExtensionsIO cabalOptions stringBuffer = do + logger <- Logger.initLogger + (dynFlags, _, _) <- Session.parseDynamicFilePragma logger DynFlags.empty $ cabalOptions <> discoverOptions stringBuffer + pure (DynFlags.language dynFlags, DynFlags.extensions dynFlags) + +discoverOptions :: StringBuffer.StringBuffer -> [SrcLoc.Located String] +discoverOptions stringBuffer = + snd $ Header.getOptions ParserOpts.empty supportedLanguages stringBuffer interactiveFilePath + +supportedLanguages :: [String] +supportedLanguages = Session.supportedLanguagesAndExtensions ArchOS.empty + +interactiveFilePath :: FilePath +interactiveFilePath = "" + +resolveExtensions :: + Maybe Session.Language -> + [DynFlags.OnOff Extension.Extension] -> + EnumSet.EnumSet Extension.Extension +resolveExtensions = + foldr (OnOff.onOff EnumSet.insert EnumSet.delete) + . EnumSet.fromList + . Session.languageExtensions + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'parse $ do + Spec.it s "succeeds with empty input" $ do + Spec.assertEq s (fst <$> parse False [] "") $ Right (Nothing, []) + + Spec.it s "fails with invalid input" $ do + Spec.assertEq s (fst <$> parse False [] "!") $ Left "{Resolved: ErrorWithoutFlag\n ErrorWithoutFlag\n parse error on input `!'}" + + Spec.it s "fails with unknown language extension" $ do + Spec.assertEq s (fst <$> parse False [] "{-# language Unknown #-}") $ Left ":1:14: error: [GHC-46537]\n Unsupported extension: Unknown" + + Spec.it s "succeeds with a language" $ do + Spec.assertEq s (fst <$> parse False [] "{-# language Haskell98 #-}") $ Right (Just Session.Haskell98, []) + + Spec.it s "succeeds with an enabled extension" $ do + Spec.assertEq s (fst <$> parse False [] "{-# language CPP #-}") $ Right (Nothing, [Session.On Extension.Cpp]) + + Spec.it s "succeeds with a disabled extension" $ do + Spec.assertEq s (fst <$> parse False [] "{-# language NoCPP #-}") $ Right (Nothing, [Session.Off Extension.Cpp]) + + Spec.it s "succeeds with a signature" $ do + Spec.assertEq s (fst <$> parse True [] "signature Foo where") $ Right (Nothing, []) + + Spec.it s "succeeds with cabal script header extension" $ do + Spec.assertEq s (fst <$> parse False [] "{- cabal:\ndefault-extensions: CPP\n-}") $ Right (Nothing, [Session.On Extension.Cpp]) + + Spec.it s "succeeds with extra options" $ do + Spec.assertEq s (fst <$> parse False ["-XOverloadedStrings"] "") $ Right (Nothing, [Session.On Extension.OverloadedStrings]) + + Spec.it s "succeeds with cabal script header and LANGUAGE pragma" $ do + Spec.assertEq s (fst <$> parse False [] "{- cabal:\ndefault-extensions: CPP\n-}\n{-# language OverloadedStrings #-}") $ Right (Nothing, [Session.On Extension.OverloadedStrings, Session.On Extension.Cpp]) diff --git a/source/library/Scrod/Ghc/ParserOpts.hs b/source/library/Scrod/Ghc/ParserOpts.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Ghc/ParserOpts.hs @@ -0,0 +1,20 @@ +-- | Construct GHC 'Lexer.ParserOpts' from a set of language extensions. +module Scrod.Ghc.ParserOpts where + +import qualified GHC.Data.EnumSet as EnumSet +import qualified GHC.LanguageExtensions.Type as Extension +import qualified GHC.Parser.Lexer as Lexer +import qualified GHC.Utils.Error as Error + +empty :: Lexer.ParserOpts +empty = fromExtensions EnumSet.empty + +fromExtensions :: EnumSet.EnumSet Extension.Extension -> Lexer.ParserOpts +fromExtensions extensions = + Lexer.mkParserOpts + extensions + Error.emptyDiagOpts + False -- Are safe imports on? + True -- Keep Haddock comments? + True -- Keep regular comments? + True -- Interpret line and column pragmas? diff --git a/source/library/Scrod/Ghc/Platform.hs b/source/library/Scrod/Ghc/Platform.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Ghc/Platform.hs @@ -0,0 +1,22 @@ +module Scrod.Ghc.Platform where + +import qualified GHC.ByteOrder as ByteOrder +import qualified GHC.Platform as Platform +import qualified Scrod.Ghc.ArchOS as ArchOS + +empty :: Platform.Platform +empty = + Platform.Platform + { Platform.platformArchOS = ArchOS.empty, + Platform.platformWordSize = Platform.PW8, + Platform.platformByteOrder = ByteOrder.LittleEndian, + Platform.platformUnregisterised = False, + Platform.platformHasGnuNonexecStack = False, + Platform.platformHasIdentDirective = False, + Platform.platformHasSubsectionsViaSymbols = False, + Platform.platformIsCrossCompiling = False, + Platform.platformLeadingUnderscore = False, + Platform.platformTablesNextToCode = False, + Platform.platformHasLibm = False, + Platform.platform_constants = Nothing + } diff --git a/source/library/Scrod/Ghc/PlatformMisc.hs b/source/library/Scrod/Ghc/PlatformMisc.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Ghc/PlatformMisc.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Ghc.PlatformMisc where + +import qualified GHC.Driver.Session as Session +import qualified GHC.Stack as Stack +import qualified Scrod.Ghc.Uninitialized as Uninitialized + +empty :: (Stack.HasCallStack) => Session.PlatformMisc +empty = + Session.PlatformMisc + { Session.platformMisc_ghcWithInterpreter = Uninitialized.throw 'Session.platformMisc_ghcWithInterpreter, + Session.platformMisc_libFFI = Uninitialized.throw 'Session.platformMisc_libFFI, + Session.platformMisc_llvmTarget = Uninitialized.throw 'Session.platformMisc_llvmTarget, + Session.platformMisc_targetPlatformString = Uninitialized.throw 'Session.platformMisc_targetPlatformString, + Session.platformMisc_targetRTSLinkerOnlySupportsSharedLibs = Uninitialized.throw 'Session.platformMisc_targetRTSLinkerOnlySupportsSharedLibs + } diff --git a/source/library/Scrod/Ghc/ToolSettings.hs b/source/library/Scrod/Ghc/ToolSettings.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Ghc/ToolSettings.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Ghc.ToolSettings where + +import qualified GHC.Settings as Settings +import qualified GHC.Stack as Stack +import qualified Scrod.Ghc.Uninitialized as Uninitialized + +empty :: (Stack.HasCallStack) => Settings.ToolSettings +empty = + Settings.ToolSettings + { Settings.toolSettings_arSupportsDashL = Uninitialized.throw 'Settings.toolSettings_arSupportsDashL, + Settings.toolSettings_ccSupportsNoPie = Uninitialized.throw 'Settings.toolSettings_ccSupportsNoPie, + Settings.toolSettings_cmmCppSupportsG0 = Uninitialized.throw 'Settings.toolSettings_cmmCppSupportsG0, + Settings.toolSettings_extraGccViaCFlags = Uninitialized.throw 'Settings.toolSettings_extraGccViaCFlags, + Settings.toolSettings_ldIsGnuLd = Uninitialized.throw 'Settings.toolSettings_ldIsGnuLd, + Settings.toolSettings_ldSupportsCompactUnwind = Uninitialized.throw 'Settings.toolSettings_ldSupportsCompactUnwind, + Settings.toolSettings_ldSupportsFilelist = Uninitialized.throw 'Settings.toolSettings_ldSupportsFilelist, + Settings.toolSettings_ldSupportsSingleModule = Uninitialized.throw 'Settings.toolSettings_ldSupportsSingleModule, + Settings.toolSettings_mergeObjsSupportsResponseFiles = Uninitialized.throw 'Settings.toolSettings_mergeObjsSupportsResponseFiles, + Settings.toolSettings_opt_CmmP = Uninitialized.throw 'Settings.toolSettings_opt_CmmP, + Settings.toolSettings_opt_CmmP_fingerprint = Uninitialized.throw 'Settings.toolSettings_opt_CmmP_fingerprint, + Settings.toolSettings_opt_F = Uninitialized.throw 'Settings.toolSettings_opt_F, + Settings.toolSettings_opt_JSP = Uninitialized.throw 'Settings.toolSettings_opt_JSP, + Settings.toolSettings_opt_JSP_fingerprint = Uninitialized.throw 'Settings.toolSettings_opt_JSP_fingerprint, + Settings.toolSettings_opt_L = Uninitialized.throw 'Settings.toolSettings_opt_L, + Settings.toolSettings_opt_P = Uninitialized.throw 'Settings.toolSettings_opt_P, + Settings.toolSettings_opt_P_fingerprint = Uninitialized.throw 'Settings.toolSettings_opt_P_fingerprint, + Settings.toolSettings_opt_a = Uninitialized.throw 'Settings.toolSettings_opt_a, + Settings.toolSettings_opt_c = Uninitialized.throw 'Settings.toolSettings_opt_c, + Settings.toolSettings_opt_cxx = Uninitialized.throw 'Settings.toolSettings_opt_cxx, + Settings.toolSettings_opt_i = Uninitialized.throw 'Settings.toolSettings_opt_i, + Settings.toolSettings_opt_l = Uninitialized.throw 'Settings.toolSettings_opt_l, + Settings.toolSettings_opt_las = Uninitialized.throw 'Settings.toolSettings_opt_las, + Settings.toolSettings_opt_lc = Uninitialized.throw 'Settings.toolSettings_opt_lc, + Settings.toolSettings_opt_lm = Uninitialized.throw 'Settings.toolSettings_opt_lm, + Settings.toolSettings_opt_lo = Uninitialized.throw 'Settings.toolSettings_opt_lo, + Settings.toolSettings_opt_windres = Uninitialized.throw 'Settings.toolSettings_opt_windres, + Settings.toolSettings_pgm_CmmP = Uninitialized.throw 'Settings.toolSettings_pgm_CmmP, + Settings.toolSettings_pgm_F = Uninitialized.throw 'Settings.toolSettings_pgm_F, + Settings.toolSettings_pgm_JSP = Uninitialized.throw 'Settings.toolSettings_pgm_JSP, + Settings.toolSettings_pgm_L = Uninitialized.throw 'Settings.toolSettings_pgm_L, + Settings.toolSettings_pgm_P = Uninitialized.throw 'Settings.toolSettings_pgm_P, + Settings.toolSettings_pgm_a = Uninitialized.throw 'Settings.toolSettings_pgm_a, + Settings.toolSettings_pgm_ar = Uninitialized.throw 'Settings.toolSettings_pgm_ar, + Settings.toolSettings_pgm_c = Uninitialized.throw 'Settings.toolSettings_pgm_c, + Settings.toolSettings_pgm_cpp = Uninitialized.throw 'Settings.toolSettings_pgm_cpp, + Settings.toolSettings_pgm_cxx = Uninitialized.throw 'Settings.toolSettings_pgm_cxx, + Settings.toolSettings_pgm_i = Uninitialized.throw 'Settings.toolSettings_pgm_i, + Settings.toolSettings_pgm_install_name_tool = Uninitialized.throw 'Settings.toolSettings_pgm_install_name_tool, + Settings.toolSettings_pgm_l = Uninitialized.throw 'Settings.toolSettings_pgm_l, + Settings.toolSettings_pgm_las = Uninitialized.throw 'Settings.toolSettings_pgm_las, + Settings.toolSettings_pgm_lc = Uninitialized.throw 'Settings.toolSettings_pgm_lc, + Settings.toolSettings_pgm_lm = Uninitialized.throw 'Settings.toolSettings_pgm_lm, + Settings.toolSettings_pgm_lo = Uninitialized.throw 'Settings.toolSettings_pgm_lo, + Settings.toolSettings_pgm_otool = Uninitialized.throw 'Settings.toolSettings_pgm_otool, + Settings.toolSettings_pgm_ranlib = Uninitialized.throw 'Settings.toolSettings_pgm_ranlib, + Settings.toolSettings_pgm_windres = Uninitialized.throw 'Settings.toolSettings_pgm_windres, + Settings.toolSettings_useInplaceMinGW = Uninitialized.throw 'Settings.toolSettings_useInplaceMinGW + } diff --git a/source/library/Scrod/Ghc/Uninitialized.hs b/source/library/Scrod/Ghc/Uninitialized.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Ghc/Uninitialized.hs @@ -0,0 +1,17 @@ +-- | Exception thrown when an unneeded GHC 'DynFlags' field is accessed. +module Scrod.Ghc.Uninitialized where + +import qualified Control.Monad.Catch as Exception +import qualified GHC.Stack as Stack +import qualified Language.Haskell.TH as TH +import qualified System.IO.Unsafe as Unsafe + +newtype Uninitialized = MkUninitialized + { unwrap :: TH.Name + } + deriving (Eq, Ord, Show) + +instance Exception.Exception Uninitialized + +throw :: (Stack.HasCallStack) => TH.Name -> a +throw = Unsafe.unsafePerformIO . Exception.throwM . MkUninitialized diff --git a/source/library/Scrod/Ghc/UnitId.hs b/source/library/Scrod/Ghc/UnitId.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Ghc/UnitId.hs @@ -0,0 +1,7 @@ +module Scrod.Ghc.UnitId where + +import qualified GHC.Data.FastString as FastString +import qualified GHC.Unit.Types as Unit + +empty :: Unit.UnitId +empty = Unit.UnitId {Unit.unitIdFS = FastString.nilFS} diff --git a/source/library/Scrod/Ghc/UnitSettings.hs b/source/library/Scrod/Ghc/UnitSettings.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Ghc/UnitSettings.hs @@ -0,0 +1,7 @@ +module Scrod.Ghc.UnitSettings where + +import qualified GHC.Settings as Settings +import qualified Scrod.Ghc.UnitId as UnitId + +empty :: Settings.UnitSettings +empty = Settings.UnitSettings {Settings.unitSettings_baseUnitId = UnitId.empty} diff --git a/source/library/Scrod/Json/Array.hs b/source/library/Scrod/Json/Array.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Json/Array.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Json.Array where + +import qualified Data.ByteString.Builder as Builder +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Monoid as Monoid +import qualified Scrod.Extra.Parsec as Parsec +import qualified Scrod.Extra.Semigroup as Semigroup +import qualified Scrod.Spec as Spec +import qualified Text.Parsec as Parsec + +newtype Array a = MkArray + { unwrap :: [a] + } + deriving (Eq, Ord, Show) + +decode :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m a -> Parsec.ParsecT s u m (Array a) +decode p = + fmap MkArray + . Parsec.between (Parsec.char '[' <* Parsec.many Parsec.blank) (Parsec.char ']') + $ Parsec.sepBy (p <* Parsec.many Parsec.blank) (Parsec.char ',' <* Parsec.many Parsec.blank) + +encode :: (a -> Builder.Builder) -> Array a -> Builder.Builder +encode b = + Semigroup.around (Builder.charUtf8 '[') (Builder.charUtf8 ']') + . Monoid.sepBy (Builder.charUtf8 ',') + . fmap b + . unwrap + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'decode $ do + let p :: (Parsec.Stream t m Char) => Parsec.ParsecT t u m String + p = Parsec.many1 Parsec.digit + + Spec.it s "succeeds with an empty array" $ do + Spec.assertEq s (Parsec.parseString (decode p) "[]") . Just $ MkArray [] + + Spec.it s "succeeds with an empty array with blank space" $ do + Spec.assertEq s (Parsec.parseString (decode p) "[ ]") . Just $ MkArray [] + + Spec.it s "succeeds with a single element" $ do + Spec.assertEq s (Parsec.parseString (decode p) "[1]") . Just $ MkArray ["1"] + + Spec.it s "succeeds with a single element with blank space" $ do + Spec.assertEq s (Parsec.parseString (decode p) "[ 1 ]") . Just $ MkArray ["1"] + + Spec.it s "succeeds with multiple elements" $ do + Spec.assertEq s (Parsec.parseString (decode p) "[1,2]") . Just $ MkArray ["1", "2"] + + Spec.it s "succeeds with multiple elements with blank space" $ do + Spec.assertEq s (Parsec.parseString (decode p) "[ 1 , 2 ]") . Just $ MkArray ["1", "2"] + + Spec.it s "fails with leading comma" $ do + Spec.assertEq s (Parsec.parseString (decode p) "[,1]") Nothing + + Spec.it s "fails with trailing comma" $ do + Spec.assertEq s (Parsec.parseString (decode p) "[1,]") Nothing + + Spec.it s "fails with extra comma" $ do + Spec.assertEq s (Parsec.parseString (decode p) "[1,,2]") Nothing + + Spec.it s "fails with only comma" $ do + Spec.assertEq s (Parsec.parseString (decode p) "[,]") Nothing + + Spec.named s 'encode $ do + let b = Builder.integerDec + + Spec.it s "encodes empty array" $ do + Spec.assertEq s (Builder.toString . encode b $ MkArray []) "[]" + + Spec.it s "encodes single element" $ do + Spec.assertEq s (Builder.toString . encode b $ MkArray [1]) "[1]" + + Spec.it s "encodes multiple elements" $ do + Spec.assertEq s (Builder.toString . encode b $ MkArray [1, 2]) "[1,2]" diff --git a/source/library/Scrod/Json/Boolean.hs b/source/library/Scrod/Json/Boolean.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Json/Boolean.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Json.Boolean where + +import qualified Data.Bool as Bool +import qualified Data.ByteString.Builder as Builder +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Parsec as Parsec +import qualified Scrod.Spec as Spec +import qualified Text.Parsec as Parsec + +newtype Boolean = MkBoolean + { unwrap :: Bool + } + deriving (Eq, Ord, Show) + +decode :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Boolean +decode = + MkBoolean + <$> Parsec.choice + [ True <$ Parsec.string' "true", + False <$ Parsec.string' "false" + ] + +encode :: Boolean -> Builder.Builder +encode = Builder.stringUtf8 . Bool.bool "false" "true" . unwrap + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'decode $ do + Spec.it s "succeeds with true" $ do + Spec.assertEq s (Parsec.parseString decode "true") . Just . MkBoolean $ True + + Spec.it s "succeeds with false" $ do + Spec.assertEq s (Parsec.parseString decode "false") . Just . MkBoolean $ False + + Spec.it s "fails with invalid input" $ do + Spec.assertEq s (Parsec.parseString decode "invalid") Nothing + + Spec.named s 'encode $ do + Spec.it s "encodes true" $ do + Spec.assertEq s (Builder.toString . encode . MkBoolean $ True) "true" + + Spec.it s "encodes false" $ do + Spec.assertEq s (Builder.toString . encode . MkBoolean $ False) "false" diff --git a/source/library/Scrod/Json/Null.hs b/source/library/Scrod/Json/Null.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Json/Null.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Json.Null where + +import qualified Data.ByteString.Builder as Builder +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Parsec as Parsec +import qualified Scrod.Spec as Spec +import qualified Text.Parsec as Parsec + +data Null + = MkNull + deriving (Eq, Ord, Show) + +decode :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Null +decode = MkNull <$ Parsec.string' "null" + +encode :: Null -> Builder.Builder +encode = const $ Builder.stringUtf8 "null" + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'decode $ do + Spec.it s "succeeds with valid input" $ do + Spec.assertEq s (Parsec.parseString decode "null") $ Just MkNull + + Spec.it s "fails with invalid input" $ do + Spec.assertEq s (Parsec.parseString decode "invalid") Nothing + + Spec.named s 'encode $ do + Spec.it s "works" $ do + Spec.assertEq s (Builder.toString $ encode MkNull) "null" diff --git a/source/library/Scrod/Json/Number.hs b/source/library/Scrod/Json/Number.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Json/Number.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Json.Number where + +import qualified Data.ByteString.Builder as Builder +import qualified Scrod.Decimal as Decimal +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Parsec as Parsec +import qualified Scrod.Extra.Read as Read +import qualified Scrod.Spec as Spec +import qualified Text.Parsec as Parsec + +newtype Number = MkNumber + { unwrap :: Decimal.Decimal + } + deriving (Eq, Ord, Show) + +decode :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Number +decode = do + sign <- decodeSign + intPart <- decodeInt + (fracPart, fracExp) <- decodeFrac + expPart <- decodeExp + pure . MkNumber $ + Decimal.mkDecimal + (sign $ intPart * (10 ^ abs fracExp) + fracPart) + (fracExp + expPart) + +decodeSign :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m (Integer -> Integer) +decodeSign = Parsec.option id (negate <$ Parsec.char '-') + +decodeInt :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Integer +decodeInt = + Parsec.choice + [ 0 <$ Parsec.char '0' <* Parsec.notFollowedBy Parsec.digit, + do + first <- Parsec.satisfy $ \c -> c >= '1' && c <= '9' + rest <- Parsec.many Parsec.digit + maybe (fail "invalid integer") pure . Read.readM $ first : rest + ] + +decodeFrac :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m (Integer, Integer) +decodeFrac = Parsec.option (0, 0) $ do + digits <- Parsec.char '.' *> Parsec.many1 Parsec.digit + fracValue <- maybe (fail "invalid fraction") pure $ Read.readM digits + pure (fracValue, negate . toInteger $ length digits) + +decodeExp :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Integer +decodeExp = Parsec.option 0 $ do + _ <- Parsec.oneOf "eE" + expSign <- + Parsec.option id $ + Parsec.choice + [ id <$ Parsec.char '+', + negate <$ Parsec.char '-' + ] + expDigits <- Parsec.many1 Parsec.digit + maybe (fail "invalid exponent") (pure . expSign) $ Read.readM expDigits + +encode :: Number -> Builder.Builder +encode n = + let d = unwrap n + in Builder.integerDec (Decimal.mantissa d) + <> if Decimal.exponent d == 0 + then mempty + else Builder.charUtf8 'e' <> Builder.integerDec (Decimal.exponent d) + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'decode $ do + Spec.it s "parses zero" $ do + Spec.assertEq s (Parsec.parseString decode "0") . Just . MkNumber $ Decimal.mkDecimal 0 0 + + Spec.it s "parses positive integer" $ do + Spec.assertEq s (Parsec.parseString decode "123") . Just . MkNumber $ Decimal.mkDecimal 123 0 + + Spec.it s "parses negative integer" $ do + Spec.assertEq s (Parsec.parseString decode "-123") . Just . MkNumber $ Decimal.mkDecimal (-123) 0 + + Spec.it s "parses decimal with fraction" $ do + Spec.assertEq s (Parsec.parseString decode "123.45") . Just . MkNumber $ Decimal.mkDecimal 12345 (-2) + + Spec.it s "parses negative decimal with fraction" $ do + Spec.assertEq s (Parsec.parseString decode "-123.45") . Just . MkNumber $ Decimal.mkDecimal (-12345) (-2) + + Spec.it s "parses with positive exponent" $ do + Spec.assertEq s (Parsec.parseString decode "123e2") . Just . MkNumber $ Decimal.mkDecimal 123 2 + + Spec.it s "parses with negative exponent" $ do + Spec.assertEq s (Parsec.parseString decode "123e-2") . Just . MkNumber $ Decimal.mkDecimal 123 (-2) + + Spec.it s "parses with uppercase E" $ do + Spec.assertEq s (Parsec.parseString decode "123E2") . Just . MkNumber $ Decimal.mkDecimal 123 2 + + Spec.it s "parses with explicit plus in exponent" $ do + Spec.assertEq s (Parsec.parseString decode "123e+2") . Just . MkNumber $ Decimal.mkDecimal 123 2 + + Spec.it s "parses fraction with exponent" $ do + Spec.assertEq s (Parsec.parseString decode "1.23e5") . Just . MkNumber $ Decimal.mkDecimal 123 3 + + Spec.it s "fails with leading zero" $ do + Spec.assertEq s (Parsec.parseString decode "01") Nothing + + Spec.it s "fails with just minus" $ do + Spec.assertEq s (Parsec.parseString decode "-") Nothing + + Spec.it s "fails with trailing fraction" $ do + Spec.assertEq s (Parsec.parseString decode "123.") Nothing + + Spec.it s "fails with leading fraction" $ do + Spec.assertEq s (Parsec.parseString decode ".123") Nothing + + Spec.it s "fails with trailing exponent" $ do + Spec.assertEq s (Parsec.parseString decode "123e") Nothing + + Spec.it s "fails with leading exponent" $ do + Spec.assertEq s (Parsec.parseString decode "e123") Nothing + + Spec.named s 'encode $ do + Spec.it s "encodes zero" $ do + Spec.assertEq s (Builder.toString . encode . MkNumber $ Decimal.mkDecimal 0 0) "0" + + Spec.it s "encodes positive integer" $ do + Spec.assertEq s (Builder.toString . encode . MkNumber $ Decimal.mkDecimal 123 0) "123" + + Spec.it s "encodes negative integer" $ do + Spec.assertEq s (Builder.toString . encode . MkNumber $ Decimal.mkDecimal (-123) 0) "-123" + + Spec.it s "encodes with positive exponent" $ do + Spec.assertEq s (Builder.toString . encode . MkNumber $ Decimal.mkDecimal 123 2) "123e2" + + Spec.it s "encodes with negative exponent" $ do + Spec.assertEq s (Builder.toString . encode . MkNumber $ Decimal.mkDecimal 12345 (-2)) "12345e-2" + + Spec.it s "encodes small fraction" $ do + Spec.assertEq s (Builder.toString . encode . MkNumber $ Decimal.mkDecimal 123 (-5)) "123e-5" diff --git a/source/library/Scrod/Json/Object.hs b/source/library/Scrod/Json/Object.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Json/Object.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Json.Object where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Monoid as Monoid +import qualified Scrod.Extra.Parsec as Parsec +import qualified Scrod.Extra.Semigroup as Semigroup +import qualified Scrod.Json.Pair as Pair +import qualified Scrod.Json.String as String +import qualified Scrod.Spec as Spec +import qualified Text.Parsec as Parsec + +newtype Object a = MkObject + { unwrap :: [Pair.Pair a] + } + deriving (Eq, Ord, Show) + +decode :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m a -> Parsec.ParsecT s u m (Object a) +decode p = + fmap MkObject + . Parsec.between (Parsec.char '{' <* Parsec.many Parsec.blank) (Parsec.char '}') + $ Parsec.sepBy (Pair.decode p <* Parsec.many Parsec.blank) (Parsec.char ',' <* Parsec.many Parsec.blank) + +encode :: (a -> Builder.Builder) -> Object a -> Builder.Builder +encode b = + Semigroup.around (Builder.charUtf8 '{') (Builder.charUtf8 '}') + . Monoid.sepBy (Builder.charUtf8 ',') + . fmap (Pair.encode b) + . unwrap + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + let object :: [(String, a)] -> Object a + object = MkObject . fmap (\(n, v) -> Pair.MkPair (String.MkString $ Text.pack n) v) + + Spec.named s 'decode $ do + let p :: (Parsec.Stream t m Char) => Parsec.ParsecT t u m Prelude.String + p = Parsec.many1 Parsec.digit + + Spec.it s "succeeds with an empty object" $ do + Spec.assertEq s (Parsec.parseString (decode p) "{}") . Just $ object [] + + Spec.it s "succeeds with an empty object with blank space" $ do + Spec.assertEq s (Parsec.parseString (decode p) "{ }") . Just $ object [] + + Spec.it s "succeeds with a single pair" $ do + Spec.assertEq s (Parsec.parseString (decode p) "{\"a\":1}") . Just $ object [("a", "1")] + + Spec.it s "succeeds with a single pair with blank space" $ do + Spec.assertEq s (Parsec.parseString (decode p) "{ \"a\":1 }") . Just $ object [("a", "1")] + + Spec.it s "succeeds with multiple pairs" $ do + Spec.assertEq s (Parsec.parseString (decode p) "{\"a\":1,\"b\":2}") . Just $ object [("a", "1"), ("b", "2")] + + Spec.it s "succeeds with multiple pairs with blank space" $ do + Spec.assertEq s (Parsec.parseString (decode p) "{ \"a\":1 , \"b\":2 }") . Just $ object [("a", "1"), ("b", "2")] + + Spec.it s "fails with leading comma" $ do + Spec.assertEq s (Parsec.parseString (decode p) "{,\"a\":1}") Nothing + + Spec.it s "fails with trailing comma" $ do + Spec.assertEq s (Parsec.parseString (decode p) "{\"a\":1,}") Nothing + + Spec.it s "fails with extra comma" $ do + Spec.assertEq s (Parsec.parseString (decode p) "{\"a\":1,,\"b\":2}") Nothing + + Spec.it s "fails with only comma" $ do + Spec.assertEq s (Parsec.parseString (decode p) "{,}") Nothing + + Spec.named s 'encode $ do + let b = Builder.integerDec + + Spec.it s "encodes empty object" $ do + Spec.assertEq s (Builder.toString . encode b $ MkObject []) "{}" + + Spec.it s "encodes single pair" $ do + Spec.assertEq s (Builder.toString . encode b $ object [("a", 1)]) "{\"a\":1}" + + Spec.it s "encodes multiple pairs" $ do + Spec.assertEq s (Builder.toString . encode b $ object [("a", 1), ("b", 2)]) "{\"a\":1,\"b\":2}" diff --git a/source/library/Scrod/Json/Pair.hs b/source/library/Scrod/Json/Pair.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Json/Pair.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Json.Pair where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Parsec as Parsec +import qualified Scrod.Json.String as String +import qualified Scrod.Spec as Spec +import qualified Text.Parsec as Parsec + +data Pair a = MkPair + { name :: String.String, + value :: a + } + deriving (Eq, Ord, Show) + +decode :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m a -> Parsec.ParsecT s u m (Pair a) +decode p = + MkPair + <$> (String.decode <* Parsec.many Parsec.blank) + <*> (Parsec.char ':' *> Parsec.many Parsec.blank *> p) + +encode :: (a -> Builder.Builder) -> Pair a -> Builder.Builder +encode b p = String.encode (name p) <> Builder.charUtf8 ':' <> b (value p) + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + let pair :: String -> a -> Pair a + pair = MkPair . String.MkString . Text.pack + + Spec.named s 'decode $ do + let p :: (Parsec.Stream t m Char) => Parsec.ParsecT t u m String + p = Parsec.many1 Parsec.digit + + Spec.it s "succeeds with simple pair" $ do + Spec.assertEq s (Parsec.parseString (decode p) "\"a\":1") . Just $ pair "a" "1" + + Spec.it s "succeeds with blank space after name" $ do + Spec.assertEq s (Parsec.parseString (decode p) "\"a\" :1") . Just $ pair "a" "1" + + Spec.it s "succeeds with blank space after separator" $ do + Spec.assertEq s (Parsec.parseString (decode p) "\"a\": 1") . Just $ pair "a" "1" + + Spec.it s "fails with missing name" $ do + Spec.assertEq s (Parsec.parseString (decode p) ":1") Nothing + + Spec.it s "fails with missing separator" $ do + Spec.assertEq s (Parsec.parseString (decode p) "\"a\" 1") Nothing + + Spec.it s "fails with extra separator" $ do + Spec.assertEq s (Parsec.parseString (decode p) "\"a\"::1") Nothing + + Spec.it s "fails with missing value" $ do + Spec.assertEq s (Parsec.parseString (decode p) ":1") Nothing + + Spec.named s 'encode $ do + let b = Builder.integerDec + + Spec.it s "encodes simple pair" $ do + Spec.assertEq s (Builder.toString . encode b $ pair "a" 1) "\"a\":1" diff --git a/source/library/Scrod/Json/String.hs b/source/library/Scrod/Json/String.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Json/String.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Json.String where + +import qualified Control.Monad as Monad +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Data.Word as Word +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Ord as Ord +import qualified Scrod.Extra.Parsec as Parsec +import qualified Scrod.Extra.Read as Read +import qualified Scrod.Extra.Semigroup as Semigroup +import qualified Scrod.Spec as Spec +import qualified Text.Parsec as Parsec + +newtype String = MkString + { unwrap :: Text.Text + } + deriving (Eq, Ord, Show) + +decode :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Scrod.Json.String.String +decode = MkString . Text.pack <$> Parsec.between (Parsec.char '"') (Parsec.char '"') (Parsec.many decodeChar) + +decodeChar :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Char +decodeChar = + Parsec.choice + [ decodeEscapedChar, + decodeUnescapedChar + ] + +decodeEscapedChar :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Char +decodeEscapedChar = + Parsec.choice + [ decodeShortEscapedChar, + decodeLongEscapedChar + ] + +decodeShortEscapedChar :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Char +decodeShortEscapedChar = + Parsec.choice + [ '"' <$ Parsec.string' "\\\"", + '\\' <$ Parsec.string' "\\\\", + '/' <$ Parsec.string' "\\/", + '\b' <$ Parsec.string' "\\b", + '\f' <$ Parsec.string' "\\f", + '\n' <$ Parsec.string' "\\n", + '\r' <$ Parsec.string' "\\r", + '\t' <$ Parsec.string' "\\t" + ] + +decodeLongEscapedChar :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Char +decodeLongEscapedChar = do + hi <- Parsec.string' "\\u" *> decodeWord16Hex + if Ord.between 0xd800 0xdbff hi + then do + lo <- Parsec.string' "\\u" *> decodeWord16Hex + Monad.unless (Ord.between 0xdc00 0xdfff lo) $ fail "invalid surrogate" + pure . toEnum $ 0x10000 + ((fromIntegral hi - 0xd800) * 0x400) + (fromIntegral lo - 0xdc00) + else pure . toEnum $ fromIntegral hi + +decodeWord16Hex :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Word.Word16 +decodeWord16Hex = do + ds <- Parsec.count 4 Parsec.hexDigit + maybe (fail "invalid escape") pure . Read.readM $ "0x" <> ds + +decodeUnescapedChar :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Char +decodeUnescapedChar = Parsec.satisfy $ \c -> c >= ' ' && c /= '"' && c /= '\\' + +encode :: Scrod.Json.String.String -> Builder.Builder +encode = Semigroup.around (Builder.charUtf8 '"') (Builder.charUtf8 '"') . foldMap encodeChar . Text.unpack . unwrap + +encodeChar :: Char -> Builder.Builder +encodeChar c = case c of + '"' -> Builder.stringUtf8 "\\\"" + '\\' -> Builder.stringUtf8 "\\\\" + '\b' -> Builder.stringUtf8 "\\b" + '\f' -> Builder.stringUtf8 "\\f" + '\n' -> Builder.stringUtf8 "\\n" + '\r' -> Builder.stringUtf8 "\\r" + '\t' -> Builder.stringUtf8 "\\t" + _ -> + if c >= ' ' + then Builder.charUtf8 c + else Builder.stringUtf8 "\\u" <> Builder.word16HexFixed (fromIntegral $ fromEnum c) + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'decode $ do + Spec.it s "succeeds with an empty string" $ do + Spec.assertEq s (Parsec.parseString decode "\"\"") . Just . MkString $ Text.pack "" + + Spec.it s "succeeds with a single character" $ do + Spec.assertEq s (Parsec.parseString decode "\"a\"") . Just . MkString $ Text.pack "a" + + Spec.it s "succeeds with two characters" $ do + Spec.assertEq s (Parsec.parseString decode "\"ab\"") . Just . MkString $ Text.pack "ab" + + Spec.it s "succeeds with an escaped quotation mark" $ do + Spec.assertEq s (Parsec.parseString decode "\" \\\" \"") . Just . MkString $ Text.pack " \" " + + Spec.it s "succeeds with an escaped reverse solidus" $ do + Spec.assertEq s (Parsec.parseString decode "\" \\\\ \"") . Just . MkString $ Text.pack " \\ " + + Spec.it s "succeeds with an escaped solidus" $ do + Spec.assertEq s (Parsec.parseString decode "\" \\/ \"") . Just . MkString $ Text.pack " / " + + Spec.it s "succeeds with an escaped backspace" $ do + Spec.assertEq s (Parsec.parseString decode "\" \\b \"") . Just . MkString $ Text.pack " \b " + + Spec.it s "succeeds with an escaped form feed" $ do + Spec.assertEq s (Parsec.parseString decode "\" \\f \"") . Just . MkString $ Text.pack " \f " + + Spec.it s "succeeds with an escaped line feed" $ do + Spec.assertEq s (Parsec.parseString decode "\" \\n \"") . Just . MkString $ Text.pack " \n " + + Spec.it s "succeeds with an escaped carriage return" $ do + Spec.assertEq s (Parsec.parseString decode "\" \\r \"") . Just . MkString $ Text.pack " \r " + + Spec.it s "succeeds with an escaped tab" $ do + Spec.assertEq s (Parsec.parseString decode "\" \\t \"") . Just . MkString $ Text.pack " \t " + + Spec.it s "fails with an unescaped tab" $ do + Spec.assertEq s (Parsec.parseString decode "\" \t \"") Nothing + + Spec.it s "succeeds with an escaped control character" $ do + Spec.assertEq s (Parsec.parseString decode "\" \\u001f \"") . Just . MkString $ Text.pack " \x1f " + + Spec.it s "succeeds with an unnecessarily escaped character" $ do + Spec.assertEq s (Parsec.parseString decode "\" \\u006F \"") . Just . MkString $ Text.pack " o " + + Spec.it s "succeeds with a surrogate pair" $ do + Spec.assertEq s (Parsec.parseString decode "\" \\uD834\\uDD1E \"") . Just . MkString $ Text.pack " \x1d11e " + + Spec.it s "fails with an unpaired surrogate" $ do + Spec.assertEq s (Parsec.parseString decode "\"\\uD800\"") Nothing + + Spec.it s "fails with an invalid low surrogate" $ do + Spec.assertEq s (Parsec.parseString decode "\"\\uD800\\u0000\"") Nothing + + Spec.named s 'encode $ do + Spec.it s "works with an empty string" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack "") "\"\"" + + Spec.it s "works with one character" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack "a") "\"a\"" + + Spec.it s "works with two characters" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack "ab") "\"ab\"" + + Spec.it s "escapes a quotation mark" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack " \" ") "\" \\\" \"" + + Spec.it s "escapes a reverse solidus" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack " \\ ") "\" \\\\ \"" + + Spec.it s "does not escape a solidus" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack " / ") "\" / \"" + + Spec.it s "escapes a backspace" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack " \b ") "\" \\b \"" + + Spec.it s "escapes a form feed" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack " \f ") "\" \\f \"" + + Spec.it s "escapes a line feed" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack " \n ") "\" \\n \"" + + Spec.it s "escapes a carriage return" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack " \r ") "\" \\r \"" + + Spec.it s "escapes a tab" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack " \t ") "\" \\t \"" + + Spec.it s "escapes a control character" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack " \x1f ") "\" \\u001f \"" + + Spec.it s "does not escape a two-byte character" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack " \x80 ") "\" \x80 \"" + + Spec.it s "does not escape a three-byte character" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack " \x800 ") "\" \x800 \"" + + Spec.it s "does not escape a four-byte character" $ do + Spec.assertEq s (Builder.toString . encode . MkString $ Text.pack " \x10000 ") "\" \x10000 \"" diff --git a/source/library/Scrod/Json/ToJson.hs b/source/library/Scrod/Json/ToJson.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Json/ToJson.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Type class for converting values into JSON. +module Scrod.Json.ToJson where + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Proxy as Proxy +import qualified Data.Text as Text +import qualified GHC.Generics as Generics +import qualified GHC.TypeLits as TypeLits +import qualified Numeric.Natural as Natural +import qualified Scrod.Json.Value as Json + +-- | Convert a value to a JSON 'Json.Value'. +class ToJson a where + toJson :: a -> Json.Value + +instance ToJson Bool where + toJson = Json.boolean + +instance ToJson Text.Text where + toJson = Json.text + +instance ToJson Int where + toJson = Json.integral + +instance ToJson Natural.Natural where + toJson = Json.integral + +instance (ToJson a) => ToJson (Maybe a) where + toJson = maybe Json.null toJson + +instance (ToJson a) => ToJson [a] where + toJson = Json.arrayOf toJson + +instance (ToJson a) => ToJson (NonEmpty.NonEmpty a) where + toJson = toJson . NonEmpty.toList + +-- | Generic JSON encoding. Dispatches between record encoding (single +-- constructor produces a JSON object) and tagged encoding (sum type +-- produces @{\"type\": \"Name\", \"value\": ...}@ objects). +-- +-- Use @deriving via 'Generics.Generically'@ with a 'Generics.Generic' +-- instance to derive 'ToJson' for record types, enum types, and tagged +-- sum types. +class GToJson f where + gToJson :: f p -> Json.Value + +instance (GToJson f) => GToJson (Generics.M1 Generics.D c f) where + gToJson (Generics.M1 x) = gToJson x + +instance (GToJsonFields f) => GToJson (Generics.M1 Generics.C c f) where + gToJson (Generics.M1 x) = + Json.object (filter (\(_, v) -> v /= Json.null) (gToJsonFields x)) + +instance (GToJsonSum f, GToJsonSum g) => GToJson (f Generics.:+: g) where + gToJson = gToJsonSum + +-- | Extract record fields as key-value pairs for JSON object encoding. +class GToJsonFields f where + gToJsonFields :: f p -> [(String, Json.Value)] + +instance + (TypeLits.KnownSymbol name, ToJson a) => + GToJsonFields (Generics.M1 Generics.S ('Generics.MetaSel ('Just name) su ss ds) (Generics.K1 i a)) + where + gToJsonFields (Generics.M1 (Generics.K1 x)) = + [(TypeLits.symbolVal (Proxy.Proxy :: Proxy.Proxy name), toJson x)] + +instance (GToJsonFields f, GToJsonFields g) => GToJsonFields (f Generics.:*: g) where + gToJsonFields (f Generics.:*: g) = gToJsonFields f <> gToJsonFields g + +instance GToJsonFields Generics.U1 where + gToJsonFields Generics.U1 = [] + +-- | Tagged encoding for sum type constructors. +class GToJsonSum f where + gToJsonSum :: f p -> Json.Value + +instance (GToJsonSum f, GToJsonSum g) => GToJsonSum (f Generics.:+: g) where + gToJsonSum (Generics.L1 x) = gToJsonSum x + gToJsonSum (Generics.R1 x) = gToJsonSum x + +instance + (TypeLits.KnownSymbol name) => + GToJsonSum (Generics.M1 Generics.C ('Generics.MetaCons name fix rec) Generics.U1) + where + gToJsonSum _ = + Json.object [("type", Json.string (TypeLits.symbolVal (Proxy.Proxy :: Proxy.Proxy name)))] + +instance + (TypeLits.KnownSymbol name, ToJson a) => + GToJsonSum (Generics.M1 Generics.C ('Generics.MetaCons name fix rec) (Generics.M1 Generics.S sel (Generics.K1 i a))) + where + gToJsonSum (Generics.M1 (Generics.M1 (Generics.K1 x))) = + Json.tagged (TypeLits.symbolVal (Proxy.Proxy :: Proxy.Proxy name)) (toJson x) + +instance (Generics.Generic a, GToJson (Generics.Rep a)) => ToJson (Generics.Generically a) where + toJson (Generics.Generically x) = gToJson (Generics.from x) diff --git a/source/library/Scrod/Json/Value.hs b/source/library/Scrod/Json/Value.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Json/Value.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Json.Value where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Decimal as Decimal +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Parsec as Parsec +import qualified Scrod.Json.Array as Array +import qualified Scrod.Json.Boolean as Boolean +import qualified Scrod.Json.Null as Null +import qualified Scrod.Json.Number as Number +import qualified Scrod.Json.Object as Object +import qualified Scrod.Json.Pair as Pair +import qualified Scrod.Json.String as String +import qualified Scrod.Spec as Spec +import qualified Text.Parsec as Parsec + +data Value + = Null Null.Null + | Boolean Boolean.Boolean + | Number Number.Number + | String String.String + | Array (Array.Array Value) + | Object (Object.Object Value) + deriving (Eq, Ord, Show) + +null :: Value +null = Null Null.MkNull + +optional :: (a -> Value) -> Maybe a -> Value +optional = maybe Scrod.Json.Value.null + +boolean :: Bool -> Value +boolean = Boolean . Boolean.MkBoolean + +number :: Integer -> Integer -> Value +number m = Number . Number.MkNumber . Decimal.mkDecimal m + +integer :: Integer -> Value +integer = flip number 0 + +integral :: (Integral a) => a -> Value +integral = integer . toInteger + +text :: Text.Text -> Value +text = String . String.MkString + +string :: String -> Value +string = text . Text.pack + +array :: [Value] -> Value +array = Array . Array.MkArray + +arrayOf :: (a -> Value) -> [a] -> Value +arrayOf f = array . fmap f + +pair :: String -> a -> Pair.Pair a +pair = Pair.MkPair . String.MkString . Text.pack + +object :: [(String, Value)] -> Value +object = Object . Object.MkObject . fmap (uncurry pair) + +tagged :: String -> Value -> Value +tagged t v = object [("type", string t), ("value", v)] + +decode :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Value +decode = + Parsec.between (Parsec.many Parsec.blank) (Parsec.many Parsec.blank) $ + Parsec.choice + [ Null <$> Null.decode, + Boolean <$> Boolean.decode, + Number <$> Number.decode, + String <$> String.decode, + Array <$> Array.decode decode, + Object <$> Object.decode decode + ] + +encode :: Value -> Builder.Builder +encode v = case v of + Null n -> Null.encode n + Boolean b -> Boolean.encode b + Number n -> Number.encode n + String s -> String.encode s + Array a -> Array.encode encode a + Object o -> Object.encode encode o + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + let null_ = Scrod.Json.Value.null + + Spec.named s 'decode $ do + Spec.it s "parses null" $ do + Spec.assertEq s (Parsec.parseString decode "null") $ Just null_ + + Spec.it s "parses true" $ do + Spec.assertEq s (Parsec.parseString decode "true") . Just $ boolean True + + Spec.it s "parses false" $ do + Spec.assertEq s (Parsec.parseString decode "false") . Just $ boolean False + + Spec.it s "parses number" $ do + Spec.assertEq s (Parsec.parseString decode "123") . Just $ number 123 0 + + Spec.it s "parses string" $ do + Spec.assertEq s (Parsec.parseString decode "\"hello\"") . Just $ string "hello" + + Spec.it s "parses empty array" $ do + Spec.assertEq s (Parsec.parseString decode "[]") . Just $ array [] + + Spec.it s "parses array with values" $ do + Spec.assertEq s (Parsec.parseString decode "[1, \"a\", true]") . Just $ array [number 1 0, string "a", boolean True] + + Spec.it s "parses empty object" $ do + Spec.assertEq s (Parsec.parseString decode "{}") . Just $ object [] + + Spec.it s "parses object with values" $ do + Spec.assertEq s (Parsec.parseString decode "{\"a\": 1, \"b\": \"x\"}") . Just $ object [("a", number 1 0), ("b", string "x")] + + Spec.it s "parses nested structure" $ do + Spec.assertEq s (Parsec.parseString decode "{\"items\": [1, 2], \"name\": \"test\"}") . Just $ object [("items", array [number 1 0, number 2 0]), ("name", string "test")] + + Spec.it s "parses with leading whitespace" $ do + Spec.assertEq s (Parsec.parseString decode " null") $ Just null_ + + Spec.it s "parses with trailing whitespace" $ do + Spec.assertEq s (Parsec.parseString decode "null ") $ Just null_ + + Spec.it s "fails with invalid input" $ do + Spec.assertEq s (Parsec.parseString decode "invalid") Nothing + + Spec.named s 'encode $ do + Spec.it s "encodes null" $ do + Spec.assertEq s (Builder.toString $ encode null_) "null" + + Spec.it s "encodes true" $ do + Spec.assertEq s (Builder.toString . encode $ boolean True) "true" + + Spec.it s "encodes false" $ do + Spec.assertEq s (Builder.toString . encode $ boolean False) "false" + + Spec.it s "encodes number" $ do + Spec.assertEq s (Builder.toString . encode $ number 123 0) "123" + + Spec.it s "encodes string" $ do + Spec.assertEq s (Builder.toString . encode $ string "hello") "\"hello\"" + + Spec.it s "encodes empty array" $ do + Spec.assertEq s (Builder.toString . encode $ array []) "[]" + + Spec.it s "encodes array with values" $ do + Spec.assertEq s (Builder.toString . encode $ array [number 1 0, string "a"]) "[1,\"a\"]" + + Spec.it s "encodes empty object" $ do + Spec.assertEq s (Builder.toString . encode $ object []) "{}" + + Spec.it s "encodes object with values" $ do + Spec.assertEq s (Builder.toString . encode $ object [("a", number 1 0)]) "{\"a\":1}" + + Spec.it s "encodes nested structure" $ do + Spec.assertEq s (Builder.toString . encode $ object [("items", array [number 1 0])]) "{\"items\":[1]}" diff --git a/source/library/Scrod/JsonPointer/Evaluate.hs b/source/library/Scrod/JsonPointer/Evaluate.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/JsonPointer/Evaluate.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.JsonPointer.Evaluate where + +import qualified Data.Function as Function +import Data.List ((!?)) +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Scrod.Extra.Read as Read +import qualified Scrod.Json.Array as Array +import qualified Scrod.Json.Object as Object +import qualified Scrod.Json.Pair as Pair +import qualified Scrod.Json.String as String +import qualified Scrod.Json.Value as Value +import qualified Scrod.JsonPointer.Pointer as Pointer +import qualified Scrod.JsonPointer.Token as Token +import qualified Scrod.Spec as Spec + +-- | Evaluates a JSON Pointer against a JSON Value. Returns 'Nothing' if the +-- path does not exist or is invalid. Per RFC 6901: +-- +-- - An empty pointer returns the document itself. +-- - For arrays, tokens must be valid non-negative integer indices. +-- - For objects, tokens are matched against member names. +evaluate :: Pointer.Pointer -> Value.Value -> Maybe Value.Value +evaluate = Function.fix $ \rec pointer value -> + case Pointer.unwrap pointer of + [] -> Just value + token : rest -> do + child <- step token value + rec (Pointer.MkPointer rest) child + +-- | Takes a single step in a JSON value using a reference token. +step :: Token.Token -> Value.Value -> Maybe Value.Value +step token value = case value of + Value.Array array -> stepArray token array + Value.Object object -> stepObject token object + _ -> Nothing + +-- | Steps into an array using a token as an index. Per RFC 6901, array indices +-- must be: +-- +-- - Non-negative integers. +-- - Either "0" or not starting with "0" (no leading zeros). +stepArray :: Token.Token -> Array.Array a -> Maybe a +stepArray token array = do + index <- case Text.unpack $ Token.unwrap token of + '0' : _ : _ -> Nothing + string -> Read.readM string + Array.unwrap array !? index + +-- | Steps into an object using a token as a key. +stepObject :: Token.Token -> Object.Object a -> Maybe a +stepObject token = + fmap Pair.value + . List.find ((== Token.unwrap token) . String.unwrap . Pair.name) + . Object.unwrap + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'evaluate $ do + Spec.it s "empty pointer returns the document" $ do + Spec.assertEq s (evaluate (Pointer.pointer []) Value.null) $ Just Value.null + + Spec.it s "empty pointer returns the document (object)" $ do + let doc = Value.object [("foo", Value.integer 1)] + Spec.assertEq s (evaluate (Pointer.pointer []) doc) $ Just doc + + Spec.it s "returns object member by name" $ do + let doc = Value.object [("foo", Value.string "bar")] + Spec.assertEq s (evaluate (Pointer.pointer ["foo"]) doc) . Just $ Value.string "bar" + + Spec.it s "returns nested object member" $ do + let doc = Value.object [("foo", Value.object [("bar", Value.integer 42)])] + Spec.assertEq s (evaluate (Pointer.pointer ["foo", "bar"]) doc) . Just $ Value.integer 42 + + Spec.it s "returns array element by index" $ do + let doc = Value.array [Value.string "a", Value.string "b", Value.string "c"] + Spec.assertEq s (evaluate (Pointer.pointer ["1"]) doc) . Just $ Value.string "b" + + Spec.it s "returns first array element with index 0" $ do + let doc = Value.array [Value.string "first", Value.string "second"] + Spec.assertEq s (evaluate (Pointer.pointer ["0"]) doc) . Just $ Value.string "first" + + Spec.it s "returns Nothing for out-of-bounds array index" $ do + let doc = Value.array [Value.string "a"] + Spec.assertEq s (evaluate (Pointer.pointer ["5"]) doc) Nothing + + Spec.it s "returns Nothing for non-integer array index" $ do + let doc = Value.array [Value.string "a"] + Spec.assertEq s (evaluate (Pointer.pointer ["foo"]) doc) Nothing + + Spec.it s "returns Nothing for leading zero in array index" $ do + let doc = Value.array [Value.string "a", Value.string "b"] + Spec.assertEq s (evaluate (Pointer.pointer ["01"]) doc) Nothing + + Spec.it s "returns Nothing for negative array index" $ do + let doc = Value.array [Value.string "a", Value.string "b"] + Spec.assertEq s (evaluate (Pointer.pointer ["-1"]) doc) Nothing + + Spec.it s "returns Nothing for missing object key" $ do + let doc = Value.object [("foo", Value.string "bar")] + Spec.assertEq s (evaluate (Pointer.pointer ["baz"]) doc) Nothing + + Spec.it s "returns Nothing when stepping into a scalar" $ do + Spec.assertEq s (evaluate (Pointer.pointer ["foo"]) (Value.string "bar")) Nothing + + Spec.describe s "rfc 6901 section 5" $ do + let rfc6901Doc = + Value.object + [ ("foo", Value.array [Value.string "bar", Value.string "baz"]), + ("", Value.integer 0), + ("a/b", Value.integer 1), + ("c%d", Value.integer 2), + ("e^f", Value.integer 3), + ("g|h", Value.integer 4), + ("i\\j", Value.integer 5), + ("k\"l", Value.integer 6), + (" ", Value.integer 7), + ("m~n", Value.integer 8) + ] + + Spec.it s "empty pointer returns the whole document" $ do + Spec.assertEq s (evaluate (Pointer.pointer []) rfc6901Doc) $ Just rfc6901Doc + + Spec.it s "/foo returns [\"bar\", \"baz\"]" $ do + Spec.assertEq s (evaluate (Pointer.pointer ["foo"]) rfc6901Doc) . Just $ Value.array [Value.string "bar", Value.string "baz"] + + Spec.it s "/foo/0 returns \"bar\"" $ do + Spec.assertEq s (evaluate (Pointer.pointer ["foo", "0"]) rfc6901Doc) . Just $ Value.string "bar" + + Spec.it s "/ (empty token) returns 0" $ do + Spec.assertEq s (evaluate (Pointer.pointer [""]) rfc6901Doc) . Just $ Value.integer 0 + + Spec.it s "/a~1b (unescaped a/b) returns 1" $ do + Spec.assertEq s (evaluate (Pointer.pointer ["a/b"]) rfc6901Doc) . Just $ Value.integer 1 + + Spec.it s "/c%d returns 2" $ do + Spec.assertEq s (evaluate (Pointer.pointer ["c%d"]) rfc6901Doc) . Just $ Value.integer 2 + + Spec.it s "/e^f returns 3" $ do + Spec.assertEq s (evaluate (Pointer.pointer ["e^f"]) rfc6901Doc) . Just $ Value.integer 3 + + Spec.it s "/g|h returns 4" $ do + Spec.assertEq s (evaluate (Pointer.pointer ["g|h"]) rfc6901Doc) . Just $ Value.integer 4 + + Spec.it s "/i\\j returns 5" $ do + Spec.assertEq s (evaluate (Pointer.pointer ["i\\j"]) rfc6901Doc) . Just $ Value.integer 5 + + Spec.it s "/k\"l returns 6" $ do + Spec.assertEq s (evaluate (Pointer.pointer ["k\"l"]) rfc6901Doc) . Just $ Value.integer 6 + + Spec.it s "/ (space) returns 7" $ do + Spec.assertEq s (evaluate (Pointer.pointer [" "]) rfc6901Doc) . Just $ Value.integer 7 + + Spec.it s "/m~0n (unescaped m~n) returns 8" $ do + Spec.assertEq s (evaluate (Pointer.pointer ["m~n"]) rfc6901Doc) . Just $ Value.integer 8 + + Spec.it s "handles empty string key" $ do + let doc = Value.object [("", Value.string "empty key")] + Spec.assertEq s (evaluate (Pointer.pointer [""]) doc) . Just $ Value.string "empty key" + + Spec.it s "handles deeply nested path" $ do + let doc = Value.object [("a", Value.object [("b", Value.object [("c", Value.string "deep")])])] + Spec.assertEq s (evaluate (Pointer.pointer ["a", "b", "c"]) doc) . Just $ Value.string "deep" + + Spec.it s "handles mixed array and object traversal" $ do + let doc = Value.object [("items", Value.array [Value.object [("name", Value.string "first")], Value.object [("name", Value.string "second")]])] + Spec.assertEq s (evaluate (Pointer.pointer ["items", "1", "name"]) doc) . Just $ Value.string "second" diff --git a/source/library/Scrod/JsonPointer/Pointer.hs b/source/library/Scrod/JsonPointer/Pointer.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/JsonPointer/Pointer.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.JsonPointer.Pointer where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Parsec as Parsec +import qualified Scrod.JsonPointer.Token as Token +import qualified Scrod.Spec as Spec +import qualified Text.Parsec as Parsec + +-- | A JSON Pointer as defined by RFC 6901. A JSON Pointer is a sequence of +-- zero or more reference tokens. An empty list represents the root of the +-- document. +newtype Pointer = MkPointer + { unwrap :: [Token.Token] + } + deriving (Eq, Ord, Show) + +pointer :: [String] -> Pointer +pointer = MkPointer . fmap (Token.MkToken . Text.pack) + +-- | Decodes a JSON Pointer from a string. Per RFC 6901, a JSON Pointer is +-- either an empty string (root) or a sequence of reference tokens each +-- prefixed by @/@. +decode :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Pointer +decode = MkPointer <$> Parsec.many (Parsec.char '/' *> Token.decode) + +-- | Encodes a JSON Pointer to a string. Each token is prefixed with @/@. +encode :: Pointer -> Builder.Builder +encode = foldMap encodeToken . unwrap + +encodeToken :: Token.Token -> Builder.Builder +encodeToken t = Builder.charUtf8 '/' <> Token.encode t + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'decode $ do + Spec.it s "succeeds with empty string (root pointer)" $ do + Spec.assertEq s (Parsec.parseString decode "") . Just $ pointer [] + + Spec.it s "succeeds with single slash (empty token)" $ do + Spec.assertEq s (Parsec.parseString decode "/") . Just $ pointer [""] + + Spec.it s "succeeds with /foo" $ do + Spec.assertEq s (Parsec.parseString decode "/foo") . Just $ pointer ["foo"] + + Spec.it s "succeeds with /foo/bar" $ do + Spec.assertEq s (Parsec.parseString decode "/foo/bar") . Just $ pointer ["foo", "bar"] + + Spec.it s "succeeds with /foo/0" $ do + Spec.assertEq s (Parsec.parseString decode "/foo/0") . Just $ pointer ["foo", "0"] + + Spec.it s "succeeds with /a~1b (contains /)" $ do + Spec.assertEq s (Parsec.parseString decode "/a~1b") . Just $ pointer ["a/b"] + + Spec.it s "succeeds with /m~0n (contains ~)" $ do + Spec.assertEq s (Parsec.parseString decode "/m~0n") . Just $ pointer ["m~n"] + + Spec.it s "succeeds with /c%d (contains percent)" $ do + Spec.assertEq s (Parsec.parseString decode "/c%d") . Just $ pointer ["c%d"] + + Spec.it s "succeeds with /e^f (contains caret)" $ do + Spec.assertEq s (Parsec.parseString decode "/e^f") . Just $ pointer ["e^f"] + + Spec.it s "succeeds with /g|h (contains pipe)" $ do + Spec.assertEq s (Parsec.parseString decode "/g|h") . Just $ pointer ["g|h"] + + Spec.it s "succeeds with /i\\\\j (contains backslash)" $ do + Spec.assertEq s (Parsec.parseString decode "/i\\j") . Just $ pointer ["i\\j"] + + Spec.it s "succeeds with /k\"l (contains quote)" $ do + Spec.assertEq s (Parsec.parseString decode "/k\"l") . Just $ pointer ["k\"l"] + + Spec.it s "succeeds with / / (contains space)" $ do + Spec.assertEq s (Parsec.parseString decode "/ ") . Just $ pointer [" "] + + Spec.it s "handles multiple empty tokens" $ do + Spec.assertEq s (Parsec.parseString decode "///") . Just $ pointer ["", "", ""] + + Spec.named s 'encode $ do + Spec.it s "works with empty pointer (root)" $ do + Spec.assertEq s (Builder.toString . encode $ pointer []) "" + + Spec.it s "works with single empty token" $ do + Spec.assertEq s (Builder.toString . encode $ pointer [""]) "/" + + Spec.it s "works with /foo" $ do + Spec.assertEq s (Builder.toString . encode $ pointer ["foo"]) "/foo" + + Spec.it s "works with /foo/bar" $ do + Spec.assertEq s (Builder.toString . encode $ pointer ["foo", "bar"]) "/foo/bar" + + Spec.it s "works with /foo/0" $ do + Spec.assertEq s (Builder.toString . encode $ pointer ["foo", "0"]) "/foo/0" + + Spec.it s "encodes / in token as ~1" $ do + Spec.assertEq s (Builder.toString . encode $ pointer ["a/b"]) "/a~1b" + + Spec.it s "encodes ~ in token as ~0" $ do + Spec.assertEq s (Builder.toString . encode $ pointer ["m~n"]) "/m~0n" + + Spec.it s "does not escape percent" $ do + Spec.assertEq s (Builder.toString . encode $ pointer ["c%d"]) "/c%d" + + Spec.it s "handles multiple empty tokens" $ do + Spec.assertEq s (Builder.toString . encode $ pointer ["", "", ""]) "///" diff --git a/source/library/Scrod/JsonPointer/Token.hs b/source/library/Scrod/JsonPointer/Token.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/JsonPointer/Token.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.JsonPointer.Token where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Parsec as Parsec +import qualified Scrod.Spec as Spec +import qualified Text.Parsec as Parsec + +-- | A reference token in a JSON Pointer, as defined by RFC 6901. The token +-- stores the unescaped text value. +newtype Token = MkToken + { unwrap :: Text.Text + } + deriving (Eq, Ord, Show) + +-- | Decodes a reference token from a JSON Pointer string. Handles the escape +-- sequences: @~0 -> ~@, @~1 -> /@. Per RFC 6901, we must decode @~1@ before +-- @~0@ to avoid errors. +decode :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Token +decode = MkToken . Text.pack <$> Parsec.many decodeChar + +decodeChar :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Char +decodeChar = + Parsec.choice + [ '/' <$ Parsec.string' "~1", + '~' <$ Parsec.string' "~0", + Parsec.noneOf "/" + ] + +-- | Encodes a token for use in a JSON Pointer string. Escapes @~@ as @~0@ and +-- @/@ as @~1@. Per RFC 6901, we must encode @~@ before @/@ to maintain +-- round-trip consistency. +encode :: Token -> Builder.Builder +encode = foldMap encodeChar . Text.unpack . unwrap + +encodeChar :: Char -> Builder.Builder +encodeChar c = case c of + '~' -> Builder.stringUtf8 "~0" + '/' -> Builder.stringUtf8 "~1" + _ -> Builder.charUtf8 c + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + let token = MkToken . Text.pack + + Spec.named s 'decode $ do + Spec.it s "succeeds with an empty token" $ do + Spec.assertEq s (Parsec.parseString decode "") . Just $ token "" + + Spec.it s "succeeds with a simple token" $ do + Spec.assertEq s (Parsec.parseString decode "foo") . Just $ token "foo" + + Spec.it s "succeeds with a numeric token" $ do + Spec.assertEq s (Parsec.parseString decode "0") . Just $ token "0" + + Spec.it s "decodes ~0 as tilde" $ do + Spec.assertEq s (Parsec.parseString decode "~0") . Just $ token "~" + + Spec.it s "decodes ~1 as slash" $ do + Spec.assertEq s (Parsec.parseString decode "~1") . Just $ token "/" + + Spec.it s "decodes ~01 as ~1 (not as /)" $ do + Spec.assertEq s (Parsec.parseString decode "~01") . Just $ token "~1" + + Spec.it s "decodes a~1b as a/b" $ do + Spec.assertEq s (Parsec.parseString decode "a~1b") . Just $ token "a/b" + + Spec.it s "decodes m~0n as m~n" $ do + Spec.assertEq s (Parsec.parseString decode "m~0n") . Just $ token "m~n" + + Spec.it s "stops at slash" $ do + Spec.assertEq s (Parsec.parseString (decode <* Parsec.char '/') "foo/") . Just $ token "foo" + + Spec.it s "handles multiple escapes" $ do + Spec.assertEq s (Parsec.parseString decode "~0~1~0~1") . Just $ token "~/~/" + + Spec.named s 'encode $ do + Spec.it s "works with an empty token" $ do + Spec.assertEq s (Builder.toString . encode $ token "") "" + + Spec.it s "works with a simple token" $ do + Spec.assertEq s (Builder.toString . encode $ token "foo") "foo" + + Spec.it s "works with a numeric token" $ do + Spec.assertEq s (Builder.toString . encode $ token "0") "0" + + Spec.it s "encodes tilde as ~0" $ do + Spec.assertEq s (Builder.toString . encode $ token "~") "~0" + + Spec.it s "encodes slash as ~1" $ do + Spec.assertEq s (Builder.toString . encode $ token "/") "~1" + + Spec.it s "encodes a/b as a~1b" $ do + Spec.assertEq s (Builder.toString . encode $ token "a/b") "a~1b" + + Spec.it s "encodes m~n as m~0n" $ do + Spec.assertEq s (Builder.toString . encode $ token "m~n") "m~0n" + + Spec.it s "handles multiple special chars" $ do + Spec.assertEq s (Builder.toString . encode $ token "~/~/") "~0~1~0~1" diff --git a/source/library/Scrod/Schema.hs b/source/library/Scrod/Schema.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Schema.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Type class for generating JSON Schema descriptions of types. +-- +-- This parallels 'Scrod.Json.ToJson.ToJson' but operates on types rather +-- than values: each instance describes the JSON Schema for the type's +-- 'ToJson' encoding. A 'Control.Monad.Trans.State.Strict.State' monad +-- tracks named definitions (for @$defs@) and detects re-entrant calls +-- to 'define' so that mutually recursive types produce @$ref@ +-- references instead of infinite inlining. +module Scrod.Schema where + +import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.Char as Char +import qualified Data.Kind as Kind +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import qualified Data.Proxy as Proxy +import qualified Data.Text as Text +import qualified GHC.Generics as Generics +import qualified GHC.TypeLits as TypeLits +import qualified Numeric.Natural as Natural +import qualified Scrod.Json.Value as Json +import qualified Scrod.Spec as Spec + +-- | A JSON Schema value. +newtype Schema = MkSchema + { unwrap :: Json.Value + } + deriving (Eq, Ord, Show) + +-- | Monad for schema generation. The state maps definition names to +-- their schema values: 'Nothing' marks a definition that is currently +-- being built (to break recursive cycles), and @'Just' v@ holds a +-- completed definition. +type SchemaM = State.State (Map.Map String (Maybe Json.Value)) + +-- | Run a schema computation, returning the result and completed +-- definitions as an association list sorted by name. +runSchemaM :: SchemaM a -> (a, [(String, Json.Value)]) +runSchemaM m = + let (a, defs) = State.runState m Map.empty + in (a, [(k, v) | (k, Just v) <- Map.toAscList defs]) + +-- | Register a named schema definition and return a @$ref@ pointing to +-- it. If the name is already registered (or currently being defined), +-- the body is not evaluated and only the @$ref@ is returned, breaking +-- recursive cycles. Characters @~@ and @/@ in the name are escaped +-- per RFC 6901 for the JSON Pointer in the @$ref@. +define :: String -> SchemaM Schema -> SchemaM Schema +define name m = + let ref = MkSchema $ Json.object [("$ref", Json.string $ "#/$defs/" <> escapeJsonPointer name)] + in do + defs <- State.get + if Map.member name defs + then pure ref + else do + State.modify' $ Map.insert name Nothing + MkSchema s <- m + State.modify' $ Map.insert name (Just s) + pure ref + +-- | Escape a JSON Pointer reference token per RFC 6901: @~@ becomes +-- @~0@ and @/@ becomes @~1@. +escapeJsonPointer :: String -> String +escapeJsonPointer = List.concatMap $ \c -> case c of + '~' -> "~0" + '/' -> "~1" + _ -> [c] + +-- | Convert a type to its JSON Schema representation. +-- +-- Use @deriving via 'Generics.Generically'@ with a 'Generics.Generic' +-- instance to derive 'ToSchema' for record types, enum types, and tagged +-- sum types. The derived instance registers the type as a named +-- definition in @$defs@ and returns a @$ref@. +type ToSchema :: Kind.Type -> Kind.Constraint +class ToSchema a where + toSchema :: Proxy.Proxy a -> SchemaM Schema + + -- | Whether the type represents an optional (omit-when-absent) field. + -- Returns 'True' for 'Maybe', 'False' for everything else. Used by + -- the generic record schema to separate required from optional + -- properties. + isOptional :: Proxy.Proxy a -> Bool + isOptional _ = False + +instance ToSchema Bool where + toSchema _ = pure . MkSchema $ Json.object [("type", Json.string "boolean")] + +instance ToSchema Text.Text where + toSchema _ = pure . MkSchema $ Json.object [("type", Json.string "string")] + +instance ToSchema Int where + toSchema _ = pure . MkSchema $ Json.object [("type", Json.string "integer")] + +instance ToSchema Natural.Natural where + toSchema _ = + pure . MkSchema $ + Json.object [("type", Json.string "integer"), ("minimum", Json.integer 0)] + +instance (ToSchema a) => ToSchema (Maybe a) where + toSchema _ = toSchema (Proxy.Proxy :: Proxy.Proxy a) + isOptional _ = True + +instance (ToSchema a) => ToSchema [a] where + toSchema _ = do + MkSchema items <- toSchema (Proxy.Proxy :: Proxy.Proxy a) + pure . MkSchema $ Json.object [("type", Json.string "array"), ("items", items)] + +instance (ToSchema a) => ToSchema (NonEmpty.NonEmpty a) where + toSchema _ = do + MkSchema items <- toSchema (Proxy.Proxy :: Proxy.Proxy a) + pure . MkSchema $ + Json.object + [("type", Json.string "array"), ("items", items), ("minItems", Json.integer 1)] + +-- * Generic schema encoding + +-- | Generic JSON Schema encoding. Dispatches between record encoding +-- (single constructor produces an object schema) and tagged encoding +-- (sum type produces a @oneOf@ schema with tagged variants). +type GToSchema :: (Kind.Type -> Kind.Type) -> Kind.Constraint +class GToSchema f where + gToSchema :: Proxy.Proxy f -> SchemaM Schema + +-- | The datatype wrapper registers the type as a named definition +-- in @$defs@ using the lowercased datatype name, and returns a +-- @$ref@ pointing to it. +instance (Generics.Datatype c, GToSchema f) => GToSchema (Generics.M1 Generics.D c f) where + gToSchema _ = + define + (lcFirst $ Generics.datatypeName (undefined :: Generics.M1 Generics.D c f ())) + (gToSchema (Proxy.Proxy :: Proxy.Proxy f)) + +instance (GToSchemaFields f) => GToSchema (Generics.M1 Generics.C c f) where + gToSchema _ = do + fields <- gToSchemaFields (Proxy.Proxy :: Proxy.Proxy f) + let allProps = fmap (\(n, MkSchema s, _) -> (n, s)) fields + let reqNames = (\(n, _, _) -> Json.string n) <$> filter (\(_, _, r) -> r) fields + pure . MkSchema $ + Json.object + [ ("type", Json.string "object"), + ("properties", Json.object allProps), + ("required", Json.array reqNames), + ("additionalProperties", Json.boolean False) + ] + +instance (GToSchemaSum f, GToSchemaSum g) => GToSchema (f Generics.:+: g) where + gToSchema _ = do + variants <- gToSchemaSum (Proxy.Proxy :: Proxy.Proxy (f Generics.:+: g)) + pure . MkSchema $ Json.object [("oneOf", Json.array $ fmap unwrap variants)] + +-- | Extract record fields as @(name, schema, required)@ triples. +type GToSchemaFields :: (Kind.Type -> Kind.Type) -> Kind.Constraint +class GToSchemaFields f where + gToSchemaFields :: Proxy.Proxy f -> SchemaM [(String, Schema, Bool)] + +instance + (TypeLits.KnownSymbol name, ToSchema a) => + GToSchemaFields (Generics.M1 Generics.S ('Generics.MetaSel ('Just name) su ss ds) (Generics.K1 i a)) + where + gToSchemaFields _ = do + s <- toSchema (Proxy.Proxy :: Proxy.Proxy a) + let n = TypeLits.symbolVal (Proxy.Proxy :: Proxy.Proxy name) + let req = not $ isOptional (Proxy.Proxy :: Proxy.Proxy a) + pure [(n, s, req)] + +instance (GToSchemaFields f, GToSchemaFields g) => GToSchemaFields (f Generics.:*: g) where + gToSchemaFields _ = do + l <- gToSchemaFields (Proxy.Proxy :: Proxy.Proxy f) + r <- gToSchemaFields (Proxy.Proxy :: Proxy.Proxy g) + pure $ l <> r + +instance GToSchemaFields Generics.U1 where + gToSchemaFields _ = pure [] + +-- | Tagged encoding for sum type constructors. +type GToSchemaSum :: (Kind.Type -> Kind.Type) -> Kind.Constraint +class GToSchemaSum f where + gToSchemaSum :: Proxy.Proxy f -> SchemaM [Schema] + +instance (GToSchemaSum f, GToSchemaSum g) => GToSchemaSum (f Generics.:+: g) where + gToSchemaSum _ = do + l <- gToSchemaSum (Proxy.Proxy :: Proxy.Proxy f) + r <- gToSchemaSum (Proxy.Proxy :: Proxy.Proxy g) + pure $ l <> r + +instance + (TypeLits.KnownSymbol name) => + GToSchemaSum (Generics.M1 Generics.C ('Generics.MetaCons name fix rec) Generics.U1) + where + gToSchemaSum _ = + let n = TypeLits.symbolVal (Proxy.Proxy :: Proxy.Proxy name) + in pure + [ MkSchema $ + Json.object + [ ("type", Json.string "object"), + ("properties", Json.object [("type", Json.object [("const", Json.string n)])]), + ("required", Json.array [Json.string "type"]), + ("additionalProperties", Json.boolean False) + ] + ] + +instance + (TypeLits.KnownSymbol name, ToSchema a) => + GToSchemaSum (Generics.M1 Generics.C ('Generics.MetaCons name fix rec) (Generics.M1 Generics.S sel (Generics.K1 i a))) + where + gToSchemaSum _ = do + MkSchema valueSchema <- toSchema (Proxy.Proxy :: Proxy.Proxy a) + let n = TypeLits.symbolVal (Proxy.Proxy :: Proxy.Proxy name) + pure + [ MkSchema $ + Json.object + [ ("type", Json.string "object"), + ( "properties", + Json.object + [ ("type", Json.object [("const", Json.string n)]), + ("value", valueSchema) + ] + ), + ("required", Json.array [Json.string "type", Json.string "value"]), + ("additionalProperties", Json.boolean False) + ] + ] + +instance (GToSchema (Generics.Rep a)) => ToSchema (Generics.Generically a) where + toSchema _ = gToSchema (Proxy.Proxy :: Proxy.Proxy (Generics.Rep a)) + +-- | Lowercase the first character of a string. +lcFirst :: String -> String +lcFirst s = case s of + [] -> [] + c : cs -> Char.toLower c : cs + +-- * Tests + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'toSchema $ do + Spec.it s "Bool schema has type boolean" $ do + let (MkSchema v, _) = runSchemaM $ toSchema (Proxy.Proxy :: Proxy.Proxy Bool) + Spec.assertEq s v $ Json.object [("type", Json.string "boolean")] + + Spec.it s "Natural schema has type integer with minimum 0" $ do + let (MkSchema v, _) = runSchemaM $ toSchema (Proxy.Proxy :: Proxy.Proxy Natural.Natural) + Spec.assertEq s v $ + Json.object [("type", Json.string "integer"), ("minimum", Json.integer 0)] + + Spec.it s "Text schema has type string" $ do + let (MkSchema v, _) = runSchemaM $ toSchema (Proxy.Proxy :: Proxy.Proxy Text.Text) + Spec.assertEq s v $ Json.object [("type", Json.string "string")] + + Spec.it s "[Bool] schema is array of boolean" $ do + let (MkSchema v, _) = runSchemaM $ toSchema (Proxy.Proxy :: Proxy.Proxy [Bool]) + Spec.assertEq s v $ + Json.object + [ ("type", Json.string "array"), + ("items", Json.object [("type", Json.string "boolean")]) + ] + + Spec.it s "NonEmpty Natural schema has minItems 1" $ do + let (MkSchema v, _) = runSchemaM $ toSchema (Proxy.Proxy :: Proxy.Proxy (NonEmpty.NonEmpty Natural.Natural)) + Spec.assertEq s v $ + Json.object + [ ("type", Json.string "array"), + ("items", Json.object [("type", Json.string "integer"), ("minimum", Json.integer 0)]), + ("minItems", Json.integer 1) + ] + + Spec.it s "Maybe is optional" $ do + Spec.assertEq s (isOptional (Proxy.Proxy :: Proxy.Proxy (Maybe Bool))) True + + Spec.it s "Bool is not optional" $ do + Spec.assertEq s (isOptional (Proxy.Proxy :: Proxy.Proxy Bool)) False + + Spec.it s "Maybe strips to inner schema" $ do + let (MkSchema v, _) = runSchemaM $ toSchema (Proxy.Proxy :: Proxy.Proxy (Maybe Bool)) + Spec.assertEq s v $ Json.object [("type", Json.string "boolean")] + + Spec.it s "define returns a $ref" $ do + let (MkSchema v, _) = + runSchemaM . define "myBool" $ + toSchema (Proxy.Proxy :: Proxy.Proxy Bool) + Spec.assertEq s v $ Json.object [("$ref", Json.string "#/$defs/myBool")] + + Spec.it s "define accumulates the definition" $ do + let (_, defs) = + runSchemaM . define "myBool" $ + toSchema (Proxy.Proxy :: Proxy.Proxy Bool) + Spec.assertEq s defs [("myBool", Json.object [("type", Json.string "boolean")])] diff --git a/source/library/Scrod/Spec.hs b/source/library/Scrod/Spec.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Spec.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE RankNTypes #-} + +-- | A test specification DSL that abstracts over the test framework. +-- +-- This module defines a record-based interface ('Spec') for writing tests +-- without depending on a concrete test framework. The test-suite entry point +-- wires 'Spec' into Tasty\/HUnit, but the abstraction allows library modules +-- to define @spec@ functions that are framework-agnostic. +module Scrod.Spec where + +import qualified Control.Monad as Monad +import qualified GHC.Stack as Stack +import qualified Language.Haskell.TH as TH + +-- | A test specification parameterized by two monads: +-- +-- * @m@ — the monad for assertions (e.g., individual test actions). +-- * @n@ — the monad for test tree structure (e.g., grouping and registration). +data Spec m n = MkSpec + { -- | Signal a test failure with a message. + assertFailure :: forall x. (Stack.HasCallStack) => String -> m x, + -- | Group a set of tests under a label. + describe :: String -> n () -> n (), + -- | Register a single test case with a label. + it :: String -> m () -> n () + } + +assertEq :: (Stack.HasCallStack, Applicative m, Eq a, Show a) => Spec m n -> a -> a -> m () +assertEq s x y = Monad.unless (x == y) . assertFailure s $ "expected: " <> show x <> " == " <> show y + +assertNe :: (Stack.HasCallStack, Applicative m, Eq a, Show a) => Spec m n -> a -> a -> m () +assertNe s x y = Monad.unless (x /= y) . assertFailure s $ "expected: " <> show x <> " /= " <> show y + +assertLt :: (Stack.HasCallStack, Applicative m, Ord a, Show a) => Spec m n -> a -> a -> m () +assertLt s x y = Monad.unless (x < y) . assertFailure s $ "expected: " <> show x <> " < " <> show y + +assertLe :: (Stack.HasCallStack, Applicative m, Ord a, Show a) => Spec m n -> a -> a -> m () +assertLe s x y = Monad.unless (x <= y) . assertFailure s $ "expected: " <> show x <> " <= " <> show y + +assertGt :: (Stack.HasCallStack, Applicative m, Ord a, Show a) => Spec m n -> a -> a -> m () +assertGt s x y = Monad.unless (x > y) . assertFailure s $ "expected: " <> show x <> " > " <> show y + +assertGe :: (Stack.HasCallStack, Applicative m, Ord a, Show a) => Spec m n -> a -> a -> m () +assertGe s x y = Monad.unless (x >= y) . assertFailure s $ "expected: " <> show x <> " >= " <> show y + +named :: Spec m n -> TH.Name -> n () -> n () +named s = describe s . show diff --git a/source/library/Scrod/TestSuite/All.hs b/source/library/Scrod/TestSuite/All.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/TestSuite/All.hs @@ -0,0 +1,96 @@ +module Scrod.TestSuite.All where + +import qualified Scrod.Cabal +import qualified Scrod.Convert.FromHaddock +import qualified Scrod.Convert.ToJsonSchema +import qualified Scrod.Core.Level +import qualified Scrod.Cpp +import qualified Scrod.Cpp.Directive +import qualified Scrod.Cpp.Expr +import qualified Scrod.Decimal +import qualified Scrod.Executable.Config +import qualified Scrod.Executable.Flag +import qualified Scrod.Executable.Format +import qualified Scrod.Extra.Builder +import qualified Scrod.Extra.Either +import qualified Scrod.Extra.Maybe +import qualified Scrod.Extra.Monoid +import qualified Scrod.Extra.Ord +import qualified Scrod.Extra.Parsec +import qualified Scrod.Extra.Read +import qualified Scrod.Extra.Semigroup +import qualified Scrod.Ghc.OnOff +import qualified Scrod.Ghc.Parse +import qualified Scrod.Json.Array +import qualified Scrod.Json.Boolean +import qualified Scrod.Json.Null +import qualified Scrod.Json.Number +import qualified Scrod.Json.Object +import qualified Scrod.Json.Pair +import qualified Scrod.Json.String +import qualified Scrod.Json.Value +import qualified Scrod.JsonPointer.Evaluate +import qualified Scrod.JsonPointer.Pointer +import qualified Scrod.JsonPointer.Token +import qualified Scrod.Schema +import qualified Scrod.Spec as Spec +import qualified Scrod.TestSuite.Integration +import qualified Scrod.Unlit +import qualified Scrod.Xml.Attribute +import qualified Scrod.Xml.Comment +import qualified Scrod.Xml.Content +import qualified Scrod.Xml.Declaration +import qualified Scrod.Xml.Document +import qualified Scrod.Xml.Element +import qualified Scrod.Xml.Instruction +import qualified Scrod.Xml.Misc +import qualified Scrod.Xml.Name +import qualified Scrod.Xml.Text + +spec :: (Monad m, Monad n) => Spec.Spec m n -> n () +spec s = do + Scrod.Cabal.spec s + Scrod.Convert.FromHaddock.spec s + Scrod.Convert.ToJsonSchema.spec s + Scrod.Core.Level.spec s + Scrod.Cpp.spec s + Scrod.Cpp.Directive.spec s + Scrod.Cpp.Expr.spec s + Scrod.Decimal.spec s + Scrod.Executable.Config.spec s + Scrod.Executable.Format.spec s + Scrod.Executable.Flag.spec s + Scrod.Extra.Builder.spec s + Scrod.Extra.Either.spec s + Scrod.Extra.Maybe.spec s + Scrod.Extra.Monoid.spec s + Scrod.Extra.Ord.spec s + Scrod.Extra.Parsec.spec s + Scrod.Extra.Read.spec s + Scrod.Extra.Semigroup.spec s + Scrod.Ghc.OnOff.spec s + Scrod.Ghc.Parse.spec s + Scrod.Json.Array.spec s + Scrod.Json.Boolean.spec s + Scrod.Json.Null.spec s + Scrod.Json.Number.spec s + Scrod.Json.Object.spec s + Scrod.Json.Pair.spec s + Scrod.Json.String.spec s + Scrod.Schema.spec s + Scrod.Json.Value.spec s + Scrod.JsonPointer.Evaluate.spec s + Scrod.JsonPointer.Pointer.spec s + Scrod.JsonPointer.Token.spec s + Scrod.TestSuite.Integration.spec s + Scrod.Unlit.spec s + Scrod.Xml.Attribute.spec s + Scrod.Xml.Comment.spec s + Scrod.Xml.Content.spec s + Scrod.Xml.Declaration.spec s + Scrod.Xml.Document.spec s + Scrod.Xml.Element.spec s + Scrod.Xml.Instruction.spec s + Scrod.Xml.Misc.spec s + Scrod.Xml.Name.spec s + Scrod.Xml.Text.spec s diff --git a/source/library/Scrod/TestSuite/Integration.hs b/source/library/Scrod/TestSuite/Integration.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/TestSuite/Integration.hs @@ -0,0 +1,3299 @@ +{-# LANGUAGE MultilineStrings #-} +{-# OPTIONS_GHC -O0 #-} + +module Scrod.TestSuite.Integration where + +import qualified Control.Monad as Monad +import qualified Control.Monad.Catch as Exception +import qualified Data.List as List +import qualified GHC.Stack as Stack +import qualified Scrod.Executable.Main as Main +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Parsec as Parsec +import qualified Scrod.Json.Value as Json +import qualified Scrod.JsonPointer.Evaluate as Pointer +import qualified Scrod.JsonPointer.Pointer as Pointer +import qualified Scrod.Spec as Spec + +spec :: (Monad m, Monad n) => Spec.Spec m n -> n () +spec s = Spec.describe s "integration" $ do + Spec.it s "works with empty input" $ do + check + s + "" + [ ("/extensions", "{}"), + ("/documentation/type", "\"Empty\""), + ("/imports", "[]"), + ("/signature", "false"), + ("/items", "[]") + ] + + Spec.describe s "$schema" $ do + Spec.it s "is present" $ do + check s "" [("/$schema", "\"https://scrod.fyi/schema.json\"")] + + Spec.describe s "version" $ do + Spec.it s "works" $ do + -- Note that we don't want this test to be too specific, otherwise we'd + -- have to update it every time we change the version number. So instead + -- we just check the first component. + check s "" [("/version/0", "0")] + + Spec.describe s "language" $ do + Spec.it s "defaults to absent" $ do + check s "" [("/language", "")] + + Spec.it s "works with a language" $ do + check s "{-# language Haskell98 #-}" [("/language", "\"Haskell98\"")] + + Spec.it s "works with GHC2024" $ do + check s "{-# language GHC2024 #-}" [("/language", "\"GHC2024\"")] + + Spec.it s "picks the last one" $ do + check s "{-# language Haskell98, Haskell2010 #-}" [("/language", "\"Haskell2010\"")] + + Spec.describe s "extensions" $ do + Spec.it s "defaults to empty object" $ do + check s "" [("/extensions", "{}")] + + Spec.it s "works with an enabled extension" $ do + check s "{-# language CPP #-}" [("/extensions/Cpp", "true")] + + Spec.it s "works with a disabled extension" $ do + check s "{-# language NoCPP #-}" [("/extensions/Cpp", "false")] + + Spec.it s "works with on then off" $ do + check s "{-# language CPP, NoCPP #-}" [("/extensions/Cpp", "false")] + + Spec.it s "works with off then on" $ do + check s "{-# language NoCPP, CPP #-}" [("/extensions/Cpp", "true")] + + Spec.it s "works with ghc options" $ do + check s "{-# options_ghc -XCPP #-}" [("/extensions/Cpp", "true")] + + Spec.it s "works with optimization flags" $ do + check s "{-# options_ghc -O #-}" [("/items", "[]")] + + Spec.it s "works with two extensions in one pragma" $ do + check + s + "{-# language CPP, DeriveGeneric #-}" + [ ("/extensions/Cpp", "true"), + ("/extensions/DeriveGeneric", "true") + ] + + Spec.it s "works with two extensions in separate pragmas" $ do + check + s + "{-# language CPP #-} {-# language DeriveGeneric #-}" + [ ("/extensions/Cpp", "true"), + ("/extensions/DeriveGeneric", "true") + ] + + Spec.it s "also enables implied extensions" $ do + check + s + "{-# language RankNTypes #-}" + [ ("/extensions/ExplicitForAll", "true"), + ("/extensions/RankNTypes", "true") + ] + + Spec.it s "works with cabal script header" $ do + check + s + """ + {- cabal: + default-extensions: CPP + -} + """ + [("/extensions/Cpp", "true")] + + Spec.it s "works with cabal script header and pragma" $ do + check + s + """ + {- cabal: + default-extensions: CPP + -} + {-# language DeriveGeneric #-} + """ + [ ("/extensions/Cpp", "true"), + ("/extensions/DeriveGeneric", "true") + ] + + Spec.it s "works with cabal script header with shebang" $ do + check + s + """ + #!/usr/bin/env cabal + {- cabal: + default-extensions: CPP + -} + """ + [("/extensions/Cpp", "true")] + + Spec.it s "works with --ghc-option extension" $ do + checkWith + s + ["--ghc-option", "-XOverloadedStrings"] + "" + [("/extensions/OverloadedStrings", "true")] + + Spec.it s "works with --ghc-option language" $ do + checkWith + s + ["--ghc-option", "-XHaskell2010"] + "" + [("/language", "\"Haskell2010\"")] + + Spec.it s "source pragmas override --ghc-option" $ do + checkWith + s + ["--ghc-option", "-XOverloadedStrings"] + "{-# language NoOverloadedStrings #-}" + [("/extensions/OverloadedStrings", "false")] + + Spec.describe s "documentation" $ do + Spec.it s "defaults to Empty" $ do + check s "" [("/documentation/type", "\"Empty\"")] + + Spec.it s "works with a string" $ do + check + s + """ + -- | x + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"String\""), + ("/documentation/value/value", "\"x\"") + ] + + Spec.it s "works with an identifier" $ do + check + s + """ + -- | 'x' + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"Identifier\""), + ("/documentation/value/value/value", "\"x\"") + ] + + Spec.it s "strips module qualifier from identifier" $ do + check + s + """ + -- | 'A.b' + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"Identifier\""), + ("/documentation/value/value/value", "\"b\"") + ] + + Spec.it s "works with a value identifier" $ do + check + s + """ + -- | v'x' + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"Identifier\""), + ("/documentation/value/value/namespace/type", "\"Value\""), + ("/documentation/value/value/value", "\"x\"") + ] + + Spec.it s "works with a type identifier" $ do + check + s + """ + -- | t'x' + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"Identifier\""), + ("/documentation/value/value/namespace/type", "\"Type\""), + ("/documentation/value/value/value", "\"x\"") + ] + + Spec.it s "works with a module" $ do + check + s + """ + -- | "X" + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"Module\""), + ("/documentation/value/value/name", "\"X\"") + ] + + Spec.it s "works with a labeled module" $ do + check + s + """ + -- | [label]("X") + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"Module\""), + ("/documentation/value/value/name", "\"X\""), + ("/documentation/value/value/label/type", "\"String\""), + ("/documentation/value/value/label/value", "\"label\"") + ] + + Spec.it s "works with emphasis" $ do + check + s + """ + -- | /x/ + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"Emphasis\""), + ("/documentation/value/value/type", "\"String\""), + ("/documentation/value/value/value", "\"x\"") + ] + + Spec.it s "works with monospaced text" $ do + -- Note that this can't use `@x@` by itself because that would be a code + -- block. + check + s + """ + -- | x @y@ + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"Append\""), + ("/documentation/value/value/0/type", "\"String\""), + ("/documentation/value/value/0/value", "\"x \""), + ("/documentation/value/value/1/type", "\"Monospaced\""), + ("/documentation/value/value/1/value/type", "\"String\""), + ("/documentation/value/value/1/value/value", "\"y\"") + ] + + Spec.it s "works with bold text" $ do + check + s + """ + -- | __x__ + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"Bold\""), + ("/documentation/value/value/type", "\"String\""), + ("/documentation/value/value/value", "\"x\"") + ] + + Spec.it s "works with an unordered list using dash" $ do + check + s + """ + -- | - x + module M where + """ + [ ("/documentation/type", "\"UnorderedList\""), + ("/documentation/value/0/type", "\"Paragraph\""), + ("/documentation/value/0/value/type", "\"String\""), + ("/documentation/value/0/value/value", "\"x\"") + ] + + Spec.it s "works with an unordered list using asterisk" $ do + check + s + """ + -- | * x + module M where + """ + [ ("/documentation/type", "\"UnorderedList\""), + ("/documentation/value/0/type", "\"Paragraph\""), + ("/documentation/value/0/value/type", "\"String\""), + ("/documentation/value/0/value/value", "\"x\"") + ] + + Spec.it s "works with an ordered list using period" $ do + check + s + """ + -- | 1. x + module M where + """ + [ ("/documentation/type", "\"OrderedList\""), + ("/documentation/value/0/index", "1"), + ("/documentation/value/0/item/type", "\"Paragraph\""), + ("/documentation/value/0/item/value/type", "\"String\""), + ("/documentation/value/0/item/value/value", "\"x\"") + ] + + Spec.it s "works with an ordered list using parens" $ do + check + s + """ + -- | (1) x + module M where + """ + [ ("/documentation/type", "\"OrderedList\""), + ("/documentation/value/0/index", "1"), + ("/documentation/value/0/item/type", "\"Paragraph\""), + ("/documentation/value/0/item/value/type", "\"String\""), + ("/documentation/value/0/item/value/value", "\"x\"") + ] + + Spec.it s "works with an ordered list starting at 2" $ do + check + s + """ + -- | 2. x + module M where + """ + [ ("/documentation/type", "\"OrderedList\""), + ("/documentation/value/0/index", "2"), + ("/documentation/value/0/item/type", "\"Paragraph\""), + ("/documentation/value/0/item/value/type", "\"String\""), + ("/documentation/value/0/item/value/value", "\"x\"") + ] + + Spec.it s "works with a definition list" $ do + check + s + """ + -- | [x]: y + module M where + """ + [ ("/documentation/type", "\"DefList\""), + ("/documentation/value/0/term/type", "\"String\""), + ("/documentation/value/0/term/value", "\"x\""), + ("/documentation/value/0/definition/type", "\"String\""), + ("/documentation/value/0/definition/value", "\"y\"") + ] + + Spec.it s "works with a code block" $ do + check + s + """ + -- | @x@ + module M where + """ + [ ("/documentation/type", "\"CodeBlock\""), + ("/documentation/value/type", "\"String\""), + ("/documentation/value/value", "\"x\"") + ] + + Spec.it s "works with a hyperlink" $ do + check + s + """ + -- | + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"Hyperlink\""), + ("/documentation/value/value/url", "\"http://example\"") + ] + + Spec.it s "works with a labeled hyperlink" $ do + check + s + """ + -- | [http://example](x) + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"Hyperlink\""), + ("/documentation/value/value/url", "\"x\""), + ("/documentation/value/value/label/type", "\"Hyperlink\""), + ("/documentation/value/value/label/value/url", "\"http://example\"") + ] + + Spec.it s "works with a picture" $ do + check + s + """ + -- | ![http://example](x) + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"Pic\""), + ("/documentation/value/value/uri", "\"x\""), + ("/documentation/value/value/title", "\"http://example\"") + ] + + Spec.it s "works with inline math" $ do + check + s + """ + -- | \\(x\\) + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"MathInline\""), + ("/documentation/value/value", "\"x\"") + ] + + Spec.it s "works with display math" $ do + check + s + """ + -- | \\[x\\] + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"MathDisplay\""), + ("/documentation/value/value", "\"x\"") + ] + + Spec.it s "works with an anchor" $ do + check + s + """ + -- | #x# + module M where + """ + [ ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"AName\""), + ("/documentation/value/value", "\"x\"") + ] + + Spec.it s "works with a property" $ do + check + s + """ + -- | prop> x + module M where + """ + [ ("/documentation/type", "\"Property\""), + ("/documentation/value", "\"x\"") + ] + + Spec.it s "works with an example" $ do + check + s + """ + -- | >>> x + module M where + """ + [ ("/documentation/type", "\"Examples\""), + ("/documentation/value/0/expression", "\"x\""), + ("/documentation/value/0/result", "[]") + ] + + Spec.it s "works with an example with a result" $ do + check + s + """ + -- | >>> x + -- y + module M where + """ + [ ("/documentation/type", "\"Examples\""), + ("/documentation/value/0/expression", "\"x\""), + ("/documentation/value/0/result/0", "\"y\"") + ] + + Spec.it s "works with an example with a blank line" $ do + check + s + """ + -- | >>> x + -- y + -- + -- z + module M where + """ + [ ("/documentation/type", "\"Examples\""), + ("/documentation/value/0/expression", "\"x\""), + ("/documentation/value/0/result/0", "\"y\""), + ("/documentation/value/0/result/1", "\"\""), + ("/documentation/value/0/result/2", "\"z\"") + ] + + Spec.it s "works with a header" $ do + check + s + """ + -- | = x + module M where + """ + [ ("/documentation/type", "\"Header\""), + ("/documentation/value/level", "1"), + ("/documentation/value/title/type", "\"String\""), + ("/documentation/value/title/value", "\"x\"") + ] + + Spec.it s "works with a level 2 header" $ do + check + s + """ + -- | == x + module M where + """ + [ ("/documentation/type", "\"Header\""), + ("/documentation/value/level", "2") + ] + + Spec.it s "works with a level 3 header" $ do + check + s + """ + -- | === x + module M where + """ + [ ("/documentation/type", "\"Header\""), + ("/documentation/value/level", "3") + ] + + Spec.it s "works with a table" $ do + check + s + """ + -- | + -- +---+---+---+ + -- | a | b | c | + -- +===+===+===+ + -- | d | e | + -- +---+---+ | + -- | f | g | | + -- +---+---+---+ + module M where + """ + [ ("/documentation/type", "\"Table\""), + ("/documentation/value/headerRows/0/0/colspan", "1"), + ("/documentation/value/headerRows/0/0/rowspan", "1"), + ("/documentation/value/headerRows/0/0/contents/type", "\"String\""), + ("/documentation/value/headerRows/0/0/contents/value", "\"a\""), + ("/documentation/value/headerRows/0/1/colspan", "1"), + ("/documentation/value/headerRows/0/1/rowspan", "1"), + ("/documentation/value/headerRows/0/1/contents/type", "\"String\""), + ("/documentation/value/headerRows/0/1/contents/value", "\"b\""), + ("/documentation/value/headerRows/0/2/colspan", "1"), + ("/documentation/value/headerRows/0/2/rowspan", "1"), + ("/documentation/value/headerRows/0/2/contents/type", "\"String\""), + ("/documentation/value/headerRows/0/2/contents/value", "\"c\""), + ("/documentation/value/bodyRows/0/0/colspan", "2"), + ("/documentation/value/bodyRows/0/0/rowspan", "1"), + ("/documentation/value/bodyRows/0/0/contents/type", "\"String\""), + ("/documentation/value/bodyRows/0/0/contents/value", "\"d\""), + ("/documentation/value/bodyRows/0/1/colspan", "1"), + ("/documentation/value/bodyRows/0/1/rowspan", "2"), + ("/documentation/value/bodyRows/0/1/contents/type", "\"String\""), + ("/documentation/value/bodyRows/0/1/contents/value", "\"e\\n\\n\""), + ("/documentation/value/bodyRows/1/0/colspan", "1"), + ("/documentation/value/bodyRows/1/0/rowspan", "1"), + ("/documentation/value/bodyRows/1/0/contents/type", "\"String\""), + ("/documentation/value/bodyRows/1/0/contents/value", "\"f\""), + ("/documentation/value/bodyRows/1/1/colspan", "1"), + ("/documentation/value/bodyRows/1/1/rowspan", "1"), + ("/documentation/value/bodyRows/1/1/contents/type", "\"String\""), + ("/documentation/value/bodyRows/1/1/contents/value", "\"g\"") + ] + + Spec.describe s "since" $ do + Spec.it s "defaults to absent" $ do + check s "" [("/since", "")] + + Spec.it s "works with a version" $ do + check + s + """ + -- | Docs + -- + -- @since 1.2.3 + module M where + """ + [ ("/since/version", "[1,2,3]") + ] + + Spec.it s "works with a package and version" $ do + check + s + """ + -- | Docs + -- + -- @since base-4.16.0 + module M where + """ + [ ("/since/package", "\"base\""), + ("/since/version", "[4,16,0]") + ] + + Spec.describe s "name" $ do + Spec.it s "defaults to absent" $ do + check s "" [("/name", "")] + + Spec.it s "works with a simple module name" $ do + check + s + "module M where" + [ ("/name/location/line", "1"), + ("/name/location/column", "8"), + ("/name/value", "\"M\"") + ] + + Spec.it s "works with a complex module name" $ do + check + s + "module Foo.Bar where" + [ ("/name/location/line", "1"), + ("/name/location/column", "8"), + ("/name/value", "\"Foo.Bar\"") + ] + + Spec.describe s "warning" $ do + Spec.it s "defaults to absent" $ do + check s "" [("/warning", "")] + + Spec.it s "works with deprecated" $ do + check + s + """ + module M {-# deprecated "foo" #-} where + """ + [ ("/warning/category", "\"deprecations\""), + ("/warning/value", "\"foo\"") + ] + + Spec.it s "works with warning" $ do + check + s + """ + module M {-# warning "foo" #-} where + """ + [ ("/warning/category", "\"deprecations\""), + ("/warning/value", "\"foo\"") + ] + + Spec.it s "works with custom warning" $ do + check + s + """ + module M {-# warning in "foo" "bar" #-} where + """ + [ ("/warning/category", "\"foo\""), + ("/warning/value", "\"bar\"") + ] + + Spec.it s "works with empty list of messages" $ do + check + s + """ + module M {-# warning [] #-} where + """ + [ ("/warning/category", "\"deprecations\""), + ("/warning/value", "\"\"") + ] + + Spec.it s "works with list of messages" $ do + check + s + """ + module M {-# warning ["foo", "bar"] #-} where + """ + [ ("/warning/category", "\"deprecations\""), + ("/warning/value", "\"foo\\nbar\"") + ] + + Spec.describe s "export ordering" $ do + Spec.it s "orders items by export list" $ do + check + s + """ + module M ( y, x ) where + x = () + y = () + """ + [ ("/items/0/value/name", "\"y\""), + ("/items/1/value/name", "\"x\"") + ] + + Spec.it s "creates section heading items from export groups" $ do + check + s + """ + module M + ( -- * Section One + x + ) where + x = () + """ + [ ("/items/0/value/kind/type", "\"DocumentationChunk\""), + ("/items/0/value/documentation/type", "\"Header\""), + ("/items/1/value/name", "\"x\"") + ] + + Spec.it s "creates inline doc items from export docs" $ do + check + s + """ + module M + ( -- | Some docs + x + ) where + x = () + """ + [ ("/items/0/value/kind/type", "\"DocumentationChunk\""), + ("/items/0/value/documentation/type", "\"Paragraph\""), + ("/items/1/value/name", "\"x\"") + ] + + Spec.it s "creates unresolved export items for module re-exports" $ do + check + s + """ + module M ( module M, x ) where + x = () + """ + [ ("/items/0/value/kind/type", "\"UnresolvedExport\""), + ("/items/0/value/name", "\"M\""), + ("/items/0/value/signature", "\"module\""), + ("/items/1/value/name", "\"x\"") + ] + + Spec.it s "creates unresolved export items for missing declarations" $ do + check + s + """ + module M ( missing ) where + """ + [ ("/items/0/value/kind/type", "\"UnresolvedExport\""), + ("/items/0/value/name", "\"missing\"") + ] + + Spec.it s "resolves named doc chunks into items" $ do + check + s + """ + module M + ( -- $foo + unit, + ) where + + -- $foo + -- bar + + unit :: () + unit = () + """ + [ ("/items/0/value/kind/type", "\"DocumentationChunk\""), + ("/items/0/value/documentation/value/value", "\"bar\""), + ("/items/1/value/name", "\"unit\""), + ("/items/1/value/kind/type", "\"Function\"") + ] + + Spec.it s "renders unresolved named doc chunks as named card items" $ do + check + s + """ + module M + ( -- $x + y + ) where + y = () + """ + [ ("/items/0/value/kind/type", "\"DocumentationChunk\""), + ("/items/0/value/name", "\"$x\""), + ("/items/0/value/documentation/type", "\"Empty\""), + ("/items/1/value/name", "\"y\"") + ] + + Spec.it s "creates metadata items for export-level doc comments" $ do + check + s + """ + module M + ( x -- ^ export doc + ) where + x = () + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/1/value/kind/type", "\"DocumentationChunk\""), + ("/items/1/value/documentation/type", "\"Paragraph\""), + ("/items/1/value/documentation/value/value", "\"export doc\"") + ] + + Spec.it s "creates metadata items for export-level warnings" $ do + check + s + """ + module M ( {-# warning "deprecated" #-} x ) where + x = () + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/1/value/kind/type", "\"DocumentationChunk\""), + ("/items/1/value/documentation/type", "\"Paragraph\"") + ] + + Spec.it s "deduplicates repeated exports" $ do + check + s + """ + module M ( x, x ) where + x = () + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/0/value/kind/type", "\"Function\"") + ] + + Spec.it s "places implicit items after exported items" $ do + check + s + """ + module M ( MyClass ) where + class MyClass a + instance MyClass Int + """ + [ ("/items/0/value/name", "\"MyClass a\""), + ("/items/0/value/visibility/type", "\"Exported\""), + ("/items/1/value/visibility/type", "\"Implicit\"") + ] + + Spec.describe s "named chunks" $ do + Spec.it s "creates items for unreferenced named chunks" $ do + check + s + """ + -- $a + -- b + x=0 + """ + [ ("/items/0/value/name", "\"$a\""), + ("/items/0/value/documentation/type", "\"Paragraph\""), + ("/items/0/value/documentation/value/value", "\"b\""), + ("/items/1/value/name", "\"x\"") + ] + + Spec.it s "preceding doc comment does not leak past named chunk" $ do + check + s + """ + module M + ( -- $bar + unit, + ) where + + -- | foo + -- $bar + -- qux + unit :: () + unit = () + """ + [ ("/items/0/value/kind/type", "\"DocumentationChunk\""), + ("/items/0/value/documentation/value/value", "\"qux\""), + ("/items/1/value/name", "\"unit\""), + ("/items/1/value/documentation/type", "\"Empty\"") + ] + + Spec.it s "preceding doc comment does not leak past unreferenced named chunk" $ do + check + s + """ + -- | foo + -- $a + -- chunk + x=0 + """ + [ ("/items/0/value/name", "\"$a\""), + ("/items/0/value/documentation/value/value", "\"chunk\""), + ("/items/1/value/name", "\"x\""), + ("/items/1/value/documentation/type", "\"Empty\"") + ] + + Spec.it s "creates items for unreferenced named chunks with explicit exports" $ do + check + s + """ + module M + ( -- $foo + unit, + ) where + + -- $foo + -- bar + + -- $baz + -- quux + + unit :: () + unit = () + """ + [ ("/items/0/value/kind/type", "\"DocumentationChunk\""), + ("/items/0/value/documentation/value/value", "\"bar\""), + ("/items/1/value/name", "\"unit\""), + ("/items/2/value/name", "\"$baz\""), + ("/items/2/value/documentation/value/value", "\"quux\"") + ] + + Spec.describe s "doc groups" $ do + Spec.it s "converts doc groups in the module body to headings" $ do + check + s + """ + a = 1 + -- * My Section + c = 2 + """ + [ ("/items/0/value/name", "\"a\""), + ("/items/1/value/kind/type", "\"DocumentationChunk\""), + ("/items/1/value/documentation/type", "\"Header\""), + ("/items/1/value/documentation/value/level", "1"), + ("/items/1/value/documentation/value/title/type", "\"Paragraph\""), + ("/items/1/value/documentation/value/title/value/value", "\"My Section\""), + ("/items/2/value/name", "\"c\"") + ] + + Spec.it s "handles level 2 doc groups" $ do + check + s + """ + -- ** Sub Section + x = () + """ + [ ("/items/0/value/kind/type", "\"DocumentationChunk\""), + ("/items/0/value/documentation/type", "\"Header\""), + ("/items/0/value/documentation/value/level", "2"), + ("/items/0/value/documentation/value/title/value/value", "\"Sub Section\""), + ("/items/1/value/name", "\"x\"") + ] + + Spec.describe s "imports" $ do + Spec.it s "defaults to empty list" $ do + check s "" [("/imports", "[]")] + + Spec.it s "works with a simple import" $ do + check + s + "import Data.List" + [ ("/imports/0/name", "\"Data.List\"") + ] + + Spec.it s "works with multiple imports" $ do + check + s + """ + import Data.List + import Data.Map + """ + [ ("/imports/0/name", "\"Data.List\""), + ("/imports/1/name", "\"Data.Map\"") + ] + + Spec.it s "works with an alias" $ do + check + s + "import Data.List as List" + [ ("/imports/0/name", "\"Data.List\""), + ("/imports/0/alias", "\"List\"") + ] + + Spec.it s "works with a package import" $ do + check + s + "{-# language PackageImports #-} import \"base\" Data.List" + [ ("/imports/0/name", "\"Data.List\""), + ("/imports/0/package", "\"base\"") + ] + + Spec.it s "works with a qualified import" $ do + check + s + "import qualified Data.Map" + [ ("/imports/0/name", "\"Data.Map\"") + ] + + Spec.it s "works with a qualified import with alias" $ do + check + s + "import qualified Data.Map as Map" + [ ("/imports/0/name", "\"Data.Map\""), + ("/imports/0/alias", "\"Map\"") + ] + + Spec.describe s "items" $ do + Spec.it s "defaults to empty list" $ do + check s "" [("/items", "[]")] + + Spec.describe s "function" $ do + -- Note that we call this a "function" because GHC does. Obviously it's + -- just a value. + + Spec.it s "works with one" $ do + check + s + "x = 0" + [ ("/items/0/location/line", "1"), + ("/items/0/location/column", "1"), + ("/items/0/value/key", "0"), + ("/items/0/value/kind/type", "\"Function\""), + ("/items/0/value/name", "\"x\""), + ("/items/0/value/documentation/type", "\"Empty\"") + ] + + Spec.it s "works with two" $ do + check + s + """ + x = 0 + y = 1 + """ + [ ("/items/0/location/line", "1"), + ("/items/0/location/column", "1"), + ("/items/0/value/key", "0"), + ("/items/0/value/name", "\"x\""), + ("/items/1/location/line", "2"), + ("/items/1/location/column", "1"), + ("/items/1/value/key", "1"), + ("/items/1/value/name", "\"y\"") + ] + + Spec.it s "works with documentation before" $ do + check + s + """ + -- | x + y = 0 + """ + [ ("/items/0/value/name", "\"y\""), + ("/items/0/value/documentation/type", "\"Paragraph\""), + ("/items/0/value/documentation/value/type", "\"String\""), + ("/items/0/value/documentation/value/value", "\"x\"") + ] + + Spec.it s "works with documentation after" $ do + check + s + """ + x = 0 + -- ^ y + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/0/value/documentation/type", "\"Paragraph\""), + ("/items/0/value/documentation/value/type", "\"String\""), + ("/items/0/value/documentation/value/value", "\"y\"") + ] + + Spec.it s "works with signature" $ do + check + s + """ + x :: Int + x = 0 + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/0/value/signature", "\"Int\"") + ] + + Spec.it s "works with @since annotation" $ do + check + s + """ + -- | Docs + -- + -- @since 1.2.3 + x :: Int + x = 0 + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/0/value/since/version", "[1,2,3]") + ] + + Spec.it s "works with @since annotation with package" $ do + check + s + """ + -- | Docs + -- + -- @since base-4.16.0 + x :: Int + x = 0 + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/0/value/since/package", "\"base\""), + ("/items/0/value/since/version", "[4,16,0]") + ] + + Spec.it s "defaults to no @since" $ do + check + s + "x = 0" + [ ("/items/0/value/since", "") + ] + + Spec.describe s "operator" $ do + Spec.it s "works with a type signature" $ do + check + s + "(+++) :: Int -> Int -> Int" + [ ("/items/0/value/kind/type", "\"Operator\""), + ("/items/0/value/name", "\"+++\""), + ("/items/0/value/signature", "\"Int -> Int -> Int\"") + ] + + Spec.it s "works with a binding" $ do + check + s + "(+++) a b = a" + [ ("/items/0/value/kind/type", "\"Operator\""), + ("/items/0/value/name", "\"+++\"") + ] + + Spec.it s "works with both signature and binding" $ do + check + s + """ + (+++) :: Int -> Int -> Int + (+++) a b = a + """ + [ ("/items/0/value/kind/type", "\"Operator\""), + ("/items/0/value/name", "\"+++\""), + ("/items/0/value/signature", "\"Int -> Int -> Int\"") + ] + + Spec.it s "does not affect regular functions" $ do + check + s + "f :: Int -> Int" + [ ("/items/0/value/kind/type", "\"Function\""), + ("/items/0/value/name", "\"f\"") + ] + + Spec.it s "open type family" $ do + check s "{-# language TypeFamilies #-} type family A" [("/items/0/value/kind/type", "\"OpenTypeFamily\"")] + + Spec.it s "closed type family" $ do + check s "{-# language TypeFamilies #-} type family B where" [("/items/0/value/kind/type", "\"ClosedTypeFamily\"")] + + Spec.it s "closed type family with instance" $ do + check + s + "{-# language TypeFamilies #-} type family C a where C () = ()" + [ ("/items/0/value/kind/type", "\"ClosedTypeFamily\""), + ("/items/1/value/kind/type", "\"TypeFamilyInstance\""), + ("/items/1/value/parentKey", "0"), + ("/items/1/value/signature", "\"C () = ()\"") + ] + + Spec.it s "closed type family with multiple equations" $ do + check + s + "{-# language TypeFamilies, DataKinds #-} type family IsUnit a where IsUnit () = 'True; IsUnit _ = 'False" + [ ("/items/1/value/signature", "\"IsUnit () = 'True\""), + ("/items/2/value/signature", "\"IsUnit _ = 'False\"") + ] + + Spec.it s "data family" $ do + check s "{-# language TypeFamilies #-} data family F" [("/items/0/value/kind/type", "\"DataFamily\"")] + + Spec.it s "type synonym" $ do + check + s + "type G = ()" + [ ("/items/0/value/kind/type", "\"TypeSynonym\""), + ("/items/0/value/signature", "\"= ()\"") + ] + + Spec.it s "type synonym with type variable" $ do + check + s + "type G a = [a]" + [ ("/items/0/value/kind/type", "\"TypeSynonym\""), + ("/items/0/value/signature", "\"a = [a]\"") + ] + + Spec.it s "data" $ do + check s "data H" [("/items/0/value/kind/type", "\"DataType\"")] + + Spec.it s "data with type variable" $ do + check + s + "data T a" + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/0/value/name", "\"T\""), + ("/items/0/value/signature", "\"a\"") + ] + + Spec.it s "data with multiple type variables" $ do + check + s + "data E a b" + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/0/value/name", "\"E\""), + ("/items/0/value/signature", "\"a b\"") + ] + + Spec.it s "newtype with type variable" $ do + check + s + "newtype N a = MkN a" + [ ("/items/0/value/kind/type", "\"Newtype\""), + ("/items/0/value/name", "\"N\""), + ("/items/0/value/signature", "\"a\"") + ] + + Spec.it s "GADT with type variable" $ do + check + s + "data G a where MkG :: a -> G a" + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/0/value/name", "\"G\""), + ("/items/0/value/signature", "\"a\"") + ] + + Spec.it s "data constructor" $ do + check + s + "data I = J" + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/1/value/kind/type", "\"DataConstructor\"") + ] + + Spec.it s "infix data constructor" $ do + check + s + "data T = Int :+: Bool" + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/1/value/kind/type", "\"DataConstructor\""), + ("/items/1/value/name", "\":+:\""), + ("/items/1/value/signature", "\"Int -> Bool -> T\"") + ] + + Spec.it s "data constructor with doc" $ do + check + s + "data I2 = {- | x -} J2" + [ ("/items/1/value/kind/type", "\"DataConstructor\""), + ("/items/1/value/name", "\"J2\""), + ("/items/1/value/documentation/type", "\"Paragraph\""), + ("/items/1/value/documentation/value/type", "\"String\""), + ("/items/1/value/documentation/value/value", "\"x \""), + ("/items/1/value/signature", "\"I2\"") + ] + + Spec.it s "data constructor GADT" $ do + check + s + "data K where L :: K" + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/1/value/kind/type", "\"GADTConstructor\"") + ] + + Spec.it s "GADT with multiple constructor names" $ do + check + s + "data T where A, B :: Int -> T" + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/0/value/name", "\"T\""), + ("/items/1/value/kind/type", "\"GADTConstructor\""), + ("/items/1/value/name", "\"A\""), + ("/items/1/value/signature", "\"Int -> T\""), + ("/items/2/value/kind/type", "\"Argument\""), + ("/items/2/value/parentKey", "1"), + ("/items/3/value/kind/type", "\"GADTConstructor\""), + ("/items/3/value/name", "\"B\""), + ("/items/3/value/signature", "\"Int -> T\""), + ("/items/4/value/kind/type", "\"Argument\""), + ("/items/4/value/parentKey", "3") + ] + + Spec.it s "data constructor GADT with doc" $ do + check + s + """ + data K2 where + -- | d + L2 :: K2 + """ + [ ("/items/1/value/kind/type", "\"GADTConstructor\""), + ("/items/1/value/name", "\"L2\""), + ("/items/1/value/documentation/type", "\"Paragraph\""), + ("/items/1/value/documentation/value/type", "\"String\""), + ("/items/1/value/documentation/value/value", "\"d\""), + ("/items/1/value/signature", "\"K2\"") + ] + + Spec.it s "data constructor with arg doc" $ do + check + s + """ + data T2 + = C2 + Int -- ^ arg doc + Bool + """ + [ ("/items/1/value/name", "\"C2\""), + ("/items/1/value/signature", "\"Int -> Bool -> T2\"") + ] + + Spec.it s "data constructor GADT with arg doc" $ do + check + s + """ + data T3 where + C3 :: + Int -- ^ arg doc + -> T3 + """ + [ ("/items/1/value/name", "\"C3\""), + ("/items/1/value/signature", "\"Int -> T3\"") + ] + + Spec.it s "data constructor with record field doc" $ do + check + s + """ + data T4 = C4 + { -- | field doc + f4 :: Int + } + """ + [ ("/items/1/value/name", "\"C4\""), + ("/items/1/value/signature", "\"{ f4 :: Int } -> T4\"") + ] + + Spec.it s "data constructor with multiple record fields" $ do + check + s + "data T = C { f1 :: Int, f2 :: Bool }" + [ ("/items/1/value/signature", "\"{ f1 :: Int\\n, f2 :: Bool\\n} -> T\"") + ] + + Spec.it s "data constructor with existential" $ do + check + s + "{-# language ExistentialQuantification #-} data T5 = forall a. C5 a" + [ ("/items/1/value/name", "\"C5\""), + ("/items/1/value/signature", "\"forall a. a -> T5\"") + ] + + Spec.it s "data constructor with context" $ do + check + s + "{-# language ExistentialQuantification, FlexibleContexts #-} data T6 = forall a. Show a => C6 a" + [ ("/items/1/value/name", "\"C6\""), + ("/items/1/value/signature", "\"forall a. Show a => a -> T6\"") + ] + + Spec.it s "type data" $ do + check s "{-# language TypeData #-} type data L" [("/items/0/value/kind/type", "\"TypeData\"")] + + Spec.it s "type data constructor" $ do + check + s + "{-# language TypeData #-} type data M = N" + [ ("/items/0/value/kind/type", "\"TypeData\""), + ("/items/1/value/kind/type", "\"DataConstructor\"") + ] + + Spec.it s "type data constructor GADT" $ do + check + s + "{-# language TypeData #-} type data O where P :: O" + [ ("/items/0/value/kind/type", "\"TypeData\""), + ("/items/1/value/kind/type", "\"GADTConstructor\"") + ] + + Spec.it s "newtype" $ do + check + s + "newtype Q = R ()" + [ ("/items/0/value/kind/type", "\"Newtype\""), + ("/items/1/value/kind/type", "\"DataConstructor\"") + ] + + Spec.it s "record field" $ do + check + s + "data S = T { u :: () }" + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/1/value/kind/type", "\"DataConstructor\""), + ("/items/2/value/kind/type", "\"RecordField\""), + ("/items/2/value/signature", "\"()\"") + ] + + Spec.it s "record field with strict annotation" $ do + check + s + "data A = B { c :: !Int }" + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/1/value/kind/type", "\"DataConstructor\""), + ("/items/2/value/kind/type", "\"RecordField\""), + ("/items/2/value/name", "\"c\""), + ("/items/2/value/signature", "\"!Int\"") + ] + + Spec.it s "record field with lazy annotation" $ do + check + s + "data A = B { c :: ~Int }" + [ ("/items/2/value/kind/type", "\"RecordField\""), + ("/items/2/value/signature", "\"~Int\"") + ] + + Spec.it s "record field with UNPACK pragma" $ do + check + s + "data A = B { c :: {-# UNPACK #-} !Int }" + [ ("/items/2/value/kind/type", "\"RecordField\""), + ("/items/2/value/signature", "\"{-# UNPACK #-} !Int\"") + ] + + Spec.it s "record field GADT" $ do + check + s + "data V where W :: { x :: () } -> V" + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/1/value/kind/type", "\"GADTConstructor\""), + ("/items/2/value/kind/type", "\"RecordField\"") + ] + + Spec.it s "class" $ do + check s "class Y" [("/items/0/value/kind/type", "\"Class\"")] + + Spec.it s "class with type variable" $ do + check + s + "class C a" + [ ("/items/0/value/kind/type", "\"Class\""), + ("/items/0/value/name", "\"C a\"") + ] + + Spec.it s "class instance" $ do + check + s + """ + class Z a + instance Z () + """ + [ ("/items/1/value/kind/type", "\"ClassInstance\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "class instance parent is local type" $ do + check + s + """ + class C a + data T + instance C T + """ + [ ("/items/2/value/kind/type", "\"ClassInstance\""), + ("/items/2/value/name", "\"C T\""), + ("/items/2/value/parentKey", "1") + ] + + Spec.it s "class instance parent is local class when type is external" $ do + check + s + """ + class C a + instance C Int + """ + [ ("/items/1/value/kind/type", "\"ClassInstance\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "standalone deriving parent is local class when type is external" $ do + check + s + """ + {-# language StandaloneDeriving #-} + class C a where + deriving instance C Int + """ + [ ("/items/1/value/kind/type", "\"StandaloneDeriving\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "data instance" $ do + check + s + """ + {-# language TypeFamilies #-} + data family A a + data instance A () + """ + [ ("/items/1/value/kind/type", "\"DataFamilyInstance\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "data instance constructor" $ do + check + s + """ + {-# language TypeFamilies #-} + data family B a + data instance B () = C + """ + [ ("/items/1/value/kind/type", "\"DataFamilyInstance\""), + ("/items/1/value/parentKey", "0"), + ("/items/2/value/kind/type", "\"DataConstructor\""), + ("/items/2/value/parentKey", "1"), + ("/items/2/value/signature", "\"B ()\"") + ] + + Spec.it s "data instance constructor GADT" $ do + check + s + """ + {-# language TypeFamilies #-} + data family D + data instance D where E :: D + """ + [ ("/items/1/value/kind/type", "\"DataFamilyInstance\""), + ("/items/1/value/parentKey", "0"), + ("/items/2/value/kind/type", "\"GADTConstructor\""), + ("/items/2/value/parentKey", "1") + ] + + Spec.it s "newtype instance" $ do + check + s + """ + {-# language TypeFamilies #-} + data family F + newtype instance F = G () + """ + [ ("/items/1/value/kind/type", "\"DataFamilyInstance\""), + ("/items/1/value/parentKey", "0"), + ("/items/2/value/kind/type", "\"DataConstructor\""), + ("/items/2/value/parentKey", "1"), + ("/items/2/value/signature", "\"() -> F\"") + ] + + Spec.it s "newtype instance with type argument" $ do + check + s + """ + {-# language TypeFamilies #-} + data family Collection a + newtype instance Collection Int = CollectionInt [Int] + """ + [ ("/items/2/value/kind/type", "\"DataConstructor\""), + ("/items/2/value/signature", "\"[Int] -> Collection Int\"") + ] + + Spec.it s "newtype instance GADT" $ do + check + s + """ + {-# language TypeFamilies #-} + data family H + newtype instance H where I :: () -> H + """ + [ ("/items/1/value/kind/type", "\"DataFamilyInstance\""), + ("/items/1/value/parentKey", "0"), + ("/items/2/value/kind/type", "\"GADTConstructor\""), + ("/items/2/value/parentKey", "1") + ] + + Spec.it s "type instance" $ do + check + s + """ + {-# language TypeFamilies #-} + type family J + type instance J = () + """ + [ ("/items/1/value/kind/type", "\"TypeFamilyInstance\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "standalone deriving" $ do + check + s + """ + data L + deriving instance Show L + """ + [ ("/items/1/value/kind/type", "\"StandaloneDeriving\""), + ("/items/1/value/name", "\"Show L\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "standalone deriving stock" $ do + check + s + """ + {-# language DerivingStrategies #-} + data M + deriving stock instance Show M + """ + [ ("/items/1/value/kind/type", "\"StandaloneDeriving\""), + ("/items/1/value/name", "\"Show M\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "standalone deriving newtype" $ do + check + s + """ + {-# language DerivingStrategies #-} + newtype N = MkN Int + deriving newtype instance Show N + """ + [ ("/items/2/value/kind/type", "\"Argument\""), + ("/items/2/value/parentKey", "1"), + ("/items/3/value/kind/type", "\"StandaloneDeriving\""), + ("/items/3/value/name", "\"Show N\""), + ("/items/3/value/parentKey", "0") + ] + + Spec.it s "standalone deriving anyclass" $ do + check + s + """ + {-# language DerivingStrategies, DeriveAnyClass #-} + class O a + data W2 + deriving anyclass instance O W2 + """ + [ ("/items/2/value/kind/type", "\"StandaloneDeriving\""), + ("/items/2/value/name", "\"O W2\""), + ("/items/2/value/parentKey", "1"), + ("/items/2/value/signature", "\"anyclass\"") + ] + + Spec.it s "standalone deriving via" $ do + check + s + """ + {-# language DerivingStrategies, DerivingVia #-} + newtype P = MkP Int + deriving via Int instance Show P + """ + [ ("/items/2/value/kind/type", "\"Argument\""), + ("/items/2/value/parentKey", "1"), + ("/items/3/value/kind/type", "\"StandaloneDeriving\""), + ("/items/3/value/name", "\"Show P\""), + ("/items/3/value/parentKey", "0") + ] + + Spec.it s "data deriving" $ do + check + s + "data R deriving Show" + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/1/value/kind/type", "\"DerivedInstance\""), + ("/items/1/value/name", "\"Show\"") + ] + + Spec.it s "data deriving multiple" $ do + check + s + "data R2 deriving (Show, Eq)" + [ ("/items/1/value/kind/type", "\"DerivedInstance\""), + ("/items/1/value/name", "\"Show\""), + ("/items/2/value/kind/type", "\"DerivedInstance\""), + ("/items/2/value/name", "\"Eq\"") + ] + + Spec.it s "data deriving stock" $ do + check + s + """ + {-# LANGUAGE DerivingStrategies #-} + data R3 deriving stock Show + """ + [ ("/items/1/value/kind/type", "\"DerivedInstance\""), + ("/items/1/value/name", "\"Show\""), + ("/items/1/value/signature", "\"stock\"") + ] + + Spec.it s "data deriving via" $ do + check + s + """ + {-# LANGUAGE DerivingStrategies, DerivingVia #-} + data R5 deriving Show via () + """ + [ ("/items/1/value/kind/type", "\"DerivedInstance\""), + ("/items/1/value/name", "\"Show\""), + ("/items/1/value/signature", "\"via ()\"") + ] + + Spec.it s "data deriving no strategy" $ do + check + s + "data R6 deriving Show" + [ ("/items/1/value/kind/type", "\"DerivedInstance\""), + ("/items/1/value/name", "\"Show\""), + ("/items/1/value/signature", "\"derived\"") + ] + + Spec.it s "data GADT deriving" $ do + check s "data T where deriving Show" [] + + Spec.it s "newtype deriving" $ do + check s "newtype Z = A () deriving Show" [] + + Spec.it s "newtype GADT deriving" $ do + check s "newtype C where D :: () -> C deriving Show" [] + + Spec.it s "function" $ do + check s "e f = ()" [] + + Spec.it s "infix function" $ do + check s "g `h` i = ()" [] + + Spec.it s "infix operator" $ do + check s "j % k = ()" [] + + Spec.it s "prefix operator" $ do + check s "(&) = ()" [] + + Spec.it s "strict variable" $ do + check s "f !l = ()" [] + + Spec.it s "lazy pattern" $ do + check s "~m = ()" [] + + Spec.it s "as pattern" $ do + check s "n@o = ()" [] + + Spec.it s "parenthesized pattern" $ do + check s "(p) = ()" [] + + Spec.it s "bang pattern" $ do + check s "f (!q) = ()" [] + + Spec.it s "list pattern" $ do + check s "[r] = [()]" [] + + Spec.it s "tuple pattern" $ do + check s "(s, t) = ((), ())" [] + + Spec.it s "anonymous sum pattern" $ do + check + s + """ + {-# language UnboxedSums #-} + (# u | #) = (# () | #) + """ + [] + + Spec.it s "prefix constructor pattern" $ do + check s "Just v = Just ()" [] + + Spec.it s "record constructor pattern" $ do + check + s + """ + data W = W { wx :: () } + W { wx = y } = W () + """ + [] + + Spec.it s "punned record pattern" $ do + check + s + """ + {-# language NoFieldSelectors #-} + data Z = Z { a :: () } + Z { a } = Z () + """ + [] + + Spec.it s "wild card record pattern" $ do + check + s + """ + {-# language RecordWildCards, NoFieldSelectors #-} + data B = B { bf :: () } + B { .. } = B () + """ + [] + + Spec.it s "infix constructor pattern" $ do + check s "(c : d) = [()]" [] + + Spec.it s "view pattern" $ do + check s "{-# language ViewPatterns #-} (id -> f) = ()" [] + + Spec.it s "splice pattern" $ do + check + s + """ + {-# language TemplateHaskell #-} + import Language.Haskell.TH + $( varP (mkName "y") ) = () + """ + [] + + Spec.it s "literal pattern" $ do + check s "'h' = 'i'" [] + + Spec.it s "natural pattern" $ do + check s "0 = (0 :: Int)" [] + + Spec.it s "n+k pattern" $ do + check + s + """ + {-# language NPlusKPatterns #-} + (i + 1) = (0 :: Int) + """ + [] + + Spec.it s "signature pattern" $ do + check s "(j :: ()) = ()" [] + + Spec.it s "bidirectional pattern synonym" $ do + check + s + "{-# language PatternSynonyms #-} pattern L = ()" + [("/items/0/value/kind/type", "\"PatternSynonym\"")] + + Spec.it s "unidirectional pattern synonym" $ do + check + s + "{-# language PatternSynonyms #-} pattern M <- ()" + [("/items/0/value/kind/type", "\"PatternSynonym\"")] + + Spec.it s "explicitly bidirectional pattern synonym" $ do + check + s + "{-# language PatternSynonyms #-} pattern N <- () where N = ()" + [("/items/0/value/kind/type", "\"PatternSynonym\"")] + + Spec.it s "type signature" $ do + check + s + """ + o :: () + o = () + """ + [] + + Spec.it s "pattern type signature" $ do + check + s + """ + {-# language PatternSynonyms #-} + pattern P :: () + pattern P = () + """ + [("/items/0/value/kind/type", "\"PatternSynonym\"")] + + Spec.it s "pattern synonym signature without binding" $ do + check + s + """ + {-# language PatternSynonyms #-} + pattern Q :: a + """ + [("/items/0/value/kind/type", "\"PatternSynonym\"")] + + Spec.describe s "method signature" $ do + Spec.it s "works" $ do + check + s + """ + class C a where + m :: a + """ + [ ("/items/0/value/key", "0"), + ("/items/0/value/kind/type", "\"Class\""), + ("/items/1/value/key", "1"), + ("/items/1/value/kind/type", "\"ClassMethod\""), + ("/items/1/value/parentKey", "0"), + ("/items/1/value/signature", "\"a\"") + ] + + Spec.it s "works with documentation" $ do + check + s + """ + class C a where + -- | d + m :: a + """ + [ ("/items/1/value/documentation/type", "\"Paragraph\""), + ("/items/1/value/documentation/value/type", "\"String\""), + ("/items/1/value/documentation/value/value", "\"d\"") + ] + + Spec.it s "class method with default" $ do + check + s + """ + class C a where + m :: a -> a + m = id + """ + [ ("/items/1/value/kind/type", "\"ClassMethod\""), + ("/items/1/value/name", "\"m\""), + ("/items/1/value/signature", "\"a -> a\"") + ] + + Spec.it s "default method signature" $ do + check + s + """ + {-# language DefaultSignatures #-} + class S a where + t :: a + default t :: a + t = undefined + """ + [ ("/items/0/value/kind/type", "\"Class\""), + ("/items/0/value/name", "\"S a\""), + ("/items/0/value/key", "0"), + ("/items/1/value/kind/type", "\"ClassMethod\""), + ("/items/1/value/name", "\"t\""), + ("/items/1/value/parentKey", "0"), + ("/items/1/value/key", "1"), + ("/items/2/value/kind/type", "\"DefaultMethodSignature\""), + ("/items/2/value/name", "\"t\""), + ("/items/2/value/parentKey", "1"), + ("/items/2/value/signature", "\"a\"") + ] + + Spec.it s "default method signature with doc" $ do + check + s + """ + {-# language DefaultSignatures #-} + class S a where + t :: a + -- | the default + default t :: a + t = undefined + """ + [ ("/items/2/value/kind/type", "\"DefaultMethodSignature\""), + ("/items/2/value/name", "\"t\""), + ("/items/2/value/documentation/type", "\"Paragraph\""), + ("/items/2/value/documentation/value/type", "\"String\""), + ("/items/2/value/documentation/value/value", "\"the default\"") + ] + + Spec.it s "fixity has parent set" $ do + check + s + """ + (%) = id + infixl 0 % + """ + [ ("/items/0/value/name", "\"%\""), + ("/items/0/value/kind/type", "\"Operator\""), + ("/items/1/value/name", "\"%\""), + ("/items/1/value/kind/type", "\"FixitySignature\""), + ("/items/1/value/parentKey", "0"), + ("/items/1/value/documentation/value/value", "\"infixl 0\"") + ] + + Spec.it s "fixity preserves type signature" $ do + check + s + """ + infixl 5 % + (%) :: () -> () -> () + (%) _ _ = () + """ + [ ("/items/0/value/name", "\"%\""), + ("/items/0/value/kind/type", "\"FixitySignature\""), + ("/items/0/value/parentKey", "1"), + ("/items/0/value/documentation/value/value", "\"infixl 5\""), + ("/items/1/value/name", "\"%\""), + ("/items/1/value/kind/type", "\"Operator\""), + ("/items/1/value/signature", "\"() -> () -> ()\"") + ] + + Spec.it s "fixity infixr" $ do + check + s + """ + (%) = id + infixr 9 % + """ + [ ("/items/1/value/kind/type", "\"FixitySignature\""), + ("/items/1/value/documentation/value/value", "\"infixr 9\"") + ] + + Spec.it s "fixity infix" $ do + check + s + """ + (%) = id + infix 4 % + """ + [ ("/items/1/value/kind/type", "\"FixitySignature\""), + ("/items/1/value/documentation/value/value", "\"infix 4\"") + ] + + Spec.it s "orphaned fixity has no parent" $ do + check + s + """ + infixl 0 % + """ + [ ("/items/0/value/name", "\"%\""), + ("/items/0/value/kind/type", "\"FixitySignature\""), + ("/items/0/value/parentKey", ""), + ("/items/0/value/documentation/value/value", "\"infixl 0\"") + ] + + Spec.it s "fixity preserves user documentation" $ do + check + s + """ + (%) = id + -- | user doc + infixl 5 % + """ + [ ("/items/1/value/kind/type", "\"FixitySignature\""), + ("/items/1/value/documentation/type", "\"Append\""), + ("/items/1/value/documentation/value/0/type", "\"Paragraph\""), + ("/items/1/value/documentation/value/0/value/type", "\"String\""), + ("/items/1/value/documentation/value/0/value/value", "\"user doc\""), + ("/items/1/value/documentation/value/1/type", "\"Paragraph\""), + ("/items/1/value/documentation/value/1/value/type", "\"String\""), + ("/items/1/value/documentation/value/1/value/value", "\"infixl 5\"") + ] + + Spec.it s "fixity on data constructor has no parent" $ do + check + s + """ + data T = Int :+: Int + infixl 6 :+: + """ + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/0/value/key", "0"), + ("/items/1/value/kind/type", "\"DataConstructor\""), + ("/items/1/value/name", "\":+:\""), + ("/items/1/value/parentKey", "0"), + ("/items/1/value/key", "1"), + ("/items/2/value/kind/type", "\"Argument\""), + ("/items/2/value/parentKey", "1"), + ("/items/3/value/kind/type", "\"Argument\""), + ("/items/3/value/parentKey", "1"), + ("/items/4/value/kind/type", "\"FixitySignature\""), + ("/items/4/value/name", "\":+:\"") + ] + + Spec.it s "inline pragma has parent set" $ do + check + s + """ + i = () + {-# inline i #-} + """ + [ ("/items/0/value/name", "\"i\""), + ("/items/0/value/kind/type", "\"Function\""), + ("/items/1/value/name", "\"i\""), + ("/items/1/value/kind/type", "\"InlineSignature\""), + ("/items/1/value/signature", "\"INLINE\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "inline pragma with phase control" $ do + check + s + """ + j = () + {-# inline [1] j #-} + """ + [ ("/items/1/value/kind/type", "\"InlineSignature\""), + ("/items/1/value/signature", "\"INLINE [1]\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "inline pragma with inverted phase control" $ do + check + s + """ + k = () + {-# inline [~2] k #-} + """ + [ ("/items/1/value/kind/type", "\"InlineSignature\""), + ("/items/1/value/signature", "\"INLINE [~2]\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "inline pragma with conlike modifier" $ do + check + s + """ + k2 = () + {-# inline conlike k2 #-} + """ + [ ("/items/1/value/kind/type", "\"InlineSignature\""), + ("/items/1/value/signature", "\"INLINE CONLIKE\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "noinline pragma has parent set" $ do + check + s + """ + l = () + {-# noinline l #-} + """ + [ ("/items/0/value/name", "\"l\""), + ("/items/0/value/kind/type", "\"Function\""), + ("/items/1/value/name", "\"l\""), + ("/items/1/value/kind/type", "\"InlineSignature\""), + ("/items/1/value/signature", "\"NOINLINE\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "inlinable pragma" $ do + check + s + """ + m = () + {-# inlinable m #-} + """ + [ ("/items/1/value/kind/type", "\"InlineSignature\""), + ("/items/1/value/signature", "\"INLINABLE\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "opaque pragma" $ do + check + s + """ + n = () + {-# opaque n #-} + """ + [ ("/items/1/value/kind/type", "\"InlineSignature\""), + ("/items/1/value/signature", "\"OPAQUE\""), + ("/items/1/value/parentKey", "0") + ] + + Spec.it s "orphaned inline pragma has no parent" $ do + check + s + """ + {-# inline x #-} + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/0/value/kind/type", "\"InlineSignature\""), + ("/items/0/value/signature", "\"INLINE\""), + ("/items/0/value/parentKey", "") + ] + + Spec.it s "specialize pragma" $ do + check + s + """ + j2 :: a -> a + j2 = id + {-# specialize j2 :: () -> () #-} + """ + [ ("/items/0/value/kind/type", "\"Function\""), + ("/items/0/value/name", "\"j2\""), + ("/items/1/value/kind/type", "\"SpecialiseSignature\""), + ("/items/1/value/name", "\"j2\""), + ("/items/1/value/parentKey", "0"), + ("/items/1/value/signature", "\"() -> ()\"") + ] + + Spec.it s "orphaned specialize pragma" $ do + check + s + """ + {-# specialize j3 :: () -> () #-} + """ + [ ("/items/0/value/kind/type", "\"SpecialiseSignature\""), + ("/items/0/value/name", "\"j3\""), + ("/items/0/value/signature", "\"() -> ()\"") + ] + + Spec.it s "specialize instance pragma" $ do + check + s + """ + class K2 a where + k2m :: a + instance K2 () where + k2m = () + {-# specialize instance K2 () #-} + """ + [] + + Spec.it s "minimal pragma" $ do + check + s + """ + class L2 a where + l2m :: a + {-# minimal l2m #-} + """ + [ ("/items/0/value/kind/type", "\"Class\""), + ("/items/0/value/name", "\"L2 a\""), + ("/items/1/value/kind/type", "\"ClassMethod\""), + ("/items/1/value/parentKey", "0"), + ("/items/2/value/kind/type", "\"MinimalPragma\""), + ("/items/2/value/parentKey", "0"), + ("/items/2/value/signature", "\"l2m\"") + ] + + Spec.it s "set cost center pragma" $ do + check + s + """ + m = () + {-# scc m #-} + """ + [] + + Spec.it s "complete pragma" $ do + check + s + """ + {-# language PatternSynonyms #-} + pattern N2 :: () + pattern N2 = () + {-# complete N2 #-} + """ + [ ("/items/0/value/kind/type", "\"PatternSynonym\""), + ("/items/0/value/parentKey", "2"), + ("/items/1/value/kind/type", "\"CompletePragma\""), + ("/items/1/value/signature", "\"N2\"") + ] + + Spec.it s "complete pragma with multiple patterns" $ do + check + s + """ + {-# language PatternSynonyms #-} + pattern Nil :: [a] + pattern Nil = [] + pattern Cons :: a -> [a] -> [a] + pattern Cons x xs = x : xs + {-# complete Nil, Cons #-} + """ + [ ("/items/0/value/kind/type", "\"PatternSynonym\""), + ("/items/0/value/name", "\"Nil\""), + ("/items/0/value/parentKey", "4"), + ("/items/1/value/kind/type", "\"PatternSynonym\""), + ("/items/1/value/name", "\"Cons\""), + ("/items/1/value/parentKey", "4"), + ("/items/2/value/kind/type", "\"CompletePragma\""), + ("/items/2/value/signature", "\"Nil, Cons\"") + ] + + Spec.it s "standalone kind signature" $ do + check + s + """ + type O :: * + data O + """ + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/0/value/name", "\"O\""), + ("/items/0/value/signature", "\"*\"") + ] + + Spec.it s "standalone kind signature with data" $ do + check + s + """ + type X :: a -> a + data X a = X + """ + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/0/value/name", "\"X a\""), + ("/items/0/value/signature", "\"a -> a\""), + ("/items/1/value/kind/type", "\"DataConstructor\""), + ("/items/1/value/name", "\"X\""), + ("/items/1/value/parentKey", "1") + ] + + Spec.it s "standalone kind signature with newtype" $ do + check + s + """ + type Phantom :: * -> * + newtype Phantom a = MkPhantom () + """ + [ ("/items/0/value/kind/type", "\"Newtype\""), + ("/items/0/value/name", "\"Phantom a\""), + ("/items/0/value/signature", "\"* -> *\""), + ("/items/1/value/kind/type", "\"DataConstructor\""), + ("/items/1/value/name", "\"MkPhantom\""), + ("/items/1/value/parentKey", "1") + ] + + Spec.it s "standalone kind signature with type synonym" $ do + check + s + """ + type T :: * -> * + type T a = Maybe a + """ + [ ("/items/0/value/kind/type", "\"TypeSynonym\""), + ("/items/0/value/name", "\"T\""), + ("/items/0/value/signature", "\"* -> *\"") + ] + + Spec.it s "standalone kind signature with class" $ do + check + s + """ + {-# LANGUAGE ConstraintKinds #-} + type C :: * -> Constraint + class C a + """ + [ ("/items/0/value/kind/type", "\"Class\""), + ("/items/0/value/name", "\"C a\""), + ("/items/0/value/signature", "\"* -> Constraint\"") + ] + + Spec.it s "standalone kind signature with type family" $ do + check + s + """ + {-# LANGUAGE TypeFamilies #-} + type F :: * -> * + type family F a + """ + [ ("/items/0/value/kind/type", "\"OpenTypeFamily\""), + ("/items/0/value/name", "\"F\""), + ("/items/0/value/signature", "\"* -> *\"") + ] + + Spec.it s "default declaration" $ do + check s "default ()" [("/items", "[]")] + + Spec.it s "named default declaration" $ do + check + s + "{-# language NamedDefaults #-} default Num (Int, Double)" + [ ("/items/0/value/kind/type", "\"Default\""), + ("/items/0/value/name", "\"Num\""), + ("/items/0/value/signature", "\"Int, Double\"") + ] + + Spec.it s "foreign import" $ do + check + s + "{-# language ForeignFunctionInterface #-} foreign import ccall \"\" p :: ()" + [ ("/items/0/value/kind/type", "\"ForeignImport\""), + ("/items/0/value/name", "\"p\""), + ("/items/0/value/signature", "\"()\"") + ] + + Spec.it s "foreign export" $ do + check + s + "{-# language ForeignFunctionInterface #-} foreign export ccall q :: IO ()" + [ ("/items/0/value/kind/type", "\"ForeignExport\""), + ("/items/0/value/name", "\"q\""), + ("/items/0/value/signature", "\"IO ()\"") + ] + + Spec.it s "warning pragma has parent set" $ do + check + s + """ + x = () + {-# warning x "w" #-} + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/0/value/kind/type", "\"Function\""), + ("/items/1/value/name", "\"x\""), + ("/items/1/value/kind/type", "\"Warning\""), + ("/items/1/value/parentKey", "0"), + ("/items/1/value/documentation/value/value", "\"w\""), + ("/items/1/value/signature", "\"deprecations\"") + ] + + Spec.it s "warning pragma with multiple names" $ do + check + s + """ + x = () + y = () + {-# warning x, y "z" #-} + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/0/value/kind/type", "\"Function\""), + ("/items/1/value/name", "\"y\""), + ("/items/1/value/kind/type", "\"Function\""), + ("/items/2/value/name", "\"x\""), + ("/items/2/value/kind/type", "\"Warning\""), + ("/items/2/value/parentKey", "0"), + ("/items/2/value/documentation/value/value", "\"z\""), + ("/items/3/value/name", "\"y\""), + ("/items/3/value/kind/type", "\"Warning\""), + ("/items/3/value/parentKey", "1"), + ("/items/3/value/documentation/value/value", "\"z\"") + ] + + Spec.it s "orphaned warning pragma has no parent" $ do + check + s + """ + {-# warning x "w" #-} + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/0/value/kind/type", "\"Warning\""), + ("/items/0/value/parentKey", ""), + ("/items/0/value/documentation/value/value", "\"w\""), + ("/items/0/value/signature", "\"deprecations\"") + ] + + Spec.it s "warning pragma with custom category" $ do + check + s + """ + x = () + {-# warning in "c" x "w" #-} + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/0/value/kind/type", "\"Function\""), + ("/items/1/value/name", "\"x\""), + ("/items/1/value/kind/type", "\"Warning\""), + ("/items/1/value/parentKey", "0"), + ("/items/1/value/documentation/value/value", "\"w\""), + ("/items/1/value/signature", "\"c\"") + ] + + Spec.it s "value annotation" $ do + check + s + """ + x2 = () + {-# ann x2 () #-} + """ + [] + + Spec.it s "type annotation" $ do + check + s + """ + data X4 + {-# ann type X4 () #-} + """ + [] + + Spec.it s "module annotation" $ do + check s "{-# ann module () #-}" [] + + Spec.it s "rules pragma" $ do + check + s + """ + x4 :: a -> a + x4 = id + {-# rules "q" x4 = id #-} + """ + [ ("/items/0/value/kind/type", "\"Function\""), + ("/items/0/value/name", "\"x4\""), + ("/items/1/value/kind/type", "\"Rule\""), + ("/items/1/value/name", "\"q\""), + ("/items/1/value/signature", "\"x4 = id\"") + ] + + Spec.it s "splice declaration" $ do + check + s + """ + {-# language TemplateHaskell #-} + $( return [] ) + """ + [ ("/items/0/value/kind/type", "\"Splice\""), + ("/items/0/value/signature", "\"$(return [])\"") + ] + + Spec.it s "typed splice declaration" $ do + check + s + """ + {-# language TemplateHaskell #-} + $$(pure []) + """ + [ ("/items/0/value/kind/type", "\"Splice\""), + ("/items/0/value/signature", "\"$$(pure [])\"") + ] + + Spec.it s "quasi-quote declaration" $ do + check + s + """ + {-# language QuasiQuotes #-} + [x||] + """ + [ ("/items/0/value/kind/type", "\"Splice\""), + ("/items/0/value/signature", "\"[x||]\"") + ] + + Spec.it s "role annotation" $ do + check + s + """ + {-# language RoleAnnotations #-} + data R a = MkR + type role R nominal + """ + [ ("/items/0/value/name", "\"R\""), + ("/items/0/value/kind/type", "\"DataType\""), + ("/items/1/value/kind/type", "\"DataConstructor\""), + ("/items/2/value/name", "\"R\""), + ("/items/2/value/kind/type", "\"RoleAnnotation\""), + ("/items/2/value/parentKey", "0"), + ("/items/2/value/signature", "\"nominal\"") + ] + + Spec.it s "role annotation with multiple roles" $ do + check + s + """ + {-# language RoleAnnotations #-} + data T a b = MkT + type role T nominal phantom + """ + [ ("/items/0/value/name", "\"T\""), + ("/items/0/value/kind/type", "\"DataType\""), + ("/items/1/value/kind/type", "\"DataConstructor\""), + ("/items/2/value/name", "\"T\""), + ("/items/2/value/kind/type", "\"RoleAnnotation\""), + ("/items/2/value/parentKey", "0"), + ("/items/2/value/signature", "\"nominal phantom\"") + ] + + Spec.it s "role annotation with name collision data T = T" $ do + check + s + """ + {-# language RoleAnnotations #-} + data T = T + type role T nominal + """ + [ ("/items/0/value/name", "\"T\""), + ("/items/0/value/kind/type", "\"DataType\""), + ("/items/0/value/key", "0"), + ("/items/1/value/kind/type", "\"DataConstructor\""), + ("/items/1/value/name", "\"T\""), + ("/items/2/value/name", "\"T\""), + ("/items/2/value/kind/type", "\"RoleAnnotation\""), + ("/items/2/value/parentKey", "0"), + ("/items/2/value/signature", "\"nominal\"") + ] + + Spec.it s "orphaned role annotation has no parent" $ do + check + s + """ + {-# language RoleAnnotations #-} + type role R nominal + """ + [ ("/items/0/value/name", "\"R\""), + ("/items/0/value/kind/type", "\"RoleAnnotation\""), + ("/items/0/value/parentKey", ""), + ("/items/0/value/signature", "\"nominal\"") + ] + + Spec.describe s "arguments" $ do + Spec.it s "function with per-argument docs" $ do + check + s + """ + f :: a -- ^ i + -> a -- ^ o + """ + [ ("/items/0/value/kind/type", "\"Function\""), + ("/items/0/value/name", "\"f\""), + ("/items/0/value/signature", "\"a -> a\""), + ("/items/0/value/documentation/type", "\"Empty\""), + ("/items/1/value/kind/type", "\"Argument\""), + ("/items/1/value/parentKey", "0"), + ("/items/1/value/signature", "\"a\""), + ("/items/1/value/documentation/type", "\"Paragraph\""), + ("/items/1/value/documentation/value/value", "\"i\""), + ("/items/2/value/kind/type", "\"ReturnType\""), + ("/items/2/value/parentKey", "0"), + ("/items/2/value/signature", "\"a\""), + ("/items/2/value/documentation/type", "\"Paragraph\""), + ("/items/2/value/documentation/value/value", "\"o\"") + ] + + Spec.it s "function without arg docs" $ do + check + s + "f :: Int -> Bool -> String" + [ ("/items/0/value/kind/type", "\"Function\""), + ("/items/0/value/name", "\"f\""), + ("/items/0/value/signature", "\"Int -> Bool -> String\"") + ] + + Spec.it s "function with forall and constraints and arg docs" $ do + check + s + """ + {-# language ExplicitForAll #-} + f :: forall a. Show a => a -- ^ input + -> String -- ^ output + """ + [ ("/items/0/value/kind/type", "\"Function\""), + ("/items/0/value/name", "\"f\""), + ("/items/0/value/signature", "\"forall a. Show a =>\\n a -> String\""), + ("/items/1/value/kind/type", "\"Argument\""), + ("/items/1/value/parentKey", "0"), + ("/items/1/value/signature", "\"a\""), + ("/items/1/value/documentation/type", "\"Paragraph\""), + ("/items/1/value/documentation/value/value", "\"input\""), + ("/items/2/value/kind/type", "\"ReturnType\""), + ("/items/2/value/parentKey", "0"), + ("/items/2/value/signature", "\"String\""), + ("/items/2/value/documentation/type", "\"Paragraph\""), + ("/items/2/value/documentation/value/value", "\"output\"") + ] + + Spec.it s "function with return value doc only" $ do + check + s + """ + f :: a + -> a -- ^ lost + """ + [ ("/items/0/value/kind/type", "\"Function\""), + ("/items/0/value/name", "\"f\""), + ("/items/0/value/signature", "\"a -> a\""), + ("/items/0/value/documentation/type", "\"Empty\""), + ("/items/1/value/kind/type", "\"ReturnType\""), + ("/items/1/value/parentKey", "0"), + ("/items/1/value/signature", "\"a\""), + ("/items/1/value/documentation/type", "\"Paragraph\""), + ("/items/1/value/documentation/value/value", "\"lost\"") + ] + + Spec.it s "data constructor with arg doc has argument children" $ do + check + s + """ + data T2 + = C2 + Int -- ^ arg doc + Bool + """ + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/0/value/name", "\"T2\""), + ("/items/1/value/kind/type", "\"DataConstructor\""), + ("/items/1/value/name", "\"C2\""), + ("/items/1/value/signature", "\"Int -> Bool -> T2\""), + ("/items/2/value/kind/type", "\"Argument\""), + ("/items/2/value/parentKey", "1"), + ("/items/2/value/signature", "\"Int\""), + ("/items/2/value/documentation/type", "\"Paragraph\""), + ("/items/2/value/documentation/value/value", "\"arg doc\""), + ("/items/3/value/kind/type", "\"Argument\""), + ("/items/3/value/parentKey", "1"), + ("/items/3/value/signature", "\"Bool\""), + ("/items/3/value/documentation/type", "\"Empty\"") + ] + + Spec.it s "GADT constructor with arg doc has argument children" $ do + check + s + """ + data T3 where + C3 :: + Int -- ^ arg doc + -> T3 + """ + [ ("/items/0/value/kind/type", "\"DataType\""), + ("/items/0/value/name", "\"T3\""), + ("/items/1/value/kind/type", "\"GADTConstructor\""), + ("/items/1/value/name", "\"C3\""), + ("/items/1/value/signature", "\"Int -> T3\""), + ("/items/2/value/kind/type", "\"Argument\""), + ("/items/2/value/parentKey", "1"), + ("/items/2/value/signature", "\"Int\""), + ("/items/2/value/documentation/type", "\"Paragraph\""), + ("/items/2/value/documentation/value/value", "\"arg doc\"") + ] + + Spec.it s "class method with arg docs has argument children" $ do + check + s + """ + class C a where + m :: a -- ^ input + -> Bool -- ^ result + -> String + """ + [ ("/items/0/value/kind/type", "\"Class\""), + ("/items/0/value/name", "\"C a\""), + ("/items/1/value/kind/type", "\"ClassMethod\""), + ("/items/1/value/name", "\"m\""), + ("/items/1/value/signature", "\"a -> Bool -> String\""), + ("/items/2/value/kind/type", "\"Argument\""), + ("/items/2/value/parentKey", "1"), + ("/items/2/value/signature", "\"a\""), + ("/items/2/value/documentation/type", "\"Paragraph\""), + ("/items/2/value/documentation/value/value", "\"input\""), + ("/items/3/value/kind/type", "\"Argument\""), + ("/items/3/value/parentKey", "1"), + ("/items/3/value/signature", "\"Bool\""), + ("/items/3/value/documentation/type", "\"Paragraph\""), + ("/items/3/value/documentation/value/value", "\"result\"") + ] + + Spec.describe s "pragma combinations" $ do + Spec.it s "inline and specialize on same function" $ do + check + s + """ + f :: a -> a + f = id + {-# inline f #-} + {-# specialize f :: () -> () #-} + """ + [ ("/items/0/value/name", "\"f\""), + ("/items/0/value/kind/type", "\"Function\""), + ("/items/0/value/key", "0"), + ("/items/1/value/name", "\"f\""), + ("/items/1/value/kind/type", "\"InlineSignature\""), + ("/items/1/value/parentKey", "0"), + ("/items/2/value/name", "\"f\""), + ("/items/2/value/kind/type", "\"SpecialiseSignature\""), + ("/items/2/value/parentKey", "0") + ] + + Spec.it s "warning and inline on same function" $ do + check + s + """ + g :: a -> a + g = id + {-# warning g "deprecated" #-} + {-# inline g #-} + """ + [ ("/items/0/value/name", "\"g\""), + ("/items/0/value/kind/type", "\"Function\""), + ("/items/0/value/key", "0"), + ("/items/1/value/name", "\"g\""), + ("/items/1/value/kind/type", "\"Warning\""), + ("/items/1/value/parentKey", "0"), + ("/items/2/value/name", "\"g\""), + ("/items/2/value/kind/type", "\"InlineSignature\""), + ("/items/2/value/parentKey", "0") + ] + + Spec.it s "multiple specialize pragmas on one function" $ do + check + s + """ + h :: a -> a + h = id + {-# specialize h :: () -> () #-} + {-# specialize h :: Int -> Int #-} + """ + [ ("/items/0/value/name", "\"h\""), + ("/items/0/value/kind/type", "\"Function\""), + ("/items/1/value/name", "\"h\""), + ("/items/1/value/kind/type", "\"SpecialiseSignature\""), + ("/items/1/value/parentKey", "0"), + ("/items/1/value/signature", "\"() -> ()\""), + ("/items/2/value/name", "\"h\""), + ("/items/2/value/kind/type", "\"SpecialiseSignature\""), + ("/items/2/value/parentKey", "0"), + ("/items/2/value/signature", "\"Int -> Int\"") + ] + + Spec.it s "fixity and inline and specialize on same operator" $ do + check + s + """ + (%) :: a -> a -> a + (%) = const + infixl 5 % + {-# inline (%) #-} + {-# specialize (%) :: () -> () -> () #-} + """ + [ ("/items/0/value/name", "\"%\""), + ("/items/0/value/kind/type", "\"Operator\""), + ("/items/0/value/key", "0"), + ("/items/1/value/name", "\"%\""), + ("/items/1/value/kind/type", "\"FixitySignature\""), + ("/items/1/value/parentKey", "0"), + ("/items/2/value/name", "\"%\""), + ("/items/2/value/kind/type", "\"InlineSignature\""), + ("/items/2/value/parentKey", "0"), + ("/items/3/value/name", "\"%\""), + ("/items/3/value/kind/type", "\"SpecialiseSignature\""), + ("/items/3/value/parentKey", "0") + ] + + Spec.describe s "html" $ do + Spec.it s "generates html without error" $ do + checkHtml + s + [] + """ + -- | Module documentation. + module M + ( -- * Section + x + ) where + + import Data.List + + -- | A function. + x :: Int + x = 0 + + -- | A data type. + data T = C { field :: Bool } + """ + + Spec.describe s "cpp" $ do + Spec.it s "works with simple ifdef" $ do + check + s + """ + {-# language CPP #-} + #define MY_FLAG + #ifdef MY_FLAG + module M where + #endif + """ + [("/name/value", "\"M\"")] + + Spec.it s "works with undefined macro" $ do + check + s + """ + {-# language CPP #-} + #ifdef UNDEFINED + module M where + #endif + """ + [("/name", "")] + + Spec.it s "preserves line numbers" $ do + check + s + """ + {-# language CPP #-} + #ifdef FOO + import Fake + #endif + x = 0 + """ + [("/items/0/location/line", "5")] + + Spec.it s "works with elif" $ do + check + s + """ + {-# language CPP #-} + #if 0 + module A where + #elif 1 + module B where + #endif + """ + [("/name/value", "\"B\"")] + + Spec.it s "skips elif after match" $ do + check + s + """ + {-# language CPP #-} + #if 1 + module A where + #elif 1 + module B where + #endif + """ + [("/name/value", "\"A\"")] + + Spec.it s "works with else after active ifdef" $ do + check + s + """ + {-# language CPP #-} + #define X + #ifdef X + module A where + #else + module B where + #endif + """ + [("/name/value", "\"A\"")] + + Spec.it s "uses else branch for undefined macros" $ do + check + s + """ + {-# language CPP #-} + #ifdef __GLASGOW_HASKELL__ + module GHC where + #else + module Other where + #endif + """ + [("/name/value", "\"Other\"")] + + Spec.describe s "literate" $ do + Spec.describe s "bird" $ do + Spec.it s "works" $ do + checkWith + s + ["--literate"] + "> x = 0" + [("/items/0/value/name", "\"x\"")] + + Spec.it s "preserves line numbers" $ do + checkWith + s + ["--literate"] + """ + comment + + > x = 0 + """ + [("/items/0/location/line", "3")] + + Spec.describe s "latex" $ do + Spec.it s "works" $ do + checkWith + s + ["--literate"] + """ + \\begin{code} + x = 0 + \\end{code} + """ + [("/items/0/value/name", "\"x\"")] + + Spec.it s "preserves line numbers" $ do + checkWith + s + ["--literate"] + """ + \\begin{code} + x = 0 + \\end{code} + """ + [("/items/0/location/line", "2")] + + Spec.it s "works with bird then latex" $ do + checkWith + s + ["--literate"] + """ + > x = 0 + + \\begin{code} + y = 1 + \\end{code} + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/1/value/name", "\"y\"") + ] + + Spec.it s "works with latex then bird" $ do + checkWith + s + ["--literate"] + """ + \\begin{code} + x = 0 + \\end{code} + + > y = 1 + """ + [ ("/items/0/value/name", "\"x\""), + ("/items/1/value/name", "\"y\"") + ] + + Spec.describe s "signature" $ do + Spec.it s "works with a simple signature" $ do + checkWith + s + ["--signature"] + "signature Foo where" + [ ("/name/value", "\"Foo\""), + ("/signature", "true") + ] + + Spec.it s "works with a type signature" $ do + checkWith + s + ["--signature"] + """ + signature Foo where + foo :: Int + """ + [ ("/name/value", "\"Foo\""), + ("/signature", "true"), + ("/items/0/value/kind/type", "\"Function\""), + ("/items/0/value/name", "\"foo\""), + ("/items/0/value/signature", "\"Int\"") + ] + + Spec.it s "works with an abstract data type" $ do + checkWith + s + ["--signature"] + """ + signature Foo where + data T + """ + [ ("/signature", "true"), + ("/items/0/value/kind/type", "\"DataType\""), + ("/items/0/value/name", "\"T\"") + ] + + Spec.it s "works with a class" $ do + checkWith + s + ["--signature"] + """ + signature Foo where + class C a where + bar :: a -> Bool + """ + [ ("/signature", "true"), + ("/items/0/value/kind/type", "\"Class\""), + ("/items/0/value/name", "\"C a\""), + ("/items/1/value/kind/type", "\"ClassMethod\""), + ("/items/1/value/name", "\"bar\"") + ] + + Spec.it s "works with documentation" $ do + checkWith + s + ["--signature"] + """ + -- | Module doc + signature Foo where + """ + [ ("/signature", "true"), + ("/documentation/type", "\"Paragraph\""), + ("/documentation/value/type", "\"String\""), + ("/documentation/value/value", "\"Module doc\"") + ] + + Spec.describe s "argument names" $ do + Spec.it s "captures argument name from binding" $ do + check + s + """ + f :: a {- ^ doc -} -> a + f x = x + """ + [ ("/items/0/value/kind/type", "\"Function\""), + ("/items/0/value/name", "\"f\""), + ("/items/1/value/kind/type", "\"Argument\""), + ("/items/1/value/name", "\"x\"") + ] + + Spec.it s "picks first variable name across equations" $ do + check + s + """ + or :: Bool {- ^ doc -} -> Bool -> Bool + or True _ = True + or _ x = x + """ + [ ("/items/0/value/name", "\"or\""), + ("/items/1/value/kind/type", "\"Argument\""), + ("/items/1/value/name", ""), + ("/items/2/value/kind/type", "\"Argument\""), + ("/items/2/value/name", "\"x\"") + ] + + Spec.it s "handles all-wildcard arguments" $ do + check + s + """ + f :: a {- ^ doc -} -> a + f _ = undefined + """ + [ ("/items/1/value/kind/type", "\"Argument\""), + ("/items/1/value/name", "") + ] + + Spec.it s "handles signature without binding" $ do + check + s + """ + f :: a {- ^ doc -} -> a + """ + [ ("/items/1/value/kind/type", "\"Argument\""), + ("/items/1/value/name", "") + ] + + Spec.describe s "visibility" $ do + Spec.it s "marks exported items as Exported" $ do + check + s + """ + module M ( x ) where + x = () + y = () + """ + [ ("/items/0/value/visibility/type", "\"Exported\""), + ("/items/1/value/visibility/type", "\"Unexported\"") + ] + + Spec.it s "marks all items as Exported when no export list" $ do + check + s + """ + x = () + y = () + """ + [ ("/items/0/value/visibility/type", "\"Exported\""), + ("/items/1/value/visibility/type", "\"Exported\"") + ] + + Spec.it s "marks class instances as Implicit" $ do + check + s + """ + module M ( MyClass ) where + class MyClass a + instance MyClass Int + """ + [ ("/items/0/value/visibility/type", "\"Exported\""), + ("/items/1/value/visibility/type", "\"Implicit\"") + ] + + Spec.it s "marks rules as Implicit" $ do + check + s + """ + module M ( f ) where + f x = x + {-# RULES "f/id" f = id #-} + """ + [ ("/items/0/value/visibility/type", "\"Exported\""), + ("/items/1/value/visibility/type", "\"Implicit\"") + ] + + Spec.it s "marks constructors as Unexported when type has no subordinates" $ do + check + s + """ + module M ( T ) where + data T = C1 | C2 + """ + [ ("/items/0/value/visibility/type", "\"Exported\""), + ("/items/1/value/visibility/type", "\"Unexported\""), + ("/items/2/value/visibility/type", "\"Unexported\"") + ] + + Spec.it s "marks all constructors as Exported with wildcard subordinates" $ do + check + s + """ + module M ( T(..) ) where + data T = C1 | C2 + """ + [ ("/items/0/value/visibility/type", "\"Exported\""), + ("/items/1/value/visibility/type", "\"Exported\""), + ("/items/2/value/visibility/type", "\"Exported\"") + ] + + Spec.it s "marks only listed constructors as Exported with explicit subordinates" $ do + check + s + """ + module M ( T(C1) ) where + data T = C1 | C2 + """ + [ ("/items/0/value/visibility/type", "\"Exported\""), + ("/items/1/value/visibility/type", "\"Exported\""), + ("/items/2/value/visibility/type", "\"Unexported\"") + ] + + Spec.it s "marks methods as Unexported when class has no subordinates" $ do + check + s + """ + module M ( MyClass ) where + class MyClass a where + myMethod :: a -> a + """ + [ ("/items/0/value/visibility/type", "\"Exported\""), + ("/items/1/value/visibility/type", "\"Unexported\"") + ] + + Spec.it s "marks all methods as Exported with wildcard subordinates" $ do + check + s + """ + module M ( MyClass(..) ) where + class MyClass a where + myMethod :: a -> a + """ + [ ("/items/0/value/visibility/type", "\"Exported\""), + ("/items/1/value/visibility/type", "\"Exported\"") + ] + + Spec.it s "pattern synonyms with COMPLETE pragma are not duplicated in exports" $ do + check + s + """ + {-# language PatternSynonyms #-} + module M (Nil, Cons) where + pattern Nil = [] + pattern Cons x xs = x : xs + {-# complete Nil, Cons #-} + """ + [ ("/items/0/value/kind/type", "\"PatternSynonym\""), + ("/items/0/value/name", "\"Nil\""), + ("/items/1/value/kind/type", "\"PatternSynonym\""), + ("/items/1/value/name", "\"Cons\""), + ("/items/2/value/kind/type", "\"CompletePragma\"") + ] + +-- | Run the pipeline on the given Haskell source and assert JSON pointer +-- expectations. Each @(pointer, json)@ pair asserts that the value at +-- @pointer@ equals the parsed @json@. Use an empty string for @json@ +-- (or the 'checkAbsent' wrapper) to assert that the pointer does not +-- resolve to any value. +check :: (Stack.HasCallStack, Monad m) => Spec.Spec m n -> String -> [(String, String)] -> m () +check s = checkWith s [] + +-- | Assert that a JSON pointer path does not resolve to any value. +-- Equivalent to @(pointer, "")@ in a 'check' assertion list. +checkAbsent :: String -> (String, String) +checkAbsent pointer = (pointer, "") + +checkWith :: (Stack.HasCallStack, Monad m) => Spec.Spec m n -> [String] -> String -> [(String, String)] -> m () +checkWith s arguments input assertions = do + result <- + either (Spec.assertFailure s . Exception.displayException) pure + . Main.mainWith "scrod-test-suite" arguments + $ pure input + module_ <- either (Spec.assertFailure s) pure result + json <- + maybe (Spec.assertFailure s "impossible") pure + . Parsec.parseString Json.decode + $ Builder.toString module_ + + Monad.forM_ assertions $ \(p, j) -> do + pointer <- maybe (Spec.assertFailure s "invalid pointer") pure $ Parsec.parseString Pointer.decode p + expected <- + if null j + then pure Nothing + else maybe (Spec.assertFailure s "invalid json") (pure . Just) $ Parsec.parseString Json.decode j + let actual = Pointer.evaluate pointer json + Monad.unless (actual == expected) + . Spec.assertFailure s + $ List.intercalate + "\n" + [ "at " <> p, + "expected " <> maybe "(nothing)" (Builder.toString . Json.encode) expected, + " but got " <> maybe "(nothing)" (Builder.toString . Json.encode) actual + ] + +checkHtml :: (Stack.HasCallStack, Monad m) => Spec.Spec m n -> [String] -> String -> m () +checkHtml s arguments input = do + result <- + either (Spec.assertFailure s . Exception.displayException) pure + . Main.mainWith "scrod-test-suite" ("--format" : "html" : arguments) + $ pure input + output <- either (Spec.assertFailure s) pure result + Monad.when (null $ Builder.toString output) $ + Spec.assertFailure s "expected non-empty HTML output" diff --git a/source/library/Scrod/Unlit.hs b/source/library/Scrod/Unlit.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Unlit.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | Convert literate Haskell source to plain Haskell. +-- +-- Supports both bird-track (@>@) and LaTeX (@\\begin{code}@ ... @\\end{code}@) +-- styles. Non-code lines are replaced with blank lines to preserve line +-- numbering in the output. +module Scrod.Unlit where + +import qualified Control.Monad as Monad +import qualified Data.Char as Char +import qualified Scrod.Spec as Spec + +-- | Strip literate markup from the input, returning plain Haskell source. +-- Returns 'Left' with an error message if the input is malformed (e.g., +-- unterminated LaTeX blocks, bird tracks adjacent to comments, or no code +-- at all). +unlit :: String -> Either String String +unlit input = + let go lines_ prev inLatex hasCode acc = case lines_ of + [] -> + if inLatex + then Left "unterminated \\begin{code}" + else Right (hasCode, acc) + line : rest -> + let cls = classifyLine line + in case inLatex of + True -> case cls of + EndCode -> go rest EndCode False hasCode ("" : acc) + BeginCode -> Left "nested \\begin{code}" + _ -> go rest cls True True (line : acc) + False -> case cls of + Blank -> go rest Blank False hasCode ("" : acc) + Bird -> do + Monad.when (prev == Comment) $ Left "bird track adjacent to comment" + go rest Bird False True ((' ' : drop 1 line) : acc) + BeginCode -> go rest BeginCode True True ("" : acc) + EndCode -> Left "unexpected \\end{code}" + Comment -> do + Monad.when (prev == Bird) $ Left "bird track adjacent to comment" + go rest Comment False hasCode ("" : acc) + in do + let ls = lines input + (hasCode, outputLines) <- go ls Blank False False [] + Monad.unless hasCode $ Left "no code in literate file" + Right $ unlines (reverse outputLines) + +data LineClass + = Blank + | Bird + | BeginCode + | EndCode + | Comment + deriving (Eq, Ord, Show) + +classifyLine :: String -> LineClass +classifyLine line + | all Char.isSpace line = Blank + | '>' : _ <- line = Bird + | matchesDelimiter "\\begin{code}" line = BeginCode + | matchesDelimiter "\\end{code}" line = EndCode + | otherwise = Comment + +-- | Check whether a line starts with the given LaTeX delimiter, ignoring +-- leading whitespace and case. +matchesDelimiter :: String -> String -> Bool +matchesDelimiter delim line = + let stripped = dropWhile Char.isSpace line + (prefix, _) = splitAt (length delim) stripped + in fmap Char.toLower prefix == delim + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'unlit $ do + Spec.it s "fails with no code" $ do + Spec.assertEq s (unlit "") $ Left "no code in literate file" + + Spec.it s "fails with only comments" $ do + Spec.assertEq s (unlit "hello") $ Left "no code in literate file" + + Spec.it s "works with empty latex block" $ do + Spec.assertEq s (unlit "\\begin{code}\n\\end{code}") $ Right "\n\n" + + Spec.it s "works with bird style" $ do + Spec.assertEq s (unlit "> x = 0") $ Right " x = 0\n" + + Spec.it s "works with bird style without space" $ do + Spec.assertEq s (unlit ">x = 0") $ Right " x = 0\n" + + Spec.it s "works with latex style" $ do + Spec.assertEq s (unlit "\\begin{code}\nx = 0\n\\end{code}") $ Right "\nx = 0\n\n" + + Spec.describe s "bird adjacency" $ do + Spec.it s "fails with comment before bird" $ do + Spec.assertEq s (unlit "before\n> x = 0") $ Left "bird track adjacent to comment" + + Spec.it s "works with blank before bird" $ do + Spec.assertEq s (unlit "before\n\n> x = 0") $ Right "\n\n x = 0\n" + + Spec.it s "fails with comment after bird" $ do + Spec.assertEq s (unlit "> x = 0\nafter") $ Left "bird track adjacent to comment" + + Spec.it s "works with blank after bird" $ do + Spec.assertEq s (unlit "> x = 0\n\nafter") $ Right " x = 0\n\n\n" + + Spec.describe s "latex blocks" $ do + Spec.it s "fails with unclosed begin" $ do + Spec.assertEq s (unlit "\\begin{code}") $ Left "unterminated \\begin{code}" + + Spec.it s "fails with extra end" $ do + Spec.assertEq s (unlit "\\begin{code}\n\\end{code}\n\\end{code}") $ Left "unexpected \\end{code}" + + Spec.it s "fails with end without begin" $ do + Spec.assertEq s (unlit "\\end{code}") $ Left "unexpected \\end{code}" + + Spec.it s "fails with nested begin" $ do + Spec.assertEq s (unlit "\\begin{code}\n\\begin{code}") $ Left "nested \\begin{code}" + + Spec.describe s "latex indentation" $ do + Spec.it s "works with indented delimiters" $ do + Spec.assertEq s (unlit " \\begin{code}\nx = 0\n \\end{code}") $ Right "\nx = 0\n\n" + + Spec.it s "fails with spaces in delimiter" $ do + Spec.assertEq s (unlit " \\ begin { code }\nx = 0\n \\end{code}") $ Left "unexpected \\end{code}" + + Spec.describe s "latex trailing text" $ do + Spec.it s "works with text after delimiters" $ do + Spec.assertEq s (unlit "\\begin{code} foo\nx = 0\n\\end{code} bar") $ Right "\nx = 0\n\n" + + Spec.it s "fails with text before delimiter" $ do + Spec.assertEq s (unlit "foo \\begin{code}\nx = 0\nbar \\end{code}") $ Left "no code in literate file" + + Spec.it s "is case insensitive for latex" $ do + Spec.assertEq s (unlit "\\BEGIN{CODE}\nx = 0\n\\END{CODE}") $ Right "\nx = 0\n\n" + + Spec.it s "converts comment lines to blank lines" $ do + Spec.assertEq s (unlit "comment\n\n> x = 0\n\ncomment") $ Right "\n\n x = 0\n\n\n" diff --git a/source/library/Scrod/Xml/Attribute.hs b/source/library/Scrod/Xml/Attribute.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Xml/Attribute.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Xml.Attribute where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Semigroup as Semigroup +import qualified Scrod.Spec as Spec +import qualified Scrod.Xml.Name as Name +import qualified Scrod.Xml.Text as XmlText + +-- | XML Attribute +-- name="value" or name='value' +-- Can have spaces around equal sign +data Attribute = MkAttribute + { name :: Name.Name, + value :: Text.Text + } + deriving (Eq, Ord, Show) + +encode :: Attribute -> Builder.Builder +encode attr = + Name.encode (name attr) + <> Builder.charUtf8 '=' + <> Semigroup.around (Builder.charUtf8 '"') (Builder.charUtf8 '"') (XmlText.encodeAttr $ value attr) + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'encode $ do + Spec.it s "encodes simple attribute" $ do + Spec.assertEq s (Builder.toString . encode $ MkAttribute (Name.MkName $ Text.pack "foo") (Text.pack "bar")) "foo=\"bar\"" + + Spec.it s "encodes empty value" $ do + Spec.assertEq s (Builder.toString . encode $ MkAttribute (Name.MkName $ Text.pack "foo") (Text.pack "")) "foo=\"\"" + + Spec.it s "escapes ampersand in value" $ do + Spec.assertEq s (Builder.toString . encode $ MkAttribute (Name.MkName $ Text.pack "foo") (Text.pack "a & b")) "foo=\"a & b\"" + + Spec.it s "escapes quote in value" $ do + Spec.assertEq s (Builder.toString . encode $ MkAttribute (Name.MkName $ Text.pack "foo") (Text.pack "a \" b")) "foo=\"a " b\"" + + Spec.it s "escapes less-than in value" $ do + Spec.assertEq s (Builder.toString . encode $ MkAttribute (Name.MkName $ Text.pack "foo") (Text.pack "a < b")) "foo=\"a < b\"" diff --git a/source/library/Scrod/Xml/Comment.hs b/source/library/Scrod/Xml/Comment.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Xml/Comment.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Xml.Comment where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Semigroup as Semigroup +import qualified Scrod.Spec as Spec + +-- | XML Comment like @\@. Cannot contain @-->@. +newtype Comment = MkComment + { unwrap :: Text.Text + } + deriving (Eq, Ord, Show) + +encode :: Comment -> Builder.Builder +encode = + Semigroup.around (Builder.stringUtf8 "") + . Builder.stringUtf8 + . Text.unpack + . unwrap + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'encode $ do + Spec.it s "encodes empty comment" $ do + Spec.assertEq s (Builder.toString . encode . MkComment $ Text.pack "") "" + + Spec.it s "encodes comment with text" $ do + Spec.assertEq s (Builder.toString . encode . MkComment $ Text.pack " hello ") "" + + Spec.it s "encodes comment with special chars" $ do + Spec.assertEq s (Builder.toString . encode . MkComment $ Text.pack " & ") "" diff --git a/source/library/Scrod/Xml/Content.hs b/source/library/Scrod/Xml/Content.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Xml/Content.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Xml.Content where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Spec as Spec +import qualified Scrod.Xml.Comment as Comment +import qualified Scrod.Xml.Text as XmlText + +-- | XML Content (what can appear inside an element). Parameterized by element +-- type to avoid circular dependencies. "Scrod.Xml.Element" uses @'Content' +-- Element@. +data Content a + = Comment Comment.Comment + | Element a + | Raw Text.Text + | Text Text.Text + deriving (Eq, Ord, Show) + +-- | Returns 'True' for content nodes that render as the empty string (empty +-- 'Text' or 'Raw' nodes). Useful for checking whether a list of content is +-- effectively empty. +isEmpty :: Content a -> Bool +isEmpty c = case c of + Text t -> Text.null t + Raw r -> Text.null r + _ -> False + +-- | Encode content, parameterized by element encoder. +encode :: (a -> Builder.Builder) -> Content a -> Builder.Builder +encode encodeElement c = case c of + Comment comment -> Comment.encode comment + Element element -> encodeElement element + Raw raw -> foldMap Builder.charUtf8 (Text.unpack raw) + Text text -> XmlText.encode text + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'isEmpty $ do + Spec.it s "returns True for empty Text" $ do + Spec.assertEq s (isEmpty $ Text Text.empty) True + + Spec.it s "returns False for non-empty Text" $ do + Spec.assertEq s (isEmpty . Text $ Text.pack "hello") False + + Spec.it s "returns True for empty Raw" $ do + Spec.assertEq s (isEmpty $ Raw Text.empty) True + + Spec.it s "returns False for non-empty Raw" $ do + Spec.assertEq s (isEmpty . Raw $ Text.pack "hello") False + + Spec.it s "returns False for Element" $ do + Spec.assertEq s (isEmpty $ Element "test") False + + Spec.it s "returns False for Comment" $ do + Spec.assertEq s (isEmpty $ Comment (Comment.MkComment $ Text.pack " test ")) False + + Spec.named s 'encode $ do + let encodeElement :: String -> Builder.Builder + encodeElement _ = Builder.stringUtf8 "" + + Spec.it s "encodes comment" $ do + Spec.assertEq s (Builder.toString . encode encodeElement $ Comment (Comment.MkComment $ Text.pack " hello ")) "" + + Spec.it s "encodes element" $ do + Spec.assertEq s (Builder.toString . encode encodeElement $ Element "test") "" + + Spec.it s "encodes text" $ do + Spec.assertEq s (Builder.toString . encode encodeElement $ Text (Text.pack "hello")) "hello" + + Spec.it s "escapes text" $ do + Spec.assertEq s (Builder.toString . encode encodeElement $ Text (Text.pack "a & b")) "a & b" + + Spec.it s "encodes raw" $ do + Spec.assertEq s (Builder.toString . encode encodeElement $ Raw (Text.pack "hello")) "hello" + + Spec.it s "does not escape raw" $ do + Spec.assertEq s (Builder.toString . encode encodeElement $ Raw (Text.pack "a > b & c < d")) "a > b & c < d" diff --git a/source/library/Scrod/Xml/Declaration.hs b/source/library/Scrod/Xml/Declaration.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Xml/Declaration.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Xml.Declaration where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Semigroup as Semigroup +import qualified Scrod.Spec as Spec +import qualified Scrod.Xml.Name as Name + +-- | XML Declaration (for DOCTYPE and similar), like @\@. Similar +-- to 'Instruction' but different delimiters. Cannot contain @>@. +data Declaration = MkDeclaration + { name :: Name.Name, + value :: Text.Text + } + deriving (Eq, Ord, Show) + +encode :: Declaration -> Builder.Builder +encode decl = + Semigroup.around (Builder.stringUtf8 "') $ + Name.encode (name decl) + <> if Text.null (value decl) + then mempty + else Builder.charUtf8 ' ' <> Builder.stringUtf8 (Text.unpack $ value decl) + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'encode $ do + Spec.it s "encodes empty value" $ do + Spec.assertEq s (Builder.toString . encode $ MkDeclaration (Name.MkName $ Text.pack "foo") (Text.pack "")) "" + + Spec.it s "encodes with value" $ do + Spec.assertEq s (Builder.toString . encode $ MkDeclaration (Name.MkName $ Text.pack "foo") (Text.pack "bar")) "" + + Spec.it s "encodes doctype" $ do + Spec.assertEq s (Builder.toString . encode $ MkDeclaration (Name.MkName $ Text.pack "DOCTYPE") (Text.pack "html")) "" diff --git a/source/library/Scrod/Xml/Document.hs b/source/library/Scrod/Xml/Document.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Xml/Document.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Xml.Document where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Spec as Spec +import qualified Scrod.Xml.Attribute as Attribute +import qualified Scrod.Xml.Content as Content +import qualified Scrod.Xml.Declaration as Declaration +import qualified Scrod.Xml.Element as Element +import qualified Scrod.Xml.Instruction as Instruction +import qualified Scrod.Xml.Misc as Misc +import qualified Scrod.Xml.Name as Name + +-- | XML Document. Prolog (misc items) followed by root element. No epilog +-- support. +data Document = MkDocument + { prolog :: [Misc.Misc], + root :: Element.Element + } + deriving (Eq, Ord, Show) + +element :: String -> [Attribute.Attribute] -> [Content.Content Element.Element] -> Element.Element +element name attributes contents = + Element.MkElement + { Element.name = Name.MkName $ Text.pack name, + Element.attributes = attributes, + Element.contents = contents + } + +attribute :: String -> String -> Attribute.Attribute +attribute name value = + Attribute.MkAttribute + { Attribute.name = Name.MkName $ Text.pack name, + Attribute.value = Text.pack value + } + +raw :: Text.Text -> Content.Content a +raw = Content.Raw + +string :: String -> Content.Content a +string = text . Text.pack + +text :: Text.Text -> Content.Content a +text = Content.Text + +encode :: Document -> Builder.Builder +encode doc = + foldMap (\m -> Misc.encode m <> Builder.charUtf8 '\n') (prolog doc) + <> Element.encode (root doc) + +-- | Encode as HTML. Only void elements are self-closing. +encodeHtml :: Document -> Builder.Builder +encodeHtml doc = + foldMap (\m -> Misc.encode m <> Builder.charUtf8 '\n') (prolog doc) + <> Element.encodeHtml (root doc) + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + let mkName :: String -> Name.Name + mkName = Name.MkName . Text.pack + mkText :: String -> Content.Content Element.Element + mkText = Content.Text . Text.pack + mkElement :: String -> [Content.Content Element.Element] -> Element.Element + mkElement n = Element.MkElement (mkName n) [] + + Spec.named s 'encode $ do + Spec.it s "encodes simple document" $ do + Spec.assertEq s (Builder.toString . encode $ MkDocument [] (mkElement "root" [])) "" + + Spec.it s "encodes document with xml declaration" $ do + Spec.assertEq + s + ( Builder.toString . encode $ + MkDocument + [Misc.Instruction $ Instruction.MkInstruction (mkName "xml") (Text.pack "version=\"1.0\"")] + (mkElement "root" []) + ) + "\n" + + Spec.it s "encodes document with multiple prolog items" $ do + Spec.assertEq + s + ( Builder.toString . encode $ + MkDocument + [ Misc.Instruction $ Instruction.MkInstruction (mkName "xml") (Text.pack "version=\"1.0\""), + Misc.Declaration $ Declaration.MkDeclaration (mkName "DOCTYPE") (Text.pack "html") + ] + (mkElement "html" []) + ) + "\n\n" + + Spec.it s "encodes document with content" $ do + Spec.assertEq + s + ( Builder.toString . encode $ + MkDocument + [] + (mkElement "root" [mkText "hello"]) + ) + "hello" + + Spec.it s "encodes raw content without escaping" $ do + Spec.assertEq + s + ( Builder.toString . encode $ + MkDocument + [] + (mkElement "style" [Content.Raw $ Text.pack "a > b { color: red; }"]) + ) + "" + + Spec.named s 'encodeHtml $ do + Spec.it s "uses paired tags for empty non-void elements" $ do + Spec.assertEq + s + ( Builder.toString . encodeHtml $ + MkDocument + [] + (mkElement "html" []) + ) + "" + + Spec.it s "self-closes void elements" $ do + Spec.assertEq + s + ( Builder.toString . encodeHtml $ + MkDocument + [] + (mkElement "div" [Content.Element $ Element.MkElement (Name.MkName $ Text.pack "br") [] []]) + ) + "

" diff --git a/source/library/Scrod/Xml/Element.hs b/source/library/Scrod/Xml/Element.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Xml/Element.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Xml.Element where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Spec as Spec +import qualified Scrod.Xml.Attribute as Attribute +import qualified Scrod.Xml.Content as Content +import qualified Scrod.Xml.Name as Name + +-- | XML Element, like @\content\@. Can be +-- self-closing: @\@. +data Element = MkElement + { name :: Name.Name, + attributes :: [Attribute.Attribute], + contents :: [Content.Content Element] + } + deriving (Eq, Ord, Show) + +encode :: Element -> Builder.Builder +encode el = + if null (contents el) + then encodeSelfClosing el + else encodeWithContents el + +encodeSelfClosing :: Element -> Builder.Builder +encodeSelfClosing el = + Builder.charUtf8 '<' + <> Name.encode (name el) + <> encodeAttributes (attributes el) + <> Builder.stringUtf8 " />" + +encodeWithContents :: Element -> Builder.Builder +encodeWithContents el = + Builder.charUtf8 '<' + <> Name.encode (name el) + <> encodeAttributes (attributes el) + <> Builder.charUtf8 '>' + <> foldMap (Content.encode encode) (contents el) + <> Builder.stringUtf8 " Name.encode (name el) + <> Builder.charUtf8 '>' + +encodeAttributes :: [Attribute.Attribute] -> Builder.Builder +encodeAttributes = foldMap (\a -> Builder.charUtf8 ' ' <> Attribute.encode a) + +-- | Encode an element as HTML. Only void elements are self-closing; all +-- other elements use open and close tags even when empty. Recursively +-- fills empty non-void elements with an empty text node so that the +-- regular XML encoder produces paired tags. +encodeHtml :: Element -> Builder.Builder +encodeHtml = encode . fillNonVoidElements + +fillNonVoidElements :: Element -> Element +fillNonVoidElements el = + let cs = fmap fillNonVoidContent (contents el) + in if null cs && not (isHtmlVoidElement (Name.unwrap $ name el)) + then el {contents = [Content.Text Text.empty]} + else el {contents = cs} + +fillNonVoidContent :: Content.Content Element -> Content.Content Element +fillNonVoidContent c = case c of + Content.Element e -> Content.Element (fillNonVoidElements e) + _ -> c + +-- | Whether a tag name is an HTML void element that may be self-closing. +-- See . +isHtmlVoidElement :: Text.Text -> Bool +isHtmlVoidElement = (`Set.member` htmlVoidElements) + +htmlVoidElements :: Set.Set Text.Text +htmlVoidElements = + Set.fromList $ + fmap + Text.pack + [ "area", + "base", + "br", + "col", + "embed", + "hr", + "img", + "input", + "link", + "meta", + "source", + "track", + "wbr" + ] + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + let mkName :: String -> Name.Name + mkName = Name.MkName . Text.pack + mkAttr :: String -> String -> Attribute.Attribute + mkAttr n v = Attribute.MkAttribute (mkName n) (Text.pack v) + mkText :: String -> Content.Content Element + mkText = Content.Text . Text.pack + mkElement :: String -> [Attribute.Attribute] -> [Content.Content Element] -> Content.Content Element + mkElement n as cs = Content.Element $ MkElement (mkName n) as cs + + Spec.named s 'encode $ do + Spec.it s "encodes self-closing tag" $ do + Spec.assertEq s (Builder.toString . encode $ MkElement (mkName "foo") [] []) "" + + Spec.it s "encodes with text content" $ do + Spec.assertEq s (Builder.toString . encode $ MkElement (mkName "foo") [] [mkText "bar"]) "bar" + + Spec.it s "encodes with attribute" $ do + Spec.assertEq s (Builder.toString . encode $ MkElement (mkName "foo") [mkAttr "bar" "baz"] []) "" + + Spec.it s "encodes with multiple attributes" $ do + Spec.assertEq s (Builder.toString . encode $ MkElement (mkName "foo") [mkAttr "a" "1", mkAttr "b" "2"] []) "" + + Spec.it s "encodes nested elements" $ do + Spec.assertEq s (Builder.toString . encode $ MkElement (mkName "foo") [] [mkElement "bar" [] []]) "" + + Spec.it s "escapes text content" $ do + Spec.assertEq s (Builder.toString . encode $ MkElement (mkName "foo") [] [Content.Text $ Text.pack "a & b"]) "a & b" + + Spec.named s 'encodeHtml $ do + Spec.it s "self-closes void elements" $ do + Spec.assertEq s (Builder.toString . encodeHtml $ MkElement (mkName "br") [] []) "
" + + Spec.it s "self-closes void elements with attributes" $ do + Spec.assertEq s (Builder.toString . encodeHtml $ MkElement (mkName "img") [mkAttr "src" "x.png"] []) "" + + Spec.it s "uses paired tags for non-void elements when empty" $ do + Spec.assertEq s (Builder.toString . encodeHtml $ MkElement (mkName "div") [] []) "
" + + Spec.it s "uses paired tags for non-void elements with content" $ do + Spec.assertEq s (Builder.toString . encodeHtml $ MkElement (mkName "div") [] [mkText "hello"]) "
hello
" + + Spec.it s "applies recursively to nested elements" $ do + Spec.assertEq s (Builder.toString . encodeHtml $ MkElement (mkName "div") [] [mkElement "span" [] []]) "
" + + Spec.it s "applies recursively to nested void elements" $ do + Spec.assertEq s (Builder.toString . encodeHtml $ MkElement (mkName "div") [] [mkElement "br" [] []]) "

" diff --git a/source/library/Scrod/Xml/Instruction.hs b/source/library/Scrod/Xml/Instruction.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Xml/Instruction.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Xml.Instruction where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Extra.Semigroup as Semigroup +import qualified Scrod.Spec as Spec +import qualified Scrod.Xml.Name as Name + +-- | XML Processing Instruction, like @\@. If value is empty, no +-- space after the name. Otherwise there must be a space after the name. Cannot +-- contain @?>@. +data Instruction = MkInstruction + { name :: Name.Name, + value :: Text.Text + } + deriving (Eq, Ord, Show) + +encode :: Instruction -> Builder.Builder +encode instr = + Semigroup.around (Builder.stringUtf8 "") $ + Name.encode (name instr) + <> if Text.null (value instr) + then mempty + else Builder.charUtf8 ' ' <> Builder.stringUtf8 (Text.unpack $ value instr) + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'encode $ do + Spec.it s "encodes empty value" $ do + Spec.assertEq s (Builder.toString . encode $ MkInstruction (Name.MkName $ Text.pack "foo") (Text.pack "")) "" + + Spec.it s "encodes with value" $ do + Spec.assertEq s (Builder.toString . encode $ MkInstruction (Name.MkName $ Text.pack "foo") (Text.pack "bar")) "" + + Spec.it s "encodes xml declaration" $ do + Spec.assertEq s (Builder.toString . encode $ MkInstruction (Name.MkName $ Text.pack "xml") (Text.pack "version=\"1.0\"")) "" diff --git a/source/library/Scrod/Xml/Misc.hs b/source/library/Scrod/Xml/Misc.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Xml/Misc.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Xml.Misc where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Spec as Spec +import qualified Scrod.Xml.Comment as Comment +import qualified Scrod.Xml.Declaration as Declaration +import qualified Scrod.Xml.Instruction as Instruction +import qualified Scrod.Xml.Name as Name + +-- | XML Misc (what can appear in the prolog). Comments, Declarations, and +-- Processing Instructions. +data Misc + = Comment Comment.Comment + | Declaration Declaration.Declaration + | Instruction Instruction.Instruction + deriving (Eq, Ord, Show) + +encode :: Misc -> Builder.Builder +encode m = case m of + Comment c -> Comment.encode c + Declaration d -> Declaration.encode d + Instruction i -> Instruction.encode i + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'encode $ do + Spec.it s "encodes comment" $ do + Spec.assertEq s (Builder.toString . encode $ Comment (Comment.MkComment $ Text.pack " hello ")) "" + + Spec.it s "encodes declaration" $ do + Spec.assertEq s (Builder.toString . encode $ Declaration (Declaration.MkDeclaration (Name.MkName $ Text.pack "DOCTYPE") (Text.pack "html"))) "" + + Spec.it s "encodes instruction" $ do + Spec.assertEq s (Builder.toString . encode $ Instruction (Instruction.MkInstruction (Name.MkName $ Text.pack "xml") (Text.pack "version=\"1.0\""))) "" diff --git a/source/library/Scrod/Xml/Name.hs b/source/library/Scrod/Xml/Name.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Xml/Name.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Xml.Name where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Spec as Spec + +-- | XML Name (used for elements, attributes, and instructions). +newtype Name = MkName + { unwrap :: Text.Text + } + deriving (Eq, Ord, Show) + +encode :: Name -> Builder.Builder +encode = Builder.stringUtf8 . Text.unpack . unwrap + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'encode $ do + Spec.it s "encodes a simple name" $ do + Spec.assertEq s (Builder.toString . encode . MkName $ Text.pack "foo") "foo" + + Spec.it s "encodes a name with special chars" $ do + Spec.assertEq s (Builder.toString . encode . MkName $ Text.pack "foo-bar_123") "foo-bar_123" diff --git a/source/library/Scrod/Xml/Text.hs b/source/library/Scrod/Xml/Text.hs new file mode 100644 --- /dev/null +++ b/source/library/Scrod/Xml/Text.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Scrod.Xml.Text where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Text as Text +import qualified Scrod.Extra.Builder as Builder +import qualified Scrod.Spec as Spec + +encode :: Text.Text -> Builder.Builder +encode = foldMap encodeChar . Text.unpack + +encodeChar :: Char -> Builder.Builder +encodeChar c = case c of + '&' -> Builder.stringUtf8 "&" + '<' -> Builder.stringUtf8 "<" + '>' -> Builder.stringUtf8 ">" + _ -> Builder.charUtf8 c + +-- | Encode for attribute values (also escapes quotes) +encodeAttr :: Text.Text -> Builder.Builder +encodeAttr = foldMap encodeAttrChar . Text.unpack + +encodeAttrChar :: Char -> Builder.Builder +encodeAttrChar c = case c of + '\'' -> Builder.stringUtf8 "'" + '"' -> Builder.stringUtf8 """ + _ -> encodeChar c + +spec :: (Applicative m, Monad n) => Spec.Spec m n -> n () +spec s = do + Spec.named s 'encode $ do + Spec.it s "encodes empty text" $ do + Spec.assertEq s (Builder.toString . encode $ Text.pack "") "" + + Spec.it s "encodes plain text" $ do + Spec.assertEq s (Builder.toString . encode $ Text.pack "hello") "hello" + + Spec.it s "encodes ampersand" $ do + Spec.assertEq s (Builder.toString . encode $ Text.pack "a & b") "a & b" + + Spec.it s "encodes less-than" $ do + Spec.assertEq s (Builder.toString . encode $ Text.pack "a < b") "a < b" + + Spec.it s "encodes greater-than" $ do + Spec.assertEq s (Builder.toString . encode $ Text.pack "a > b") "a > b" + + Spec.named s 'encodeAttr $ do + Spec.it s "encodes single quote" $ do + Spec.assertEq s (Builder.toString . encodeAttr $ Text.pack "a ' b") "a ' b" + + Spec.it s "encodes double quote" $ do + Spec.assertEq s (Builder.toString . encodeAttr $ Text.pack "a \" b") "a " b" diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs new file mode 100644 --- /dev/null +++ b/source/test-suite/Main.hs @@ -0,0 +1,19 @@ +import qualified Control.Monad.Trans.Writer as Writer +import qualified Scrod +import qualified Scrod.Spec as Spec +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Unit + +main :: IO () +main = Tasty.defaultMain testTree + +testTree :: Tasty.TestTree +testTree = Tasty.testGroup "scrod" . Writer.execWriter $ Scrod.spec tasty + +tasty :: Spec.Spec IO (Writer.Writer [Tasty.TestTree]) +tasty = + Spec.MkSpec + { Spec.assertFailure = Unit.assertFailure, + Spec.describe = \s -> Writer.tell . pure . Tasty.testGroup s . Writer.execWriter, + Spec.it = \s -> Writer.tell . pure . Unit.testCase s + }