├── .circleci └── config.yml ├── .ghci ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── data └── lts-10.5.yaml ├── default.nix ├── ex-hack.cabal ├── img ├── gh-screenshot.jpg └── logo │ ├── README.md │ ├── ex-hack-full-src.svg │ ├── ex-hack-full.svg │ ├── ex-hack-logo-src.svg │ └── ex-hack-logo.svg ├── misc └── useful-requests.sql ├── nix ├── cabal-helper.nix ├── ex-hack.nix └── selda-sqlite.nix ├── shell.nix ├── src └── ExHack │ ├── Cabal │ └── CabalParser.hs │ ├── Data │ └── Db.hs │ ├── Ghc.hs │ ├── Hackage │ └── Hackage.hs │ ├── ModulePaths.hs │ ├── ProcessingSteps.hs │ ├── Renderer │ ├── Html.hs │ ├── Types.hs │ └── templates │ │ ├── header.hamlet │ │ ├── homePage.hamlet │ │ ├── index.html │ │ ├── menu.hamlet │ │ ├── module.html │ │ ├── modulePage.hamlet │ │ ├── package.html │ │ ├── packagePage.hamlet │ │ └── static │ │ ├── Inter-UI-Regular.woff │ │ ├── list.min.js │ │ └── style.css │ ├── Stackage │ ├── Stack.hs │ ├── StackageParser.hs │ └── StackageTypes.hs │ ├── Types.hs │ └── Utils.hs ├── stack.yaml └── test ├── integration ├── ExHack │ └── Hackage │ │ └── IntegrationHackageSpec.hs ├── Int.hs └── fixtures │ ├── cabal │ ├── text.cabal │ └── timeit.cabal │ └── tarballs │ ├── BiobaseNewick.tar.gz │ ├── StateVar.tar.gz │ ├── text.tar.gz │ └── timeit.tar.gz └── unit ├── ExHack ├── CabalSpec.hs ├── ModulePathSpec.hs └── StackageSpec.hs ├── Spec.hs └── fixtures ├── cabal-fixture.cabal ├── config-fixture.yaml └── stack-fixture.yaml /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 1 2 | jobs: 3 | build: 4 | machine: true 5 | steps: 6 | - checkout 7 | - run: 8 | name: Install Nix 9 | # Note: we need to install stack since we can't run the tests directly from the nix-build 10 | # command because of some cabal-helper dark magic. 11 | command: 'sudo mkdir -p /nix && sudo chown circleci /nix && curl https://nixos.org/nix/install | sh && echo "source ~/.nix-profile/etc/profile.d/nix.sh" >> ~/.circlerc && source ~/.circlerc' 12 | - run: 13 | name: Run Ex-Hack test suite 14 | # Note: cabal-helper will get mad if we don't update our cabal pkg 15 | command: 'source ~/.circlerc && mkdir -p test/integration/workdir test/integration/output && nix-shell --run "cabal test unit-tests"' 16 | -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set -i./src 2 | :set -i./app 3 | :set -i./test/integration 4 | :set -i./test/unit 5 | :set -Wall 6 | :load Main 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Ex-Hack: Hackage Example Database 2 | 3 | [![CircleCI](https://circleci.com/gh/NinjaTrappeur/ex-hack.svg?style=svg)](https://circleci.com/gh/NinjaTrappeur/ex-hack) 4 | 5 | [![Ex-Hack Logo](img/logo/ex-hack-full.svg)](https://exhack.org) 6 | 7 | *[Ex-Hack-tement Jamy!](https://en.wikipedia.org/wiki/Jamy_Gourmaud)* 8 | 9 | Ex-Hack, shorthand for Hackage EXamples is a Haskell 10 | example-based documentation. 11 | 12 | https://exhack.org 13 | 14 | **Note: This is an alpha release. See the How to Contribute section to help us 15 | making this tool more reliable/complete.** 16 | 17 | ![Screenshot showcasing the Ex-Hack HTML documentation](img/gh-screenshot.jpg) 18 | 19 | ## Abstract 20 | 21 | Ex-Hack is a CLI tool able to generate an example-based documentation from a 22 | stackage build plan. 23 | 24 | It may be useful: 25 | 26 | - For stackage users to learn how to use a library missing proper documentation 27 | - For library maintainers as a way to see which symbols are mostly used in the 28 | wild before performing an API refactoring. 29 | 30 | **/!\ Again, this is an alpha release.** We may miss a lot of symbols 31 | occurrences, please do not use this tool as a way to assess your API usage yet. 32 | 33 | ## How to Use? 34 | 35 | 1. Build and install ex-hack. 36 | 1. Download a Stackage build plan from [this 37 | repo](https://github.com/commercialhaskell/lts-haskell). **Note**: Ex-Hack 38 | not yet compatible with the GHC 8.6 line. 39 | 1. Run ex-hack -s ${stackageFile} to generate the documentation. **Note**: this 40 | process will download, build and index the whole Stackage packages. It will 41 | take quite some time. 42 | 43 | ## How to Contribute? 44 | 45 | First, pick an issue labelled as 46 | [todo](https://github.com/NinjaTrappeur/ex-hack/issues?q=is%3Aissue+is%3Aopen+label%3ATodo), 47 | fork the project, fix the issue, add some tests and open a PR. 48 | 49 | We use this repository as main form of communication. If you have some 50 | questions/need a more informal channel to get in touch with us, you can join 51 | the [#ex-hack](http://webchat.freenode.net?channels=%23ex-hack) channel on the 52 | freenode irc network. 53 | 54 | ## Architecture Overview 55 | 56 | The software is built around the `processing step` notion. Basically, a 57 | processing step is an atomic transformation applied to every package. Each 58 | processing step is dependent from the previous one and is a dependency for the 59 | next one. 60 | 61 | Because of this, every processing step can be distributed on several processes 62 | or machines using a map/reduce strategy. 63 | 64 | There are currently 8 processing steps: 65 | 66 | 1. **Generate database scheme**: initialize the database. 67 | 2. **Parse the Stackage YAML description**: parse the stackage YAML file. 68 | 3. **Download assets (cabal + tarballs)**. 69 | 4. **Generate the package dependency graph**: generate a dependency graph using 70 | the downloaded cabal files. 71 | 5. **Save the dependency graph to the database**. 72 | 6. **Retrieve the packages exported symbols**: for each package, we will look 73 | for an exposed library, load and type-checking it in GHC using the GHC API to 74 | finally retrieve all of the exported symbols. 75 | 7. **Index the used symbols**: we parse every source file of every package and 76 | look for occurrences of the symbols retrieved in the previous step. 77 | 8. **Generate the HTML documentation**: we render the ex-hack SQLite database 78 | into a static HTML documentation. This documentation can either be served on 79 | the web, or consulted locally. 80 | 81 | 82 | ## Development Tooling 83 | 84 | You can either use [Nix](https://nixos.org/nix/) or 85 | [Stack](https://hackage.haskell.org/package/stack) to build/install ex-hack. 86 | 87 | Both the project's maintainer and the CI are using Nix as the primary build 88 | tool, the stack build may be broken. If that's the case, please open an issue 89 | and submit a PR fixing the issue (if you can :)). 90 | 91 | **Note:** You don't necessarily need NixOS to use Nix, you probably can do it on your 92 | favorite OS. 93 | 94 | ### How to Generate the Doc? 95 | 96 | Once you installed ex-hack, you can download a Stackage build plan and generate 97 | the associated documentation with 98 | 99 | ``` 100 | ex-hack -s stackage_file.yml 101 | ``` 102 | 103 | By default, the files will be generated in your `XDG_DATA/ex-hack/output` directory. 104 | That will be `.local/share/ex-hack/output` on Linux. Once generated, you can 105 | either copy this static HTML documentation to the web-server you want to deploy 106 | it onto or spawn a small local web-server to browse it. 107 | 108 | These directory can be overridden, check out the appropriate flags using the 109 | `--help` argument. 110 | 111 | You may want to save the logs on top of displaying them: 112 | 113 | ``` 114 | ex-hack -s lts-12.11.yaml 2>&1 | tee ex-hack-run.log 115 | ``` 116 | 117 | ### How to Install? 118 | 119 | #### Using Cachix as Binary Cache 120 | 121 | TODO 122 | 123 | #### With Nix 124 | 125 | ``` 126 | cd ${ex-hack dir} 127 | nix-env -f default.nix -iA ex-hack 128 | ``` 129 | 130 | #### With Stack 131 | 132 | Check that the `./local/bin` directory is in your `$PATH`. 133 | 134 | ``` 135 | cd ${ex-hack dir} 136 | stack install 137 | ``` 138 | 139 | ### How to Build? 140 | 141 | #### Using Nix 142 | 143 | To work on ex-hack interactively: 144 | 145 | ``` 146 | nix-shell 147 | cabal build 148 | ``` 149 | 150 | To test the nix release system: 151 | 152 | ``` 153 | nix-build 154 | ``` 155 | 156 | #### Using Stack 157 | 158 | ``` 159 | stack build 160 | ``` 161 | 162 | ### How to Test? 163 | 164 | There are currently two test suites: a unit one and an integration one. 165 | 166 | Running the integration test suite can take quite some time (~1 minute on my 167 | 7yo desktop). 168 | 169 | #### Using Nix 170 | 171 | ``` 172 | nix-shell 173 | # Run both the unit and integration tests 174 | cabal test 175 | # Run unit tests only 176 | cabal test unit-tests 177 | # Run integration tests only 178 | cabal test integration-tests 179 | ``` 180 | 181 | Unfortunately, you can't test ex-hack using the nix-build command. For some 182 | reason, cabal-helper doesn't like being used from within the nix-store 183 | environment. 184 | 185 | #### Using Stack 186 | 187 | ``` 188 | stack test 189 | ``` 190 | 191 | ### How to Profile? 192 | 193 | You'll either need to build the nix expression with the profile parameter 194 | enabled: 195 | 196 | ``` 197 | nix-shell --arg profile true 198 | #or 199 | nix-build --arg profile true 200 | ``` 201 | If you are interactively using cabal to build and debug your project, you can 202 | enable the profiling by using: 203 | 204 | ``` 205 | cabal configure --enable-profiling --flags=profiling 206 | cabal build 207 | ``` 208 | 209 | Then, use the regular [RTS profiling 210 | options](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/profiling.html) 211 | to either profile the heap or get an overview of the cost centers. 212 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Main where 6 | 7 | import Control.Lens.Getter ((^.)) 8 | import Options.Applicative (execParser, failureCode, help, helper, 9 | info, long, metavar, short, strOption, 10 | value, (<**>)) 11 | import System.Directory (XdgDirectory (XdgData), 12 | createDirectoryIfMissing, 13 | getXdgDirectory, listDirectory, 14 | removeDirectoryRecursive) 15 | import System.FilePath (()) 16 | import System.IO (BufferMode (NoBuffering), 17 | hSetBuffering, stdin, stdout) 18 | 19 | 20 | import ExHack.ProcessingSteps (dlAssets, genGraphDep, generateDb, 21 | generateHtmlPages, indexSymbols, 22 | parseStackage, retrievePkgsExports, 23 | saveGraphDep) 24 | import ExHack.Types (CabalFilesDir (..), Config (..), 25 | DatabaseHandle, DatabaseStatus (..), 26 | HtmlDir (..), StackageFile (..), 27 | TarballsDir (..), WorkDir (..), 28 | cabalFilesDir, getDatabaseHandle, 29 | htmlDir, newDatabaseHandle, runStep, 30 | tarballsDir, workDir) 31 | 32 | main :: IO () 33 | main = do 34 | hSetBuffering stdin NoBuffering 35 | hSetBuffering stdout NoBuffering 36 | c <- parseOpts 37 | createConfigDirs c 38 | dbInit <- shouldBypassDBInit (_dbHandle c) $ runStep generateDb c 39 | let ci = c {_dbHandle= dbInit} :: Config 'Initialized 40 | descs <- runStep parseStackage ci 41 | shouldBypassAssetsDl (_tarballsDir c) (_cabalFilesDir c) $ runStep (dlAssets descs) ci 42 | !pkgs <- runStep (genGraphDep descs) ci 43 | dbGraph <- shouldBypassGraphDepsGen dbInit $ runStep (saveGraphDep pkgs) ci 44 | let cg = ci {_dbHandle=dbGraph} :: Config 'DepsGraph 45 | dbExprt <- runStep (retrievePkgsExports pkgs) cg 46 | let ce = cg {_dbHandle=dbExprt} :: Config 'PkgExports 47 | dbIdx <- runStep (indexSymbols pkgs) ce 48 | let cidx = ce {_dbHandle=dbIdx} :: Config 'IndexedSyms 49 | runStep generateHtmlPages cidx 50 | pure () 51 | 52 | createConfigDirs :: Config 'New -> IO () 53 | createConfigDirs c = do 54 | let TarballsDir tbd = c ^. tarballsDir 55 | CabalFilesDir cbd = c ^. cabalFilesDir 56 | WorkDir wd = c ^. workDir 57 | HtmlDir htd = c ^. htmlDir 58 | createDirectoryIfMissing True tbd 59 | createDirectoryIfMissing True cbd 60 | createDirectoryIfMissing True wd 61 | createDirectoryIfMissing True htd 62 | 63 | shouldBypassDBInit :: DatabaseHandle 'New -> IO (DatabaseHandle 'Initialized) -> IO (DatabaseHandle 'Initialized) 64 | shouldBypassDBInit dbh s = 65 | promptUser "Do you wanna empty and init the database?" 66 | s 67 | (pure . snd $ getDatabaseHandle dbh) 68 | 69 | shouldBypassAssetsDl :: TarballsDir -> CabalFilesDir -> IO () -> IO () 70 | shouldBypassAssetsDl (TarballsDir fpt) (CabalFilesDir fpc) s = do 71 | dirT <- listDirectory fpt 72 | dirC <- listDirectory fpc 73 | if null (dirT <> dirC) 74 | then s 75 | else promptUser "Your assets folder is not empty. Do you want to empty it and re-download everything?" 76 | (removeDirectoryRecursive fpt >> removeDirectoryRecursive fpc >> s) 77 | (pure ()) 78 | 79 | shouldBypassGraphDepsGen :: DatabaseHandle 'Initialized -> IO (DatabaseHandle 'DepsGraph) -> IO (DatabaseHandle 'DepsGraph) 80 | shouldBypassGraphDepsGen h s = 81 | promptUser "Do you wanna save the dependancy graph to the db?" 82 | s 83 | (pure . snd $ getDatabaseHandle h) 84 | 85 | promptUser :: String -> IO a -> IO a -> IO a 86 | promptUser str true false = do 87 | putStrLn (str <> " [y/N]") 88 | res <- getLine 89 | if null res || head (words res) == "n" || head (words res) == "N" 90 | then false 91 | else true 92 | 93 | parseOpts :: IO (Config 'New) 94 | parseOpts = do 95 | dataDir <- getXdgDirectory XdgData "ex-hack" 96 | let dfttarballs = dataDir "tarballs" 97 | dftcabal = dataDir "cabal-files" 98 | dftworkdir = dataDir "workdir" 99 | dftdb = dataDir "database.sqlite" 100 | dftoutdir = dataDir "output" 101 | let parser = Config 102 | <$> (newDatabaseHandle <$> strOption 103 | (long "database-filepath" 104 | <> short 'd' 105 | <> value dftdb 106 | <> metavar "DB_FILEPATH" 107 | <> help "Path to the database file")) 108 | <*> (StackageFile <$> strOption 109 | (long "stackage-filepath" 110 | <> short 's' 111 | <> metavar "STACKAGE_FILE" 112 | <> help "Stackage build plan file")) 113 | <*> (TarballsDir <$> strOption 114 | (long "tarballs-directory" 115 | <> short 't' 116 | <> value dfttarballs 117 | <> metavar "TARBALLS_DIR" 118 | <> help "Directory in which the tarballs will be downloaded")) 119 | <*> (CabalFilesDir <$> strOption 120 | (long "cabal-files-directory" 121 | <> short 'c' 122 | <> value dftcabal 123 | <> metavar "CABALFILES_DIR" 124 | <> help "Directory in which the cabal files will be downloaded")) 125 | <*> (WorkDir <$> strOption 126 | (long "working-directory" 127 | <> short 'w' 128 | <> value dftworkdir 129 | <> metavar "WORKDIR" 130 | <> help "Directory used to unpack/build the packages")) 131 | <*> (HtmlDir <$> strOption 132 | (long "output-directory" 133 | <> short 'w' 134 | <> value dftoutdir 135 | <> metavar "OUTDIR" 136 | <> help "Directory where exhack HTML documentation will be saved")) 137 | execParser $ info (parser <**> helper) (failureCode 1) 138 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { compiler ? "ghc843" 2 | , rev ? "f9002b83fd1998a6cc6fb8d66b8c9752b42c7fcd" 3 | , sha256 ? "19cb7rf2yv933k5p6mc60i2wqwy7i1ralrb49gvma65f1kipk0rv" 4 | , profile ? false 5 | }: 6 | 7 | let 8 | pkgs = import (builtins.fetchTarball { 9 | url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; 10 | inherit sha256; }) {inherit config;}; 11 | 12 | config = { 13 | packageOverrides = pkgs: rec { 14 | haskell = pkgs.haskell // { 15 | packages = pkgs.haskell.packages // { 16 | "${compiler}" = pkgs.haskell.packages."${compiler}".override { 17 | overrides = super: self: { 18 | cabal-helper = pkgs.haskell.lib.doJailbreak 19 | (super.callPackage ./nix/cabal-helper.nix {}); 20 | selda-sqlite = pkgs.haskell.lib.doJailbreak 21 | (super.callPackage ./nix/selda-sqlite.nix {}); 22 | ex-hack = super.callPackage ./nix/ex-hack.nix { 23 | stack = pkgs.stack; 24 | profile = profile; 25 | pygments = pkgs.python36Packages.pygments; 26 | }; 27 | }; 28 | }; 29 | }; 30 | }; 31 | }; 32 | }; 33 | 34 | buildTools = with pkgs; 35 | [ zlib gmp sqlite python36Packages.pygments 36 | haskell.packages.${compiler}.cabal-install 37 | ]; 38 | 39 | in 40 | 41 | { 42 | ex-hack = pkgs.haskell.lib.addBuildTools 43 | pkgs.haskell.packages.${compiler}.ex-hack 44 | buildTools; 45 | } 46 | -------------------------------------------------------------------------------- /ex-hack.cabal: -------------------------------------------------------------------------------- 1 | name: ex-hack 2 | version: 0.1.0.0 3 | description: Haskell examples database 4 | homepage: https://github.com/TORELEASE 5 | bug-reports: https://github.com/TORELEASE 6 | author: Félix Baylac-Jacqué 7 | maintainer: felix@alternativebit.fr 8 | copyright: 2018 Félix Baylac-Jacqué 9 | license: GPL-3 10 | license-file: LICENSE 11 | build-type: Simple 12 | cabal-version: >= 1.10 13 | 14 | extra-source-files: 15 | README.md 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/TOFILL 20 | 21 | library 22 | hs-source-dirs: 23 | src 24 | build-depends: 25 | ansi-terminal >= 0.8.0.4, 26 | base >= 4.11, 27 | blaze-html >= 0.9.1.1, 28 | bytestring >= 0.10.8.2, 29 | Cabal >= 2.2, 30 | cabal-helper >= 0.8.1, 31 | containers >= 0.5.11, 32 | deepseq >= 1.4.3, 33 | directory >= 1.3.1.5, 34 | exceptions >= 0.10, 35 | file-embed >= 0.0.10, 36 | filepath >= 1.4.2, 37 | ghc >= 8.4.3, 38 | ghc-paths >= 0.1, 39 | hashable >= 1.2, 40 | http-client >= 0.5, 41 | http-client-tls >= 0.3, 42 | lens >= 4.16, 43 | mtl >= 2.2, 44 | network-uri >= 2.6.1.0, 45 | process >= 1.6, 46 | safe >= 0.3, 47 | selda >= 0.2 && <0.3, 48 | selda-sqlite >= 0.1.6, 49 | shakespeare >= 2.0.15, 50 | tar >= 0.5, 51 | text >= 1.2, 52 | unordered-containers >= 0.2, 53 | yaml >= 0.8.32, 54 | zlib >= 0.6 55 | exposed-modules: 56 | ExHack.Cabal.CabalParser, 57 | ExHack.Data.Db, 58 | ExHack.Ghc, 59 | ExHack.Hackage.Hackage, 60 | ExHack.ModulePaths, 61 | ExHack.ProcessingSteps, 62 | ExHack.Renderer.Html, 63 | ExHack.Renderer.Types, 64 | ExHack.Stackage.Stack, 65 | ExHack.Stackage.StackageParser, 66 | ExHack.Stackage.StackageTypes, 67 | ExHack.Types, 68 | ExHack.Utils 69 | default-language: Haskell2010 70 | ghc-options: -Wall -O2 71 | 72 | executable ex-hack 73 | main-is: Main.hs 74 | hs-source-dirs: 75 | app 76 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 77 | build-depends: 78 | base >= 4.11 && <5, 79 | directory >= 1.3.1.5, 80 | ex-hack, 81 | filepath >= 1.4.2, 82 | lens >= 4.16, 83 | optparse-applicative >= 0.14.2.0, 84 | text >= 1.2 85 | default-language: Haskell2010 86 | 87 | test-suite unit-tests 88 | type: exitcode-stdio-1.0 89 | main-is: Spec.hs 90 | hs-source-dirs: 91 | test/unit 92 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 93 | build-depends: 94 | base >=4.11 && <5, 95 | containers, 96 | ex-hack, 97 | file-embed >= 0.0.10, 98 | hspec, 99 | text 100 | other-modules: 101 | ExHack.CabalSpec, 102 | ExHack.ModulePathSpec, 103 | ExHack.StackageSpec 104 | default-language: Haskell2010 105 | 106 | test-suite integration-tests 107 | type: exitcode-stdio-1.0 108 | main-is: Int.hs 109 | hs-source-dirs: 110 | test/integration 111 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 112 | build-depends: 113 | base >=4.11 && <5 114 | , directory 115 | , ex-hack 116 | , file-embed 117 | , filepath 118 | , hspec 119 | , text 120 | other-modules: 121 | ExHack.Hackage.IntegrationHackageSpec 122 | default-language: Haskell2010 123 | -------------------------------------------------------------------------------- /img/gh-screenshot.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/picnoir/ex-hack/dace36926065d5a0dd0076beec1a6eeacd848732/img/gh-screenshot.jpg -------------------------------------------------------------------------------- /img/logo/README.md: -------------------------------------------------------------------------------- 1 | # Logo 2 | 3 | You can edit the logo by opening the ex-hack-logo-src.svg file using the 4 | [inkscape](https://inkscape.org) image editor. 5 | 6 | When saving the source file, please use the "Inkscape SVG" format to keep all 7 | the editing-related meta-data. 8 | 9 | When saving the actual logo, use the "simple SVG" format to remove all the 10 | unnecessary stuff. 11 | -------------------------------------------------------------------------------- /img/logo/ex-hack-logo-src.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 21 | 23 | 24 | 26 | image/svg+xml 27 | 29 | 30 | 31 | 32 | 33 | 35 | 38 | 42 | 43 | 47 | 52 | 58 | 63 | 68 | 74 | 75 | 79 | 84 | 90 | 95 | 100 | 106 | 107 | 111 | 116 | 122 | 127 | 132 | 138 | 139 | 143 | 148 | 154 | 159 | 164 | 170 | 171 | 175 | 180 | 186 | 191 | 196 | 202 | 203 | 207 | 212 | 218 | 223 | 228 | 234 | 235 | 236 | 261 | 265 | 273 | 277 | 285 | 292 | 299 | 306 | 313 | 314 | 321 | 327 | 333 | 339 | 346 | 347 | 348 | -------------------------------------------------------------------------------- /img/logo/ex-hack-logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 14 | 16 | 17 | 19 | image/svg+xml 20 | 22 | 23 | 24 | 25 | 26 | 28 | 31 | 35 | 36 | 39 | 44 | 50 | 55 | 60 | 66 | 67 | 70 | 75 | 81 | 86 | 91 | 97 | 98 | 101 | 106 | 112 | 117 | 122 | 128 | 129 | 132 | 137 | 143 | 148 | 153 | 159 | 160 | 163 | 168 | 174 | 179 | 184 | 190 | 191 | 194 | 199 | 205 | 210 | 215 | 221 | 222 | 223 | 226 | 233 | 236 | 241 | 246 | 251 | 257 | 263 | 264 | 268 | 272 | 276 | 280 | 284 | 285 | 286 | -------------------------------------------------------------------------------- /misc/useful-requests.sql: -------------------------------------------------------------------------------- 1 | -- Those requests are quite handy to manually debug the software. 2 | 3 | -- Check the packages dep graph 4 | select p1.name, '=>', p2.name from dependancies d 5 | inner join packages p1 on (d.packId = p1.packageId) 6 | inner join packages p2 on (d.depId = p2.packageId); 7 | 8 | -- Where did we find the occurences? 9 | select p.name, em.name, es.name from symbolOccurences so 10 | inner join exposedSymbols es on (so.importedSymId = es.id) 11 | inner join exposedModules em on (es.modId = em.id) 12 | inner join packages p on (em.packId = p.packageId); 13 | -------------------------------------------------------------------------------- /nix/cabal-helper.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, Cabal, cabal-install, cabal-plan 2 | , containers, directory, filepath, ghc, ghc-paths, mtl, pretty-show 3 | , process, semigroupoids, stdenv, template-haskell, temporary, text 4 | , transformers, unix, unix-compat, utf8-string 5 | }: 6 | mkDerivation { 7 | pname = "cabal-helper"; 8 | version = "0.8.1.2"; 9 | sha256 = "345ad343095f75c1223f26052fa7c1966397427318594baafb7ea62a825abedf"; 10 | isLibrary = true; 11 | isExecutable = true; 12 | setupHaskellDepends = [ base Cabal ]; 13 | libraryHaskellDepends = [ 14 | base Cabal cabal-plan containers directory filepath mtl process 15 | semigroupoids transformers unix unix-compat 16 | ]; 17 | executableHaskellDepends = [ 18 | base bytestring Cabal cabal-plan containers directory filepath mtl 19 | pretty-show process template-haskell temporary text transformers 20 | unix unix-compat utf8-string 21 | ]; 22 | executableToolDepends = [ cabal-install ]; 23 | testHaskellDepends = [ 24 | base bytestring Cabal cabal-plan containers directory filepath ghc 25 | ghc-paths mtl pretty-show process template-haskell temporary text 26 | transformers unix unix-compat utf8-string 27 | ]; 28 | testToolDepends = [ cabal-install ]; 29 | doCheck = false; 30 | description = "Simple interface to some of Cabal's configuration state, mainly used by ghc-mod"; 31 | license = stdenv.lib.licenses.gpl3; 32 | } 33 | -------------------------------------------------------------------------------- /nix/ex-hack.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, ansi-terminal, base, blaze-html, bytestring, Cabal 2 | , cabal-helper, containers, deepseq, directory, exceptions 3 | , file-embed, filepath, ghc, ghc-paths, hashable, hspec 4 | , http-client, http-client-tls, lens, mtl, network-uri 5 | , optparse-applicative, process, pygments, safe, selda, selda-sqlite 6 | , shakespeare, stdenv, tar, text, unordered-containers, yaml, zlib, stack 7 | , profile 8 | }: 9 | mkDerivation rec { 10 | pname = "ex-hack"; 11 | version = "0.1.0.0"; 12 | src = ../.; 13 | isLibrary = true; 14 | isExecutable = true; 15 | doCheck = false; 16 | libraryHaskellDepends = [ 17 | ansi-terminal base blaze-html bytestring Cabal cabal-helper 18 | containers deepseq directory exceptions file-embed filepath ghc 19 | ghc-paths hashable http-client http-client-tls lens mtl network-uri 20 | process safe selda selda-sqlite shakespeare tar text 21 | unordered-containers yaml zlib 22 | ]; 23 | 24 | # Dirty hack: cabal-helper seems to dislike nix-build and makes the whole 25 | # build to fail if doCheck is enabled. However, we still want to have 26 | # the test deps to run cabal test in the CI Script. With doCheck disabled, 27 | # we won't get the test deps in scope, so instead, we force them as build deps. 28 | buildDepends = testHaskellDepends; 29 | enableLibraryProfiling = profile; 30 | executableHaskellDepends = [ 31 | base directory filepath lens optparse-applicative text 32 | ]; 33 | testHaskellDepends = [ 34 | base containers directory file-embed filepath hspec text stack 35 | ]; 36 | homepage = "https://github.com/TORELEASE"; 37 | license = stdenv.lib.licenses.gpl3; 38 | # We need to rewrite the runtime binary dependencies to their correct nix path. 39 | postConfigure = '' 40 | substituteInPlace src/ExHack/Stackage/Stack.hs --replace 'stackPath = "stack"' 'stackPath = "${stack}/bin/stack"' 41 | substituteInPlace src/ExHack/Renderer/Html.hs --replace '"pygmentize"' '"${pygments}/bin/pygmentize"' 42 | ''; 43 | } 44 | -------------------------------------------------------------------------------- /nix/selda-sqlite.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, direct-sqlite, directory, exceptions, selda 2 | , stdenv, text 3 | }: 4 | mkDerivation { 5 | pname = "selda-sqlite"; 6 | version = "0.1.6.0"; 7 | sha256 = "c67ba89114a82ece42b7e478bcf480ae0241cefb41e2e9b340a268f9f08be390"; 8 | revision = "2"; 9 | editedCabalFile = "198pg9i0lfx3fwf7b7cw0x5kial6vbf0dqwh18jnh7na3pyn1jr6"; 10 | libraryHaskellDepends = [ 11 | base direct-sqlite directory exceptions selda text 12 | ]; 13 | homepage = "https://github.com/valderman/selda"; 14 | description = "SQLite backend for the Selda database EDSL"; 15 | license = stdenv.lib.licenses.mit; 16 | } 17 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (import ./default.nix {}).ex-hack.env 2 | -------------------------------------------------------------------------------- /src/ExHack/Cabal/CabalParser.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : ExHack.Cabal.CabalParser 3 | Description : Cabal files parsers collection. 4 | Copyright : (c) Félix Baylac-Jacqué, 2018 5 | License : GPL-3 6 | Stability : experimental 7 | Portability : POSIX 8 | -} 9 | {-# LANGUAGE BangPatterns #-} 10 | module ExHack.Cabal.CabalParser ( 11 | parseCabalFile 12 | ) where 13 | 14 | import Control.DeepSeq (force) 15 | import Data.Maybe (fromMaybe, 16 | maybeToList) 17 | import Data.Set (Set, fromList) 18 | import qualified Data.Set as S (filter) 19 | import Data.Text.Encoding (encodeUtf8) 20 | import Distribution.PackageDescription.Parsec (ParseResult, parseGenericPackageDescription, 21 | runParseResult) 22 | import Distribution.Types.Benchmark (Benchmark, benchmarkBuildInfo, 23 | benchmarkModules) 24 | import Distribution.Types.BuildInfo (hsSourceDirs) 25 | import Distribution.Types.CondTree (condTreeConstraints, 26 | condTreeData) 27 | import Distribution.Types.Dependency (Dependency, 28 | depPkgName) 29 | import Distribution.Types.Executable (Executable, 30 | buildInfo, 31 | exeModules) 32 | import Distribution.Types.GenericPackageDescription (GenericPackageDescription, 33 | condBenchmarks, 34 | condExecutables, 35 | condLibrary, 36 | condSubLibraries, 37 | condTestSuites, 38 | packageDescription) 39 | import Distribution.Types.Library (Library, 40 | libBuildInfo) 41 | import qualified Distribution.Types.Library as Lib (explicitLibModules, 42 | exposedModules) 43 | import Distribution.Types.PackageDescription (package) 44 | import Distribution.Types.TestSuite (TestSuite, 45 | testBuildInfo, 46 | testModules) 47 | 48 | import ExHack.Types (ComponentRoot (..), 49 | Package (..), 50 | PackageComponent (..), 51 | PackageName, 52 | PackageDesc(..), 53 | pkgName) 54 | 55 | -- | Parse a cabalFile into a `Package` 56 | -- 57 | -- TODO: some benchs and test suites are not exposing any modules but instead 58 | -- are directly exposing a single .hs file. It's a bit too tricky to implement 59 | -- for V1, but we probably should find a way to list those files later on. 60 | parseCabalFile :: PackageDesc -> Maybe Package 61 | parseCabalFile (PackageDesc (pfp, cf)) = force $ extractPack <$> gpackageDesc 62 | where 63 | gpackageDesc :: Maybe GenericPackageDescription 64 | !gpackageDesc = parseResultToMaybe . parseGenericPackageDescription $ encodeUtf8 cf 65 | parseResultToMaybe :: ParseResult GenericPackageDescription -> Maybe GenericPackageDescription 66 | parseResultToMaybe !pr = 67 | let !r = runParseResult pr in 68 | case r of 69 | (_, Left _) -> Nothing 70 | (_, Right x) -> Just x 71 | extractPack :: GenericPackageDescription -> Package 72 | extractPack !gp = Package packN filteredPackDep cf pfp expMainLibMods Nothing allMods 73 | where 74 | !packN = package . packageDescription $ gp 75 | -- The package should not be a dependancy to itself. 76 | !filteredPackDep = S.filter (/= pkgName packN) packDeps 77 | packDeps :: Set PackageName 78 | !packDeps = fromList (depPkgName <$> allDeps) 79 | allDeps :: [Dependency] 80 | !allDeps = mainLibDep <> subLibDep <> execDep <> testDep <> benchDep 81 | mainLibDep :: [Dependency] 82 | !mainLibDep = treeToDep (maybeToList . condLibrary) gp 83 | !subLibDep = fromMaybe [] $ treeToDep $ getTree condSubLibraries 84 | !execDep = fromMaybe [] $ treeToDep $ getTree condExecutables 85 | !testDep = fromMaybe [] $ treeToDep $ getTree condTestSuites 86 | !benchDep = fromMaybe [] $ treeToDep $ getTree condBenchmarks 87 | -- We want deps for both the app and the potential libs. 88 | -- The following code is messy as hell but necessary. Deps are quite heavily burried 89 | -- in Cabal's packages data structures... 90 | -- 91 | -- I made types explicits to document a bit this black magic. 92 | allMods :: [PackageComponent] 93 | !allMods = (testToPackageComponent <$> tMods) <> 94 | (libToPackageComponentInternal <$> lMods) <> 95 | (benchToPackageComponent <$> bMods) <> 96 | (exeToPackageComponent <$> execMods) <> 97 | maybeToList allMainLibMods 98 | expMainLibMods :: Maybe PackageComponent 99 | !expMainLibMods = libToPackageComponent . condTreeData <$> condLibrary gp 100 | allMainLibMods :: Maybe PackageComponent 101 | !allMainLibMods = libToPackageComponentInternal . condTreeData <$> condLibrary gp 102 | tMods :: [TestSuite] 103 | !tMods = condTreeData . snd <$> condTestSuites gp 104 | bMods :: [Benchmark] 105 | !bMods = condTreeData . snd <$> condBenchmarks gp 106 | lMods :: [Library] 107 | !lMods = condTreeData . snd <$> condSubLibraries gp 108 | execMods :: [Executable] 109 | !execMods = condTreeData . snd <$> condExecutables gp 110 | -- Helper functions 111 | -- ================ 112 | getTree st = (fmap . fmap) snd (st <$> gpackageDesc) 113 | treeToDep t = concat <$> (fmap . fmap) condTreeConstraints t 114 | 115 | -- | Do not return internal modules. 116 | libToPackageComponent :: Library -> PackageComponent 117 | libToPackageComponent lib = PackageComponent (Lib.exposedModules lib) 118 | (ComponentRoot <$> hsSourceDirs (libBuildInfo lib)) 119 | 120 | -- | Return both exposed and internal modules. 121 | libToPackageComponentInternal :: Library -> PackageComponent 122 | libToPackageComponentInternal lib = PackageComponent (Lib.explicitLibModules lib) 123 | (ComponentRoot <$> hsSourceDirs (libBuildInfo lib)) 124 | 125 | exeToPackageComponent :: Executable -> PackageComponent 126 | exeToPackageComponent exe = PackageComponent (exeModules exe) 127 | (ComponentRoot <$> hsSourceDirs (buildInfo exe)) 128 | 129 | testToPackageComponent :: TestSuite -> PackageComponent 130 | testToPackageComponent t = PackageComponent (testModules t) 131 | (ComponentRoot <$> hsSourceDirs (testBuildInfo t)) 132 | 133 | benchToPackageComponent :: Benchmark -> PackageComponent 134 | benchToPackageComponent b = PackageComponent (benchmarkModules b) 135 | (ComponentRoot <$> hsSourceDirs (benchmarkBuildInfo b)) 136 | -------------------------------------------------------------------------------- /src/ExHack/Data/Db.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : ExHack.Data.Db 3 | Description : Database-related operations. 4 | Copyright : (c) Félix Baylac-Jacqué, 2018 5 | License : GPL-3 6 | Stability : experimental 7 | Portability : POSIX 8 | -} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | 14 | module ExHack.Data.Db ( 15 | getHomePagePackages, 16 | getModulePageSyms, 17 | getPackageId, 18 | getPackagePageMods, 19 | getPkgImportScopes, 20 | initDb, 21 | saveModuleExports, 22 | saveModuleUnifiedSymbols, 23 | savePackageDeps, 24 | savePackageMods, 25 | savePackages 26 | ) where 27 | 28 | import Control.Monad (unless) 29 | import Control.Monad.Catch (Exception, MonadMask, throwM) 30 | import qualified Data.HashMap.Strict as HM (fromList) 31 | import qualified Data.HashSet as HS (HashSet, fromList) 32 | import Data.Maybe (listToMaybe, maybe) 33 | import Data.Text (Text, pack) 34 | import qualified Data.Text as T (lines, unlines) 35 | import Database.Selda ((:*:) (..), RowID, Selector, Table, 36 | aggregate, autoPrimary, count, def, fk, 37 | fromRowId, fromSql, groupBy, innerJoin, 38 | insertWithPK, insert_, literal, query, 39 | required, restrict, select, 40 | tableWithSelectors, text, 41 | tryCreateTable, (!), (.==)) 42 | import Database.Selda.Backend (MonadSelda (..), SqlValue (SqlInt)) 43 | import GHC (SrcSpan (..), getLoc, srcSpanStartCol, 44 | srcSpanStartLine) 45 | 46 | import ExHack.Renderer.Types (HomePagePackage (..), ModuleName (..), 47 | PackageName (..), SymbolName, 48 | SymbolOccurs (..)) 49 | import ExHack.Types (ImportsScope, IndexedModuleNameT (..), 50 | IndexedSym (..), LocatedSym (..), 51 | ModuleNameT (..), PackageNameT (..), 52 | SourceCodeFile (..), 53 | SourceCodeFile (..), SymName (..), 54 | UnifiedSym (..), depsNames, getModName, 55 | getName) 56 | import qualified ExHack.Types as ET (ModuleExports, ModuleName, 57 | Package (..)) 58 | 59 | packageId :: Selector (RowID :*: Text) RowID 60 | packageName :: Selector (RowID :*: Text) Text 61 | packages ::  Table (RowID :*: Text) 62 | (packages, packageId :*: packageName) 63 | = tableWithSelectors "packages" $ 64 | autoPrimary "packageId" 65 | :*: required "name" 66 | 67 | dependancies :: Table (RowID :*: RowID :*: RowID) 68 | depPack :: Selector (RowID :*: RowID :*: RowID) RowID 69 | depId :: Selector (RowID :*: RowID :*: RowID) RowID 70 | (dependancies, _ :*: depPack :*: depId) = tableWithSelectors "dependancies" $ 71 | autoPrimary "id" 72 | :*: required "packID" `fk` (packages, packageId) 73 | :*: required "depID" `fk` (packages, packageId) 74 | 75 | exposedModules :: Table (RowID :*: Text :*: RowID) 76 | modId :: Selector (RowID :*: Text :*: RowID) RowID 77 | modName :: Selector (RowID :*: Text :*: RowID) Text 78 | modPack :: Selector (RowID :*: Text :*: RowID) RowID 79 | (exposedModules, modId :*: modName :*: modPack) = tableWithSelectors "exposedModules" $ 80 | autoPrimary "id" 81 | :*: required "name" 82 | :*: required "packID" `fk` (packages, packageId) 83 | 84 | exposedSymbols :: Table (RowID :*: Text :*: RowID) 85 | symId :: Selector (RowID :*: Text :*: RowID) RowID 86 | symName :: Selector (RowID :*: Text :*: RowID) Text 87 | symModId :: Selector (RowID :*: Text :*: RowID) RowID 88 | (exposedSymbols, symId :*: symName :*: symModId) = tableWithSelectors "exposedSymbols" $ 89 | autoPrimary "id" 90 | :*: required "name" 91 | :*: required "modId" `fk` (exposedModules, modId) 92 | 93 | sourceFiles :: Table (RowID :*: Text :*: Text :*: Text) 94 | fileId :: Selector (RowID :*: Text :*: Text :*: Text) RowID 95 | fileContent :: Selector (RowID :*: Text :*: Text :*: Text) Text 96 | fileModule :: Selector (RowID :*: Text :*: Text :*: Text) Text 97 | filePackage :: Selector (RowID :*: Text :*: Text :*: Text) Text 98 | (sourceFiles, fileId :*: fileContent :*: fileModule :*: filePackage) 99 | = tableWithSelectors "sourceFiles" $ 100 | autoPrimary "id" 101 | :*: required "fileContent" 102 | :*: required "modName" 103 | :*: required "packName" 104 | 105 | symbolOccurences :: Table (RowID :*: Int :*: Int :*: RowID :*: RowID) 106 | occCol :: Selector (RowID :*: Int :*: Int :*: RowID :*: RowID) Int 107 | occLine :: Selector (RowID :*: Int :*: Int :*: RowID :*: RowID) Int 108 | occFileId :: Selector (RowID :*: Int :*: Int :*: RowID :*: RowID) RowID 109 | occSymId :: Selector (RowID :*: Int :*: Int :*: RowID :*: RowID) RowID 110 | (symbolOccurences, _ :*: occCol :*: occLine :*: occFileId :*: occSymId) 111 | = tableWithSelectors "symbolOccurences" $ 112 | autoPrimary "id" 113 | :*: required "column" 114 | :*: required "line" 115 | :*: required "sourceFileId" `fk` (sourceFiles, fileId) 116 | :*: required "importedSymID" `fk` (exposedSymbols, symId) 117 | 118 | 119 | -- | Create the internal database schema. 120 | initDb :: (MonadSelda m) => m () 121 | initDb = do 122 | tryCreateTable packages 123 | tryCreateTable dependancies 124 | tryCreateTable exposedModules 125 | tryCreateTable exposedSymbols 126 | tryCreateTable symbolOccurences 127 | tryCreateTable sourceFiles 128 | 129 | -- | Save a package dependancies. 130 | -- 131 | -- Note that if we can't find a dependancy in the 132 | -- packages table, we'll ignore it. 133 | -- 134 | -- You should make sure your package database is already 135 | -- populated before using this. 136 | savePackageDeps :: (MonadSelda m) => ET.Package -> m () 137 | savePackageDeps p = do 138 | mpid <- queryPkg p 139 | let resPackDeps = depsNames p 140 | mapM_ (\rowId -> saveDep rowId `mapM_` resPackDeps) mpid 141 | where 142 | saveDep pid d = do 143 | mdid <- query $ do 144 | pks <- select packages 145 | restrict (pks ! packageName .== text (pack d)) 146 | return $ pks ! packageId 147 | mapM_ (\did -> insert_ dependancies [ def :*: pid :*: did]) (listToMaybe mdid) 148 | 149 | -- | Save a package list in the DB. 150 | savePackages :: (MonadSelda m) => [ET.Package] -> m () 151 | savePackages xs = insert_ packages $ (\p -> def :*: getName p) <$> xs 152 | 153 | data SaveModuleException = PackageNotInDatabase | ModuleNotInDatabase Text 154 | deriving (Show) 155 | 156 | instance Exception SaveModuleException 157 | 158 | -- | Potentially confusing: 159 | -- * If we have a package id in the Package type, use it 160 | -- * Otherwise retrieve the package id from the DB 161 | -- * If the package is not in the DB, something weird happened... 162 | -- Throw an error 163 | getPackageId :: forall m. (MonadSelda m, MonadMask m) 164 | => ET.Package -> m RowID 165 | getPackageId p = maybe 166 | (queryPkg p >>= maybe (throwM PackageNotInDatabase) pure) 167 | pure 168 | (fromSql . SqlInt <$> ET.dbId p) 169 | 170 | -- | Save the exposed modules as well as their exposed symbols. 171 | savePackageMods :: forall m. (MonadSelda m, MonadMask m) 172 | => ET.Package -> [ET.ModuleExports] -> m RowID 173 | savePackageMods p xs = do 174 | pid <- getPackageId p 175 | saveMod pid `mapM_` xs 176 | pure pid 177 | where 178 | saveMod pid (m, syms) = do 179 | mid <- insertWithPK exposedModules [def :*: getModName m :*: pid] 180 | insert_ exposedSymbols $ (\(SymName sn) -> def :*: sn :*: mid) <$> syms 181 | 182 | -- | Given a module database ID, saves the exported symbols of this 183 | -- module in ExHack's database. 184 | saveModuleExports :: (MonadSelda m) => RowID -> ET.ModuleName -> [SymName] -> m () 185 | saveModuleExports pid mn xs = do 186 | midi <- insertWithPK exposedModules [def :*: getModName mn :*: pid] 187 | insert_ exposedSymbols $ 188 | (\(SymName s) -> def :*: s :*: midi) <$> xs 189 | 190 | queryPkg :: (MonadSelda m) => ET.Package -> m (Maybe RowID) 191 | queryPkg p = do 192 | let r = query $ do 193 | pks <- select packages 194 | restrict (pks ! packageName .== (text . getName) p) 195 | return $ pks ! packageId 196 | listToMaybe <$> r 197 | 198 | -- | Query ExHack database to retrieve the available symbols to be imported 199 | -- from within this package. 200 | -- 201 | -- This scope should be filtered on a per-module basis, depending on the module 202 | -- imports, before being used in a symbol unification process. 203 | getPkgImportScopes :: forall m. (MonadSelda m, MonadMask m) => ET.Package -> m ImportsScope 204 | getPkgImportScopes p = do 205 | mods <- getScopeModules p 206 | o <- sequence (wrapSyms <$> mods) 207 | pure $ HM.fromList o 208 | where 209 | wrapSyms :: IndexedModuleNameT -> m (IndexedModuleNameT, HS.HashSet IndexedSym) 210 | wrapSyms mnt@(IndexedModuleNameT (_, i)) = do 211 | let mid = fromSql $ SqlInt i :: RowID 212 | q <- query $ do 213 | mods <- select exposedModules 214 | restrict (mods ! modId .== literal mid) 215 | syms <- innerJoin (\s -> s ! symModId .== mods ! modId) $ select exposedSymbols 216 | pure $ syms ! symId :*: syms ! symName 217 | pure (mnt, HS.fromList (wrapResult <$> q)) 218 | wrapResult (i :*: n) = IndexedSym (SymName n, fromRowId i) 219 | 220 | getScopeModules :: (MonadSelda m, MonadMask m) => ET.Package -> m [IndexedModuleNameT] 221 | getScopeModules p = do 222 | pid <- getPackageId p 223 | q <- query $ do 224 | deps <- select dependancies 225 | restrict (deps ! depPack .== literal pid) 226 | mods <- innerJoin (\m -> m ! modPack .== deps ! depId) $ select exposedModules 227 | return (mods ! modId :*: mods ! modName) 228 | -- Here, we also want to look for occurences in current's package module. 229 | -- Not sure if it's a really good idea: we'll find occurences for sure, but we also 230 | -- probably consider the symbol definition as an occurence... 231 | qp <- query $ do 232 | mods <- select exposedModules 233 | restrict $ (mods ! modPack .== literal pid) 234 | return (mods ! modId :*: mods ! modName) 235 | pure $ (wrapResult <$> q) <> (wrapResult <$> qp) 236 | where 237 | wrapResult (i :*: n) = IndexedModuleNameT (ModuleNameT n, fromRowId i) 238 | 239 | 240 | -- | Insert both the source file in which some symbols have been unified as well as 241 | -- the symbols occurences in ExHack's database. 242 | saveModuleUnifiedSymbols :: forall m. (MonadSelda m, MonadMask m) => [UnifiedSym] -> SourceCodeFile -> m () 243 | saveModuleUnifiedSymbols xs (SourceCodeFile f (ModuleNameT mnt) (PackageNameT pnt)) = 244 | unless (null xs) $ do 245 | fid <- insertWithPK sourceFiles [def :*: f :*: mnt :*: pnt] 246 | insert_ symbolOccurences $ generateLine fid <$> xs 247 | where 248 | generateLine fid (UnifiedSym (IndexedSym (_, sidi), LocatedSym (_, _, gloc))) = 249 | def :*: col :*: line :*: fid :*: sid 250 | where 251 | (RealSrcSpan loc) = getLoc gloc 252 | !line = srcSpanStartLine loc 253 | !col = srcSpanStartCol loc 254 | !sid = fromSql (SqlInt sidi) 255 | 256 | -- | Retrieve the data necessary to render the HTML home page. 257 | getHomePagePackages :: forall m. (MonadSelda m, MonadMask m) => m [HomePagePackage] 258 | getHomePagePackages = do 259 | res <- query $ aggregate $ do 260 | pkgs <- select packages 261 | mods <- innerJoin (\m -> pkgs ! packageId .== m ! modPack) $ select exposedModules 262 | pid <- groupBy (pkgs ! packageId) 263 | pn <- groupBy (pkgs ! packageName) 264 | pure $ pid :*: pn :*: count (mods ! modId) 265 | pure $ wrapResult <$> res 266 | where 267 | wrapResult (i :*: n :*: c) = HomePagePackage (PackageName (i,n)) c 268 | 269 | -- | Retrieve the data necessary to render the HTML package page. 270 | getPackagePageMods :: forall m. (MonadSelda m, MonadMask m) => PackageName -> m [ModuleName] 271 | getPackagePageMods (PackageName (pid, _)) = do 272 | res <- query $ do 273 | pkgs <- select packages 274 | restrict $ pkgs ! packageId .== literal pid 275 | mods <- innerJoin (\m -> pkgs ! packageId .== m ! modPack) $ select exposedModules 276 | pure $ mods ! modId :*: mods ! modName 277 | pure $ wrapResult <$> res 278 | where 279 | wrapResult (i :*: n) = ModuleName (i,n) 280 | 281 | -- | Retrieve the data necessary to render the HTML module page. 282 | getModulePageSyms :: forall m. (MonadSelda m, MonadMask m) => PackageName -> ModuleName -> m [SymbolOccurs] 283 | getModulePageSyms _ (ModuleName (mid,_)) = do 284 | sids <- query $ do 285 | syms <- select exposedSymbols 286 | restrict $ syms ! symModId .== literal mid 287 | pure $ syms ! symId :*: syms ! symName 288 | mapM (\(sid :*: sn) -> wrapResult sn <$> querySym sid) sids 289 | where 290 | querySym :: RowID -> m [Int :*: Int :*: Text :*: Text :*: Text] 291 | querySym sid = query $ do 292 | syms <- select exposedSymbols 293 | restrict $ syms ! symId .== literal sid 294 | occs <- innerJoin (\o -> o ! occSymId .== syms ! symId) $ select symbolOccurences 295 | files <- innerJoin (\f -> f ! fileId .== occs ! occFileId) $ select sourceFiles 296 | pure $ (occs ! occCol) :*: (occs ! occLine) :*: 297 | (files ! fileContent) :*: (files ! fileModule) :*: 298 | (files ! filePackage) 299 | wrapResult :: SymbolName -> [Int :*: Int :*: Text :*: Text :*: Text] -> SymbolOccurs 300 | wrapResult sname occs = SymbolOccurs sname (wrapOcc occs) 301 | wrapOcc = fmap 302 | (\(col :*: line :*: content :*: mname :*: pname) -> 303 | let (nLine, nContent) = extractSample line content 304 | in (col, nLine, 305 | SourceCodeFile nContent 306 | (ModuleNameT mname) 307 | (PackageNameT pname))) 308 | 309 | -- Ahum, not typesafe at all. TODO: create sample-associated datatypes. 310 | extractSample :: Int -> Text -> (Int, Text) 311 | extractSample line t = (nLine, T.unlines nText) 312 | where 313 | !tLines = T.lines t 314 | linesBefore = 15 315 | linesAfter = 5 316 | -- Nb lines to ignore. 317 | !toIgnore = max 0 (line - linesBefore) 318 | -- Intermediate length, ie init length - ignored lines. 319 | !iLength = length tLines - toIgnore 320 | -- New line number. 321 | !nLine = line - toIgnore 322 | -- Nb lines to take 323 | !toTake = min (nLine + linesAfter) iLength 324 | !nText = take toTake $ drop toIgnore tLines 325 | -------------------------------------------------------------------------------- /src/ExHack/Ghc.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : ExHack.Ghc 3 | Description : GHC-API programs. 4 | Copyright : (c) Félix Baylac-Jacqué, 2018 5 | License : GPL-3 6 | Stability : experimental 7 | Portability : POSIX 8 | -} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | module ExHack.Ghc ( 12 | UnitId(..), 13 | TypecheckedSource, 14 | DesugaredModule(..), 15 | getDesugaredMod, 16 | getModExports, 17 | getModImports, 18 | getModSymbols, 19 | unLoc 20 | ) where 21 | 22 | import Avail (AvailInfo (..)) 23 | import Control.DeepSeq (force) 24 | import Control.Monad (when, liftM2) 25 | import Control.Monad.IO.Class (MonadIO, liftIO) 26 | import Data.Maybe (fromMaybe, isNothing) 27 | import Data.Text (pack) 28 | import qualified Data.Text as T (pack, unpack) 29 | import qualified Distribution.Helper as H (ChComponentName (ChLibName), 30 | components, ghcOptions, 31 | mkQueryEnv, runQuery) 32 | import Distribution.ModuleName (ModuleName, toFilePath) 33 | import FastString (unpackFS) 34 | import GHC (DesugaredModule, GenLocated (..), Ghc, 35 | LoadHowMuch (..), ModSummary, 36 | TypecheckedSource, desugarModule, 37 | dm_core_module, dm_typechecked_module, 38 | findModule, getModSummary, 39 | getSessionDynFlags, getTokenStream, 40 | guessTarget, load, mkModuleName, 41 | moduleNameString, ms_textual_imps, 42 | noLoc, parseDynamicFlags, parseModule, 43 | runGhc, setSessionDynFlags, 44 | setTargets, typecheckModule, unLoc) 45 | import GHC.Paths (libdir) 46 | import HscTypes (ModGuts (..)) 47 | import Lexer (Token (ITqvarid, ITvarid)) 48 | import Module (UnitId (..)) 49 | import Name (getOccString) 50 | import Safe (headMay) 51 | import System.Directory (withCurrentDirectory, listDirectory) 52 | import System.FilePath ((<.>), ()) 53 | 54 | import ExHack.ModulePaths (modName) 55 | import ExHack.Types (ComponentRoot (..), LocatedSym (..), 56 | ModuleNameT (..), MonadLog (..), 57 | Package (..), PackageFilePath (..), 58 | SymName (..), getModName) 59 | 60 | -- | Retrieves a GHC-API's module after type-checking and desugaring it. 61 | -- 62 | -- This function will call GHC to parse, typecheck and desugar the module. 63 | -- 64 | -- This will fails if the pointed source code is not valid. 65 | getDesugaredMod :: (MonadIO m, MonadLog m) => PackageFilePath -> ComponentRoot -> ModuleName -> m DesugaredModule 66 | getDesugaredMod pfp cr mn = 67 | onModSum pfp cr mn (\modSum -> 68 | parseModule modSum >>= typecheckModule >>= desugarModule) 69 | 70 | -- | Retrieves a module's imported symbols. 71 | -- 72 | -- This function will call GHC to parse and typecheck the module. 73 | -- 74 | -- This will fails if the pointed source code is not valid. 75 | getModImports :: (MonadIO m, MonadLog m) => PackageFilePath -> ComponentRoot -> ModuleName -> m [ModuleNameT] 76 | getModImports pfp cr mn = 77 | onModSum pfp cr mn (\modSum -> 78 | pure $ ModuleNameT . pack . moduleNameString . unLoc . snd <$> ms_textual_imps modSum) 79 | 80 | -- | Retrieve all the symbols used in the module body. 81 | -- 82 | -- This function wil use GHC to generate the tokens of source code. 83 | getModSymbols :: (MonadIO m, MonadLog m) => Package -> PackageFilePath -> ComponentRoot -> ModuleName -> m [LocatedSym] 84 | getModSymbols p pfp cr@(ComponentRoot crt) mn = 85 | withGhcEnv pfp cr mn $ do 86 | m <- findModule (mkModuleName $ T.unpack $ getModName mn) Nothing 87 | ts <- getTokenStream m 88 | let sns = (SymName . pack . unpackFS . getTNames) <$$> filter filterTokenTypes ts 89 | pure $ (\sn -> LocatedSym (p, fileName, sn)) <$> sns 90 | where 91 | filterTokenTypes (L _ (ITqvarid _)) = True 92 | filterTokenTypes (L _ (ITvarid _)) = True 93 | filterTokenTypes _ = False 94 | getTNames (ITqvarid (_,n)) = n 95 | getTNames (ITvarid n) = n 96 | getTNames _ = error "The impossible happened." 97 | (<$$>) = fmap . fmap 98 | fileName = crt toFilePath mn <.> "hs" 99 | 100 | getCabalDynFlagsLib :: forall m. (MonadIO m) => FilePath -> m (Maybe [String]) 101 | getCabalDynFlagsLib fp = do 102 | mdir <- getDistDir 103 | let dist = fromMaybe "dist" mdir 104 | let qe = H.mkQueryEnv fp (fp dist) 105 | cs <- H.runQuery qe $ H.components $ (,) <$> H.ghcOptions 106 | pure $ fst <$> headMay (filter getLib cs) 107 | where 108 | getDistDir :: m (Maybe FilePath) 109 | getDistDir = do 110 | platformDir <- liftIO $ listDirectory $ ".stack-work" "dist" 111 | let mpd = ((".stack-work" "dist") ) <$> headMay platformDir 112 | cabalInstallDir <- liftIO $ mapM listDirectory mpd 113 | let mid = headMay =<< cabalInstallDir 114 | pure $ liftM2 () mpd mid 115 | getLib (_,H.ChLibName) = True 116 | getLib _ = False 117 | 118 | -- | Retrieves a `DesugaredModule` exported symbols. 119 | getModExports :: DesugaredModule -> [SymName] 120 | getModExports = force $ fmap getAvName . mg_exports . dm_core_module 121 | 122 | getAvName :: AvailInfo -> SymName 123 | getAvName (Avail n) = SymName $ pack $ getOccString n 124 | getAvName (AvailTC n _ _) = SymName $ pack $ getOccString n 125 | 126 | withGhcEnv :: (MonadIO m, MonadLog m) => PackageFilePath -> ComponentRoot -> ModuleName -> Ghc a -> m a 127 | withGhcEnv (PackageFilePath pfp) (ComponentRoot cr) mn a = 128 | liftIO $ withCurrentDirectory pfp $ do 129 | dflagsCM <- getCabalDynFlagsLib pfp 130 | when (isNothing dflagsCM) . logError $ "Cannot retrieve cabal flags for " <> T.pack pfp <> "." 131 | let dflagsC = fromMaybe [] dflagsCM 132 | liftIO . runGhc (Just libdir) $ do 133 | dflagsS <- getSessionDynFlags 134 | (dflags, _, _) <- parseDynamicFlags dflagsS (noLoc <$> dflagsC) 135 | _ <- setSessionDynFlags dflags 136 | target <- guessTarget fileName Nothing 137 | setTargets [target] 138 | _ <- load LoadAllTargets 139 | a 140 | where 141 | fileName = cr toFilePath mn 142 | 143 | onModSum :: (MonadIO m, MonadLog m) => PackageFilePath -> ComponentRoot -> ModuleName -> (ModSummary -> Ghc a) -> m a 144 | onModSum pfp cr mn f = withGhcEnv pfp cr mn 145 | (getModSummary (mkModuleName $ modName mn) >>= f) 146 | -------------------------------------------------------------------------------- /src/ExHack/Hackage/Hackage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module ExHack.Hackage.Hackage ( 4 | findComponentRoot, 5 | getModExports, 6 | getModNames, 7 | getPackageExports, 8 | unpackHackageTarball, 9 | PackageExports(..) 10 | ) where 11 | 12 | import qualified Codec.Archive.Tar as Tar (Entries (..), entryPath, read, 13 | unpack) 14 | import Codec.Compression.GZip (decompress) 15 | import Control.DeepSeq (force) 16 | import Control.Monad.Catch (MonadThrow) 17 | import Control.Monad.IO.Class (MonadIO, liftIO) 18 | import qualified Data.ByteString as BS (ByteString) 19 | import qualified Data.ByteString.Lazy as BL (fromStrict) 20 | import System.Directory (makeAbsolute, withCurrentDirectory) 21 | import System.FilePath (FilePath, splitDirectories, ()) 22 | 23 | import qualified ExHack.Ghc as GHC (getDesugaredMod, getModExports) 24 | import ExHack.ModulePaths (findComponentRoot) 25 | import ExHack.Types (ComponentRoot (..), ModuleExports, 26 | ModuleName, MonadLog, 27 | Package (exposedModules), 28 | PackageComponent (..), 29 | PackageExports (..), 30 | PackageFilePath (..)) 31 | 32 | -- | Unpack a tarball to a specified directory. 33 | unpackHackageTarball :: (MonadIO m) => 34 | FilePath -- ^ 'FilePath' pointing to the directory we want to extract the tarball to. 35 | -> BS.ByteString -- ^ Tarball in the 'ByteString'. 36 | -> m PackageFilePath -- ^ Newly created directory containing the extracted tarball. 37 | unpackHackageTarball dir tb = do 38 | let rp = Tar.read . decompress $ BL.fromStrict tb 39 | liftIO $ Tar.unpack dir rp 40 | adir <- liftIO $ makeAbsolute dir 41 | pure $ PackageFilePath $ adir getRootPath rp 42 | where 43 | -- TODO: unsafe head here. We are pretty sure we'll have at least a basedir 44 | -- since the tarballs we are unpacking are haskell packages. However, it would 45 | -- be nice to incorporate this in the API design. 46 | getRootPath (Tar.Next e _) = head $ splitDirectories $ Tar.entryPath e 47 | getRootPath _ = error "Cannot find tar's root directory." 48 | 49 | getModNames :: Package -> [ModuleName] 50 | getModNames p = maybe mempty mods exMods 51 | where 52 | exMods :: Maybe PackageComponent 53 | !exMods = exposedModules p 54 | 55 | -- | Retrieve the exported symbols of a module. 56 | getModExports :: forall m. (MonadIO m, MonadThrow m, MonadLog m) 57 | => PackageFilePath -> [ComponentRoot] -> ModuleName -> m ModuleExports 58 | getModExports pfp@(PackageFilePath pfps) croots mn = 59 | liftIO $ withCurrentDirectory pfps $ do 60 | cr <- findComponentRoot pfp croots mn 61 | ds <- GHC.getDesugaredMod pfp cr mn 62 | let !exps = force $ GHC.getModExports ds 63 | pure (mn, exps) 64 | 65 | -- | Retrieve the exported symbols of a package, module by module. 66 | getPackageExports :: forall m. (MonadIO m, MonadThrow m, MonadLog m) 67 | => PackageFilePath -> Package -> m [ModuleExports] 68 | getPackageExports pfp@(PackageFilePath pfps) p = 69 | liftIO $ withCurrentDirectory pfps $ getModExports pfp croots `mapM` mns 70 | where 71 | pcs :: Maybe PackageComponent 72 | pcs = exposedModules p 73 | croots :: [ComponentRoot] 74 | !croots = maybe [ComponentRoot "./"] roots pcs 75 | mns :: [ModuleName] 76 | mns = getModNames p 77 | -------------------------------------------------------------------------------- /src/ExHack/ModulePaths.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : ExHack.ModulePaths 3 | Description : Helpers related to modules filepaths. 4 | Copyright : (c) Félix Baylac-Jacqué, 2018 5 | License : GPL-3 6 | Stability : experimental 7 | Portability : POSIX 8 | -} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | 11 | module ExHack.ModulePaths ( 12 | modName, 13 | findComponentRoot, 14 | toModFilePath 15 | ) where 16 | 17 | import Control.Monad (filterM) 18 | import Control.Monad.Catch (MonadThrow, throwM) 19 | import Control.Monad.IO.Class (MonadIO, liftIO) 20 | import Data.List (intercalate) 21 | import Distribution.ModuleName (ModuleName, components, toFilePath) 22 | import System.Directory (doesPathExist, withCurrentDirectory) 23 | import System.FilePath ((<.>), ()) 24 | 25 | import ExHack.Types (ComponentRoot (..), 26 | PackageFilePath (..), 27 | PackageLoadError (..)) 28 | 29 | -- | Convert a `ModuleName` to its canonical form, eg. @Data.Text@ . 30 | modName :: ModuleName -> String 31 | modName mn = intercalate "." $ components mn 32 | 33 | -- | Generates the module filepath according to a package fp, a component root 34 | -- and a module name. 35 | toModFilePath :: PackageFilePath -> ComponentRoot -> ModuleName -> FilePath 36 | toModFilePath (PackageFilePath pfp) (ComponentRoot cr) mn = 37 | pfp cr toFilePath mn <.> "hs" 38 | 39 | -- | Look for a module file in a list of component roots and return 40 | -- the `ComponentRoot` containing the actual module file. 41 | findComponentRoot :: (MonadIO m, MonadThrow m) => PackageFilePath -> [ComponentRoot] -> ModuleName -> m ComponentRoot 42 | findComponentRoot (PackageFilePath pfp) croots mn = do 43 | let acroots = (\(ComponentRoot cr') -> ComponentRoot (pfp cr')) <$> croots 44 | xs <- liftIO $ withCurrentDirectory pfp $ filterM testPath ("./" : acroots) 45 | if length xs == 1 46 | then pure $ head xs 47 | else throwM $ CannotFindModuleFile mn croots 48 | where 49 | testPath (ComponentRoot p) = liftIO $ doesPathExist (p toFilePath mn <.> "hs") 50 | -------------------------------------------------------------------------------- /src/ExHack/ProcessingSteps.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : ExHack.ProcessingSteps 3 | Description : Processing operations used to both generate the ExHack database and the HTML documentation. 4 | Copyright : (c) Félix Baylac-Jacqué, 2018 5 | License : GPL-3 6 | Stability : experimental 7 | Portability : POSIX 8 | -} 9 | 10 | {-# LANGUAGE BangPatterns #-} 11 | {-# LANGUAGE DataKinds #-} 12 | {-# LANGUAGE FlexibleContexts #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | {-# LANGUAGE RankNTypes #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE TemplateHaskell #-} 17 | {-# LANGUAGE TypeFamilies #-} 18 | 19 | module ExHack.ProcessingSteps ( 20 | dlAssets, 21 | generateDb, 22 | generateHtmlPages, 23 | genGraphDep, 24 | indexSymbols, 25 | parseStackage, 26 | retrievePkgsExports, 27 | saveGraphDep 28 | ) where 29 | 30 | import Control.Lens (view) 31 | import Control.Monad (foldM_) 32 | import Control.Monad.Catch (MonadCatch, MonadThrow, 33 | displayException, handleAll, 34 | throwM) 35 | import Control.Monad.IO.Class (liftIO) 36 | import Control.Monad.Reader.Class (asks) 37 | import qualified Data.ByteString as BS (readFile, writeFile) 38 | import qualified Data.ByteString.Lazy as BL (writeFile) 39 | import Data.FileEmbed (embedFile) 40 | import qualified Data.HashMap.Strict as HM (HashMap, elems, empty, 41 | filterWithKey, insert, 42 | lookup) 43 | import qualified Data.HashSet as HS (foldl', unions) 44 | import Data.List (foldl') 45 | import Data.Maybe (fromJust) 46 | import qualified Data.Text as T (pack, replace, unpack) 47 | import qualified Data.Text.IO as T (readFile) 48 | import qualified Data.Text.Lazy as TL (Text) 49 | import qualified Data.Text.Lazy.IO as TL (hPutStr) 50 | import Database.Selda (RowID, SeldaM) 51 | import Database.Selda.SQLite (withSQLite) 52 | import Network.HTTP.Client (Manager, httpLbs, 53 | managerSetProxy, newManager, 54 | parseRequest_, 55 | proxyEnvironment, responseBody) 56 | import Network.HTTP.Client.TLS (tlsManagerSettings) 57 | import System.Directory (createDirectoryIfMissing) 58 | import System.FilePath ((<.>), ()) 59 | import System.IO (IOMode (WriteMode), 60 | hSetEncoding, utf8, withFile) 61 | import Text.Blaze.Html.Renderer.Text (renderHtml) 62 | 63 | import ExHack.Cabal.CabalParser (parseCabalFile) 64 | import ExHack.Data.Db (getHomePagePackages, 65 | getModulePageSyms, 66 | getPackageId, 67 | getPackagePageMods, 68 | getPkgImportScopes, initDb, 69 | saveModuleExports, 70 | saveModuleUnifiedSymbols, 71 | savePackageDeps, savePackages) 72 | import ExHack.Ghc (getModImports, getModSymbols, 73 | unLoc) 74 | import ExHack.Hackage.Hackage (findComponentRoot, 75 | getModExports, getModNames, 76 | unpackHackageTarball) 77 | import ExHack.ModulePaths (toModFilePath) 78 | import ExHack.Renderer.Html (addLineMarker, highLightCode, 79 | homePageTemplate, 80 | modulePageTemplate, 81 | packagePageTemplate) 82 | import qualified ExHack.Renderer.Types as RT (HighlightedSourceCodeFile (..), 83 | HighlightedSymbolOccurs (..), 84 | HomePagePackage (..), 85 | ModuleName (..), 86 | PackageName (..), 87 | SymbolOccurs (..), 88 | renderRoute) 89 | import ExHack.Stackage.Stack (buildPackage) 90 | import ExHack.Stackage.StackageParser (getHackageUrls, 91 | parseStackageYaml) 92 | import ExHack.Types (AlterDatabase, 93 | CabalBuildError (..), 94 | CabalFilesDir (..), 95 | ComponentRoot (..), 96 | DatabaseHandle, 97 | DatabaseStatus (..), 98 | HtmlDir (..), ImportsScope, 99 | IndexedModuleNameT (..), 100 | IndexedSym (..), 101 | LocatedSym (..), ModuleName, 102 | ModuleNameT (..), 103 | MonadLog (..), MonadStep, 104 | Package (allComponents, exposedModules, packageFilePath), 105 | PackageComponent (..), 106 | PackageDesc (..), 107 | PackageDlDesc, 108 | PackageDlDesc (..), 109 | PackageFilePath (..), 110 | SourceCodeFile (..), 111 | StackageFile (..), SymName, 112 | TarballsDir (..), 113 | UnifiedSym (..), WorkDir (..), 114 | getDatabaseHandle, getModNameT, 115 | getName, getPackageNameT, 116 | logInfo, packagedlDescName) 117 | import ExHack.Utils (Has (..), foldM') 118 | 119 | -- | `Step` 1: database generation. 120 | -- 121 | -- This function creates a new SQLite database initialized according 122 | -- to ex-hack's internal SQL scheme. 123 | generateDb :: forall c m. 124 | (Has c (DatabaseHandle 'New), 125 | MonadStep c m) 126 | => m (DatabaseHandle (AlterDatabase 'New)) 127 | generateDb = do 128 | logInfoTitle "[Step 1] Generating database scheme." 129 | dh <- asks (view hasLens) :: m (DatabaseHandle 'New) 130 | let (fp, dh') = getDatabaseHandle dh 131 | withSQLite fp initDb 132 | pure dh' 133 | 134 | -- | `Step` 2: stackage file parsing. 135 | -- 136 | -- This function parses the stackage file that will be used to 137 | -- generate the packages dependancy graph. 138 | parseStackage :: forall c m. 139 | (Has c StackageFile, 140 | MonadStep c m) 141 | => m [PackageDlDesc] 142 | parseStackage = do 143 | logInfoTitle "[Step 2] Parsing Stackage file" 144 | (StackageFile stackageFp) <- asks (view hasLens) 145 | stackageYaml <- liftIO $ T.readFile stackageFp 146 | let packages = fromJust $ parseStackageYaml stackageYaml 147 | pure $ getHackageUrls packages 148 | 149 | -- | `Step` 3: assets downloading. 150 | -- 151 | -- This function downloads both the cabal files and the taballs of the packages. 152 | -- Everything will be downloaded from the mirror. 153 | dlAssets :: forall c m. 154 | (Has c TarballsDir, 155 | Has c CabalFilesDir, 156 | MonadStep c m) 157 | => [PackageDlDesc] -> m () 158 | dlAssets packages = do 159 | logInfoTitle "[Step 3] Downloading hackage assets (cabal files, tarballs)." 160 | let settings = managerSetProxy 161 | (proxyEnvironment Nothing) 162 | tlsManagerSettings 163 | tbd <- asks (view hasLens) 164 | cd <- asks (view hasLens) 165 | m <- liftIO $ newManager settings 166 | _ <- foldr (dlFoldCabalFiles cd tbd m (length packages)) (return 1) packages 167 | return () 168 | where 169 | dlFoldCabalFiles :: CabalFilesDir -> TarballsDir -> Manager -> Int -> PackageDlDesc -> m Int -> m Int 170 | dlFoldCabalFiles !cd !td man totalSteps !p step = handleAll logErrors $ do 171 | step' <- step 172 | let !pn = packagedlDescName p 173 | logInfoProgress 3 totalSteps step' $ "Downloading " <> pn <> " assets." 174 | downloadHackageFiles cd td man p 175 | return $ step' + 1 176 | where 177 | logErrors e = do 178 | logError $ "[Step 3] ERROR while downloading " <> packagedlDescName p 179 | <> " assets: " <> T.pack (displayException e) 180 | step' <- step 181 | pure (step' + 1) 182 | downloadHackageFiles :: CabalFilesDir -> TarballsDir -> Manager -> PackageDlDesc -> m () 183 | downloadHackageFiles 184 | (CabalFilesDir cabalFilesDir) (TarballsDir tarballsDir) man 185 | (PackageDlDesc (name, cabalUrl, tarballUrl)) = 186 | liftIO $ do 187 | f <- httpLbs (parseRequest_ $ T.unpack cabalUrl) man 188 | BL.writeFile (cabalFilesDir T.unpack name <.> "cabal") $ responseBody f 189 | f' <- httpLbs (parseRequest_ $ T.unpack tarballUrl) man 190 | BL.writeFile (tarballsDir T.unpack name <.> "tar.gz") $ responseBody f' 191 | return () 192 | 193 | -- | `Step` 4: Dependencies graph generation. 194 | -- 195 | -- This function generates the packages dependancy graph. 196 | -- 197 | genGraphDep :: forall c m. 198 | (Has c TarballsDir, 199 | Has c CabalFilesDir, 200 | Has c WorkDir, 201 | Has c (DatabaseHandle 'Initialized), 202 | MonadStep c m) 203 | => [PackageDlDesc] -> m [Package] 204 | genGraphDep pd = do 205 | logInfoTitle "[Step 4] Generating dependencies graph." 206 | tbd <- asks (view hasLens) 207 | cd <- asks (view hasLens) 208 | wd <- asks (view hasLens) 209 | logInfo "[+] Parsing cabal files." 210 | (_, !pkgs) <- foldM' (readPkgsFiles cd wd tbd (length pd)) (1,[]) pd 211 | pure pkgs 212 | where 213 | readPkgsFiles (CabalFilesDir cabalFilesDir) (WorkDir wd) (TarballsDir tarballsDir) !totalSteps (!step, xs) p = 214 | handleAll logErrors $ do 215 | logInfoProgress 4 totalSteps step $ "Unzip " <> packagedlDescName p <> " package." 216 | let tbp = tarballsDir T.unpack (packagedlDescName p) <.> "tar.gz" 217 | tb <- liftIO $ BS.readFile tbp 218 | pfp <- unpackHackageTarball wd tb 219 | logInfoProgress 4 totalSteps step $ "Reading " <> packagedlDescName p <> " cabal file." 220 | !cf <- liftIO $ T.readFile $ cabalFilesDir T.unpack (packagedlDescName p) <.> "cabal" 221 | let !pack = parseCabalFile $ PackageDesc (pfp,cf) 222 | case pack of 223 | Nothing -> pure (step + 1, xs) 224 | Just !x -> pure (step + 1, x:xs) 225 | where 226 | logErrors e = do 227 | logError $ "[Step 4] ERROR cannot read " <> packagedlDescName p 228 | <> " cabal file: " <> T.pack (displayException e) 229 | pure (step + 1, xs) 230 | 231 | -- | `Step` 5: Save dependancies graph. 232 | -- 233 | -- This step takes the previously generated dependancies graph and saves it 234 | -- in the database. 235 | -- 236 | -- Caution: this step can be **really** long. 237 | saveGraphDep :: forall c m. 238 | (Has c TarballsDir, 239 | Has c CabalFilesDir, 240 | Has c (DatabaseHandle 'Initialized), 241 | MonadStep c m) 242 | => [Package] -> m (DatabaseHandle 'DepsGraph) 243 | saveGraphDep pkgs = do 244 | logInfoTitle "[Step 5] Saving dependencies graph." 245 | dbHandle <- asks (view hasLens) :: m (DatabaseHandle 'Initialized) 246 | let (dbFp, dbHandle') = getDatabaseHandle dbHandle 247 | liftIO $ withSQLite dbFp $ do 248 | logInfo "[+] Saving packages to DB (may take some time)..." 249 | savePackages pkgs 250 | logInfo "[+] Done." 251 | logInfo "[+] Saving dependancies to DB..." 252 | -- TODO: maybe speedup this insert by caching the packages ids 253 | -- in a hasmap in the memory. (or use sqlite in memory system????) 254 | foldM_ (foldInsertDep (length pkgs)) 1 pkgs 255 | logInfo "[+] Done." 256 | return () 257 | pure dbHandle' 258 | where 259 | foldInsertDep :: Int -> Int -> Package -> SeldaM Int 260 | foldInsertDep totalDeps step pkg = handleAll logErrors $ do 261 | savePackageDeps pkg 262 | logInfoProgress 5 totalDeps step $ "Saving " <> getName pkg <> " dependancies to DB." 263 | pure $ step + 1 264 | where 265 | logErrors e = do 266 | logError $ "[Step 5] ERROR cannot insert " <> getName pkg <> " dependancies to DB: " 267 | <> T.pack (displayException e) 268 | pure $ step + 1 269 | 270 | -- | `Step` 6: extracting and indexing modules exports. 271 | -- 272 | -- Builds the packages using cabal, load the modules in a 273 | -- GHC-API program which extracts the exports and finally save 274 | -- everything in the ex-hack database. 275 | retrievePkgsExports :: forall c m. 276 | (Has c (DatabaseHandle 'DepsGraph), 277 | MonadStep c m) 278 | => [Package] -> m (DatabaseHandle 'PkgExports) 279 | retrievePkgsExports pkgs = do 280 | logInfoTitle "[Step 6] Retrieving modules exports." 281 | dbHandle <- asks (view hasLens) :: m (DatabaseHandle 'DepsGraph) 282 | let (dbFp, dbHandle') = getDatabaseHandle dbHandle 283 | foldM_ (getPkgExports dbFp (length pkgs)) 1 pkgs 284 | pure dbHandle' 285 | where 286 | getPkgExports :: FilePath -> Int -> Int -> Package -> m Int 287 | getPkgExports dbFp totalSteps !nb p = handleAll logErrors $ do 288 | logInfoProgress 6 totalSteps nb $ "Retrieving "<> getName p <> " exports." 289 | let pfp = packageFilePath p 290 | cr <- buildPackage pfp 291 | maybe (pure ()) (\(errCode, errStr) -> throwM $ CabalBuildError errCode errStr) cr 292 | let mns = getModNames p 293 | croots = maybe [ComponentRoot "./"] roots $ exposedModules p 294 | pid <- liftIO $ withSQLite dbFp $ getPackageId p 295 | processMod pid pfp croots `mapM_` mns 296 | pure $ nb + 1 297 | where 298 | processMod :: RowID -> PackageFilePath -> [ComponentRoot] -> ModuleName -> m () 299 | processMod pid pfp crs mn = do 300 | (_, me) <- getModExports pfp crs mn 301 | -- Breaks a bit the design but necessary to keep 302 | -- memory usage under control. 303 | liftIO $ withSQLite dbFp $ saveModuleExports pid mn me 304 | pure () 305 | logErrors e = do 306 | logError $ "[Step 6] ERROR cannot get exports for " <> getName p <> ": " 307 | <> T.pack (displayException e) 308 | pure $ nb + 1 309 | 310 | -- | `Step` 7: Indexes the code source symbols in the database. 311 | -- 312 | -- For each package, component and module, this step will: 313 | -- 314 | -- 1. Retrieve the imported symbols and try to match them to the previously 315 | -- indexed package exports. 316 | -- 2. Use GHC parser to get this file symbols. 317 | -- 3. Unify these symbols to the imported one. 318 | -- 4. We save each unified occurence in the database. 319 | indexSymbols :: forall c m. 320 | (MonadStep c m, 321 | MonadCatch m, 322 | MonadThrow m, 323 | Has c (DatabaseHandle 'PkgExports)) 324 | => [Package] -> m (DatabaseHandle 'IndexedSyms) 325 | indexSymbols pkgs = do 326 | logInfoTitle "[Step 7] Indexing used symbols." 327 | dbh <- asks (view hasLens) :: m (DatabaseHandle 'PkgExports) 328 | let (dbfp, dbh') = getDatabaseHandle dbh 329 | foldM_ (indexPackage dbfp (length pkgs)) 1 pkgs 330 | pure dbh' 331 | where 332 | indexPackage :: FilePath -> Int -> Int -> Package -> m Int 333 | indexPackage !dbFp nb cur p = do 334 | logInfoProgress 7 nb cur $ "Indexing " <> getName p <> " used symbols." 335 | is <- liftIO $ withSQLite dbFp $ getPkgImportScopes p 336 | indexComponent dbFp p (packageFilePath p) is `mapM_` allComponents p 337 | pure $ cur + 1 338 | indexComponent :: FilePath -> Package -> PackageFilePath -> ImportsScope 339 | -> PackageComponent -> m () 340 | indexComponent dbh p pfp is pc = handleAll logErrors $ do 341 | mfps <- findModuleFilePath pfp (roots pc) `mapM` mods pc 342 | indexModule dbh p pfp is `mapM_` mfps 343 | where 344 | logErrors e = 345 | logError $ "[Step 7] ERROR while indexing component " <> T.pack (show pc) <> " from package " 346 | <> getName p <> ": " <> T.pack (displayException e) 347 | indexModule :: FilePath -> Package -> PackageFilePath -> ImportsScope 348 | -> (ModuleName, ComponentRoot) -> m () 349 | indexModule dbFp p pfp is (mn,cr) = handleAll logErrors $ do 350 | imports <- getModImports pfp cr mn 351 | -- fis: filtered import scope according to this module imports 352 | -- isyms: imported symbols hashsets on which we will perform the unification 353 | let !fis = HM.filterWithKey (\(IndexedModuleNameT (n, _)) _ -> n `elem` imports) is 354 | !isyms = HS.unions $ HM.elems fis 355 | !isymsMap = HS.foldl' (\hm is'@(IndexedSym (n, _)) -> HM.insert n is' hm) HM.empty isyms 356 | syms <- getModSymbols p pfp cr mn 357 | fileContent <- liftIO $ T.readFile $ toModFilePath pfp cr mn 358 | let !file = SourceCodeFile fileContent (getModNameT mn) (getPackageNameT p) 359 | unsyms = unifySymbols isymsMap syms 360 | withSQLite dbFp $ saveModuleUnifiedSymbols unsyms file 361 | where 362 | logErrors e = do 363 | let (ModuleNameT mnt) = getModNameT mn 364 | logError $ "[Step 7] ERROR while indexing module " <> mnt <> " from package " 365 | <> getName p <> ": " <> T.pack (displayException e) 366 | 367 | findModuleFilePath :: PackageFilePath -> [ComponentRoot] -> ModuleName -> m (ModuleName, ComponentRoot) 368 | findModuleFilePath pfp crs mn = do 369 | cr <- findComponentRoot pfp crs mn 370 | pure (mn, cr) 371 | unifySymbols :: HM.HashMap SymName IndexedSym -> [LocatedSym] -> [UnifiedSym] 372 | unifySymbols isyms = foldl' foldLSym [] 373 | where 374 | foldLSym xs ls@(LocatedSym (_, _, locSym)) = 375 | maybe xs (\is -> UnifiedSym(is,ls) : xs) (HM.lookup (unLoc locSym) isyms) 376 | 377 | -- | `Step` 8: Generates the HTML documentation using the previously 378 | -- generated database. 379 | generateHtmlPages :: forall c m. 380 | (MonadStep c m, 381 | MonadCatch m, 382 | MonadThrow m, 383 | Has c (DatabaseHandle 'IndexedSyms), 384 | Has c HtmlDir) 385 | => m () 386 | generateHtmlPages = do 387 | logInfoTitle "[Step 8] Generating the HTML documentation." 388 | HtmlDir outfp <- asks (view hasLens) :: m HtmlDir 389 | dbh <- asks (view hasLens) :: m (DatabaseHandle 'IndexedSyms) 390 | let (dbfp,_) = getDatabaseHandle dbh 391 | pkgs <- liftIO $ withSQLite dbfp getHomePagePackages 392 | let hp = renderHtml $ homePageTemplate pkgs RT.renderRoute 393 | liftIO $ withFile 394 | (outfp "index.html") 395 | WriteMode 396 | (\h -> hSetEncoding h utf8 >> TL.hPutStr h hp) 397 | foldM_ (generatePackPage dbfp outfp (length pkgs)) 1 pkgs 398 | copyAssets outfp 399 | where 400 | generatePackPage :: FilePath -> FilePath -> Int -> Int -> RT.HomePagePackage -> m Int 401 | generatePackPage !dbfp outfp nbI i hp@(RT.HomePagePackage pack@(RT.PackageName (_,pname)) _) = 402 | handleAll logErrors $ do 403 | expmods <- liftIO $ withSQLite dbfp (getPackagePageMods pack) 404 | logInfoProgress 8 nbI i $ "Generating HTML documentation for " <> pname 405 | let fp = outfp "packages" T.unpack pname 406 | pp = renderHtml $ packagePageTemplate hp expmods RT.renderRoute 407 | liftIO $ do createDirectoryIfMissing True fp 408 | writeUtf8File fp pp 409 | generateModPage dbfp fp hp `mapM_` expmods 410 | pure $ i + 1 411 | where 412 | logErrors e = do 413 | logError $ "[Step 7] ERROR while generating " <> pname <> 414 | " HTML documentation: " <> T.pack (displayException e) 415 | pure $ i + 1 416 | generateModPage :: FilePath -> FilePath -> RT.HomePagePackage -> RT.ModuleName -> m () 417 | generateModPage dbfp packfp hp@(RT.HomePagePackage pack _) modn@(RT.ModuleName (_,modnt)) = do 418 | syms <- liftIO $ withSQLite dbfp (getModulePageSyms pack modn) 419 | hsyms <- highLightOccs syms 420 | let mp = renderHtml $ modulePageTemplate hp modn hsyms RT.renderRoute 421 | fp = packfp T.unpack (T.replace "." "-" modnt) 422 | liftIO $ do createDirectoryIfMissing True fp 423 | writeUtf8File fp mp 424 | -- | TODO: highlighting shouldn't be performed here but directly when extracted from the DB. 425 | -- This hack has been performed in a rush, should be fixed after V0. 426 | highLightOccs :: [RT.SymbolOccurs] -> m [RT.HighlightedSymbolOccurs] 427 | highLightOccs xs = highSyms `mapM` xs 428 | where 429 | highSyms (RT.SymbolOccurs sn xs') = do 430 | hs <- highSym `mapM` xs' 431 | pure $ RT.HighlightedSymbolOccurs sn hs 432 | highSym (col, line, SourceCodeFile c p m) = do 433 | hc <- handleAll highErr $ highLightCode c 434 | pure (col, line, RT.HighlightedSourceCodeFile (addLineMarker line hc) p m) 435 | where 436 | highErr e = do 437 | logError $ "[Step 8] HIGHLIGHT ERROR " <> T.pack (displayException e) 438 | pure c 439 | copyAssets :: FilePath -> m () 440 | copyAssets fp = do 441 | let font = $(embedFile "./src/ExHack/Renderer/templates/static/Inter-UI-Regular.woff") 442 | list = $(embedFile "./src/ExHack/Renderer/templates/static/list.min.js") 443 | style = $(embedFile "./src/ExHack/Renderer/templates/static/style.css") 444 | logo = $(embedFile "./img/logo/ex-hack-logo.svg") 445 | stat = fp "static" 446 | liftIO $ do 447 | createDirectoryIfMissing True stat 448 | BS.writeFile (stat "Inter-UI-Regular.woff") font 449 | BS.writeFile (stat "list.min.js") list 450 | BS.writeFile (stat "style.css") style 451 | BS.writeFile (stat "ex-hack-logo.svg") logo 452 | writeUtf8File :: FilePath -> TL.Text -> IO () 453 | writeUtf8File fp txt = 454 | withFile (fp "index.html") 455 | WriteMode 456 | (\h -> hSetEncoding h utf8 >> TL.hPutStr h txt) 457 | -------------------------------------------------------------------------------- /src/ExHack/Renderer/Html.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : ExHack.Renderer.Html 3 | Description : HTML renderer. 4 | Copyright : (c) Félix Baylac-Jacqué, 2018 5 | License : GPL-3 6 | Stability : experimental 7 | Portability : POSIX 8 | -} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | module ExHack.Renderer.Html ( 13 | addLineMarker, 14 | highLightCode, 15 | homePageTemplate, 16 | modulePageTemplate, 17 | packagePageTemplate 18 | ) where 19 | 20 | import Control.Monad.Catch (MonadMask, throwM) 21 | import Control.Monad.IO.Class (MonadIO, liftIO) 22 | import qualified Data.Text as T (Text, lines, pack, unlines, 23 | unpack) 24 | import Safe (headMay) 25 | import System.Exit (ExitCode (..)) 26 | import System.Process (readProcessWithExitCode) 27 | import Text.Blaze.Html (preEscapedToHtml) 28 | import Text.Hamlet (HtmlUrl, hamletFile) 29 | 30 | import ExHack.Renderer.Types (HighLightError (..), 31 | HighlightedSourceCodeFile (..), 32 | HighlightedSymbolOccurs (..), 33 | HomePagePackage (..), ModuleName (..), 34 | PackageName (..), Route (..)) 35 | import ExHack.Types (ModuleNameT (..), PackageNameT (..)) 36 | 37 | -- | Highlights the source file using pygments. 38 | highLightCode :: forall m. (MonadIO m, MonadMask m) => T.Text -> m T.Text 39 | highLightCode t = do 40 | (ec,out,err) <- liftIO $ readProcessWithExitCode 41 | "pygmentize" 42 | ["-l", "haskell", "-f", "html"] 43 | $ T.unpack t 44 | case ec of 45 | ExitSuccess -> pure $ T.pack out 46 | ExitFailure _ -> throwM $ HighLightError err 47 | 48 | -- | Adds an arrow pointing to the selected symbol. 49 | addLineMarker :: Int -> T.Text -> T.Text 50 | addLineMarker line t = let slm = headMay end 51 | in maybe t (\l -> T.unlines $ start <> [wrapL l] <> drop 1 end) slm 52 | where 53 | xs = T.lines t 54 | start = take (line - 1) xs 55 | end = drop (line - 1) xs 56 | wrapL txt = "" <> txt <> "" 57 | 58 | getHeader :: T.Text -> HtmlUrl Route 59 | getHeader pageTitle = $(hamletFile "./src/ExHack/Renderer/templates/header.hamlet") 60 | 61 | menu :: HtmlUrl Route 62 | menu = $(hamletFile "./src/ExHack/Renderer/templates/menu.hamlet") 63 | 64 | -- | Template rendered in order to create the home page. 65 | homePageTemplate :: [HomePagePackage] -> HtmlUrl Route 66 | homePageTemplate packages = 67 | $(hamletFile "./src/ExHack/Renderer/templates/homePage.hamlet") 68 | where 69 | header = getHeader "The Haskell Examples Database" 70 | 71 | -- | Template rendered in order to create a package's page. 72 | packagePageTemplate :: HomePagePackage -> [ModuleName] -> HtmlUrl Route 73 | packagePageTemplate pack@(HomePagePackage (PackageName (_,pn)) _) mods = 74 | $(hamletFile "./src/ExHack/Renderer/templates/packagePage.hamlet") 75 | where 76 | header = getHeader $ pn <> " usage examples" 77 | 78 | -- | Template rendered in order to create a module's page. 79 | modulePageTemplate :: HomePagePackage -> ModuleName -> [HighlightedSymbolOccurs] -> HtmlUrl Route 80 | modulePageTemplate _ (ModuleName (_,mname)) soccs = 81 | $(hamletFile "./src/ExHack/Renderer/templates/modulePage.hamlet") 82 | where 83 | header = getHeader $ mname <> " usage examples" 84 | -------------------------------------------------------------------------------- /src/ExHack/Renderer/Types.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : ExHack.Renderer.Types 3 | Description : Types associated to the HTML renderer. 4 | Copyright : (c) Félix Baylac-Jacqué, 2018 5 | License : GPL-3 6 | Stability : experimental 7 | Portability : POSIX 8 | -} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE DeriveGeneric #-} 11 | 12 | module ExHack.Renderer.Types ( 13 | Col, 14 | HighLightError(..), 15 | HighlightedSymbolOccurs(..), 16 | HighlightedSourceCodeFile(..), 17 | HomePagePackage(..), 18 | Line, 19 | ModuleName(..), 20 | PackageName(..), 21 | Route(..), 22 | SymbolName, 23 | SymbolOccurs(..), 24 | renderRoute 25 | ) where 26 | 27 | import Control.Monad.Catch (Exception) 28 | import Data.Text (Text, pack, replace, unpack) 29 | import Database.Selda (RowID) 30 | import GHC.Generics (Generic) 31 | import Network.URI (escapeURIString, isReserved) 32 | import Text.Hamlet (Render) 33 | 34 | import ExHack.Types (ModuleNameT, PackageNameT, 35 | SourceCodeFile (..)) 36 | 37 | newtype PackageName = PackageName (RowID, Text) 38 | deriving (Eq, Show, Generic) 39 | 40 | newtype ModuleName = ModuleName (RowID, Text) 41 | deriving (Eq, Show, Generic) 42 | 43 | -- Source code file that has been highligthed by pygments. 44 | data HighlightedSourceCodeFile = HighlightedSourceCodeFile !Text !ModuleNameT !PackageNameT 45 | deriving (Eq, Show, Generic) 46 | 47 | type SymbolName = Text 48 | 49 | type Col = Int 50 | 51 | type Line = Int 52 | 53 | -- | Renderer's routing datatype 54 | data Route = 55 | HomePage 56 | | PackagePage PackageName 57 | | ModulePage PackageName ModuleName 58 | 59 | -- | Datatype used to populate the home page template. 60 | data HomePagePackage = HomePagePackage !PackageName !Int 61 | deriving (Eq, Show, Generic) 62 | 63 | -- | Datatype used to populate the module HTML template whith non highlighted code. 64 | data SymbolOccurs = SymbolOccurs !SymbolName [(Col, Line, SourceCodeFile)] 65 | deriving (Eq, Show, Generic) 66 | 67 | -- | Datatype used to populate the module HTML template whith highlighted code. 68 | data HighlightedSymbolOccurs = HighlightedSymbolOccurs SymbolName [(Col, Line, HighlightedSourceCodeFile)] 69 | deriving (Eq, Show, Generic) 70 | 71 | -- | Exception raised during the code highlight process. 72 | newtype HighLightError = HighLightError String 73 | deriving (Eq, Show, Generic) 74 | 75 | instance Exception HighLightError 76 | 77 | escapeUrlSegment :: Text -> Text 78 | escapeUrlSegment = pack . escapeURIString (not . isReserved) . unpack 79 | 80 | -- | Render a 'Route' to a proper HTTP URL. 81 | renderRoute :: Render Route 82 | renderRoute HomePage _ = "/" 83 | renderRoute (PackagePage (PackageName (_,pn))) _ = "/packages/" <> escapeUrlSegment pn <> "/" 84 | renderRoute (ModulePage (PackageName (_,pn)) (ModuleName (_,mn))) _ = 85 | "/packages/" <> escapeUrlSegment pn <> "/" <> escapeUrlSegment (replace "." "-" mn) <> "/" 86 | -------------------------------------------------------------------------------- /src/ExHack/Renderer/templates/header.hamlet: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | #{pageTitle} | ExHack 7 | 8 | -------------------------------------------------------------------------------- /src/ExHack/Renderer/templates/homePage.hamlet: -------------------------------------------------------------------------------- 1 | $doctype 5 2 | <html> 3 | ^{header} 4 | <body> 5 | ^{menu} 6 | <div id="content"> 7 | <h1>The Haskell Examples Database 8 | <div id="package-table"> 9 | <input id="search" class="search" placeholder="Search for a package name" autocomplete="off"> 10 | <table id="table" class="fancy row-border order-column compact dataTable no-footer" role="grid"> 11 | <thead> 12 | <tr role="row"> 13 | <th> 14 | <div>Package Name 15 | <th> 16 | <div>Nb Exported Modules 17 | <tbody class="list"> 18 | $forall HomePagePackage pn@(PackageName (_,pname)) nbMods <- packages 19 | <tr class="package" role="row"> 20 | <td> 21 | <a href="@{PackagePage pn}" class="packageName">#{pname} 22 | <td>#{nbMods} 23 | <script src="/static/list.min.js"> 24 | <script> 25 | document.addEventListener("DOMContentLoaded", function(event) { 26 | var list = new List('package-table', { 27 | valueNames: ['packageName'] 28 | }); 29 | }); 30 | -------------------------------------------------------------------------------- /src/ExHack/Renderer/templates/index.html: -------------------------------------------------------------------------------- 1 | $doctype 5 2 | <!DOCTYPE html> 3 | <html> 4 | <head> 5 | <meta charset="utf-8"/> 6 | <meta name="viewport" content="width=device-width, initial-scale=1"> 7 | <link href="https://fonts.googleapis.com/css?family=PT+Sans:400,400i,700" rel="stylesheet"> 8 | <link rel="stylesheet" href="/static/style.css" type="text/css" /> 9 | <link rel="icon" type="image/png" href="/static/favicon.png" /> 10 | <link rel="search" type="application/opensearchdescription+xml" title="ExHack" href="/packages/opensearch.xml" /> 11 | 12 | <title>ExHack | Haskell Examples Database 13 | 14 | 15 | 16 |
17 | 18 | ExHack :: [Package] 19 | 20 | 25 | 26 |
27 | 28 |
29 |

The Haskell Examples Database

30 |
31 | 32 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 |
57 |
58 | 59 | 66 | 67 | 68 | -------------------------------------------------------------------------------- /src/ExHack/Renderer/templates/menu.hamlet: -------------------------------------------------------------------------------- 1 |
2 | 3 | ExHack :: Haskell Examples Database 4 |