├── cabal.project ├── test ├── SpecDriver.hs ├── ResourceTests.hs └── resource │ └── TestSrc.hs ├── dummy_includes ├── DerivedConstants.h ├── GHCConstantsHaskellType.hs ├── GHCConstantsHaskellExports.hs ├── GHCConstantsHaskellWrappers.hs ├── primop-list.hs-incl ├── primop-tag.hs-incl ├── primop-fixity.hs-incl ├── primop-can-fail.hs-incl ├── primop-code-size.hs-incl ├── primop-data-decl.hs-incl ├── primop-commutable.hs-incl ├── primop-out-of-line.hs-incl ├── primop-primop-info.hs-incl ├── primop-strictness.hs-incl ├── primop-vector-tys.hs-incl ├── primop-vector-tycons.hs-incl ├── primop-vector-uniques.hs-incl ├── primop-has-side-effects.hs-incl └── primop-vector-tys-exports.hs-incl ├── ChangeLog.md ├── .gitignore ├── stack.yaml ├── conf └── ghc-8.6.4.yml ├── .editorconfig ├── Makefile ├── docs ├── Makefile ├── index.rst └── conf.py ├── src ├── GHC │ └── Compiler │ │ ├── Notes │ │ ├── Types.hs │ │ ├── Config.hs │ │ ├── Parser.hs │ │ ├── FormatRstDoc.hs │ │ ├── App.hs │ │ └── Parser │ │ │ └── Internal.hs │ │ └── Utils │ │ ├── Lexer.hs │ │ └── HeaderOptions.hs └── Data │ └── Text │ └── Extra.hs ├── LICENSE ├── app ├── ExtractNotes.hs └── Comment.hs ├── .circleci └── config.yml ├── README.md ├── doc └── ParsingNotes.md ├── ghc-compiler-notes.cabal └── floskell.json /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./ 3 | -------------------------------------------------------------------------------- /test/SpecDriver.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF tasty-discover #-} 2 | -------------------------------------------------------------------------------- /dummy_includes/DerivedConstants.h: -------------------------------------------------------------------------------- 1 | -- includes/dist-derivedconstants/header/DerivedConstants.hs 2 | -------------------------------------------------------------------------------- /dummy_includes/GHCConstantsHaskellType.hs: -------------------------------------------------------------------------------- 1 | -- includes/dist-derivedconstants/header/GHCConstantsHaskellType.hs 2 | -------------------------------------------------------------------------------- /dummy_includes/GHCConstantsHaskellExports.hs: -------------------------------------------------------------------------------- 1 | -- includes/dist-derivedconstants/header/GHCConstantsHaskellExports.hs 2 | -------------------------------------------------------------------------------- /dummy_includes/GHCConstantsHaskellWrappers.hs: -------------------------------------------------------------------------------- 1 | -- includes/dist-derivedconstants/header/GHCConstantsHaskellWrappers.hs 2 | -------------------------------------------------------------------------------- /dummy_includes/primop-list.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-list.hs-incl 2 | -- compiler/stage2/build/primop-list.hs-incl 3 | -------------------------------------------------------------------------------- /dummy_includes/primop-tag.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-tag.hs-incl 2 | -- compiler/stage2/build/primop-tag.hs-incl 3 | -------------------------------------------------------------------------------- /dummy_includes/primop-fixity.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-fixity.hs-incl 2 | -- compiler/stage2/build/primop-fixity.hs-incl 3 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for ghc-compiler-notes 2 | 3 | ## 0.1.1.0 (2019-03-25) 4 | 5 | * Support note id 6 | * Add `source` links for notes 7 | -------------------------------------------------------------------------------- /dummy_includes/primop-can-fail.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-can-fail.hs-incl 2 | -- compiler/stage2/build/primop-can-fail.hs-incl 3 | -------------------------------------------------------------------------------- /dummy_includes/primop-code-size.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-code-size.hs-incl 2 | -- compiler/stage2/build/primop-code-size.hs-incl 3 | -------------------------------------------------------------------------------- /dummy_includes/primop-data-decl.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-data-decl.hs-incl 2 | -- compiler/stage2/build/primop-data-decl.hs-incl 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /output/ 2 | 3 | .stack-work/ 4 | .ghc.* 5 | /dist*/ 6 | cabal.project.local 7 | 8 | *~ 9 | 10 | docs/_build 11 | docs/notes 12 | -------------------------------------------------------------------------------- /dummy_includes/primop-commutable.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-commutable.hs-incl 2 | -- compiler/stage2/build/primop-commutable.hs-incl 3 | -------------------------------------------------------------------------------- /dummy_includes/primop-out-of-line.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-out-of-line.hs-incl 2 | -- compiler/stage2/build/primop-out-of-line.hs-incl 3 | -------------------------------------------------------------------------------- /dummy_includes/primop-primop-info.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-primop-info.hs-incl 2 | -- compiler/stage2/build/primop-primop-info.hs-incl 3 | -------------------------------------------------------------------------------- /dummy_includes/primop-strictness.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-strictness.hs-incl 2 | -- compiler/stage2/build/primop-strictness.hs-incl 3 | -------------------------------------------------------------------------------- /dummy_includes/primop-vector-tys.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-vector-tys.hs-incl 2 | -- compiler/stage2/build/primop-vector-tys.hs-incl 3 | -------------------------------------------------------------------------------- /dummy_includes/primop-vector-tycons.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-vector-tycons.hs-incl 2 | -- compiler/stage2/build/primop-vector-tycons.hs-incl 3 | -------------------------------------------------------------------------------- /dummy_includes/primop-vector-uniques.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-vector-uniques.hs-incl 2 | -- compiler/stage2/build/primop-vector-uniques.hs-incl 3 | -------------------------------------------------------------------------------- /dummy_includes/primop-has-side-effects.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-has-side-effects.hs-incl 2 | -- compiler/stage2/build/primop-has-side-effects.hs-incl 3 | -------------------------------------------------------------------------------- /dummy_includes/primop-vector-tys-exports.hs-incl: -------------------------------------------------------------------------------- 1 | -- compiler/stage1/build/primop-vector-tys-exports.hs-incl 2 | -- compiler/stage2/build/primop-vector-tys-exports.hs-incl 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.13 2 | packages: 3 | - . 4 | extra-deps: 5 | - capability-0.1.0.0@sha256:59fb5c11627d56be3df9f726c920ca12e76a8a4652057ddb6d20bb3c890a9da5 6 | - generic-lens-1.0.0.2@sha256:67d2c24fc5bc616af69ea30e4412d75455bbcbeff49cff03823691f789ce7a8a 7 | -------------------------------------------------------------------------------- /conf/ghc-8.6.4.yml: -------------------------------------------------------------------------------- 1 | resource: 2 | type: official-gitlab 3 | identifier: ghc-8.6.4-release 4 | 5 | outDir: docs/notes 6 | 7 | targets: 8 | - compiler/**/*.hs 9 | - compiler/**/*.hs-boot 10 | - libraries/*/**/*.hs 11 | - libraries/*/**/*.hs-boot 12 | - utils/*/**/*.hs 13 | - utils/*/**/*.hs-boot 14 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | root = true 2 | 3 | [*] 4 | charset = utf-8 5 | end_of_line = lf 6 | 7 | [*] 8 | indent_style = space 9 | indent_size = 2 10 | 11 | [Makefile] 12 | indent_style = tab 13 | indent_size = 4 14 | 15 | [*.json] 16 | indent_size = 4 17 | 18 | [*] 19 | trim_trailing_whitespace = true 20 | insert_final_newline = true 21 | 22 | [*.md] 23 | trim_trailing_whitespace = false 24 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build 2 | build: 3 | cabal new-build 4 | 5 | .PHONY: format 6 | format: 7 | find app src test -type f \( -name "*.hs" -or -name "*.lhs" \) | xargs -I{} sh -c "floskell {} || true" 8 | 9 | .PHONY: test 10 | test: 11 | cabal new-test --flag dev 12 | 13 | .PHONY: generate 14 | generate: 15 | rm -rf docs/notes 16 | cabal new-build && cabal new-exec -- ghc-compiler-notes conf/ghc-8.6.4.yml 17 | 18 | .PHONY: docs 19 | docs: 20 | sphinx-build docs docs/_build 21 | 22 | .PHONY: serve-docs 23 | serve-docs: 24 | sphinx-autobuild docs docs/_build 25 | -------------------------------------------------------------------------------- /test/ResourceTests.hs: -------------------------------------------------------------------------------- 1 | module ResourceTests where 2 | 3 | import GHC.Compiler.Notes.App 4 | import GHC.Compiler.Notes.Parser 5 | import GHC.Compiler.Notes.Types 6 | 7 | import Test.Tasty.Hspec 8 | 9 | spec_prelude :: Spec 10 | spec_prelude = do 11 | describe "Expect Success" $ do 12 | it "Standard Example with CPP" $ do 13 | let app = parseCollectedNotesFromHsFile "test/resource/TestSrc.hs" 14 | ctx <- defaultAppContext 15 | r <- runAppT app ctx 16 | case r of 17 | Left{} -> expectationFailure "Expect success of parsing" 18 | Right ns -> length (notes ns) `shouldBe` 4 19 | -------------------------------------------------------------------------------- /docs/Makefile: -------------------------------------------------------------------------------- 1 | # Minimal makefile for Sphinx documentation 2 | # 3 | 4 | # You can set these variables from the command line. 5 | SPHINXOPTS = 6 | SPHINXBUILD = sphinx-build 7 | SOURCEDIR = . 8 | BUILDDIR = _build 9 | 10 | # Put it first so that "make" without argument is like "make help". 11 | help: 12 | @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) 13 | 14 | .PHONY: help Makefile 15 | 16 | # Catch-all target: route all unknown targets to Sphinx using the new 17 | # "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). 18 | %: Makefile 19 | @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) -------------------------------------------------------------------------------- /src/GHC/Compiler/Notes/Types.hs: -------------------------------------------------------------------------------- 1 | module GHC.Compiler.Notes.Types where 2 | 3 | import Data.Sequence (Seq(..)) 4 | import Data.Text (Text) 5 | 6 | import SrcLoc 7 | 8 | newtype NoteId = NoteId Text 9 | deriving (Eq, Show) 10 | 11 | data Note = Note { noteId :: NoteId, noteContent :: Text } 12 | deriving (Eq, Show) 13 | 14 | data CollectedNotes = 15 | CollectedNotes { notes :: Seq (Located Note), noteRefs :: Seq (Located NoteId) } 16 | 17 | instance Semigroup CollectedNotes where 18 | ns1 <> ns2 = 19 | CollectedNotes { notes = notes ns1 <> notes ns2, noteRefs = noteRefs ns1 <> noteRefs ns2 } 20 | 21 | instance Monoid CollectedNotes where 22 | mempty = CollectedNotes { notes = mempty, noteRefs = mempty } 23 | 24 | addNoteByCollecting :: Located Note -> CollectedNotes -> CollectedNotes 25 | addNoteByCollecting n ns = ns { notes = notes ns :|> n } 26 | 27 | class HasSourceResourceGetter m where 28 | sourceResourceGetter :: FilePath -> Maybe SrcSpan -> m Text 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019 myuon 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /test/resource/TestSrc.hs: -------------------------------------------------------------------------------- 1 | {- Note [Head note] 2 | ~~~~~~~~~~~~~~~~~~~ 3 | This is a note on head. 4 | -} 5 | 6 | {-# LANGUAGE CPP #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | 9 | module TestSrc where 10 | 11 | -- Note [Line comment note] 12 | -- ~~~~~~~~~~~~~~~~~~~~~~~~ 13 | -- A note is on line comments. 14 | 15 | {- 16 | ************************************************************************ 17 | * * 18 | sub section 19 | * * 20 | ************************************************************************ 21 | 22 | Sub section. 23 | -} 24 | 25 | {- 26 | Note [Standard note] 27 | ~~~~~~~~~~~~~~~~~~~~ 28 | Many notes are multi-line comments. 29 | -} 30 | 31 | -- | Document comment 32 | someFunc :: Bool -> Int 33 | someFunc = \case 34 | True -> 0 35 | False -> 1 36 | 37 | {- 38 | Note [Underlines of notes allow some symbols] 39 | ============================================= 40 | See http://docutils.sourceforge.net/docs/ref/rst/restructuredtext.html#sections 41 | -} 42 | 43 | str :: String 44 | str = "str\ 45 | with CPP" 46 | -------------------------------------------------------------------------------- /src/GHC/Compiler/Notes/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module GHC.Compiler.Notes.Config where 4 | 5 | import qualified Data.ByteString as ByteString 6 | import Data.Yaml 7 | 8 | import qualified System.FilePath.Glob as Glob 9 | 10 | data NoteConfig = NoteConfig { confResource :: NoteConfigResource 11 | , confOutDir :: String 12 | , confTargets :: [Glob.Pattern] 13 | } 14 | deriving (Eq, Show) 15 | 16 | instance FromJSON NoteConfig where 17 | parseJSON = withObject "NoteConfig" $ \v -> NoteConfig 18 | <$> v .: "resource" 19 | <*> v .: "outDir" 20 | <*> (fmap Glob.compile 21 | <$> v .: "targets") 22 | 23 | data NoteConfigResource = NoteConfigResource 24 | deriving (Eq, Show) 25 | 26 | instance FromJSON NoteConfigResource where 27 | parseJSON = withObject "NoteConfigResource" $ \_ -> pure NoteConfigResource 28 | 29 | parseConfigFromString :: ByteString.ByteString -> Either ParseException NoteConfig 30 | parseConfigFromString = decodeEither' 31 | 32 | parseConfigFromFile :: FilePath -> IO (Either ParseException NoteConfig) 33 | parseConfigFromFile = decodeFileEither 34 | -------------------------------------------------------------------------------- /app/ExtractNotes.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad.IO.Class 4 | 5 | import qualified Data.Text.IO as Text 6 | 7 | import GHC.Compiler.Notes.App 8 | import GHC.Compiler.Notes.FormatRstDoc 9 | import GHC.Compiler.Notes.Parser 10 | 11 | import Options.Applicative hiding (Parser) 12 | import qualified Options.Applicative as Options 13 | 14 | data ExtractNotesOption = ExtractNotesOption { optHsSrcPath :: FilePath } 15 | deriving (Eq, Show) 16 | 17 | extractNotesOption :: Options.Parser ExtractNotesOption 18 | extractNotesOption = ExtractNotesOption 19 | <$> strArgument (metavar "FILE") 20 | 21 | main :: IO () 22 | main = do 23 | opt <- execParser $ info (extractNotesOption <**> helper) $ 24 | header "Extractor of GHC Compiler Notes" <> progDesc "Extract GHC compiler notes" <> fullDesc 25 | ctx <- defaultAppContext 26 | runAppT (app opt) ctx 27 | 28 | app :: ExtractNotesOption -> AppT IO () 29 | app opt = do 30 | r <- parseCollectedNotesFromHsFile $ optHsSrcPath opt 31 | case r of 32 | Left lf -> liftIO $ print lf 33 | Right ns -> liftIO . Text.putStrLn =<< formatRstDoc (optHsSrcPath opt) ns 34 | -------------------------------------------------------------------------------- /docs/index.rst: -------------------------------------------------------------------------------- 1 | .. ghc-compiler-notes documentation master file, created by 2 | sphinx-quickstart on Sat Mar 23 19:35:54 2019. 3 | You can adapt this file completely to your liking, but it should at least 4 | contain the root `toctree` directive. 5 | 6 | ghc-compiler-notes 7 | ============================================== 8 | 9 | Acknowledgements 10 | ---------------- 11 | 12 | The documents in this repository are generated from the source code in the GHC repository, `ghc/ghc `_. 13 | They are hosted under the `The Glasgow Haskell Compiler License `_ 14 | (Click the link for the whole disclaimer). 15 | Please read and follow the disclaimer for the use of the documents. 16 | 17 | The source code itself in the repository is released under `MIT License `_, 18 | and this is only applied to ghc-compiler-notes source code. 19 | 20 | TOC 21 | ---- 22 | 23 | .. toctree:: 24 | :maxdepth: 2 25 | :caption: Contents: 26 | :glob: 27 | 28 | notes/**/index 29 | 30 | Indices and tables 31 | ================== 32 | 33 | * :ref:`genindex` 34 | * :ref:`modindex` 35 | * :ref:`search` 36 | -------------------------------------------------------------------------------- /src/GHC/Compiler/Notes/Parser.hs: -------------------------------------------------------------------------------- 1 | module GHC.Compiler.Notes.Parser where 2 | 3 | import Capability.Reader 4 | 5 | import Control.Monad.IO.Class 6 | import Control.Monad.Trans.State 7 | 8 | import Data.Conduit 9 | 10 | import DynFlags (DynFlags) 11 | 12 | import GHC.Compiler.Notes.Parser.Internal 13 | import GHC.Compiler.Notes.Types 14 | import GHC.Compiler.Utils.HeaderOptions (runParserMayPreprocessFromFile) 15 | import GHC.Compiler.Utils.Lexer 16 | 17 | import Lexer (Token(..)) 18 | 19 | import SrcLoc 20 | 21 | parseCollectedNotesFromHsFile :: (HasReader "envDynFlags" DynFlags m, MonadIO m) 22 | => FilePath 23 | -> m (Either ParseFailed CollectedNotes) 24 | parseCollectedNotesFromHsFile = runParserFromHsFile pCollectNotes 25 | 26 | runParserFromHsFile :: (HasReader "envDynFlags" DynFlags m, MonadIO m) 27 | => Parser a 28 | -> FilePath 29 | -> m (Either ParseFailed a) 30 | runParserFromHsFile p fn = do 31 | dflags <- ask @"envDynFlags" 32 | runParserMayPreprocessFromFile p dflags fn 33 | 34 | pCollectNotes :: Parser CollectedNotes 35 | pCollectNotes = runConduit $ pTokenConsumer .| sinkCollectNotes 36 | 37 | sinkCollectNotes :: ConduitT (Located Token) o Parser CollectedNotes 38 | sinkCollectNotes = cnCtxCollectedNotes 39 | <$> execStateT sinkWaitingNoteComment initialCollectedNotesCtx 40 | -------------------------------------------------------------------------------- /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | 3 | jobs: 4 | build-test-8_6_3: 5 | working_directory: ~/workspace 6 | docker: 7 | - image: haskell:8.6.3 8 | steps: 9 | - checkout 10 | - run: cabal new-update 11 | - restore_cache: 12 | keys: 13 | - cabal-index-{{ checksum "~/.cabal/packages/hackage.haskell.org/01-index.cache" }}-v1 14 | - run: make build 15 | - run: make test 16 | - save_cache: 17 | key: cabal-index-{{ checksum "~/.cabal/packages/hackage.haskell.org/01-index.cache" }}-v1 18 | paths: 19 | - ~/.cabal 20 | - persist_to_workspace: 21 | root: . 22 | paths: 23 | - dist-newstyle 24 | generate: 25 | working_directory: ~/workspace 26 | docker: 27 | - image: haskell:8.6.3 28 | steps: 29 | - checkout 30 | - run: cabal new-update 31 | - restore_cache: 32 | keys: 33 | - cabal-index-{{ checksum "~/.cabal/packages/hackage.haskell.org/01-index.cache" }}-v1 34 | - run: git config --global user.email "ci@example.com" 35 | - run: git config --global user.name "ci-build" 36 | - run: git checkout -B docs 37 | - run: git rebase master 38 | - attach_workspace: 39 | at: . 40 | - run: git clone --depth 1 https://gitlab.haskell.org/ghc/ghc.git output/ghc 41 | - run: make generate 42 | - run: git add -f docs/notes/ 43 | - run: git status 44 | - run: git remote add gh-release "https://${GITHUB_TOKEN}@github.com/myuon/ghc-compiler-notes.git" 45 | - run: git commit -m 'build' && git push -f gh-release docs 46 | 47 | workflows: 48 | version: 2 49 | 50 | # When test has passed, tag a release 51 | build_and_test: 52 | jobs: 53 | - build-test-8_6_3: 54 | filters: 55 | branches: 56 | ignore: 57 | - docs 58 | - generate: 59 | requires: 60 | - build-test-8_6_3 61 | filters: 62 | branches: 63 | only: 64 | - master 65 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ghc-docs-book 2 | 3 | [![Join the chat at https://gitter.im/ghc-compiler-notes/community](https://badges.gitter.im/ghc-compiler-notes/community.svg)](https://gitter.im/ghc-compiler-notes/community?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) [![CircleCI](https://circleci.com/gh/myuon/ghc-compiler-notes.svg?style=svg)](https://circleci.com/gh/myuon/ghc-compiler-notes) [![Documentation Status](https://readthedocs.org/projects/ghc-compiler-notes/badge/?version=latest)](https://ghc-compiler-notes.readthedocs.io/en/latest/?badge=latest) 4 | 5 | 6 | ## Installation 7 | 8 | Requirements: 9 | 10 | * GHC (== 8.6.x): for `ghc-paths` 11 | * GCC: for `CPP` 12 | * Sphinx: for `docs` building 13 | 14 | ```bash 15 | git clone https://github.com/myuon/ghc-compiler-notes.git 16 | cd ghc-compiler-notes 17 | git clone --depth 1 https://gitlab.haskell.org/ghc/ghc.git output/ghc 18 | make generate 19 | make docs 20 | ``` 21 | 22 | Run `make serve-docs` and enjoy reading the notes from `http://localhost:8000`. 23 | 24 | ## Development 25 | 26 | Using stack. 27 | 28 | ```shell 29 | $ stack run 30 | $ stack test --flag ghc-compiler-notes:dev 31 | ``` 32 | 33 | Using cabal. 34 | 35 | ```shell 36 | $ cabal new-run 37 | $ cabal new-test --enable-tests -fdev 38 | ``` 39 | 40 | ## TODO 41 | 42 | * Read Cabal config 43 | - For `MIN_VERSION_Cabal` / etc. macros. 44 | - e.g. Failed to parse `utils/haddock/haddock-test/src/Test/Haddock/Config.hs`. 45 | 46 | * Sources using nested pragmas: https://ghc.haskell.org/trac/ghc/ticket/314 47 | - GHC 8.6.x has an issue for raw stream token with nested comments. 48 | - Fixed this issue in GHC 8.8.x. 49 | - e.g. Failed to parse `libraries/ghc-prim/GHC/Classes.hs`. 50 | 51 | * Notes not followed standard style 52 | - e.g. "A note about the stupid context" at `compiler/basicTypes/DataCon.hs`. 53 | - e.g. "Note [About the NameSorts]" at `compiler/basicTypes/Name.hs`. 54 | - e.g. "Note [Continuation BlockId]" at `compiler/cmm/CmmNode.hs`. 55 | - e.g. "Soundness checks" at `compiler/ghci/RtClosureInspect.hs`. 56 | 57 | * Collect note references 58 | - Collect `See Note [...]` and relate them to notes 59 | -------------------------------------------------------------------------------- /src/Data/Text/Extra.hs: -------------------------------------------------------------------------------- 1 | module Data.Text.Extra where 2 | 3 | import qualified Data.Char as Char 4 | import Data.Text () -- instance Monoid Text 5 | import Data.Text.Internal 6 | import Data.Text.Unsafe 7 | 8 | takeWhileM :: Monad m => (Char -> m Bool) -> Text -> m Text 9 | takeWhileM p t@(Text arr off len) = loop 0 10 | where 11 | loop !i 12 | | i >= len = pure t 13 | | otherwise = do 14 | let Iter c d = iter t i 15 | p c >>= \case 16 | True -> loop $ i + d 17 | False -> pure $ text arr off i 18 | 19 | {-# INLINE takeWhileM #-} 20 | 21 | dropWhileM :: Monad m => (Char -> m Bool) -> Text -> m Text 22 | dropWhileM p t@(Text arr off len) = loop 0 23 | where 24 | loop !i 25 | | i >= len = pure mempty 26 | | otherwise = do 27 | let Iter c d = iter t i 28 | p c >>= \case 29 | True -> loop (i + d) 30 | False -> pure $ text arr (off + i) (len - i) 31 | 32 | {-# INLINE dropWhileM #-} 33 | 34 | stripEmptyLinesStart :: Text -> Text 35 | stripEmptyLinesStart t@(Text arr off len) = loop 0 0 36 | where 37 | loop !ri !i 38 | | i >= len = loopEnd ri 39 | | otherwise = let Iter c d = iter t i in if 40 | | c == '\n' -> let !ni = i + d in loop ni ni 41 | | Char.isSpace c -> loop ri (i + d) 42 | | otherwise -> loopEnd ri 43 | 44 | loopEnd ri 45 | | ri >= len = mempty 46 | | otherwise = text arr (off + ri) (len - ri) 47 | 48 | {-# INLINE stripEmptyLinesStart #-} 49 | 50 | stripEmptyLinesEnd :: Text -> Text 51 | stripEmptyLinesEnd t@(Text arr off len) = let !i0 = len - 1 in loop i0 i0 52 | where 53 | loop !ri !i 54 | | i < 0 = loopEnd i 55 | | otherwise = let (c, d) = reverseIter t i in if 56 | | c == '\n' -> loop i (i + d) 57 | | Char.isSpace c -> loop ri (i + d) 58 | | otherwise -> loopEnd ri 59 | 60 | loopEnd ri 61 | | ri < 0 = mempty 62 | | otherwise = text arr off (ri + 1) 63 | 64 | {-# INLINE stripEmptyLinesEnd #-} 65 | 66 | stripEmptyLines :: Text -> Text 67 | stripEmptyLines = stripEmptyLinesEnd . stripEmptyLinesStart 68 | 69 | {-# INLINE stripEmptyLines #-} 70 | -------------------------------------------------------------------------------- /src/GHC/Compiler/Utils/Lexer.hs: -------------------------------------------------------------------------------- 1 | module GHC.Compiler.Utils.Lexer where 2 | 3 | import Control.Monad.IO.Class 4 | import Control.Monad.Trans.Class 5 | 6 | import Data.Conduit 7 | import Data.Conduit.Combinators (sinkList) 8 | 9 | import DynFlags (DynFlags) 10 | 11 | import FastString (mkFastString) 12 | 13 | import qualified Lexer 14 | import Lexer (ParseResult(..), Token(..)) 15 | 16 | import qualified Outputable 17 | 18 | import Pretty (Doc) 19 | 20 | import SrcLoc 21 | 22 | import qualified StringBuffer 23 | 24 | type Parser = Lexer.P 25 | 26 | newtype ParseFailed = ParseFailed { pFailedMsg :: [(SrcSpan, Doc)] } 27 | deriving Show 28 | 29 | fromParseResult :: DynFlags -> ParseResult a -> Either ParseFailed a 30 | fromParseResult _ (POk _ x) = Right x 31 | fromParseResult dflags (PFailed _ s d) = Left $ ParseFailed [(s, Outputable.runSDoc d ctx)] 32 | where 33 | ctx = Outputable.initSDocContext dflags $ Outputable.defaultErrStyle dflags 34 | 35 | runParser :: Parser a 36 | -> DynFlags 37 | -> StringBuffer.StringBuffer 38 | -> RealSrcLoc 39 | -> Either ParseFailed a 40 | runParser p dflags buf loc = fromPR $ Lexer.unP p $ Lexer.mkPState dflags buf loc 41 | where 42 | fromPR = fromParseResult dflags 43 | 44 | runParserFromString :: Parser a -> DynFlags -> String -> Either ParseFailed a 45 | runParserFromString p dflags str = runParser p dflags buf loc 46 | where 47 | buf = StringBuffer.stringToStringBuffer str 48 | 49 | loc = mkRealSrcLoc (mkFastString "") 1 1 50 | 51 | runParserFromFile :: MonadIO m => Parser a -> DynFlags -> String -> m (Either ParseFailed a) 52 | runParserFromFile p dflags fn = do 53 | buf <- liftIO $ StringBuffer.hGetStringBuffer fn 54 | pure $ runParser p dflags buf loc 55 | where 56 | loc = mkRealSrcLoc (mkFastString fn) 1 1 57 | 58 | pTokenConsumer :: ConduitT i (Located Token) Parser () 59 | pTokenConsumer = go 60 | where 61 | go = do 62 | t <- lift $ Lexer.lexer False pure 63 | yield t 64 | case unLoc t of 65 | ITeof -> pure () 66 | _ -> go 67 | 68 | pTokenize :: Parser [Located Token] 69 | pTokenize = runConduit $ pTokenConsumer .| sinkList 70 | -------------------------------------------------------------------------------- /app/Comment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.IO.Class 6 | 7 | import Data.Maybe (fromJust) 8 | import qualified Data.Text as Text 9 | import qualified Data.Text.IO as Text 10 | 11 | import GHC.Compiler.Notes.App 12 | import GHC.Compiler.Notes.Config 13 | 14 | import GHC.Compiler.Notes.FormatRstDoc 15 | import GHC.Compiler.Notes.Parser 16 | import GHC.Compiler.Notes.Types 17 | 18 | import Options.Applicative hiding (Parser) 19 | import qualified Options.Applicative as Options 20 | 21 | import RIO 22 | 23 | import System.Directory 24 | import System.FilePath 25 | import qualified System.FilePath.Glob as Glob 26 | 27 | data CommentOption = CommentOption { optConfigPath :: FilePath } 28 | deriving (Eq, Show) 29 | 30 | commentOption :: Options.Parser CommentOption 31 | commentOption = CommentOption 32 | <$> argument str (metavar "FILE") 33 | 34 | main :: IO () 35 | main = do 36 | opt <- execParser $ info (commentOption <**> helper) $ 37 | header "GHC Compiler Notes" <> progDesc "Output GHC compiler notes" <> fullDesc 38 | ctx <- defaultAppContext 39 | runAppT (app opt) ctx 40 | 41 | app :: CommentOption -> AppT IO () 42 | app opt = do 43 | config <- (liftIO $ parseConfigFromFile $ optConfigPath opt) >>= \case 44 | Right conf -> pure conf 45 | Left err -> throwM err 46 | files <- fmap join $ liftIO $ Glob.globDir (confTargets config) "output/ghc" 47 | forM_ files \fn -> do 48 | let targetFn = joinPath $ drop 2 $ splitPath fn 49 | let outputFn = confOutDir config targetFn <> ".rst" 50 | r <- parseCollectedNotesFromHsFile fn 51 | case r of 52 | Left lf -> liftIO $ print lf 53 | Right ns -> when (length (notes ns) > 0) $ do 54 | d <- formatRstDoc targetFn ns 55 | -- Create a directory and place an index.rst 56 | directoryExists <- liftIO $ doesDirectoryExist $ takeDirectory outputFn 57 | when (not directoryExists) $ do 58 | liftIO $ createDirectoryIfMissing True $ takeDirectory outputFn 59 | liftIO $ Text.writeFile (takeDirectory outputFn "index.rst") $ 60 | Text.unlines [ fromJust $ Text.stripPrefix "docs/notes/" $ 61 | Text.pack (takeDirectory outputFn) 62 | , "=================================" 63 | , "" 64 | , ".. toctree::" 65 | , " :maxdepth: 2" 66 | , " :caption: Contents:" 67 | , " :glob:" 68 | , "" 69 | , " *" 70 | ] 71 | 72 | liftIO $ Text.writeFile outputFn d 73 | -------------------------------------------------------------------------------- /doc/ParsingNotes.md: -------------------------------------------------------------------------------- 1 | # Parsing Notes 2 | 3 | The implementation: `GHC.Compiler.Notes.Parser.Internal` 4 | 5 | ## State Transition 6 | 7 | ### Waiting Note 8 | 9 | Any notes start as a new section at top-level comment. 10 | 11 | ```haskell 12 | {- 13 | Note [Usual Note] 14 | ~~~~~~~~~~~~~~~~~ 15 | many notes start by multi-line comment. 16 | -} 17 | ``` 18 | 19 | ```haskell 20 | {- Note [Example Note] 21 | ~~~~~~~~~~~~~~~~~~~~~~ 22 | Titles of some notes start by multi-line comment without newline. 23 | -} 24 | ``` 25 | 26 | ```haskell 27 | -- Note [Example Note] 28 | -- ~~~~~~~~~~~~~~~~~~~ 29 | -- Some notes often start by single-line comment. 30 | ``` 31 | 32 | ```haskell 33 | {- 34 | Note [Example Note] 35 | =================== 36 | Some notes use not `~` symbol for new section. 37 | We can use `~` / `=` / `-` / etc. for underline. 38 | See also the reference of reStructuredText: http://docutils.sourceforge.net/docs/ref/rst/restructuredtext.html#sections 39 | -} 40 | ``` 41 | 42 | ### Parsing Note 43 | 44 | Continue: 45 | 46 | ```haskell 47 | -- Some notes often include single-line comments which contents are indented. 48 | ``` 49 | 50 | ```haskell 51 | -- Some notes often continue 52 | 53 | -- with empty line. 54 | ``` 55 | 56 | ```haskell 57 | -- Some notes often include single-line and 58 | 59 | {- 60 | multi-line comments. 61 | -} 62 | ``` 63 | 64 | ```haskell 65 | {- 66 | Some notes often include 67 | 68 | $named-doc 69 | named document comments. 70 | -} 71 | ``` 72 | 73 | End: 74 | 75 | ```haskell 76 | {- 77 | Note [Example Note] 78 | ~~~~~~~~~~~~~~~~~~~ 79 | Many notes end with a next document comment. 80 | -} 81 | 82 | -- | Document comment for @someFunc@ 83 | someFunc :: a 84 | ``` 85 | 86 | ```haskell 87 | {- 88 | Note [Example Note] 89 | ~~~~~~~~~~~~~~~~~~~ 90 | A note. 91 | 92 | Note [New Note] 93 | ~~~~~~~~~~~~~~~ 94 | Many notes end by a new title of note. 95 | -} 96 | ``` 97 | 98 | ```haskell 99 | {- 100 | Note [Example Note] 101 | ~~~~~~~~~~~~~~~~~~~ 102 | Many notes end by a new token not comment. 103 | -} 104 | 105 | someFunc :: a 106 | ``` 107 | 108 | ```haskell 109 | {- 110 | Note [Example Note] 111 | ~~~~~~~~~~~~~~~~~~~ 112 | Some notes end by a subsection. 113 | -} 114 | 115 | {- 116 | ************************************************************************ 117 | * * 118 | Sub section 119 | * * 120 | ************************************************************************ 121 | -} 122 | ``` 123 | 124 | ```haskell 125 | {- 126 | Note [Example Note] 127 | ~~~~~~~~~~~~~~~~~~~ 128 | Some notes end by a horizontal rule 129 | -} 130 | 131 | ------------------------------- 132 | ``` 133 | 134 | ```haskell 135 | {- 136 | Note [Example Note] 137 | ~~~~~~~~~~~~~~~~~~~ 138 | Some notes end by a indented comment. 139 | -} 140 | 141 | -- an indented comment. 142 | ``` 143 | -------------------------------------------------------------------------------- /src/GHC/Compiler/Notes/FormatRstDoc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module GHC.Compiler.Notes.FormatRstDoc 4 | ( formatRstDoc 5 | ) where 6 | 7 | import Control.Monad 8 | 9 | import Data.List (groupBy) 10 | import qualified Data.Text as Text 11 | 12 | import GHC.Compiler.Notes.Types 13 | 14 | import SrcLoc 15 | 16 | formatRstDoc :: (HasSourceResourceGetter m, Monad m) => FilePath -> CollectedNotes -> m Text.Text 17 | formatRstDoc targetFn CollectedNotes{..} = do 18 | fileNameLink <- sourceResourceGetter targetFn Nothing 19 | let textTargetFn = Text.pack targetFn 20 | contentHeader <- pure $ Text.unlines -- Link to source 21 | [ "`[source] <" <> fileNameLink <> ">`_" 22 | , "" 23 | -- Filename header 24 | , textTargetFn 25 | , Text.replicate (Text.length textTargetFn) "=" 26 | ] 27 | foldM combineNotes contentHeader notes 28 | where 29 | combineNotes txt (L p Note{..}) = do 30 | let NoteId noteId' = noteId 31 | let noteTitle = "Note [" <> noteId' <> "]" 32 | noteLink <- sourceResourceGetter targetFn $ Just p 33 | pure $ Text.unlines [ txt 34 | , "" 35 | , noteTitle 36 | , Text.replicate (Text.length noteTitle) "~" 37 | , "" 38 | , "`[note link] <" <> noteLink <> ">`__" 39 | , "" 40 | , codeBlocks noteContent 41 | ] 42 | 43 | codeBlocks :: Text.Text -> Text.Text 44 | codeBlocks = Text.concat . map Text.unlines 45 | . map (\p -> if detectBlocks p then wrapCodeBlock p else p) . paragraphs 46 | where 47 | paragraphs = groupBy (\x y -> Text.stripStart x /= "" && Text.stripStart y /= "") 48 | . Text.lines 49 | 50 | detectBlocks = 51 | all (\line -> 52 | -- A code block should not be empty 53 | Text.length (Text.stripStart line) /= 0 && 54 | -- A code block should be indented 55 | " " `Text.isPrefixOf` line && 56 | -- A (long enough) code block at least contains code words (word starting symbols) >= 20% 57 | (let codeWordSize = length $ filter codeWord $ tokenize line 58 | wordSize = length $ tokenize line 59 | in wordSize > 5 || fromIntegral codeWordSize / fromIntegral wordSize >= 0.2) && 60 | -- A code block should not be an ordered list 61 | all (not . (`Text.isPrefixOf` Text.stripStart line)) ["(1", "(2", "(3", "(4"] && 62 | -- A code block should not start with * or - (that might be a list) 63 | all (not . (`Text.isPrefixOf` Text.stripStart line)) ["-", "*"]) 64 | 65 | tokenize t = Text.words t 66 | 67 | codeWord t = t `elem` ["class", "data", "where", "module", "forall", "pattern", "case"] 68 | || Text.head t `elem` ("!\"#$%&'()-=~^\\|@`[{;+:*]}<,>/?_" :: String) 69 | 70 | wrapCodeBlock p = ("::\n" : p) ++ ["\n.."] 71 | -------------------------------------------------------------------------------- /ghc-compiler-notes.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: ghc-compiler-notes 3 | version: 0.1.1.0 4 | license: MIT 5 | license-file: LICENSE 6 | maintainer: ioi.joi.koi.loi@gmail.com 7 | author: myuon 8 | homepage: https://github.com/myuon/ghc-compiler-notes 9 | category: Language 10 | build-type: Simple 11 | 12 | tested-with: 13 | ghc ==8.6.3 14 | ghc ==8.6.4 15 | 16 | extra-source-files: 17 | ChangeLog.md 18 | README.md 19 | 20 | flag dev 21 | description: 22 | Turn on development settings. 23 | default: False 24 | manual: True 25 | 26 | common general 27 | default-language: Haskell2010 28 | autogen-modules: 29 | Paths_ghc_compiler_notes 30 | other-modules: 31 | Paths_ghc_compiler_notes 32 | build-depends: 33 | base >= 4.12.0 && < 4.13, 34 | bytestring >= 0.10.8 && < 0.11, 35 | text >= 1.2.3 && < 1.3, 36 | exceptions >= 0.10.0 && < 0.11, 37 | capability >= 0.1.0 && < 0.2, 38 | transformers >= 0.5.5 && < 0.6, 39 | rio >= 0.1.8 && < 0.2, 40 | template-haskell >= 2.14.0 && < 2.15, 41 | 42 | ghc >= 8.6 && < 8.7, 43 | ghc-boot >= 8.6 && < 8.7, 44 | ghc-paths >= 0.1.0 && < 0.2, 45 | -- cpphs, 46 | 47 | conduit >= 1.3.1 && < 1.4, 48 | containers >= 0.6.0 && < 0.7, 49 | directory >= 1.3.3 && < 1.4, 50 | filepath >= 1.4.2 && < 1.5, 51 | Glob >= 0.10.0 && < 0.11, 52 | regex-applicative >= 0.3.3 && < 0.4, 53 | temporary >= 1.3 && < 1.4, 54 | yaml >= 0.11.0 && < 0.12, 55 | ghc-options: 56 | -Wall 57 | 58 | if flag(dev) 59 | ghc-options: 60 | -Wcompat 61 | -Wincomplete-record-updates 62 | -Wincomplete-uni-patterns 63 | -Wpartial-fields 64 | 65 | -dcore-lint 66 | else 67 | ghc-options: 68 | -O2 69 | 70 | default-extensions: 71 | BangPatterns 72 | BlockArguments 73 | DataKinds 74 | DeriveFunctor 75 | DeriveGeneric 76 | DerivingStrategies 77 | FlexibleContexts 78 | FlexibleInstances 79 | GADTs 80 | LambdaCase 81 | MultiParamTypeClasses 82 | MultiWayIf 83 | PolyKinds 84 | RecordWildCards 85 | ScopedTypeVariables 86 | StandaloneDeriving 87 | TypeApplications 88 | 89 | common exec 90 | build-depends: 91 | ghc-compiler-notes, 92 | optparse-applicative >= 0.14.3 && < 0.15, 93 | 94 | library 95 | import: general 96 | hs-source-dirs: src 97 | exposed-modules: 98 | GHC.Compiler.Notes.App 99 | GHC.Compiler.Notes.Config 100 | GHC.Compiler.Notes.Parser 101 | GHC.Compiler.Notes.Parser.Internal 102 | GHC.Compiler.Notes.Types 103 | GHC.Compiler.Notes.FormatRstDoc 104 | 105 | GHC.Compiler.Utils.Lexer 106 | GHC.Compiler.Utils.HeaderOptions 107 | 108 | Data.Text.Extra 109 | 110 | executable ghc-compiler-notes 111 | import: general, exec 112 | hs-source-dirs: app 113 | main-is: Comment.hs 114 | 115 | executable extract-notes 116 | import: general, exec 117 | hs-source-dirs: app 118 | main-is: ExtractNotes.hs 119 | 120 | test-suite unit-tests 121 | import: general, exec 122 | type: exitcode-stdio-1.0 123 | hs-source-dirs: test 124 | main-is: SpecDriver.hs 125 | build-tool-depends: 126 | tasty-discover:tasty-discover >= 4.2 && < 4.3, 127 | build-depends: 128 | tasty >= 1.2 && < 1.3, 129 | tasty-hspec >= 1.1.5 && < 1.2, 130 | other-modules: 131 | ResourceTests 132 | -------------------------------------------------------------------------------- /src/GHC/Compiler/Notes/App.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module GHC.Compiler.Notes.App where 5 | 6 | import Capability.Accessors 7 | import Capability.Reader 8 | 9 | import Control.Monad 10 | import Control.Monad.Catch 11 | 12 | import Control.Monad.IO.Class 13 | import Control.Monad.Trans.Reader (ReaderT(..)) 14 | 15 | import Control.Monad.Trans.State 16 | 17 | import Data.Kind 18 | 19 | import qualified Data.Text as Text 20 | 21 | import qualified DynFlags 22 | 23 | import GHC (getSessionDynFlags, runGhc) 24 | 25 | import GHC.Compiler.Notes.Types 26 | import GHC.Generics 27 | 28 | import GHC.LanguageExtensions (Extension) 29 | import qualified GHC.Paths 30 | 31 | import qualified Packages 32 | 33 | import SrcLoc 34 | 35 | data AppContext = AppContext { envDynFlags :: DynFlags.DynFlags 36 | , envSourceResourceGetter :: FilePath -> Maybe SrcSpan -> Text.Text 37 | } 38 | deriving Generic 39 | 40 | type OnOff a = (Bool, a) 41 | 42 | data AppContextCommon = AppContextCommon { sFlagsExtensions :: [OnOff Extension] 43 | , sFlagsGeneralOptions :: [OnOff DynFlags.GeneralFlag] 44 | , sFlagsGlobalIncludePaths :: [String] 45 | } 46 | 47 | ghcInitDynFlags :: MonadIO m => m DynFlags.DynFlags 48 | ghcInitDynFlags = do 49 | dflags0 <- liftIO $ runGhc (Just GHC.Paths.libdir) getSessionDynFlags 50 | (dflags1, _) <- liftIO $ Packages.initPackages dflags0 51 | pure dflags1 52 | 53 | appContext :: MonadIO m => AppContextCommon -> m AppContext 54 | appContext AppContextCommon{..} = do 55 | defDflags <- ghcInitDynFlags 56 | let dflags = execState dflagsUpdater defDflags 57 | 58 | return $ AppContext { envDynFlags = dflags, envSourceResourceGetter = gitlabResourceGetter } 59 | where 60 | dflagsUpdater = do 61 | forM_ sFlagsGeneralOptions \(b, opt) -> modify' 62 | \dflags -> if b then dflags `DynFlags.gopt_set` opt else dflags `DynFlags.gopt_unset` opt 63 | forM_ sFlagsExtensions \(b, ext) -> modify' 64 | \dflags -> if b then dflags `DynFlags.xopt_set` ext else dflags `DynFlags.xopt_unset` ext 65 | modify' \dflags -> 66 | dflags { DynFlags.includePaths = DynFlags.addGlobalInclude (DynFlags.includePaths dflags) 67 | sFlagsGlobalIncludePaths 68 | } 69 | 70 | gitlabResourceGetter fn opts = 71 | "https://gitlab.haskell.org/ghc/ghc/tree/master/" <> Text.pack fn <> case opts of 72 | Nothing -> "" 73 | Just s -> case srcSpanStart s of 74 | RealSrcLoc l -> "#L" <> Text.pack (show $ srcLocLine l) 75 | _ -> "#" 76 | 77 | defaultAppContext :: MonadIO m => m AppContext 78 | defaultAppContext = appContext $ 79 | AppContextCommon { sFlagsExtensions = [] 80 | , sFlagsGeneralOptions = 81 | [(True, DynFlags.Opt_Haddock), (True, DynFlags.Opt_KeepRawTokenStream)] 82 | , sFlagsGlobalIncludePaths = [ "dummy_includes" 83 | , "output/ghc/compiler" 84 | , "output/ghc/libraries/base/include" 85 | ] 86 | } 87 | 88 | newtype AppT (m :: Type -> Type) a = AppT { runAppT :: AppContext -> m a } 89 | deriving 90 | ( Functor 91 | , Applicative 92 | , Monad 93 | , MonadIO 94 | , MonadThrow 95 | ) via (ReaderT AppContext m) 96 | 97 | deriving 98 | via (MonadReader (ReaderT AppContext m)) 99 | instance Monad m => HasReader "AppContext" AppContext (AppT m) 100 | 101 | deriving 102 | via (Field "envDynFlags" "ctx" (MonadReader (ReaderT AppContext m))) 103 | instance Monad m => HasReader "envDynFlags" DynFlags.DynFlags (AppT m) 104 | 105 | instance Monad m => HasSourceResourceGetter (AppT m) where 106 | sourceResourceGetter fn opts = do 107 | ctx <- ask @"AppContext" 108 | pure $ envSourceResourceGetter ctx fn opts 109 | -------------------------------------------------------------------------------- /docs/conf.py: -------------------------------------------------------------------------------- 1 | # -*- coding: utf-8 -*- 2 | # 3 | # Configuration file for the Sphinx documentation builder. 4 | # 5 | # This file does only contain a selection of the most common options. For a 6 | # full list see the documentation: 7 | # http://www.sphinx-doc.org/en/master/config 8 | 9 | # -- Path setup -------------------------------------------------------------- 10 | 11 | # If extensions (or modules to document with autodoc) are in another directory, 12 | # add these directories to sys.path here. If the directory is relative to the 13 | # documentation root, use os.path.abspath to make it absolute, like shown here. 14 | # 15 | # import os 16 | # import sys 17 | # sys.path.insert(0, os.path.abspath('.')) 18 | 19 | 20 | # -- Project information ----------------------------------------------------- 21 | 22 | project = 'ghc-compiler-notes' 23 | copyright = '2019, myuon' 24 | author = 'myuon' 25 | 26 | # The short X.Y version 27 | version = '' 28 | # The full version, including alpha/beta/rc tags 29 | release = '' 30 | 31 | 32 | # -- General configuration --------------------------------------------------- 33 | 34 | # If your documentation needs a minimal Sphinx version, state it here. 35 | # 36 | # needs_sphinx = '1.0' 37 | 38 | # Add any Sphinx extension module names here, as strings. They can be 39 | # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom 40 | # ones. 41 | extensions = [ 42 | 'sphinx.ext.githubpages', 43 | ] 44 | 45 | # Add any paths that contain templates here, relative to this directory. 46 | templates_path = ['_templates'] 47 | 48 | # The suffix(es) of source filenames. 49 | # You can specify multiple suffix as a list of string: 50 | # 51 | # source_suffix = ['.rst', '.md'] 52 | source_suffix = '.rst' 53 | 54 | # The master toctree document. 55 | master_doc = 'index' 56 | 57 | # The language for content autogenerated by Sphinx. Refer to documentation 58 | # for a list of supported languages. 59 | # 60 | # This is also used if you do content translation via gettext catalogs. 61 | # Usually you set "language" from the command line for these cases. 62 | language = 'en' 63 | 64 | # List of patterns, relative to source directory, that match files and 65 | # directories to ignore when looking for source files. 66 | # This pattern also affects html_static_path and html_extra_path. 67 | exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store'] 68 | 69 | # Default highlighting language 70 | highlight_language = 'haskell' 71 | 72 | # The name of the Pygments (syntax highlighting) style to use. 73 | pygments_style = None 74 | 75 | 76 | # -- Options for HTML output ------------------------------------------------- 77 | 78 | # The theme to use for HTML and HTML Help pages. See the documentation for 79 | # a list of builtin themes. 80 | # 81 | html_theme = 'alabaster' 82 | 83 | html_theme_options = { 84 | 'github_user': 'myuon', 85 | 'github_repo': 'ghc-compiler-notes', 86 | 'github_banner': True, 87 | } 88 | 89 | # Theme options are theme-specific and customize the look and feel of a theme 90 | # further. For a list of options available for each theme, see the 91 | # documentation. 92 | # 93 | # html_theme_options = {} 94 | 95 | # Add any paths that contain custom static files (such as style sheets) here, 96 | # relative to this directory. They are copied after the builtin static files, 97 | # so a file named "default.css" will overwrite the builtin "default.css". 98 | html_static_path = ['_static'] 99 | 100 | # Custom sidebar templates, must be a dictionary that maps document names 101 | # to template names. 102 | # 103 | # The default sidebars (for documents that don't match any pattern) are 104 | # defined by theme itself. Builtin themes are using these templates by 105 | # default: ``['localtoc.html', 'relations.html', 'sourcelink.html', 106 | # 'searchbox.html']``. 107 | # 108 | # html_sidebars = {} 109 | 110 | 111 | # -- Options for HTMLHelp output --------------------------------------------- 112 | 113 | # Output file base name for HTML help builder. 114 | htmlhelp_basename = 'ghc-compiler-notesdoc' 115 | 116 | 117 | # -- Options for LaTeX output ------------------------------------------------ 118 | 119 | latex_elements = { 120 | # The paper size ('letterpaper' or 'a4paper'). 121 | # 122 | # 'papersize': 'letterpaper', 123 | 124 | # The font size ('10pt', '11pt' or '12pt'). 125 | # 126 | # 'pointsize': '10pt', 127 | 128 | # Additional stuff for the LaTeX preamble. 129 | # 130 | # 'preamble': '', 131 | 132 | # Latex figure (float) alignment 133 | # 134 | # 'figure_align': 'htbp', 135 | } 136 | 137 | # Grouping the document tree into LaTeX files. List of tuples 138 | # (source start file, target name, title, 139 | # author, documentclass [howto, manual, or own class]). 140 | latex_documents = [ 141 | (master_doc, 'ghc-compiler-notes.tex', 'ghc-compiler-notes Documentation', 142 | 'myuon', 'manual'), 143 | ] 144 | 145 | 146 | # -- Options for manual page output ------------------------------------------ 147 | 148 | # One entry per manual page. List of tuples 149 | # (source start file, name, description, authors, manual section). 150 | man_pages = [ 151 | (master_doc, 'ghc-compiler-notes', 'ghc-compiler-notes Documentation', 152 | [author], 1) 153 | ] 154 | 155 | 156 | # -- Options for Texinfo output ---------------------------------------------- 157 | 158 | # Grouping the document tree into Texinfo files. List of tuples 159 | # (source start file, target name, title, author, 160 | # dir menu entry, description, category) 161 | texinfo_documents = [ 162 | (master_doc, 'ghc-compiler-notes', 'ghc-compiler-notes Documentation', 163 | author, 'ghc-compiler-notes', 'One line description of project.', 164 | 'Miscellaneous'), 165 | ] 166 | 167 | 168 | # -- Options for Epub output ------------------------------------------------- 169 | 170 | # Bibliographic Dublin Core info. 171 | epub_title = project 172 | 173 | # The unique identifier of the text. This can be a ISBN number 174 | # or the project homepage. 175 | # 176 | # epub_identifier = '' 177 | 178 | # A unique identification for the text. 179 | # 180 | # epub_uid = '' 181 | 182 | # A list of files that should not be packed into the epub file. 183 | epub_exclude_files = ['search.html'] 184 | 185 | 186 | # -- Extension configuration ------------------------------------------------- 187 | -------------------------------------------------------------------------------- /floskell.json: -------------------------------------------------------------------------------- 1 | { 2 | "style": "cramer", 3 | "extensions": [ 4 | "BangPatterns", 5 | "DataKinds", 6 | "ExplicitForAll", 7 | "FlexibleContexts", 8 | "LambdaCase", 9 | "MultiParamTypeClasses", 10 | "MultiWayIf", 11 | "NoImplicitPrelude", 12 | "OverloadedLabels", 13 | "OverloadedStrings", 14 | "PolyKinds", 15 | "QuasiQuotes", 16 | "RankNTypes", 17 | "RecordWildCards", 18 | "ScopedTypeVariables", 19 | "TemplateHaskell", 20 | "TypeApplications", 21 | "TypeFamilies", 22 | "TypeOperators" 23 | ], 24 | "formatting": { 25 | "op": { 26 | "default": { 27 | "force-linebreak": false, 28 | "spaces": "both", 29 | "linebreaks": "before" 30 | }, 31 | ",": { 32 | "force-linebreak": false, 33 | "spaces": "after", 34 | "linebreaks": "before" 35 | }, 36 | "=": { 37 | "force-linebreak": false, 38 | "spaces": "both", 39 | "linebreaks": "after" 40 | }, 41 | "@": { 42 | "force-linebreak": false, 43 | "spaces": "none", 44 | "linebreaks": "none" 45 | }, 46 | ". in expression": { 47 | "force-linebreak": false, 48 | "spaces": "both", 49 | "linebreaks": "before" 50 | }, 51 | ": in pattern": { 52 | "force-linebreak": false, 53 | "spaces": "none", 54 | "linebreaks": "none" 55 | }, 56 | "-> in expression": { 57 | "force-linebreak": false, 58 | "spaces": "both", 59 | "linebreaks": "after" 60 | }, 61 | ". in type": { 62 | "force-linebreak": false, 63 | "spaces": "after", 64 | "linebreaks": "after" 65 | }, 66 | "$": { 67 | "force-linebreak": false, 68 | "spaces": "both", 69 | "linebreaks": "after" 70 | }, 71 | "$$": { 72 | "force-linebreak": false, 73 | "spaces": "before", 74 | "linebreaks": "none" 75 | }, 76 | "record in pattern": { 77 | "force-linebreak": false, 78 | "spaces": "none", 79 | "linebreaks": "none" 80 | }, 81 | "record": { 82 | "force-linebreak": false, 83 | "spaces": "after", 84 | "linebreaks": "none" 85 | }, 86 | "<: in expression": { 87 | "force-linebreak": true, 88 | "spaces": "after", 89 | "linebreaks": "before" 90 | }, 91 | "<* in expression": { 92 | "force-linebreak": true, 93 | "spaces": "both", 94 | "linebreaks": "before" 95 | }, 96 | "<$> in expression": { 97 | "force-linebreak": true, 98 | "spaces": "both", 99 | "linebreaks": "before" 100 | }, 101 | "<*> in expression": { 102 | "force-linebreak": true, 103 | "spaces": "both", 104 | "linebreaks": "before" 105 | } 106 | }, 107 | "group": { 108 | "default": { 109 | "force-linebreak": false, 110 | "spaces": "both", 111 | "linebreaks": "after" 112 | }, 113 | "$(": { 114 | "force-linebreak": false, 115 | "spaces": "none", 116 | "linebreaks": "none" 117 | }, 118 | "[ in pattern": { 119 | "force-linebreak": false, 120 | "spaces": "none", 121 | "linebreaks": "after" 122 | }, 123 | "(# in pattern": { 124 | "force-linebreak": false, 125 | "spaces": "both", 126 | "linebreaks": "after" 127 | }, 128 | "( in other": { 129 | "force-linebreak": false, 130 | "spaces": "none", 131 | "linebreaks": "after" 132 | }, 133 | "(# in expression": { 134 | "force-linebreak": false, 135 | "spaces": "both", 136 | "linebreaks": "after" 137 | }, 138 | "* in type": { 139 | "force-linebreak": false, 140 | "spaces": "none", 141 | "linebreaks": "after" 142 | }, 143 | "* in pattern": { 144 | "force-linebreak": false, 145 | "spaces": "none", 146 | "linebreaks": "after" 147 | }, 148 | "(": { 149 | "force-linebreak": false, 150 | "spaces": "none", 151 | "linebreaks": "after" 152 | }, 153 | "[": { 154 | "force-linebreak": false, 155 | "spaces": "none", 156 | "linebreaks": "after" 157 | }, 158 | "[|": { 159 | "force-linebreak": false, 160 | "spaces": "none", 161 | "linebreaks": "none" 162 | }, 163 | "[p|": { 164 | "force-linebreak": false, 165 | "spaces": "none", 166 | "linebreaks": "none" 167 | }, 168 | "[d|": { 169 | "force-linebreak": false, 170 | "spaces": "none", 171 | "linebreaks": "none" 172 | }, 173 | "[t|": { 174 | "force-linebreak": false, 175 | "spaces": "none", 176 | "linebreaks": "none" 177 | } 178 | }, 179 | "layout": { 180 | "infix-app": "flex", 181 | "if": "flex", 182 | "import-spec-list": "flex", 183 | "con-decls": "vertical", 184 | "typesig": "try-oneline", 185 | "declaration": "flex", 186 | "app": "try-oneline", 187 | "let": "flex", 188 | "record": "try-oneline", 189 | "export-spec-list": "vertical", 190 | "list-comp": "try-oneline" 191 | }, 192 | "penalty": { 193 | "overfull": 10, 194 | "indent": 1, 195 | "overfull-once": 200, 196 | "max-line-length": 100, 197 | "linebreak": 100 198 | }, 199 | "indent": { 200 | "deriving": 2, 201 | "if": "align-or-indent-by 2", 202 | "let-binds": "align-or-indent-by 2", 203 | "import-spec-list": "align-or-indent-by 7", 204 | "onside": 2, 205 | "where": 2, 206 | "do": "indent-by 2", 207 | "app": "align", 208 | "case": "indent-by 2", 209 | "let-in": "indent-by 2", 210 | "where-binds": "indent-by 2", 211 | "let": "align-or-indent-by 2", 212 | "export-spec-list": "indent-by 2", 213 | "multi-if": "indent-by 2", 214 | "class": "indent-by 2" 215 | }, 216 | "align": { 217 | "let-binds": false, 218 | "where": true, 219 | "limits": [ 220 | 10, 221 | 25 222 | ], 223 | "case": true, 224 | "import-module": true, 225 | "import-spec": true, 226 | "class": false, 227 | "record-fields": true 228 | }, 229 | "options": { 230 | "sort-pragmas": true, 231 | "split-language-pragmas": true, 232 | "sort-import-lists": true, 233 | "preserve-vertical-space": true, 234 | "sort-imports": true 235 | } 236 | }, 237 | "language": "Haskell2010" 238 | } 239 | -------------------------------------------------------------------------------- /src/GHC/Compiler/Notes/Parser/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module GHC.Compiler.Notes.Parser.Internal where 4 | 5 | import Control.Applicative 6 | 7 | import Control.Monad 8 | import Control.Monad.Trans.Class 9 | import Control.Monad.Trans.State 10 | 11 | import qualified Data.Char as Char 12 | 13 | import Data.Coerce 14 | import Data.Conduit 15 | 16 | import Data.Monoid 17 | import qualified Data.Text as Text 18 | 19 | import qualified Data.Text.Extra as Text 20 | 21 | import GHC.Compiler.Notes.Types 22 | import GHC.Compiler.Utils.Lexer 23 | 24 | import Lexer (Token(..)) 25 | 26 | import SrcLoc 27 | 28 | import qualified Text.Regex.Applicative as Regex 29 | 30 | data CollectedNotesCtx = 31 | CollectedNotesCtx { cnCtxCollectedNotes :: CollectedNotes, cnCtxCommentIndent :: Int } 32 | 33 | initialCollectedNotesCtx :: CollectedNotesCtx 34 | initialCollectedNotesCtx = 35 | CollectedNotesCtx { cnCtxCollectedNotes = mempty, cnCtxCommentIndent = -1 } 36 | 37 | addNoteByCollectingInState :: Monad m => Located Note -> StateT CollectedNotesCtx m () 38 | addNoteByCollectingInState n = 39 | modify' \ctx -> ctx { cnCtxCollectedNotes = addNoteByCollecting n $ cnCtxCollectedNotes ctx } 40 | 41 | type CollectNotesStateParser o = StateT CollectedNotesCtx (ConduitT (Located Token) o Parser) 42 | 43 | type ParsingCtx = Located Text.Text 44 | 45 | addBufferByCollecting :: Bool -> Located String -> ParsingCtx -> ParsingCtx 46 | addBufferByCollecting b (L p2 s) (L p1 t) = L (combineSrcSpans p1 p2) $ 47 | t <> ls <> Text.pack s <> if b then "\n" else "" 48 | where 49 | n = betweenLineCount p1 p2 50 | 51 | ls = Text.replicate n "\n" 52 | 53 | betweenLineCount :: SrcSpan -> SrcSpan -> Int 54 | betweenLineCount (RealSrcSpan sp1) (RealSrcSpan sp2) = srcSpanEndLine sp2 - srcSpanEndLine sp1 - 1 55 | betweenLineCount _ _ = 0 56 | 57 | stripIndentedLineComment :: Monad m 58 | => Located String 59 | -> StateT CollectedNotesCtx m (Located String) 60 | stripIndentedLineComment (L p s) = case s of 61 | '-':'-':ns -> do 62 | m <- fmap cnCtxCommentIndent get 63 | go m 0 ns 64 | _ -> error "unreachable" 65 | where 66 | go !m !n ns = case ns of 67 | _ 68 | | m == n -> goEnd n ns 69 | ' ':ns' -> go m (n + 1) ns' 70 | [] -> goEnd m ns 71 | _ -> goEnd n ns 72 | 73 | goEnd n ns = do 74 | modify' \ctx -> ctx { cnCtxCommentIndent = n } 75 | pure $ L p ns 76 | 77 | endLineCommentContent :: Monad m => StateT CollectedNotesCtx m () 78 | endLineCommentContent = modify' \ctx -> ctx { cnCtxCommentIndent = -1 } 79 | 80 | initialParsingCtx :: Bool -> Located String -> ParsingCtx 81 | initialParsingCtx b (L p s) = L p $ Text.pack s <> if b then "\n" else "" 82 | 83 | isNoteStartLineComment :: Located String -> CollectNotesStateParser o (Maybe (Located String)) 84 | isNoteStartLineComment s = do 85 | ns <- stripIndentedLineComment s 86 | let ~m = pure Nothing 87 | case Regex.match noteTitleMatcher $ unLoc ns of 88 | Nothing -> m 89 | Just{} -> lift await >>= \case 90 | Nothing -> m 91 | Just t -> do 92 | lift $ leftover t 93 | case t of 94 | L p (ITlineComment s2) 95 | | isTopLevelSrcLoc $ srcSpanStart p -> do 96 | ns2 <- stripIndentedLineComment $ L p s2 97 | case Regex.match noteTitleSectionLineMatcher $ unLoc ns2 of 98 | Nothing -> m 99 | Just{} -> pure $ Just ns 100 | _ -> m 101 | 102 | noteTitleMatcher :: Regex.RE Char String 103 | noteTitleMatcher = "Note [" *> Regex.few Regex.anySym 104 | <* "]" 105 | <* spacesMatcher 106 | 107 | noteTitleSectionLineMatcher :: Regex.RE Char String 108 | noteTitleSectionLineMatcher = lineMatcher 109 | <* spacesMatcher 110 | where 111 | lineMatcher = getAlt $ mconcat $ coerce $ some . Regex.sym 112 | <$> [ '=' 113 | , '-' 114 | , '`' 115 | , ':' 116 | , '.' 117 | , '\'' 118 | , '"' 119 | , '~' 120 | , '^' 121 | , '_' 122 | -- , '*' -- for sub section 123 | , '+' 124 | , '#' 125 | ] 126 | 127 | isHorizontalRuleLineComment :: String -> Bool 128 | isHorizontalRuleLineComment ('-':'-':s) = case Regex.match horizontalRuleMatcher s of 129 | Just{} -> True 130 | Nothing -> False 131 | isHorizontalRuleLineComment _ = error "illegal line comment" 132 | 133 | horizontalRuleMatcher :: Regex.RE Char String 134 | horizontalRuleMatcher = some (Regex.sym '-') <* spacesMatcher 135 | 136 | spacesMatcher :: Regex.RE Char String 137 | spacesMatcher = many $ Regex.psym Char.isSpace 138 | 139 | sinkWaitingNoteComment :: CollectNotesStateParser o () 140 | sinkWaitingNoteComment = lift await >>= \case 141 | Nothing -> pure () 142 | Just (L p t) -> let ~m = do 143 | endLineCommentContent 144 | sinkWaitingNoteComment in case isTopLevelSrcLoc $ srcSpanStart p of 145 | False -> m 146 | True -> case t of 147 | ITlineComment s -> isNoteStartLineComment (L p s) >>= \case 148 | Just ns -> sinkParsingNoteComment $ initialParsingCtx True ns 149 | Nothing -> sinkWaitingNoteComment 150 | ITblockComment s -> parseBlockComment Nothing $ L p s 151 | _ -> m 152 | 153 | parseBlockComment :: Maybe ParsingCtx -> Located String -> CollectNotesStateParser o () 154 | parseBlockComment mctx s 155 | | isPragmaBlockComment $ unLoc s = case mctx of 156 | Nothing -> cont mctx 157 | Just ctx -> do 158 | completeParsingNote ctx 159 | cont Nothing 160 | | otherwise = runConduit $ sourceBlockCommentLines s .| sinkBlockCommentContents cont mctx 161 | where 162 | cont Nothing = sinkWaitingNoteComment 163 | cont (Just ctx) = sinkParsingNoteComment ctx 164 | 165 | isPragmaBlockComment :: String -> Bool 166 | isPragmaBlockComment = \case 167 | '{':'-':'#':s -> go s 168 | _ -> False 169 | where 170 | go "#-}" = True 171 | go [] = False 172 | go (_:ns) = go ns 173 | 174 | sourceBlockCommentLines :: Monad m => Located String -> ConduitT i (Located String) m () 175 | sourceBlockCommentLines (L p s) = case s of 176 | '{':'-':ns -> let l = srcSpanStart p in go l l id ns 177 | _ -> error "unreachable" 178 | where 179 | go sl !el chunk "-}" = yield $ L (mkSrcSpan sl el) $ chunk [] 180 | go sl !el chunk (c:ns) = let el' = advanceSrcLocFromChar el c 181 | nchunk = chunk . (c :) in case c of 182 | '\n' -> do 183 | yield $ L (mkSrcSpan sl el) $ nchunk [] 184 | go el' el' id ns 185 | _ -> go sl el' nchunk ns 186 | go _ _ _ [] = error "unreachable" 187 | 188 | advanceSrcLocFromChar :: SrcLoc -> Char -> SrcLoc 189 | advanceSrcLocFromChar (RealSrcLoc l) c = RealSrcLoc $ advanceSrcLoc l c 190 | advanceSrcLocFromChar l _ = l 191 | 192 | sinkBlockCommentContents :: (Maybe ParsingCtx -> CollectNotesStateParser o2 ()) 193 | -> Maybe ParsingCtx 194 | -> ConduitT (Located String) o (CollectNotesStateParser o2) () 195 | sinkBlockCommentContents cont = goStart 196 | where 197 | goStart mctx = await >>= \case 198 | Nothing -> lift $ cont mctx 199 | Just (L p s) -> do 200 | leftover $ L p $ dropWhile Char.isSpace s 201 | case mctx of 202 | Nothing -> goWaitingNote 203 | Just ctx -> goParsingNote ctx 204 | 205 | goWaitingNote = await >>= \case 206 | Nothing -> lift $ cont Nothing 207 | Just s -> isNoteStartLine s >>= \case 208 | Just ns -> goParsingNote $ initialParsingCtx False ns 209 | Nothing -> goWaitingNote 210 | 211 | goParsingNote ctx = await >>= \case 212 | Nothing -> lift $ cont $ Just ctx 213 | Just s -> isNoteStartLine s >>= \case 214 | Just ns -> do 215 | lift $ completeParsingNote ctx 216 | goParsingNote $ initialParsingCtx False ns 217 | Nothing -> isSectionStartComment s >>= \case 218 | True -> do 219 | lift $ completeParsingNote ctx 220 | goWaitingNote 221 | False -> do 222 | let ns = s -- TODO: indentation parsing 223 | let nctx = addBufferByCollecting False ns ctx 224 | goParsingNote nctx 225 | 226 | isNoteStartLine s = do 227 | let ns = s -- TODO: indentation parsing 228 | let ~m = pure Nothing 229 | case Regex.match noteTitleMatcher $ unLoc ns of 230 | Nothing -> m 231 | Just{} -> await >>= \case 232 | Nothing -> m 233 | Just s2 -> do 234 | leftover s2 235 | let ns2 = s2 -- TODO: indentation parsing 236 | case Regex.match noteTitleSectionLineMatcher $ unLoc ns2 of 237 | Nothing -> m 238 | Just{} -> pure $ Just ns 239 | 240 | isSectionStartComment s = case Regex.match sectionLineMatcher $ unLoc s of 241 | Nothing -> pure False 242 | Just{} -> await >>= \case 243 | Nothing -> pure False 244 | Just s2 -> do 245 | leftover s2 246 | case unLoc s2 of 247 | '*':_ -> pure True 248 | _ -> pure False 249 | 250 | sectionLineMatcher = some (Regex.sym '*') 251 | <* spacesMatcher 252 | 253 | sinkParsingNoteComment :: ParsingCtx -> CollectNotesStateParser o () 254 | sinkParsingNoteComment ctx = lift await >>= \case 255 | Nothing -> pure () 256 | Just (L p t) -> let ~m = do 257 | completeParsingNote ctx 258 | endLineCommentContent 259 | sinkWaitingNoteComment in case isTopLevelSrcLoc $ srcSpanStart p of 260 | False -> m 261 | True -> case t of 262 | ITdocCommentNamed s -> let nctx = addBufferByCollecting True (removeNamedTag $ L p s) ctx 263 | in sinkParsingNoteComment nctx 264 | ITlineComment s -> if isHorizontalRuleLineComment s 265 | then m 266 | else isNoteStartLineComment (L p s) >>= \case 267 | Just ns -> do 268 | completeParsingNote ctx 269 | sinkParsingNoteComment $ initialParsingCtx True ns 270 | Nothing -> do 271 | ns <- stripIndentedLineComment $ L p s 272 | let nctx = addBufferByCollecting True ns ctx 273 | sinkParsingNoteComment nctx 274 | ITblockComment s -> parseBlockComment (Just ctx) $ L p s 275 | ITsemi -> sinkParsingNoteComment ctx -- skip layout tokens 276 | _ -> m 277 | where 278 | removeNamedTag (L p s) = removeNamedTag' (srcSpanStart p) (srcSpanEnd p) s 279 | 280 | removeNamedTag' sl el [] = L (mkSrcSpan sl el) [] 281 | removeNamedTag' sl el (c:s) = let sl' = advanceSrcLocFromChar sl c in case c of 282 | '\n' -> L (mkSrcSpan sl' el) s 283 | _ -> removeNamedTag' sl' el s 284 | 285 | completeParsingNote :: ParsingCtx -> CollectNotesStateParser o () 286 | completeParsingNote (L p buf) = addNoteByCollectingInState $ L p $ 287 | Note { noteId = noteIdFromBuf, noteContent = noteContentFromBuf } 288 | where 289 | noteIdFromBuf = let firstLine = Text.takeWhile (/= '\n') buf 290 | in case Regex.match noteTitleMatcher $ Text.unpack firstLine of 291 | Nothing -> error "unreachable" 292 | Just title -> NoteId $ Text.pack title 293 | 294 | noteContentFromBuf = 295 | let skipTwoLine c = do 296 | i <- get 297 | if i >= 2 then pure False else do 298 | when (c == '\n') do 299 | put $ i + 1 300 | pure True in Text.stripEmptyLines $ 301 | evalState (Text.dropWhileM skipTwoLine buf) (0 :: Int) 302 | 303 | isTopLevelSrcLoc :: SrcLoc -> Bool 304 | isTopLevelSrcLoc UnhelpfulLoc{} = False 305 | isTopLevelSrcLoc (RealSrcLoc l) = srcLocCol l == 1 306 | -------------------------------------------------------------------------------- /src/GHC/Compiler/Utils/HeaderOptions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module GHC.Compiler.Utils.HeaderOptions where 4 | 5 | import Bag (unitBag) 6 | 7 | import Control.Monad 8 | import Control.Monad.IO.Class 9 | 10 | import Data.Functor 11 | import Data.List (intercalate) 12 | import Data.Maybe (catMaybes) 13 | import Data.Version 14 | 15 | import DynFlags 16 | 17 | import ErrUtils 18 | 19 | import Exception 20 | 21 | import FastString 22 | 23 | import FileCleanup 24 | 25 | import GHC.Compiler.Utils.Lexer 26 | 27 | import qualified GHC.LanguageExtensions as LangExt 28 | 29 | import HeaderInfo 30 | 31 | import HscTypes 32 | 33 | import Lexer 34 | 35 | import Module 36 | 37 | import Outputable 38 | 39 | import Packages 40 | 41 | import Panic 42 | 43 | import Prelude hiding ((<>)) 44 | 45 | import SrcLoc 46 | 47 | import StringBuffer 48 | 49 | import SysTools 50 | 51 | import System.Directory 52 | import System.FilePath 53 | import qualified System.IO.Temp as Temp 54 | 55 | import Util 56 | 57 | -- See https://hackage.haskell.org/package/ghc-8.6.1/docs/src/DriverPipeline.html#line-917 58 | parseDynFlagsFromHsFileHead :: MonadIO m => DynFlags -> FilePath -> m DynFlags 59 | parseDynFlagsFromHsFileHead dflags inputFn = do 60 | let dflags0 = dflags `gopt_unset` Opt_Haddock `gopt_unset` Opt_KeepRawTokenStream 61 | 62 | srcOpts <- liftIO $ getOptionsFromFile dflags0 inputFn 63 | (dflags1, unhandledFlags, _) <- parseDynamicFilePragma dflags srcOpts 64 | checkProcessArgsResult dflags unhandledFlags 65 | 66 | pure dflags1 67 | 68 | runParserMayPreprocessFromFile 69 | :: MonadIO m 70 | => Parser a 71 | -> DynFlags 72 | -> FilePath 73 | -> m (Either ParseFailed a) 74 | runParserMayPreprocessFromFile p dflags fn = do 75 | dflagsWithOptions <- parseDynFlagsFromHsFileHead dflags fn 76 | ebuf <- if LangExt.Cpp `xopt` dflagsWithOptions then liftIO $ 77 | Temp.withTempDirectory (sTmpDir $ settings dflagsWithOptions) 78 | "GHC-Compiler-Notes-runParserMayPreprocessFromFile" \tdir -> do 79 | let outFn = tdir takeFileName fn 80 | r <- (doCpp dflagsWithOptions True fn outFn *> pure Nothing) `catch` \(e :: GhcException) -> 81 | pure $ Just e 82 | case r of 83 | Just e -> pure $ Left e 84 | Nothing -> do 85 | -- avoid lazy I/O 86 | s <- readFile outFn 87 | length s `seq` (pure $ Right $ stringToStringBuffer s) else do 88 | s <- liftIO $ readFile fn 89 | pure $ Right $ stringToStringBuffer s 90 | case ebuf of 91 | -- FIXME: to ParseFailed 92 | Left e -> do 93 | liftIO $ print e 94 | pure $ Left $ ParseFailed [] 95 | Right buf -> pure $ runParser p dflagsWithOptions buf loc 96 | where 97 | loc = mkRealSrcLoc (mkFastString fn) 1 1 98 | #include "ghcplatform.h" 99 | 100 | -- TODO: To use cpphs 101 | -- See https://hackage.haskell.org/package/ghc-8.6.1/docs/src/DriverPipeline.html#doCpp 102 | doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () 103 | doCpp dflags raw input_fn output_fn = do 104 | let hscpp_opts = picPOpts dflags 105 | let cmdline_include_paths = includePaths dflags 106 | 107 | pkg_include_dirs <- getPackageIncludePath dflags [] 108 | let include_paths_global = foldr (\x xs -> ("-I" ++ x) : xs) 109 | [] 110 | (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) 111 | let include_paths_quote = 112 | foldr (\x xs -> ("-iquote" ++ x) : xs) [] (includePathsQuote cmdline_include_paths) 113 | let include_paths = include_paths_quote ++ include_paths_global 114 | 115 | let verbFlags = getVerbFlags dflags 116 | 117 | let cpp_prog args 118 | | raw = SysTools.runCpp dflags args 119 | | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) 120 | 121 | let target_defs = [ "-D" ++ HOST_OS ++ "_BUILD_OS" 122 | , "-D" ++ HOST_ARCH ++ "_BUILD_ARCH" 123 | , "-D" ++ TARGET_OS ++ "_HOST_OS" 124 | , "-D" ++ TARGET_ARCH ++ "_HOST_ARCH" 125 | ] 126 | -- remember, in code we *compile*, the HOST is the same our TARGET, 127 | -- and BUILD is the same as our HOST. 128 | let sse_defs = ["-D__SSE__" | isSseEnabled dflags] ++ ["-D__SSE2__" | isSse2Enabled dflags] 129 | ++ ["-D__SSE4_2__" | isSse4_2Enabled dflags] 130 | 131 | let avx_defs = ["-D__AVX__" | isAvxEnabled dflags] ++ ["-D__AVX2__" | isAvx2Enabled dflags] 132 | ++ ["-D__AVX512CD__" | isAvx512cdEnabled dflags] 133 | ++ ["-D__AVX512ER__" | isAvx512erEnabled dflags] 134 | ++ ["-D__AVX512F__" | isAvx512fEnabled dflags] 135 | ++ ["-D__AVX512PF__" | isAvx512pfEnabled dflags] 136 | 137 | backend_defs <- getBackendDefs dflags 138 | 139 | let th_defs = ["-D__GLASGOW_HASKELL_TH__"] 140 | -- Default CPP defines in Haskell source 141 | ghcVersionH <- getGhcVersionPathName dflags 142 | let hsSourceCppOpts = ["-include", ghcVersionH] 143 | 144 | -- MIN_VERSION macros 145 | let uids = explicitPackages (pkgState dflags) 146 | pkgs = catMaybes (map (lookupPackage dflags) uids) 147 | mb_macro_include <- if not (null pkgs) && gopt Opt_VersionMacros dflags then do 148 | macro_stub <- newTempName dflags TFL_CurrentModule "h" 149 | writeFile macro_stub (generatePackageVersionMacros pkgs) 150 | -- Include version macros for every *exposed* package. 151 | -- Without -hide-all-packages and with a package database 152 | -- size of 1000 packages, it takes cpp an estimated 2 153 | -- milliseconds to process this file. See Trac #10970 154 | -- comment 8. 155 | return [SysTools.FileOption "-include" macro_stub] else return [] 156 | 157 | cpp_prog (map SysTools.Option verbFlags ++ map SysTools.Option include_paths 158 | ++ map SysTools.Option hsSourceCppOpts ++ map SysTools.Option target_defs 159 | ++ map SysTools.Option backend_defs ++ map SysTools.Option th_defs 160 | ++ map SysTools.Option hscpp_opts ++ map SysTools.Option sse_defs 161 | ++ map SysTools.Option avx_defs ++ mb_macro_include 162 | ++ [ SysTools.Option "-x" 163 | , SysTools.Option "assembler-with-cpp" 164 | , SysTools.Option input_fn 165 | -- We hackily use Option instead of FileOption here, so that the file 166 | -- name is not back-slashed on Windows. cpp is capable of 167 | -- dealing with / in filenames, so it works fine. Furthermore 168 | -- if we put in backslashes, cpp outputs #line directives 169 | -- with *double* backslashes. And that in turn means that 170 | -- our error messages get double backslashes in them. 171 | -- In due course we should arrange that the lexer deals 172 | -- with these \\ escapes properly. 173 | , SysTools.Option "-o" 174 | , SysTools.FileOption "" output_fn 175 | ]) 176 | 177 | -- See https://hackage.haskell.org/package/ghc-8.6.1/docs/src/HeaderInfo.html#getOptions%27 178 | getOptionsFromTokenStream :: DynFlags -> Parser [Located String] 179 | getOptionsFromTokenStream dflags = parseToksWithFullArg 180 | where 181 | pToken = lexer False pure 182 | 183 | getToken (L _loc tok) = tok 184 | 185 | -- getLoc (L loc _tok) = loc 186 | parseToksWithFullArg = do 187 | arg1 <- pToken 188 | parseToksWith1Arg arg1 189 | 190 | parseToksWith1Arg arg1 = do 191 | arg2 <- pToken 192 | parseToks arg1 arg2 193 | 194 | parseToks open close 195 | | IToptions_prag str <- getToken open, ITclose_prag <- getToken close = case toArgs str of 196 | Left err -> panic ("getOptions'.parseToks: " ++ err) 197 | Right args -> (map (L (getLoc open)) args ++) 198 | <$> parseToksWithFullArg 199 | parseToks open close 200 | | ITinclude_prag str <- getToken open, ITclose_prag 201 | <- getToken close = (map (L (getLoc open)) ["-#include", removeSpaces str] ++) 202 | <$> parseToksWithFullArg 203 | parseToks open close 204 | | ITdocOptions str <- getToken open, ITclose_prag 205 | <- getToken close = (map (L (getLoc open)) ["-haddock-opts", removeSpaces str] ++) 206 | <$> parseToksWithFullArg 207 | parseToks open rarg1 208 | | ITlanguage_prag <- getToken open = parseLanguage rarg1 209 | parseToks comment rarg1 -- Skip over comments 210 | | isComment (getToken comment) = parseToksWith1Arg rarg1 211 | parseToks _ _ = pure [] 212 | 213 | parseLanguage (L loc1 (ITconid fs)) = (checkExtension dflags (L loc1 fs) :) 214 | <$> do 215 | pToken >>= \case 216 | L _loc2 ITcomma -> pToken >>= parseLanguage 217 | L _loc2 ITclose_prag -> pToken >>= parseLanguage 218 | L loc2 _ -> languagePragParseError dflags loc2 219 | -- [] -> panic "getOptions'.parseLanguage(1) went past eof token" 220 | parseLanguage tok = 221 | languagePragParseError dflags 222 | (getLoc tok) 223 | {- 224 | parseLanguage [] 225 | = panic "getOptions'.parseLanguage(2) went past eof token" 226 | -} 227 | 228 | isComment :: Token -> Bool 229 | isComment c = case c of 230 | (ITlineComment{}) -> True 231 | (ITblockComment{}) -> True 232 | (ITdocCommentNext{}) -> True 233 | (ITdocCommentPrev{}) -> True 234 | (ITdocCommentNamed{}) -> True 235 | (ITdocSection{}) -> True 236 | _ -> False 237 | 238 | languagePragParseError :: DynFlags -> SrcSpan -> a 239 | languagePragParseError dflags loc = throw $ mkSrcErr $ unitBag $ 240 | (mkPlainErrMsg dflags loc $ 241 | vcat [ text "Cannot parse LANGUAGE pragma" 242 | , text "Expecting comma-separated list of language options," 243 | , text "each starting with a capital letter" 244 | , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") 245 | ]) 246 | 247 | checkExtension :: DynFlags -> Located FastString -> Located String 248 | checkExtension dflags (L l ext) 249 | -- Checks if a given extension is valid, and if so returns 250 | -- its corresponding flag. Otherwise it throws an exception. 251 | = let ext' = unpackFS ext in if ext' `elem` supportedLanguagesAndExtensions 252 | then L l ("-X" ++ ext') else unsupportedExtnError dflags l ext' 253 | 254 | unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a 255 | unsupportedExtnError dflags loc unsup = throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc $ 256 | text "Unsupported extension: " <> text unsup $$if null suggestions then Outputable.empty 257 | else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) 258 | where 259 | suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions 260 | 261 | -- See https://hackage.haskell.org/package/ghc-8.6.1/docs/src/DriverPipeline.html#getBackendDefs 262 | getBackendDefs :: DynFlags -> IO [String] 263 | getBackendDefs dflags 264 | | hscTarget dflags == HscLlvm = do 265 | llvmVer <- figureLlvmVersion dflags 266 | return $ case llvmVer of 267 | Just n -> ["-D__GLASGOW_HASKELL_LLVM__=" ++ format n] 268 | _ -> [] 269 | where 270 | format (major, minor) 271 | | minor >= 100 = error "getBackendDefs: Unsupported minor version" 272 | | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int 273 | getBackendDefs _ = return [] 274 | 275 | -- See https://hackage.haskell.org/package/ghc-8.6.1/docs/src/DriverPipeline.html#getGhcVersionPathName 276 | getGhcVersionPathName :: DynFlags -> IO FilePath 277 | getGhcVersionPathName dflags = do 278 | candidates <- case ghcVersionFile dflags of 279 | Just path -> return [path] 280 | Nothing -> (map ( "ghcversion.h")) 281 | <$> (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]) 282 | 283 | found <- filterM doesFileExist candidates 284 | case found of 285 | [] -> throwGhcExceptionIO (InstallationError ("ghcversion.h missing; tried: " 286 | ++ intercalate ", " candidates)) 287 | (x:_) -> return x 288 | 289 | -- See https://hackage.haskell.org/package/ghc-8.6.1/docs/src/DriverPipeline.html#generatePackageVersionMacros 290 | generatePackageVersionMacros :: [PackageConfig] -> String 291 | generatePackageVersionMacros pkgs = 292 | concat 293 | -- Do not add any C-style comments. See Trac #3389. 294 | [generateMacros "" pkgname version 295 | | pkg <- pkgs 296 | , let version = packageVersion pkg 297 | pkgname = map fixchar (packageNameString pkg) 298 | ] 299 | 300 | -- See https://hackage.haskell.org/package/ghc-8.6.1/docs/src/DriverPipeline.html#fixchar 301 | fixchar :: Char -> Char 302 | fixchar '-' = '_' 303 | fixchar c = c 304 | 305 | -- See https://hackage.haskell.org/package/ghc-8.6.1/docs/src/DriverPipeline.html#generateMacros 306 | generateMacros :: String -> String -> Version -> String 307 | generateMacros prefix name version = 308 | concat [ "#define " 309 | , prefix 310 | , "VERSION_" 311 | , name 312 | , " " 313 | , show (showVersion version) 314 | , "\n" 315 | , "#define MIN_" 316 | , prefix 317 | , "VERSION_" 318 | , name 319 | , "(major1,major2,minor) (\\\n" 320 | , " (major1) < " 321 | , major1 322 | , " || \\\n" 323 | , " (major1) == " 324 | , major1 325 | , " && (major2) < " 326 | , major2 327 | , " || \\\n" 328 | , " (major1) == " 329 | , major1 330 | , " && (major2) == " 331 | , major2 332 | , " && (minor) <= " 333 | , minor 334 | , ")" 335 | , "\n\n" 336 | ] 337 | where 338 | unconsVersionBranch [] = ("0", []) 339 | unconsVersionBranch (v:vs) = (v, vs) 340 | 341 | (major1, (major2, (minor, _))) = let vs = map show $ versionBranch version 342 | in unconsVersionBranch vs <&> \vs0 -> unconsVersionBranch vs0 <&> unconsVersionBranch 343 | --------------------------------------------------------------------------------