scrod (empty) → 0.2026.2.21
raw patch · 130 files changed
+14097/−0 lines, 130 filesdep +Cabal-syntaxdep +basedep +bytestring
Dependencies added: Cabal-syntax, base, bytestring, containers, exceptions, ghc, ghc-boot-th, ghc-experimental, haddock-library, parsec, scrod, tasty, tasty-bench, tasty-hunit, template-haskell, text, transformers
Files
- CHANGELOG.md +4/−0
- CONTRIBUTING.md +76/−0
- LICENSE.txt +14/−0
- README.md +72/−0
- scrod.cabal +254/−0
- source/benchmark/Main.hs +17/−0
- source/executables/scrod-wasi/Main.hs +5/−0
- source/executables/scrod-wasm/Main.hs +25/−0
- source/executables/scrod/Main.hs +5/−0
- source/library/Scrod.hs +9/−0
- source/library/Scrod/Cabal.hs +141/−0
- source/library/Scrod/Convert/FromGhc.hs +1003/−0
- source/library/Scrod/Convert/FromGhc/CompleteParents.hs +88/−0
- source/library/Scrod/Convert/FromGhc/Constructors.hs +316/−0
- source/library/Scrod/Convert/FromGhc/Doc.hs +122/−0
- source/library/Scrod/Convert/FromGhc/ExportOrdering.hs +310/−0
- source/library/Scrod/Convert/FromGhc/Exports.hs +151/−0
- source/library/Scrod/Convert/FromGhc/FamilyInstanceParents.hs +94/−0
- source/library/Scrod/Convert/FromGhc/FixityParents.hs +30/−0
- source/library/Scrod/Convert/FromGhc/InlineParents.hs +30/−0
- source/library/Scrod/Convert/FromGhc/InstanceParents.hs +192/−0
- source/library/Scrod/Convert/FromGhc/Internal.hs +243/−0
- source/library/Scrod/Convert/FromGhc/ItemKind.hs +98/−0
- source/library/Scrod/Convert/FromGhc/KindSigParents.hs +156/−0
- source/library/Scrod/Convert/FromGhc/Merge.hs +139/−0
- source/library/Scrod/Convert/FromGhc/Names.hs +227/−0
- source/library/Scrod/Convert/FromGhc/ParentAssociation.hs +69/−0
- source/library/Scrod/Convert/FromGhc/RoleParents.hs +30/−0
- source/library/Scrod/Convert/FromGhc/SigArguments.hs +112/−0
- source/library/Scrod/Convert/FromGhc/SpecialiseParents.hs +43/−0
- source/library/Scrod/Convert/FromGhc/Visibility.hs +179/−0
- source/library/Scrod/Convert/FromGhc/WarningParents.hs +39/−0
- source/library/Scrod/Convert/FromHaddock.hs +271/−0
- source/library/Scrod/Convert/ToHtml.hs +886/−0
- source/library/Scrod/Convert/ToJsonSchema.hs +87/−0
- source/library/Scrod/Core/Category.hs +13/−0
- source/library/Scrod/Core/Column.hs +13/−0
- source/library/Scrod/Core/Definition.hs +16/−0
- source/library/Scrod/Core/Doc.hs +46/−0
- source/library/Scrod/Core/Example.hs +17/−0
- source/library/Scrod/Core/Export.hs +25/−0
- source/library/Scrod/Core/ExportIdentifier.hs +22/−0
- source/library/Scrod/Core/ExportName.hs +18/−0
- source/library/Scrod/Core/ExportNameKind.hs +19/−0
- source/library/Scrod/Core/Extension.hs +13/−0
- source/library/Scrod/Core/Header.hs +17/−0
- source/library/Scrod/Core/Hyperlink.hs +17/−0
- source/library/Scrod/Core/Identifier.hs +18/−0
- source/library/Scrod/Core/Import.hs +18/−0
- source/library/Scrod/Core/Item.hs +28/−0
- source/library/Scrod/Core/ItemKey.hs +13/−0
- source/library/Scrod/Core/ItemKind.hs +111/−0
- source/library/Scrod/Core/ItemName.hs +13/−0
- source/library/Scrod/Core/Language.hs +13/−0
- source/library/Scrod/Core/Level.hs +79/−0
- source/library/Scrod/Core/Line.hs +13/−0
- source/library/Scrod/Core/Located.hs +16/−0
- source/library/Scrod/Core/Location.hs +17/−0
- source/library/Scrod/Core/ModLink.hs +17/−0
- source/library/Scrod/Core/Module.hs +104/−0
- source/library/Scrod/Core/ModuleName.hs +13/−0
- source/library/Scrod/Core/Namespace.hs +17/−0
- source/library/Scrod/Core/NumberedItem.hs +16/−0
- source/library/Scrod/Core/PackageName.hs +13/−0
- source/library/Scrod/Core/Picture.hs +17/−0
- source/library/Scrod/Core/Section.hs +15/−0
- source/library/Scrod/Core/Since.hs +17/−0
- source/library/Scrod/Core/Subordinates.hs +19/−0
- source/library/Scrod/Core/Table.hs +17/−0
- source/library/Scrod/Core/TableCell.hs +18/−0
- source/library/Scrod/Core/Version.hs +14/−0
- source/library/Scrod/Core/Visibility.hs +23/−0
- source/library/Scrod/Core/Warning.hs +17/−0
- source/library/Scrod/Cpp.hs +228/−0
- source/library/Scrod/Cpp/Directive.hs +116/−0
- source/library/Scrod/Cpp/Expr.hs +274/−0
- source/library/Scrod/Decimal.hs +63/−0
- source/library/Scrod/Executable/Config.hs +156/−0
- source/library/Scrod/Executable/Flag.hs +106/−0
- source/library/Scrod/Executable/Format.hs +31/−0
- source/library/Scrod/Executable/Main.hs +73/−0
- source/library/Scrod/Extra/Builder.hs +71/−0
- source/library/Scrod/Extra/Either.hs +30/−0
- source/library/Scrod/Extra/Maybe.hs +18/−0
- source/library/Scrod/Extra/Monoid.hs +22/−0
- source/library/Scrod/Extra/Ord.hs +26/−0
- source/library/Scrod/Extra/Parsec.hs +42/−0
- source/library/Scrod/Extra/Read.hs +28/−0
- source/library/Scrod/Extra/Semigroup.hs +14/−0
- source/library/Scrod/Ghc/ArchOS.hs +10/−0
- source/library/Scrod/Ghc/DynFlags.hs +195/−0
- source/library/Scrod/Ghc/FileSettings.hs +17/−0
- source/library/Scrod/Ghc/GhcNameVersion.hs +14/−0
- source/library/Scrod/Ghc/OnOff.hs +20/−0
- source/library/Scrod/Ghc/Parse.hs +143/−0
- source/library/Scrod/Ghc/ParserOpts.hs +20/−0
- source/library/Scrod/Ghc/Platform.hs +22/−0
- source/library/Scrod/Ghc/PlatformMisc.hs +17/−0
- source/library/Scrod/Ghc/ToolSettings.hs +60/−0
- source/library/Scrod/Ghc/Uninitialized.hs +17/−0
- source/library/Scrod/Ghc/UnitId.hs +7/−0
- source/library/Scrod/Ghc/UnitSettings.hs +7/−0
- source/library/Scrod/Json/Array.hs +78/−0
- source/library/Scrod/Json/Boolean.hs +46/−0
- source/library/Scrod/Json/Null.hs +33/−0
- source/library/Scrod/Json/Number.hs +137/−0
- source/library/Scrod/Json/Object.hs +84/−0
- source/library/Scrod/Json/Pair.hs +63/−0
- source/library/Scrod/Json/String.hs +186/−0
- source/library/Scrod/Json/ToJson.hs +104/−0
- source/library/Scrod/Json/Value.hs +163/−0
- source/library/Scrod/JsonPointer/Evaluate.hs +169/−0
- source/library/Scrod/JsonPointer/Pointer.hs +109/−0
- source/library/Scrod/JsonPointer/Token.hs +104/−0
- source/library/Scrod/Schema.hs +300/−0
- source/library/Scrod/Spec.hs +47/−0
- source/library/Scrod/TestSuite/All.hs +96/−0
- source/library/Scrod/TestSuite/Integration.hs +3299/−0
- source/library/Scrod/Unlit.hs +137/−0
- source/library/Scrod/Xml/Attribute.hs +44/−0
- source/library/Scrod/Xml/Comment.hs +34/−0
- source/library/Scrod/Xml/Content.hs +80/−0
- source/library/Scrod/Xml/Declaration.hs +38/−0
- source/library/Scrod/Xml/Document.hs +134/−0
- source/library/Scrod/Xml/Element.hs +141/−0
- source/library/Scrod/Xml/Instruction.hs +39/−0
- source/library/Scrod/Xml/Misc.hs +38/−0
- source/library/Scrod/Xml/Name.hs +26/−0
- source/library/Scrod/Xml/Text.hs +53/−0
- source/test-suite/Main.hs +19/−0
+ CHANGELOG.md view
@@ -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).
+ CONTRIBUTING.md view
@@ -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.
+ LICENSE.txt view
@@ -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.
+ README.md view
@@ -0,0 +1,72 @@+# Scrod++[](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+<https://scrod.fyi>++ -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`.
+ scrod.cabal view
@@ -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
+ source/benchmark/Main.hs view
@@ -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
+ source/executables/scrod-wasi/Main.hs view
@@ -0,0 +1,5 @@+import qualified GHC.Stack as Stack+import qualified Scrod++main :: (Stack.HasCallStack) => IO ()+main = Scrod.defaultMain
+ source/executables/scrod-wasm/Main.hs view
@@ -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
+ source/executables/scrod/Main.hs view
@@ -0,0 +1,5 @@+import qualified GHC.Stack as Stack+import qualified Scrod++main :: (Stack.HasCallStack) => IO ()+main = Scrod.defaultMain
+ source/library/Scrod.hs view
@@ -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
+ source/library/Scrod/Cabal.hs view
@@ -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")
+ source/library/Scrod/Convert/FromGhc.hs view
@@ -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
+ source/library/Scrod/Convert/FromGhc/CompleteParents.hs view
@@ -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
+ source/library/Scrod/Convert/FromGhc/Constructors.hs view
@@ -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
+ source/library/Scrod/Convert/FromGhc/Doc.hs view
@@ -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
+ source/library/Scrod/Convert/FromGhc/ExportOrdering.hs view
@@ -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+ }+ }
+ source/library/Scrod/Convert/FromGhc/Exports.hs view
@@ -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+ }
+ source/library/Scrod/Convert/FromGhc/FamilyInstanceParents.hs view
@@ -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
+ source/library/Scrod/Convert/FromGhc/FixityParents.hs view
@@ -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+ _ -> []
+ source/library/Scrod/Convert/FromGhc/InlineParents.hs view
@@ -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)+ _ -> []
+ source/library/Scrod/Convert/FromGhc/InstanceParents.hs view
@@ -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
+ source/library/Scrod/Convert/FromGhc/Internal.hs view
@@ -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+ )
+ source/library/Scrod/Convert/FromGhc/ItemKind.hs view
@@ -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
+ source/library/Scrod/Convert/FromGhc/KindSigParents.hs view
@@ -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+ }+ }
+ source/library/Scrod/Convert/FromGhc/Merge.hs view
@@ -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}+ }
+ source/library/Scrod/Convert/FromGhc/Names.hs view
@@ -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
+ source/library/Scrod/Convert/FromGhc/ParentAssociation.hs view
@@ -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
+ source/library/Scrod/Convert/FromGhc/RoleParents.hs view
@@ -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)+ _ -> []
+ source/library/Scrod/Convert/FromGhc/SigArguments.hs view
@@ -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
+ source/library/Scrod/Convert/FromGhc/SpecialiseParents.hs view
@@ -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+ _ -> []+ _ -> []
+ source/library/Scrod/Convert/FromGhc/Visibility.hs view
@@ -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]]+ ]
+ source/library/Scrod/Convert/FromGhc/WarningParents.hs view
@@ -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
+ source/library/Scrod/Convert/FromHaddock.hs view
@@ -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
+ source/library/Scrod/Convert/ToHtml.hs view
@@ -0,0 +1,886 @@+{-# LANGUAGE MultilineStrings #-}++-- | Render a 'Module.Module' as a self-contained HTML document.+--+-- Produces a complete @\<html\>@ 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+ ]
+ source/library/Scrod/Convert/ToJsonSchema.hs view
@@ -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
+ source/library/Scrod/Core/Category.hs view
@@ -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
+ source/library/Scrod/Core/Column.hs view
@@ -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
+ source/library/Scrod/Core/Definition.hs view
@@ -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)
+ source/library/Scrod/Core/Doc.hs view
@@ -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
+ source/library/Scrod/Core/Example.hs view
@@ -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
+ source/library/Scrod/Core/Export.hs view
@@ -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
+ source/library/Scrod/Core/ExportIdentifier.hs view
@@ -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
+ source/library/Scrod/Core/ExportName.hs view
@@ -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
+ source/library/Scrod/Core/ExportNameKind.hs view
@@ -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
+ source/library/Scrod/Core/Extension.hs view
@@ -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
+ source/library/Scrod/Core/Header.hs view
@@ -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)
+ source/library/Scrod/Core/Hyperlink.hs view
@@ -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)
+ source/library/Scrod/Core/Identifier.hs view
@@ -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
+ source/library/Scrod/Core/Import.hs view
@@ -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
+ source/library/Scrod/Core/Item.hs view
@@ -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
+ source/library/Scrod/Core/ItemKey.hs view
@@ -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
+ source/library/Scrod/Core/ItemKind.hs view
@@ -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
+ source/library/Scrod/Core/ItemName.hs view
@@ -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
+ source/library/Scrod/Core/Language.hs view
@@ -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
+ source/library/Scrod/Core/Level.hs view
@@ -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
+ source/library/Scrod/Core/Line.hs view
@@ -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
+ source/library/Scrod/Core/Located.hs view
@@ -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)
+ source/library/Scrod/Core/Location.hs view
@@ -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
+ source/library/Scrod/Core/ModLink.hs view
@@ -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)
+ source/library/Scrod/Core/Module.hs view
@@ -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")])+ ]
+ source/library/Scrod/Core/ModuleName.hs view
@@ -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
+ source/library/Scrod/Core/Namespace.hs view
@@ -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
+ source/library/Scrod/Core/NumberedItem.hs view
@@ -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)
+ source/library/Scrod/Core/PackageName.hs view
@@ -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
+ source/library/Scrod/Core/Picture.hs view
@@ -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
+ source/library/Scrod/Core/Section.hs view
@@ -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
+ source/library/Scrod/Core/Since.hs view
@@ -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
+ source/library/Scrod/Core/Subordinates.hs view
@@ -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
+ source/library/Scrod/Core/Table.hs view
@@ -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)
+ source/library/Scrod/Core/TableCell.hs view
@@ -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)
+ source/library/Scrod/Core/Version.hs view
@@ -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
+ source/library/Scrod/Core/Visibility.hs view
@@ -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
+ source/library/Scrod/Core/Warning.hs view
@@ -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
+ source/library/Scrod/Cpp.hs view
@@ -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 <stdio.h>\nmodule M where") $ Right "\nmodule M where\n"
+ source/library/Scrod/Cpp/Directive.hs view
@@ -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 <stdio.h>") $ 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
+ source/library/Scrod/Cpp/Expr.hs view
@@ -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"
+ source/library/Scrod/Decimal.hs view
@@ -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
+ source/library/Scrod/Executable/Config.hs view
@@ -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"])
+ source/library/Scrod/Executable/Flag.hs view
@@ -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"]
+ source/library/Scrod/Executable/Format.hs view
@@ -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
+ source/library/Scrod/Executable/Main.hs view
@@ -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'
+ source/library/Scrod/Extra/Builder.hs view
@@ -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 "
+ source/library/Scrod/Extra/Either.hs view
@@ -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 ()
+ source/library/Scrod/Extra/Maybe.hs view
@@ -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 ()
+ source/library/Scrod/Extra/Monoid.hs view
@@ -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"
+ source/library/Scrod/Extra/Ord.hs view
@@ -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
+ source/library/Scrod/Extra/Parsec.hs view
@@ -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'
+ source/library/Scrod/Extra/Read.hs view
@@ -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)
+ source/library/Scrod/Extra/Semigroup.hs view
@@ -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") "<html>"
+ source/library/Scrod/Ghc/ArchOS.hs view
@@ -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+ }
+ source/library/Scrod/Ghc/DynFlags.hs view
@@ -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+ }
+ source/library/Scrod/Ghc/FileSettings.hs view
@@ -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+ }
+ source/library/Scrod/Ghc/GhcNameVersion.hs view
@@ -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+ }
+ source/library/Scrod/Ghc/OnOff.hs view
@@ -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'
+ source/library/Scrod/Ghc/Parse.hs view
@@ -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 = "<interactive>"++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 "<interactive>: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])
+ source/library/Scrod/Ghc/ParserOpts.hs view
@@ -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?
+ source/library/Scrod/Ghc/Platform.hs view
@@ -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+ }
+ source/library/Scrod/Ghc/PlatformMisc.hs view
@@ -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+ }
+ source/library/Scrod/Ghc/ToolSettings.hs view
@@ -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+ }
+ source/library/Scrod/Ghc/Uninitialized.hs view
@@ -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
+ source/library/Scrod/Ghc/UnitId.hs view
@@ -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}
+ source/library/Scrod/Ghc/UnitSettings.hs view
@@ -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}
+ source/library/Scrod/Json/Array.hs view
@@ -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]"
+ source/library/Scrod/Json/Boolean.hs view
@@ -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"
+ source/library/Scrod/Json/Null.hs view
@@ -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"
+ source/library/Scrod/Json/Number.hs view
@@ -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"
+ source/library/Scrod/Json/Object.hs view
@@ -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}"
+ source/library/Scrod/Json/Pair.hs view
@@ -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"
+ source/library/Scrod/Json/String.hs view
@@ -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 \""
+ source/library/Scrod/Json/ToJson.hs view
@@ -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)
+ source/library/Scrod/Json/Value.hs view
@@ -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]}"
+ source/library/Scrod/JsonPointer/Evaluate.hs view
@@ -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"
+ source/library/Scrod/JsonPointer/Pointer.hs view
@@ -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 ["", "", ""]) "///"
+ source/library/Scrod/JsonPointer/Token.hs view
@@ -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"
+ source/library/Scrod/Schema.hs view
@@ -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")])]
+ source/library/Scrod/Spec.hs view
@@ -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
+ source/library/Scrod/TestSuite/All.hs view
@@ -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
+ source/library/Scrod/TestSuite/Integration.hs view
@@ -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+ """+ -- | <http://example>+ 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+ """+ -- | + 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+ -- <BLANKLINE>+ -- 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"
+ source/library/Scrod/Unlit.hs view
@@ -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"
+ source/library/Scrod/Xml/Attribute.hs view
@@ -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\""
+ source/library/Scrod/Xml/Comment.hs view
@@ -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 @\<!-- comment text -->@. Cannot contain @-->@.+newtype Comment = MkComment+ { unwrap :: Text.Text+ }+ deriving (Eq, Ord, Show)++encode :: Comment -> Builder.Builder+encode =+ Semigroup.around (Builder.stringUtf8 "<!--") (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 ") "<!-- hello -->"++ Spec.it s "encodes comment with special chars" $ do+ Spec.assertEq s (Builder.toString . encode . MkComment $ Text.pack " & ") "<!-- & -->"
+ source/library/Scrod/Xml/Content.hs view
@@ -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 "<test/>"++ Spec.it s "encodes comment" $ do+ Spec.assertEq s (Builder.toString . encode encodeElement $ Comment (Comment.MkComment $ Text.pack " hello ")) "<!-- hello -->"++ Spec.it s "encodes element" $ do+ Spec.assertEq s (Builder.toString . encode encodeElement $ Element "test") "<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"
+ source/library/Scrod/Xml/Declaration.hs view
@@ -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 @\<!name value>@. 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 "<!") (Builder.charUtf8 '>') $+ 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 "")) "<!foo>"++ Spec.it s "encodes with value" $ do+ Spec.assertEq s (Builder.toString . encode $ MkDeclaration (Name.MkName $ Text.pack "foo") (Text.pack "bar")) "<!foo bar>"++ Spec.it s "encodes doctype" $ do+ Spec.assertEq s (Builder.toString . encode $ MkDeclaration (Name.MkName $ Text.pack "DOCTYPE") (Text.pack "html")) "<!DOCTYPE html>"
+ source/library/Scrod/Xml/Document.hs view
@@ -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" [])) "<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" [])+ )+ "<?xml version=\"1.0\"?>\n<root />"++ 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" [])+ )+ "<?xml version=\"1.0\"?>\n<!DOCTYPE html>\n<html />"++ Spec.it s "encodes document with content" $ do+ Spec.assertEq+ s+ ( Builder.toString . encode $+ MkDocument+ []+ (mkElement "root" [mkText "hello"])+ )+ "<root>hello</root>"++ 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; }"])+ )+ "<style>a > b { color: red; }</style>"++ 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" [])+ )+ "<html></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") [] []])+ )+ "<div><br /></div>"
+ source/library/Scrod/Xml/Element.hs view
@@ -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 @\<name attr="value">content\</name>@. Can be+-- self-closing: @\<name />@.+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 <https://html.spec.whatwg.org/multipage/syntax.html#void-elements>.+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") [] []) "<foo />"++ Spec.it s "encodes with text content" $ do+ Spec.assertEq s (Builder.toString . encode $ MkElement (mkName "foo") [] [mkText "bar"]) "<foo>bar</foo>"++ Spec.it s "encodes with attribute" $ do+ Spec.assertEq s (Builder.toString . encode $ MkElement (mkName "foo") [mkAttr "bar" "baz"] []) "<foo 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"] []) "<foo a=\"1\" b=\"2\" />"++ Spec.it s "encodes nested elements" $ do+ Spec.assertEq s (Builder.toString . encode $ MkElement (mkName "foo") [] [mkElement "bar" [] []]) "<foo><bar /></foo>"++ Spec.it s "escapes text content" $ do+ Spec.assertEq s (Builder.toString . encode $ MkElement (mkName "foo") [] [Content.Text $ Text.pack "a & b"]) "<foo>a & b</foo>"++ Spec.named s 'encodeHtml $ do+ Spec.it s "self-closes void elements" $ do+ Spec.assertEq s (Builder.toString . encodeHtml $ MkElement (mkName "br") [] []) "<br />"++ Spec.it s "self-closes void elements with attributes" $ do+ Spec.assertEq s (Builder.toString . encodeHtml $ MkElement (mkName "img") [mkAttr "src" "x.png"] []) "<img 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") [] []) "<div></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"]) "<div>hello</div>"++ Spec.it s "applies recursively to nested elements" $ do+ Spec.assertEq s (Builder.toString . encodeHtml $ MkElement (mkName "div") [] [mkElement "span" [] []]) "<div><span></span></div>"++ Spec.it s "applies recursively to nested void elements" $ do+ Spec.assertEq s (Builder.toString . encodeHtml $ MkElement (mkName "div") [] [mkElement "br" [] []]) "<div><br /></div>"
+ source/library/Scrod/Xml/Instruction.hs view
@@ -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 @\<?name value?>@. 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 "<?") (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 "")) "<?foo?>"++ Spec.it s "encodes with value" $ do+ Spec.assertEq s (Builder.toString . encode $ MkInstruction (Name.MkName $ Text.pack "foo") (Text.pack "bar")) "<?foo 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\"")) "<?xml version=\"1.0\"?>"
+ source/library/Scrod/Xml/Misc.hs view
@@ -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 ")) "<!-- hello -->"++ Spec.it s "encodes declaration" $ do+ Spec.assertEq s (Builder.toString . encode $ Declaration (Declaration.MkDeclaration (Name.MkName $ Text.pack "DOCTYPE") (Text.pack "html"))) "<!DOCTYPE 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\""))) "<?xml version=\"1.0\"?>"
+ source/library/Scrod/Xml/Name.hs view
@@ -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"
+ source/library/Scrod/Xml/Text.hs view
@@ -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"
+ source/test-suite/Main.hs view
@@ -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+ }