├── example ├── README.md ├── .gitignore ├── Setup.hs ├── stack.yaml ├── ChangeLog.md ├── test │ └── Spec.hs ├── app │ └── Main.hs ├── src │ └── Lib.hs ├── stack.yaml.lock ├── package.yaml ├── LICENSE └── example.cabal ├── ChangeLog.md ├── server.dhall.dist ├── split.gif ├── izuna-builder ├── test │ ├── Spec.hs │ ├── fixtures │ │ └── hie │ │ │ ├── project0 │ │ │ ├── Lib.hie │ │ │ ├── Main.hie │ │ │ └── Paths_example.hie │ │ │ └── project1 │ │ │ ├── Lib.hie │ │ │ ├── Main.hie │ │ │ └── Paths_example.hie │ └── ProjectInfo │ │ └── AppSpec.hs ├── app │ └── Main.hs ├── src │ ├── IzunaBuilder │ │ ├── ProjectInfo │ │ │ ├── Util.hs │ │ │ ├── RecoverType.hs │ │ │ ├── Model.hs │ │ │ └── App.hs │ │ ├── Type.hs │ │ ├── NonEmptyString.hs │ │ ├── Server.hs │ │ ├── HieFile │ │ │ └── App.hs │ │ └── Json.hs │ └── DevelMain.hs ├── project.nix ├── README.md ├── servant-multipart.nix ├── default.nix ├── package.yaml └── izuna-builder.cabal ├── unified.gif ├── chrome-extension ├── src │ ├── cache.js │ ├── constants.js │ ├── popup.js │ ├── popup.html │ ├── izunaServerService.js │ ├── numBlob.js │ ├── filesInfo.js │ ├── background.js │ ├── splitter.js │ ├── popper.js │ ├── contentScript.js │ └── pullRequestPageService.js ├── icons │ ├── izuna-16.png │ ├── izuna-48.png │ └── izuna-128.png ├── .eslintrc.js ├── webpack.config.test.js ├── manifest.json ├── css │ └── contentScript.css ├── webpack.config.js ├── package.json └── test │ ├── test.js │ └── filesInfoTest.js ├── izuna-server ├── app │ └── Main.hs ├── src │ ├── IzunaServer │ │ ├── Env.hs │ │ ├── PullRequest │ │ │ ├── App.hs │ │ │ └── Model.hs │ │ ├── Service │ │ │ └── Github.hs │ │ ├── Project │ │ │ └── App.hs │ │ └── Server.hs │ └── DevelMain.hs ├── package.yaml └── izuna-server.cabal ├── .gitignore ├── stack-8.10.3.yaml ├── stack-8.10.2.yaml ├── nixpkgs.nix ├── stack-8.10.3.yaml.lock ├── stack.yaml.lock ├── stack-8.10.2.yaml.lock ├── stack-8.10.1.yaml ├── LICENSE ├── Makefile ├── .github └── workflows │ └── main.yml ├── .hlint.yaml ├── stack-8.10.1.yaml.lock └── README.md /example/README.md: -------------------------------------------------------------------------------- 1 | # example 2 | -------------------------------------------------------------------------------- /example/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for HieParser 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /example/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2020-08-14 2 | packages: 3 | - . 4 | -------------------------------------------------------------------------------- /server.dhall.dist: -------------------------------------------------------------------------------- 1 | { appPort = 3000 2 | , githubAuthToken = "" 3 | } 4 | -------------------------------------------------------------------------------- /split.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matsumonkie/izuna/HEAD/split.gif -------------------------------------------------------------------------------- /izuna-builder/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /unified.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matsumonkie/izuna/HEAD/unified.gif -------------------------------------------------------------------------------- /chrome-extension/src/cache.js: -------------------------------------------------------------------------------- 1 | var Cache = { 2 | }; 3 | 4 | export { Cache }; 5 | -------------------------------------------------------------------------------- /example/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for example 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /example/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /example/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib 4 | 5 | main :: IO () 6 | main = someFunc 7 | -------------------------------------------------------------------------------- /chrome-extension/icons/izuna-16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matsumonkie/izuna/HEAD/chrome-extension/icons/izuna-16.png -------------------------------------------------------------------------------- /chrome-extension/icons/izuna-48.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matsumonkie/izuna/HEAD/chrome-extension/icons/izuna-48.png -------------------------------------------------------------------------------- /chrome-extension/icons/izuna-128.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matsumonkie/izuna/HEAD/chrome-extension/icons/izuna-128.png -------------------------------------------------------------------------------- /izuna-server/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import IzunaServer.Server (run) 4 | 5 | main :: IO () 6 | main = 7 | run 8 | -------------------------------------------------------------------------------- /izuna-builder/test/fixtures/hie/project0/Lib.hie: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matsumonkie/izuna/HEAD/izuna-builder/test/fixtures/hie/project0/Lib.hie -------------------------------------------------------------------------------- /izuna-builder/test/fixtures/hie/project0/Main.hie: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matsumonkie/izuna/HEAD/izuna-builder/test/fixtures/hie/project0/Main.hie -------------------------------------------------------------------------------- /izuna-builder/test/fixtures/hie/project1/Lib.hie: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matsumonkie/izuna/HEAD/izuna-builder/test/fixtures/hie/project1/Lib.hie -------------------------------------------------------------------------------- /izuna-builder/test/fixtures/hie/project1/Main.hie: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matsumonkie/izuna/HEAD/izuna-builder/test/fixtures/hie/project1/Main.hie -------------------------------------------------------------------------------- /izuna-builder/test/fixtures/hie/project0/Paths_example.hie: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matsumonkie/izuna/HEAD/izuna-builder/test/fixtures/hie/project0/Paths_example.hie -------------------------------------------------------------------------------- /izuna-builder/test/fixtures/hie/project1/Paths_example.hie: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/matsumonkie/izuna/HEAD/izuna-builder/test/fixtures/hie/project1/Paths_example.hie -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | .hie/ 4 | elm-stuff/ 5 | node_modules/ 6 | app.js 7 | backup/ 8 | package-lock.json 9 | *.zip 10 | *.tar 11 | *.dhall 12 | .#* 13 | dist/ 14 | dist-newstyle/ 15 | result -------------------------------------------------------------------------------- /izuna-builder/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Environment 4 | 5 | import IzunaBuilder.Server (run) 6 | 7 | main :: IO () 8 | main = do 9 | [port] <- getArgs 10 | run $ read @Int port 11 | -------------------------------------------------------------------------------- /stack-8.10.3.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-17.0 2 | packages: 3 | - izuna-builder 4 | - izuna-server 5 | 6 | extra-deps: 7 | - servant-flatten-0.2 8 | 9 | nix: 10 | enable: true 11 | packages: [ zlib ] 12 | path: [nixpkgs=./nixpkgs.nix] 13 | -------------------------------------------------------------------------------- /stack-8.10.2.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2020-11-23 2 | packages: 3 | - izuna-builder 4 | - izuna-server 5 | 6 | extra-deps: 7 | - servant-flatten-0.2 8 | 9 | nix: 10 | enable: true 11 | packages: [ zlib ] 12 | path: [nixpkgs=./nixpkgs.nix] 13 | -------------------------------------------------------------------------------- /example/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | 8 | add :: Int -> Int -> Int 9 | add x y = 10 | x + y 11 | 12 | foo :: String 13 | foo = 14 | let x = 42 15 | in show x 16 | -------------------------------------------------------------------------------- /nixpkgs.nix: -------------------------------------------------------------------------------- 1 | let 2 | rev = "966489a0312f80e4dd20189f885bc12d6723a9ac"; 3 | extractedTarball = fetchTarball { 4 | url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; 5 | sha256 = "sha256:10jx7y8bgkqki9nfy6fdg121pixysrrbdlyyy30sv4x65clmalwp"; 6 | }; 7 | in 8 | # extractedTarball will be a directory here, and 'import' will automatically append /default.nix here 9 | import extractedTarball 10 | -------------------------------------------------------------------------------- /chrome-extension/src/constants.js: -------------------------------------------------------------------------------- 1 | const Constants = { 2 | PULL_REQUEST_DETAILS_FETCHED: 'PULL_REQUEST_DETAILS_FETCHED', 3 | FILES_INFO_FETCHED: 'FILES_INFO_FETCHED', 4 | IZUNA_APP_DONE: 'IZUNA_APP_DONE', 5 | 6 | IZUNA_HOST_URL: 'https://izuna.app', 7 | 8 | ENABLE_IZUNA_KEY: 'IZUNA', 9 | 10 | LEFT_LOCATION: 'LEFT', 11 | CENTER_LOCATION: 'CENTER', 12 | RIGHT_LOCATION: 'RIGHT', 13 | 14 | IZUNA_HIGHLIGHT_REGION: 'izuna-highlighted-region', 15 | }; 16 | 17 | export { Constants }; 18 | -------------------------------------------------------------------------------- /example/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 520867 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/8/14.yaml 11 | sha256: 55402c1524b249053913fd87d60062c7c0e816d353e3d842df4cc032432aa0d4 12 | original: nightly-2020-08-14 13 | -------------------------------------------------------------------------------- /chrome-extension/.eslintrc.js: -------------------------------------------------------------------------------- 1 | module.exports = { 2 | 'env': { 3 | 'browser': true, 4 | 'es2021': true 5 | }, 6 | 'extends': 'eslint:recommended', 7 | 'parserOptions': { 8 | 'ecmaVersion': 12, 9 | 'sourceType': 'module' 10 | }, 11 | 'rules': { 12 | 'indent': [ 13 | 'error', 14 | 2 15 | ], 16 | 'linebreak-style': [ 17 | 'error', 18 | 'unix' 19 | ], 20 | 'quotes': [ 21 | 'warn', 22 | 'single' 23 | ], 24 | 'semi': [ 25 | 'warn', 26 | 'always' 27 | ] 28 | } 29 | }; 30 | -------------------------------------------------------------------------------- /izuna-server/src/IzunaServer/Env.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module IzunaServer.Env 4 | ( getEnv 5 | , Env(..) 6 | ) where 7 | 8 | import qualified Dhall 9 | import GHC.Generics (Generic) 10 | 11 | import IzunaBuilder.Type 12 | 13 | data Env = Env 14 | { _env_githubAuthToken :: Text 15 | , _env_port :: Nat 16 | } 17 | deriving (Generic, Show) 18 | 19 | instance Dhall.FromDhall Env where 20 | autoWith _ = Dhall.record $ 21 | Env 22 | <$> Dhall.field "githubAuthToken" Dhall.auto 23 | <*> Dhall.field "appPort" Dhall.auto 24 | 25 | getEnv :: IO Env 26 | getEnv = 27 | Dhall.input Dhall.auto "./server.dhall" 28 | -------------------------------------------------------------------------------- /chrome-extension/webpack.config.test.js: -------------------------------------------------------------------------------- 1 | const path = require('path'); 2 | const CleanTerminalPlugin = require('clean-terminal-webpack-plugin'); 3 | const glob = require('glob'); 4 | 5 | module.exports = { 6 | entry: glob.sync('./test/*.js'), 7 | output: { 8 | filename: '[name].js', 9 | path: path.resolve(__dirname, 'dist') 10 | }, 11 | plugins: [new CleanTerminalPlugin()], 12 | module: { 13 | rules: [ 14 | { 15 | test: /\.js$/, 16 | exclude: /(node_modules|bower_components)/, 17 | loader: 'babel-loader', 18 | options: { 19 | presets: ["@babel/preset-env"], 20 | plugins: ["@babel/plugin-proposal-class-properties"] 21 | } 22 | } 23 | ] 24 | } 25 | } 26 | -------------------------------------------------------------------------------- /chrome-extension/src/popup.js: -------------------------------------------------------------------------------- 1 | /*global chrome*/ 2 | 3 | import { Constants } from './constants.js'; 4 | 5 | document.addEventListener('DOMContentLoaded', () => { 6 | const checkbox = document.querySelector('input#enableIzuna'); 7 | 8 | getEnableIzuna((savedChecked) => { 9 | if(savedChecked) { 10 | checkbox.checked = savedChecked; 11 | } 12 | }); 13 | 14 | checkbox.addEventListener('change', () => { 15 | var keyValue = {}; 16 | keyValue[Constants.ENABLE_IZUNA_KEY] = checkbox.checked; 17 | chrome.storage.sync.set(keyValue); 18 | }); 19 | }); 20 | 21 | function getEnableIzuna(callback) { 22 | chrome.storage.sync.get(Constants.ENABLE_IZUNA_KEY, (checked) => { 23 | callback(chrome.runtime.lastError ? null : checked[Constants.ENABLE_IZUNA_KEY]); 24 | }); 25 | } 26 | -------------------------------------------------------------------------------- /stack-8.10.3.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 9 | pantry-tree: 10 | size: 325 11 | sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3 12 | original: 13 | hackage: servant-flatten-0.2 14 | snapshots: 15 | - completed: 16 | size: 563100 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/0.yaml 18 | sha256: e93a85871577ea3423d5f3454b2b6bd37c2c2123c79faf511dfb64f5b49a9f8b 19 | original: lts-17.0 20 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 9 | pantry-tree: 10 | size: 325 11 | sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3 12 | original: 13 | hackage: servant-flatten-0.2 14 | snapshots: 15 | - completed: 16 | size: 554194 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/11/23.yaml 18 | sha256: d4037ffda88f024e83ce3e466d7b612939024f2e5d4895f8af7b4ff96cd7ea68 19 | original: nightly-2020-11-23 20 | -------------------------------------------------------------------------------- /stack-8.10.2.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 9 | pantry-tree: 10 | size: 325 11 | sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3 12 | original: 13 | hackage: servant-flatten-0.2 14 | snapshots: 15 | - completed: 16 | size: 554194 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/11/23.yaml 18 | sha256: d4037ffda88f024e83ce3e466d7b612939024f2e5d4895f8af7b4ff96cd7ea68 19 | original: nightly-2020-11-23 20 | -------------------------------------------------------------------------------- /chrome-extension/manifest.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "Izuna", 3 | "version": "0.1.1", 4 | "icons": { "16": "icons/izuna-16.png", 5 | "48": "icons/izuna-48.png", 6 | "128": "icons/izuna-128.png" 7 | }, 8 | "description": "Better Haskell code review for Github!", 9 | "permissions": [ "declarativeContent", 10 | "tabs", 11 | "storage", 12 | "https://izuna.app/", 13 | "http://localhost/" 14 | ], 15 | "background": { 16 | "scripts": [ "dist/background.js" ], 17 | "persistent": false 18 | }, 19 | "content_scripts": [ 20 | { 21 | "matches": ["https://github.com/*"], 22 | "css": [ "css/contentScript.css" ], 23 | "js": [ "dist/contentScript.js" ] 24 | } 25 | ], 26 | "page_action": { 27 | "default_popup": "src/popup.html" 28 | }, 29 | "manifest_version": 2 30 | } 31 | -------------------------------------------------------------------------------- /stack-8.10.1.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2020-08-14 2 | packages: 3 | - izuna-builder 4 | - izuna-server 5 | 6 | extra-deps: 7 | - servant-flatten-0.2 8 | - servant-server-0.18.2@sha256:56679af62ab8820a2108da6153d9ae9dde37199e62172365bdaea1458c3f7c2d,5482 9 | - servant-0.18.2@sha256:f8c9f0e9891a3ada1337a3c0b369333a3b5a2d0909dd3cd09d79bc26adeaca44,5298 10 | - servant-multipart-0.12@sha256:aa81dd0478270ade4a21b75611d5bc9cce8107df2e89c37b9964a3421629825d,2761 11 | - servant-client-0.18.2@sha256:82578ade7468873259bb2fdc9d62290a0f998550900683e1410a237ed4b05410,4591 12 | - servant-client-core-0.18.2@sha256:ad63ae0f227373fea7e547d4c2a7b0b69e112ff409a83cbadffc9f6ee049926f,3763 13 | - servant-docs-0.11.8@sha256:1068303ebafa5df9ec936c727959c15b94f3569d52a5c250bb0693036391effc,3282 14 | - servant-foreign-0.15.3@sha256:5c9230a470776bbf1e9f1126906c08ef090044db9e5bb530a9d8f1c96386ea55,2767 15 | 16 | nix: 17 | enable: true 18 | packages: [ zlib ] 19 | path: [nixpkgs=./nixpkgs.nix] 20 | -------------------------------------------------------------------------------- /chrome-extension/css/contentScript.css: -------------------------------------------------------------------------------- 1 | #tooltip { 2 | background: #333; 3 | color: white; 4 | font-weight: bold; 5 | padding: 4px 8px; 6 | font-size: 13px; 7 | border-radius: 4px; 8 | 9 | display: block; 10 | opacity: 0; 11 | transition: opacity 0.2s linear; 12 | } 13 | 14 | #tooltip[data-show] { 15 | opacity: 1; 16 | } 17 | 18 | #arrow, 19 | #arrow::before { 20 | position: absolute; 21 | width: 8px; 22 | height: 8px; 23 | z-index: -1; 24 | } 25 | 26 | #arrow::before { 27 | content: ''; 28 | transform: rotate(45deg); 29 | background: #333; 30 | } 31 | 32 | #tooltip[data-popper-placement^='top'] > #arrow { 33 | bottom: -4px; 34 | } 35 | 36 | #tooltip[data-popper-placement^='bottom'] > #arrow { 37 | top: -4px; 38 | } 39 | 40 | #tooltip[data-popper-placement^='left'] > #arrow { 41 | right: -4px; 42 | } 43 | 44 | #tooltip[data-popper-placement^='right'] > #arrow { 45 | left: -4px; 46 | } 47 | 48 | .izuna-highlighted-region { 49 | text-decoration: underline; 50 | } 51 | -------------------------------------------------------------------------------- /izuna-builder/src/IzunaBuilder/ProjectInfo/Util.hs: -------------------------------------------------------------------------------- 1 | module IzunaBuilder.ProjectInfo.Util where 2 | 3 | import System.FilePath.Posix (()) 4 | import qualified System.FilePath.Posix as FilePath 5 | 6 | import IzunaBuilder.NonEmptyString 7 | import IzunaBuilder.Type 8 | 9 | getProjectPath 10 | :: NonEmptyString Username 11 | -> NonEmptyString Repo 12 | -> NonEmptyString Commit 13 | -> FilePath 14 | getProjectPath username repo commit = 15 | FilePath.joinPath [ defaultProjectInfoBaseDir 16 | , toString username 17 | , toString repo 18 | , toString commit 19 | ] 20 | where 21 | defaultProjectInfoBaseDir :: FilePath 22 | defaultProjectInfoBaseDir = "./backup" 23 | 24 | getJsonPath :: FilePath -> FilePath -> String 25 | getJsonPath projectPath projectRoot = projectPath "json" projectRoot 26 | 27 | getHiePath :: FilePath -> String 28 | getHiePath projectPath = projectPath "hie" 29 | -------------------------------------------------------------------------------- /chrome-extension/webpack.config.js: -------------------------------------------------------------------------------- 1 | const path = require('path'); 2 | const CleanTerminalPlugin = require('clean-terminal-webpack-plugin'); 3 | const ESLintPlugin = require('eslint-webpack-plugin'); 4 | 5 | module.exports = { 6 | entry: { 7 | contentScript: './src/contentScript.js', 8 | background: './src/background.js', 9 | popup: './src/popup.js', 10 | }, 11 | output: { 12 | filename: '[name].js', 13 | path: path.resolve(__dirname, 'dist'), 14 | sourceMapFilename: "[name].js.map" 15 | }, 16 | devtool: "inline-cheap-module-source-map", 17 | plugins: [ 18 | new CleanTerminalPlugin(), 19 | new ESLintPlugin(), 20 | ], 21 | module: { 22 | rules: [ 23 | { 24 | test: /\.js$/, 25 | exclude: /(node_modules|bower_components)/, 26 | loader: 'babel-loader', 27 | options: { 28 | presets: ["@babel/preset-env"], 29 | plugins: [ 30 | "@babel/plugin-transform-runtime", 31 | ], 32 | } 33 | } 34 | ] 35 | } 36 | } 37 | -------------------------------------------------------------------------------- /izuna-builder/project.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, array, async, base, bytestring, containers 2 | , directory, filepath, foreign-store, generic-lens, ghc-lib 3 | , ghc-lib-parser, ghc-paths, hpack, hspec, html-entities, mtl 4 | , safe-exceptions, say, servant, servant-multipart, servant-server 5 | , stdenv, tar, text, wai, warp, ghcVersion 6 | }: 7 | mkDerivation { 8 | pname = "izuna-builder-${ghcVersion}"; 9 | version = "0.1.0.0"; 10 | src = ./.; 11 | isLibrary = true; 12 | isExecutable = true; 13 | doCheck = false; 14 | doHaddock = false; 15 | libraryHaskellDepends = [ 16 | aeson array async base bytestring containers directory filepath 17 | foreign-store generic-lens ghc-lib ghc-lib-parser ghc-paths 18 | html-entities mtl safe-exceptions say servant servant-multipart 19 | servant-server tar text wai warp 20 | ]; 21 | libraryToolDepends = [ hpack ]; 22 | executableHaskellDepends = [ base ]; 23 | testHaskellDepends = [ base containers hspec text ]; 24 | prePatch = "hpack"; 25 | homepage = "https://github.com/matsumonkie/izuna#readme"; 26 | license = stdenv.lib.licenses.bsd3; 27 | } 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 iori 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /izuna-builder/src/IzunaBuilder/Type.hs: -------------------------------------------------------------------------------- 1 | {- | This module re export common used external types in this project for convenience 2 | -} 3 | 4 | module IzunaBuilder.Type where 5 | 6 | import qualified Data.Array as Array 7 | import qualified Data.ByteString as ByteString 8 | import qualified Data.List.NonEmpty as NE 9 | import qualified Data.Map as M 10 | import qualified Data.Set as S 11 | import qualified Data.Text as T 12 | import qualified DynFlags as Ghc 13 | import qualified HieTypes as Ghc 14 | import Numeric.Natural as Natural 15 | 16 | type ByteString = ByteString.ByteString 17 | type HieTypeFlat = Ghc.HieTypeFlat 18 | type HieFile = Ghc.HieFile 19 | type HieAST = Ghc.HieAST 20 | type TypeIndex = Int 21 | type PrintedType = String 22 | type DynFlags = Ghc.DynFlags 23 | type Set = S.Set 24 | type NodeIdentifiers = Ghc.NodeIdentifiers String 25 | type Text = T.Text 26 | type Map = M.Map 27 | type Nat = Natural.Natural 28 | type NonEmpty = NE.NonEmpty 29 | type Array = Array.Array 30 | 31 | data GhcVersion 32 | data Username 33 | data Repo 34 | data Commit 35 | data CommitId 36 | data ProjectRoot 37 | -------------------------------------------------------------------------------- /izuna-builder/README.md: -------------------------------------------------------------------------------- 1 | # izuna 2 | 3 | Izuna is a tool to help you code review your Haskell project on Github. It shows type annotations directly in Github interface. 4 | Izuna only works with project built with stack, GHC 8.10.2 and when browsing github with Chrome. 5 | 6 | ## Server 7 | 8 | ### How to build 9 | 10 | build: `make build GHC=8.10.2` 11 | run: `make run GHC=8.10.2` 12 | devel: `make devel GHC=8.10.2`. This will start a ghcid session that will run your project and restart the server on every code changes. 13 | 14 | ## Extension 15 | 16 | 17 | ### Prerequisites 18 | 19 | Parts of the browser extension is written in Elm so you need to install some utilities to make it work. 20 | 21 | ``` 22 | npm install elm 23 | npm install chokidar-cli # so you can trigger a compilation on every file changes 24 | ``` 25 | 26 | ### Build 27 | 28 | ```shell 29 | cd chrome-extension/ 30 | make app # to build the app 31 | make watch # to build the app on every code changes 32 | ``` 33 | Building the app should create a `app.js` in the `chrome-extension/` folder. 34 | 35 | ### Install 36 | 37 | Once built, you can add the extension in chrome by going to `chrome://extensions/` and clicking `load unpacked` (then select the `chrome-extension` folder) 38 | -------------------------------------------------------------------------------- /chrome-extension/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "chrome-extension", 3 | "version": "1.0.0", 4 | "description": "", 5 | "private": true, 6 | "directories": { 7 | "test": "test" 8 | }, 9 | "devDependencies": { 10 | "@babel/core": "^7.12.10", 11 | "@babel/plugin-transform-runtime": "^7.12.10", 12 | "@babel/preset-env": "^7.12.11", 13 | "babel-loader": "^8.2.2", 14 | "chai": "^4.2.0", 15 | "clean-terminal-webpack-plugin": "^3.0.0", 16 | "crx": "^5.0.1", 17 | "eslint": "^7.18.0", 18 | "eslint-webpack-plugin": "^2.4.3", 19 | "jsdom": "16.4.0", 20 | "jsdom-global": "3.0.2", 21 | "mocha": "^8.2.1", 22 | "mocha-clearscreen-reporter": "^1.0.1", 23 | "webpack": "^5.15.0", 24 | "webpack-cli": "^4.3.1" 25 | }, 26 | "scripts": { 27 | "prod": "npx crx pack -p key.pem --zip-output iz.zip", 28 | "build": "webpack --mode production", 29 | "build-app": "webpack --watch --mode production", 30 | "build-test": "webpack --watch --mode production --config webpack.config.test.js", 31 | "watch-test": "npx mocha --watch --reporter mocha-clearscreen-reporter dist/main.js -r jsdom-global/register" 32 | }, 33 | "keywords": [], 34 | "author": "", 35 | "license": "ISC", 36 | "dependencies": { 37 | "@popperjs/core": "^2.6.0", 38 | "path": "^0.12.7" 39 | } 40 | } 41 | -------------------------------------------------------------------------------- /izuna-builder/servant-multipart.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, array, base, bytestring, directory, http-client 2 | , http-media, http-types, lens, network, random, resourcet, servant 3 | , servant-client, servant-client-core, servant-docs 4 | , servant-foreign, servant-server, stdenv, string-conversions 5 | , tasty, tasty-wai, text, transformers, wai, wai-extra, warp 6 | }: 7 | mkDerivation { 8 | pname = "servant-multipart"; 9 | version = "0.12"; 10 | sha256 = "74e398d14426e077105b4da57e980362392d1a6025b615be757642f98d8141c3"; 11 | revision = "1"; 12 | editedCabalFile = "0pc254b458v4k5xw729fvw3q3klwpkai2mmp455dw2i7g02dv0da"; 13 | isLibrary = true; 14 | isExecutable = true; 15 | libraryHaskellDepends = [ 16 | array base bytestring directory http-media lens random resourcet 17 | servant servant-client-core servant-docs servant-foreign 18 | servant-server string-conversions text transformers wai wai-extra 19 | ]; 20 | executableHaskellDepends = [ 21 | base bytestring http-client network servant servant-client 22 | servant-client-core servant-server text transformers wai warp 23 | ]; 24 | testHaskellDepends = [ 25 | base bytestring http-types servant-server string-conversions tasty 26 | tasty-wai text 27 | ]; 28 | homepage = "https://github.com/haskell-servant/servant-multipart#readme"; 29 | description = "multipart/form-data (e.g file upload) support for servant"; 30 | license = stdenv.lib.licenses.bsd3; 31 | } 32 | -------------------------------------------------------------------------------- /example/package.yaml: -------------------------------------------------------------------------------- 1 | name: example 2 | version: 0.1.0.0 3 | github: "githubuser/example" 4 | license: BSD3 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2020 Author name here" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | ghc-options: 23 | - -fwrite-ide-info 24 | - -hiedir=.hie 25 | 26 | dependencies: 27 | - base >= 4.7 && < 5 28 | 29 | library: 30 | source-dirs: src 31 | 32 | executables: 33 | example-exe: 34 | main: Main.hs 35 | source-dirs: app 36 | ghc-options: 37 | - -threaded 38 | - -rtsopts 39 | - -with-rtsopts=-N 40 | dependencies: 41 | - example 42 | 43 | tests: 44 | example-test: 45 | main: Spec.hs 46 | source-dirs: test 47 | ghc-options: 48 | - -threaded 49 | - -rtsopts 50 | - -with-rtsopts=-N 51 | dependencies: 52 | - example 53 | -------------------------------------------------------------------------------- /izuna-builder/default.nix: -------------------------------------------------------------------------------- 1 | let 2 | rev = "966489a0312f80e4dd20189f885bc12d6723a9ac"; 3 | extractedTarball = fetchTarball { 4 | url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; 5 | sha256 = "sha256:10jx7y8bgkqki9nfy6fdg121pixysrrbdlyyy30sv4x65clmalwp"; 6 | }; 7 | 8 | mkConfig = compiler: { 9 | allowBroken = true; 10 | doCheck = false; 11 | doHaddock = false; 12 | packageOverrides = pkgs: rec { 13 | haskell = pkgs.haskell // { 14 | packages = pkgs.haskell.packages // { 15 | "${compiler}" = pkgs.haskell.packages."${compiler}".override { 16 | overrides = haskellPackagesNew: haskellPackagesOld: rec { 17 | servant-multipart = 18 | haskellPackagesNew.callPackage ./servant-multipart.nix { }; 19 | 20 | izuna-builder = 21 | haskellPackagesNew.callPackage ./project.nix { ghcVersion = "${compiler}"; }; 22 | }; 23 | }; 24 | }; 25 | }; 26 | }; 27 | }; 28 | 29 | mkPkgs = compiler: import extractedTarball { config = ( mkConfig compiler ); }; 30 | 31 | mkIzunaBuilder = ghcVersion: (mkPkgs ghcVersion).haskell.packages."${ghcVersion}".izuna-builder; 32 | in 33 | { izuna-builder-8101 = (mkPkgs "ghc8101").haskell.packages.ghc8101.izuna-builder; 34 | izuna-builder-8102 = mkIzunaBuilder "ghc8102"; 35 | izuna-builder-8103 = mkIzunaBuilder "ghc8103"; 36 | pkgs = import extractedTarball { }; # for dev 37 | } 38 | -------------------------------------------------------------------------------- /chrome-extension/test/test.js: -------------------------------------------------------------------------------- 1 | const equal = require('chai').assert.equal; 2 | import { Splitter } from '../src/splitter.js'; 3 | require('jsdom-global')(); 4 | 5 | describe('Splitter', function() { 6 | describe('#split()', function() { 7 | it('foo', function() { 8 | var dom = document.createElement("span"); 9 | dom.setAttribute('class', 'whatever'); 10 | dom.setAttribute('data-code-marker', '+'); 11 | dom.textContent = 'hey'; 12 | const splitter = new Splitter(document, Node); 13 | const splitted = splitter.split(new DocumentFragment(), dom, 'someFilePath', 'ADDED', 1) 14 | 15 | /* 16 | splitter.show(dom) 17 | console.log("\n###\n"); 18 | splitter.show(splitted) 19 | */ 20 | 21 | equal(true, true); 22 | }); 23 | 24 | /*it('foo', function() { 25 | const dom = new JSDOM(`hey :: String`).window.document.querySelector("span"); 26 | 27 | const splitter = new Splitter(new JSDOM().window.document, new JSDOM().window.Node); 28 | const splitted = splitter.split(JSDOM.fragment(), dom, 1) 29 | /* 30 | splitter.show(dom, "") 31 | console.log("\n###\n"); 32 | splitter.show(splitted, "") 33 | * / 34 | 35 | equal(true, true); 36 | });*/ 37 | }); 38 | }); 39 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PACKAGE=izuna-$(APP) 2 | STACK=stack --stack-yaml=stack-$(GHC).yaml 3 | 4 | run: 5 | clear; $(STACK) exec $(PACKAGE)-exe 6 | 7 | fast: 8 | clear; LC_ALL=C.UTF-8 echo "building $(PACKAGE)"; $(STACK) build $(PACKAGE) --fast -j 2 9 | 10 | build: 11 | clear; echo "building $(PACKAGE)"; LC_ALL=C.UTF-8 $(STACK) build $(PACKAGE) --ghc-options="-threaded -rtsopts -with-rtsopts=-T -Werror" 12 | 13 | # there's a bug with -Wunused-packages and ghcid (ghcid fails to reload when unused-packages is present in package.yaml) 14 | check-unusued: 15 | clear; echo "building $(PACKAGE)"; LC_ALL=C.UTF-8 $(STACK) build $(PACKAGE) --ghc-options="-threaded -rtsopts -with-rtsopts=-T -Werror -Wunused-packages" 16 | 17 | clean: 18 | clear; LC_ALL=C.UTF-8 echo "cleaning $(PACKAGE)"; $(STACK) clean $(PACKAGE) 19 | 20 | devel: 21 | clear; LC_ALL=C.UTF-8 ghcid --command "$(STACK) ghci $(PACKAGE)" --test "DevelMain.update" 22 | 23 | test: 24 | clear; LC_ALL=C.UTF-8 echo "testing $(PACKAGE)"; $(STACK) test $(PACKAGE) --ghc-options="-Werror" 25 | 26 | watch-test: 27 | clear; LC_ALL=C.UTF-8 ghcid --command '$(STACK) ghci $(PACKAGE) --test --main-is $(PACKAGE):test:spec' --test 'main' --warnings 28 | 29 | check: 30 | clear; LC_ALL=C.UTF-8 ghcid --command '$(STACK) ghci $(PACKAGE) --test --main-is $(PACKAGE):test:spec --ghc-options="-Werror"' --test ':main' --warnings 31 | 32 | install: 33 | clear; echo "installing binary"; LC_ALL=C.UTF-8 $(STACK) build $(PACKAGE) --copy-bins 34 | 35 | hlint: 36 | clear; hlint . 37 | -------------------------------------------------------------------------------- /izuna-builder/src/IzunaBuilder/NonEmptyString.hs: -------------------------------------------------------------------------------- 1 | module IzunaBuilder.NonEmptyString where 2 | 3 | import qualified Data.Aeson as Aeson 4 | import Data.Function ((&)) 5 | --import qualified Data.Aeson.Types as Aeson 6 | import qualified Data.List.NonEmpty as NE 7 | import Data.String 8 | import qualified Data.Text as T 9 | import qualified Servant.API as Servant 10 | 11 | newtype NonEmptyString a = NonEmptyString (NE.NonEmpty Char) deriving Show 12 | 13 | instance IsString (NonEmptyString a) where 14 | fromString str = 15 | case NE.nonEmpty str of 16 | Nothing -> error "Invalid argument: Empty string" 17 | Just x -> NonEmptyString x 18 | 19 | toString :: NonEmptyString a -> String 20 | toString (NonEmptyString nonEmptyStr) = 21 | NE.toList nonEmptyStr 22 | 23 | instance Servant.FromHttpApiData (NonEmptyString a) where 24 | parseUrlPiece text = 25 | case NE.nonEmpty $ T.unpack text of 26 | Nothing -> Left "text cannot be empty" 27 | Just nonEmpty -> Right (NonEmptyString nonEmpty) 28 | 29 | instance Aeson.ToJSON (NonEmptyString a) where 30 | toJSON (NonEmptyString nonEmptyStr) = 31 | nonEmptyStr & NE.toList & Aeson.toJSON 32 | 33 | instance Aeson.FromJSON (NonEmptyString a) where 34 | parseJSON text = do 35 | str :: String <- Aeson.parseJSON text 36 | case NE.nonEmpty str of 37 | Nothing -> fail "could not parse string to non empty string" 38 | Just ne -> pure $ NonEmptyString ne 39 | -------------------------------------------------------------------------------- /izuna-server/src/IzunaServer/PullRequest/App.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module IzunaServer.PullRequest.App where 4 | 5 | import Control.Monad.Except (MonadError) 6 | import Control.Monad.IO.Class (MonadIO) 7 | import qualified Control.Monad.IO.Class as IO 8 | import Control.Monad.Reader (MonadReader) 9 | import qualified Control.Monad.Reader as Reader 10 | import Data.Functor ((<&>)) 11 | import qualified Servant 12 | 13 | import IzunaBuilder.NonEmptyString 14 | import IzunaBuilder.Type 15 | import IzunaServer.Env 16 | import IzunaServer.PullRequest.Model 17 | import qualified IzunaServer.Service.Github as Github 18 | 19 | 20 | pullRequestInfoHandler 21 | :: ( MonadReader Env m 22 | , MonadIO m 23 | , MonadError Servant.ServerError m 24 | ) 25 | => NonEmptyString Username 26 | -> NonEmptyString Repo 27 | -> Nat 28 | -> m PullRequestInfo 29 | pullRequestInfoHandler username repo pullRequestId = do 30 | authorizationToken <- Reader.ask <&> _env_githubAuthToken 31 | mGithubPullRequestInfo <- IO.liftIO $ Github.getPullRequestInfo authorizationToken $ Github.GithubPullRequestInfoInput 32 | { _prInput_username = username 33 | , _prInput_repository = repo 34 | , _prInput_pullRequestId = pullRequestId 35 | } 36 | case mGithubPullRequestInfo of 37 | Just pullRequestInfo -> return pullRequestInfo 38 | Nothing -> Servant.throwError Servant.err404 39 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | on: 2 | # Trigger the workflow on push or pull request, but only for the master branch 3 | push: 4 | branches: 5 | - master 6 | - main 7 | pull_request: 8 | 9 | jobs: 10 | build: 11 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 12 | runs-on: ${{ matrix.os }} 13 | strategy: 14 | matrix: 15 | os: [ubuntu-latest] 16 | stack: ["2.3.1"] 17 | ghc: ["8.10.1"] 18 | 19 | steps: 20 | - uses: actions/checkout@v2 21 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/main' || github.event.ref == 'refs/heads/master' 22 | 23 | - uses: haskell/actions/setup@v1 24 | name: Setup Haskell Stack 25 | with: 26 | ghc-version: ${{ matrix.ghc }} 27 | stack-version: ${{ matrix.stack }} 28 | enable-stack: true 29 | 30 | - uses: actions/cache@v2 31 | name: Cache Stack build 32 | with: 33 | path: | 34 | ~/.stack 35 | .stack-work 36 | key: ${{ runner.os }}-${{ matrix.ghc }}-stack 37 | 38 | - name: Build 39 | run: | 40 | stack build izuna-builder --stack-yaml=stack-8.10.1.yaml --no-nix --force-dirty 41 | #stack build izuna-server --stack-yaml=stack-8.10.1.yaml --no-nix --force-dirty 42 | 43 | 44 | - name: izuna for izuna-builder 45 | uses: matsumonkie/izuna-action@v1.0 46 | with: 47 | ghcVersion: '8.10.1' 48 | hieDirectory: 'izuna-builder/.hie/' 49 | projectRoot: 'izuna-builder/' 50 | -------------------------------------------------------------------------------- /example/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2020 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /chrome-extension/src/popup.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | -------------------------------------------------------------------------------- /example/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: example 8 | version: 0.1.0.0 9 | description: Please see the README on GitHub at 10 | homepage: https://github.com/githubuser/example#readme 11 | bug-reports: https://github.com/githubuser/example/issues 12 | author: Author name here 13 | maintainer: example@example.com 14 | copyright: 2020 Author name here 15 | license: BSD3 16 | license-file: LICENSE 17 | build-type: Simple 18 | extra-source-files: 19 | README.md 20 | ChangeLog.md 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/githubuser/example 25 | 26 | library 27 | exposed-modules: 28 | Lib 29 | other-modules: 30 | Paths_example 31 | hs-source-dirs: 32 | src 33 | ghc-options: -fwrite-ide-info -hiedir=.hie 34 | build-depends: 35 | base >=4.7 && <5 36 | default-language: Haskell2010 37 | 38 | executable example-exe 39 | main-is: Main.hs 40 | other-modules: 41 | Paths_example 42 | hs-source-dirs: 43 | app 44 | ghc-options: -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N 45 | build-depends: 46 | base >=4.7 && <5 47 | , example 48 | default-language: Haskell2010 49 | 50 | test-suite example-test 51 | type: exitcode-stdio-1.0 52 | main-is: Spec.hs 53 | other-modules: 54 | Paths_example 55 | hs-source-dirs: 56 | test 57 | ghc-options: -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N 58 | build-depends: 59 | base >=4.7 && <5 60 | , example 61 | default-language: Haskell2010 62 | -------------------------------------------------------------------------------- /chrome-extension/test/filesInfoTest.js: -------------------------------------------------------------------------------- 1 | const equal = require('chai').assert.equal; 2 | import { FilesInfo } from '../src/filesInfo.js'; 3 | 4 | describe('FilesInfo', function() { 5 | describe('#find()', function() { 6 | 7 | const info = { 8 | oldPackageInfo: { 9 | someFile: { 10 | typeRefs: { 11 | 42: [ 12 | { 13 | generalizedType: null, 14 | specializedType: 0, 15 | span: { 16 | lineStart: 42, 17 | lineEnd: 42, 18 | colStart: 1, 19 | colEnd: 5 20 | }, 21 | children: [ 22 | { 23 | generalizedType: null, 24 | specializedType: 1, 25 | span: { 26 | lineStart: 42, 27 | lineEnd: 42, 28 | colStart: 3, 29 | colEnd: 4 30 | }, 31 | children: [] 32 | } 33 | ] 34 | } 35 | ] 36 | }, 37 | types: { 38 | 0: "Int", 39 | 1: "String" 40 | } 41 | } 42 | } 43 | }; 44 | const filesInfo = new FilesInfo(info); 45 | 46 | it('returns the typename', function() { 47 | const { typeName } = filesInfo.findType("someFile", 'DELETED', 2, 42); 48 | equal(typeName, "Int"); 49 | }); 50 | 51 | it('returns null if location doesn\'t contain a type', function() { 52 | const res = filesInfo.findType("someFile", 'DELETED', 6, 42); 53 | equal(res, null); 54 | }); 55 | 56 | it('returns child if its location is more specific', function() { 57 | const { typeName } = filesInfo.findType("someFile", 'DELETED', 3, 42); 58 | equal(typeName, "String"); 59 | }); 60 | }); 61 | }); 62 | -------------------------------------------------------------------------------- /chrome-extension/src/izunaServerService.js: -------------------------------------------------------------------------------- 1 | /* 2 | * communicate with izuna's server 3 | */ 4 | export class IzunaServerService { 5 | 6 | constructor(serverUrl, pullRequestInfo) { 7 | this.serverUrl = serverUrl; 8 | this.user = pullRequestInfo.user; 9 | this.repo = pullRequestInfo.repo; 10 | this.pr = pullRequestInfo.pr; 11 | } 12 | 13 | getPrDetailsUrl() { 14 | return [ this.serverUrl, 'api', 'pullRequestInfo', this.user, this.repo, this.pr ].join('/'); 15 | } 16 | 17 | getFileInfoUrl(commitId) { 18 | return [ this.serverUrl, 'api', 'projectInfo', this.user, this.repo, commitId ].join('/'); 19 | } 20 | 21 | /* 22 | * from a given PR, find the target commit oid (i.e: the commit we are diffing from) 23 | * and the latest commit oid (i.e: the latest commit we pushed for this PR) 24 | */ 25 | fetchPullRequestCommitsDetails() { 26 | return fetch(this.getPrDetailsUrl()) 27 | .then(response => { 28 | if(response.ok) { 29 | return response.json(); 30 | } else { 31 | throw `Could not fetch pull request information for this PR! Response status: ${response.status} for url: ${response.url}`; 32 | } 33 | }); 34 | } 35 | 36 | fetchFilesInfo(pullRequestDetails, files) { 37 | const oldFilesInfo = this.fetchFileInfo(pullRequestDetails.targetOid, files); 38 | const newFilesInfo = this.fetchFileInfo(pullRequestDetails.commitOids[0], files); 39 | return Promise.all([oldFilesInfo, newFilesInfo]).then(filesInfo => { 40 | return { 41 | oldPackageInfo: filesInfo[0], 42 | newPackageInfo: filesInfo[1] 43 | }; 44 | }); 45 | } 46 | 47 | async fetchFileInfo(commitId, files) { 48 | return fetch( this.getFileInfoUrl(commitId), 49 | { method: 'POST', 50 | credentials: 'omit', 51 | headers: { 'Content-Type': 'application/json' }, 52 | body: JSON.stringify(files) 53 | } 54 | ) 55 | .then(response => { 56 | if (response.ok) { 57 | return response.json(); 58 | } else if (response.status === 404) { 59 | return {}; 60 | } else { 61 | throw `Could not fetch izuna project info! Response status: ${response.status} for url: ${response.url}`; 62 | } 63 | }); 64 | } 65 | 66 | } 67 | -------------------------------------------------------------------------------- /izuna-server/src/IzunaServer/PullRequest/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module IzunaServer.PullRequest.Model where 4 | 5 | -- * import 6 | 7 | -- ** vector 8 | 9 | import qualified Data.Vector as Vector 10 | 11 | -- ** base 12 | 13 | import qualified Control.Monad as Monad 14 | --import Data.Function ((&)) 15 | import Data.Functor ((<&>)) 16 | 17 | -- ** ghc 18 | 19 | import GHC.Generics 20 | 21 | -- ** non empty 22 | 23 | import qualified Data.List.NonEmpty as NE 24 | 25 | -- ** aeson 26 | 27 | import qualified Data.Aeson as Aeson 28 | import Data.Aeson.Types (Object, Parser, (.:)) 29 | 30 | -- ** local 31 | 32 | import IzunaBuilder.NonEmptyString 33 | import IzunaBuilder.Type 34 | 35 | 36 | -- * model 37 | 38 | 39 | data PullRequestInfo = PullRequestInfo 40 | { _pullRequestInfo_targetOid :: NonEmptyString CommitId 41 | , _pullRequestInfo_commitOids :: NonEmpty (NonEmptyString CommitId) 42 | } 43 | deriving (Generic) 44 | 45 | instance Aeson.FromJSON PullRequestInfo where 46 | parseJSON = Aeson.withObject "PullRequestInfo" $ \o -> do 47 | _pullRequestInfo_targetOid <- o .: "data" .-> "repository" .-> "pullRequest" .-> "baseRef" .-> "target" .-> "oid" 48 | nodes :: Aeson.Value <- o .: "data" .-> "repository" .-> "pullRequest" .-> "commits" .-> "nodes" 49 | _pullRequestInfo_commitOids <- Aeson.withArray "" arrayParser nodes 50 | return $ PullRequestInfo{..} 51 | where 52 | arrayParser :: Aeson.Array -> Parser (NonEmpty (NonEmptyString CommitId)) 53 | arrayParser array = 54 | Monad.mapM nodeParser array <&> Vector.toList <&> NE.fromList 55 | 56 | nodeParser :: Aeson.Value -> Parser (NonEmptyString CommitId) 57 | nodeParser = Aeson.withObject "Node" $ \o -> do 58 | o .: "commit" .-> "oid" 59 | 60 | (.->) :: Aeson.FromJSON a => Parser Object -> Text -> Parser a 61 | (.->) parser key = do 62 | obj <- parser 63 | obj .: key 64 | 65 | 66 | instance Aeson.ToJSON PullRequestInfo where 67 | toJSON = 68 | Aeson.genericToJSON Aeson.defaultOptions { Aeson.fieldLabelModifier = drop $ length ("_pullRequestInfo_" :: String) } 69 | -------------------------------------------------------------------------------- /chrome-extension/src/numBlob.js: -------------------------------------------------------------------------------- 1 | class NumBlobClass { 2 | 3 | constructor() {} 4 | 5 | getNumBlobForUnifiedMode(diffRowDom) { 6 | /* 7 | * this is similar for the unified mode except that graphically, the number are side to side, i.e: 8 | * 9 | * oldLineNumberDom 10 | * newLineNumberDom 11 | * ↓ ↓ 12 | * | 8 | | - someOldCode... 13 | * | | 8 | - someNewCode... 14 | * 15 | */ 16 | const [ oldLineNumberDom, newLineNumberDom ] = diffRowDom.querySelectorAll(NumBlob.blobNumSelector); 17 | 18 | const oldLineNumber = parseInt(oldLineNumberDom.dataset.lineNumber) - 1; 19 | const newLineNumber = parseInt(newLineNumberDom.dataset.lineNumber) - 1; 20 | const lineState = this.getState(oldLineNumberDom); 21 | var lineNumber; 22 | if (lineState == NumBlob.DELETED) { 23 | lineNumber = oldLineNumber; 24 | } else { 25 | lineNumber = newLineNumber; 26 | } 27 | 28 | return { 29 | lineNumber: lineNumber, 30 | lineState: lineState 31 | }; 32 | } 33 | 34 | getNumBlobForSplitMode(diffRowDom) { 35 | /* 36 | * in split mode oldLineNumberDom and newLineNumberDom represents 37 | * respectively the line number from the left and the right, i.e: 38 | * 39 | * leftLine rightLine 40 | * ↓ ↓ 41 | * | 8 | - someOldCode... | 8 | + someNewCode... 42 | */ 43 | const [ leftLine, rightLine ] = Array.from(diffRowDom.querySelectorAll(NumBlob.blobNumSelector)).map(dom => { 44 | return { 45 | lineNumber: parseInt(dom.dataset.lineNumber) - 1, 46 | lineState: this.getState(dom) 47 | }; 48 | }); 49 | 50 | return { 51 | leftLine: leftLine, 52 | rightLine: rightLine 53 | }; 54 | } 55 | 56 | getState(lineDom) { 57 | const classList = lineDom.classList; 58 | if(classList.contains('blob-num-addition')) { 59 | return NumBlob.ADDED; 60 | } else if (classList.contains('blob-num-deletion')) { 61 | return NumBlob.DELETED; 62 | } else { 63 | return NumBlob.UNMODIFIED; 64 | } 65 | } 66 | } 67 | 68 | const NumBlob = { 69 | ADDED: 'ADDED', 70 | DELETED: 'DELETED', 71 | UNMODIFIED: 'UNMODIFIED', 72 | 73 | blobNumSelector: 'td.blob-num', 74 | NumBlobClass: NumBlobClass 75 | 76 | }; 77 | 78 | export { NumBlob }; 79 | -------------------------------------------------------------------------------- /chrome-extension/src/filesInfo.js: -------------------------------------------------------------------------------- 1 | import { Constants } from './constants.js'; 2 | import { NumBlob } from './numBlob.js'; 3 | 4 | export class FilesInfo { 5 | 6 | constructor(filesInfo) { 7 | this.filesInfo = filesInfo; 8 | } 9 | 10 | findType(filePath, location, state, col, row) { 11 | var fileState; 12 | if(location === Constants.LEFT_LOCATION) { 13 | fileState = this.filesInfo.oldPackageInfo; 14 | } else if (location === Constants.RIGHT_LOCATION) { 15 | fileState = this.filesInfo.newPackageInfo; 16 | } else { // CENTER 17 | if(state === NumBlob.DELETED) { 18 | fileState = this.filesInfo.oldPackageInfo; 19 | } else { 20 | fileState = this.filesInfo.newPackageInfo; 21 | } 22 | } 23 | 24 | if(fileState) { 25 | const fileInfo = fileState[filePath]; 26 | if(fileInfo) { 27 | const typeRef = this.findTypeRef(fileInfo.typeRefs[row], col); 28 | if(typeRef) { 29 | const specializedType = fileInfo.types[typeRef.specializedType]; 30 | if(specializedType) { 31 | const spanLength = typeRef.span.colEnd - 1 - typeRef.span.colStart; 32 | const centerCol = (typeRef.span.colEnd - 1) - (spanLength / 2); 33 | return { 34 | startCol: typeRef.span.colStart, 35 | endCol: typeRef.span.colEnd - 1, 36 | centerCol: centerCol, 37 | typeName: specializedType.replace(/ -> /g, ' ⟶ ') 38 | }; 39 | } 40 | } 41 | } 42 | } 43 | } 44 | 45 | findTypeRef(typeRefs, col) { 46 | if(typeRefs) { 47 | 48 | const moreSpecialized = (a, b) => { 49 | if(!a) { 50 | return b; 51 | } else if(!b) { 52 | return a; 53 | } else { 54 | if((a.span.colEnd - a.span.colStart) > (b.span.colEnd - b.span.colStart)) { 55 | return b; 56 | } else { 57 | return a; 58 | } 59 | } 60 | }; 61 | 62 | const f = (acc, e) => { 63 | if(col >= e.span.colStart && col < e.span.colEnd) { 64 | return moreSpecialized(moreSpecialized (acc, e), e.children.reduce(f, acc)); 65 | } else { 66 | return acc; 67 | } 68 | }; 69 | 70 | return typeRefs.reduce(f, null); 71 | } else { 72 | return null; 73 | } 74 | } 75 | } 76 | -------------------------------------------------------------------------------- /izuna-server/package.yaml: -------------------------------------------------------------------------------- 1 | name: izuna-server 2 | version: 0.1.0.0 3 | github: "matsumonkie/izuna" 4 | license: BSD3 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2020 Author name here" 8 | 9 | # Metadata used when publishing your package 10 | # synopsis: Short description of your package 11 | # category: Web 12 | 13 | default-extensions: 14 | - LambdaCase 15 | - OverloadedStrings 16 | - NamedFieldPuns 17 | - QuasiQuotes 18 | - ScopedTypeVariables 19 | - TemplateHaskell 20 | - RecordWildCards 21 | - EmptyCase 22 | - FlexibleContexts 23 | - FlexibleInstances 24 | - InstanceSigs 25 | - MultiParamTypeClasses 26 | - MultiWayIf 27 | - StrictData 28 | - TypeApplications # allows you to use visible type application in expressions, eg: show (read @Int "5") 29 | 30 | # To avoid duplicated efforts in documentation and dealing with the 31 | # complications of embedding Haddock markup inside cabal files, it is 32 | # common to point users to the README.md file. 33 | description: Please see the README on GitHub at 34 | 35 | ghc-options: 36 | - -Wall 37 | - -fno-warn-name-shadowing 38 | - -Wincomplete-patterns 39 | - -Wcompat # make code future compatible to adapt to new features 40 | - -Wincomplete-record-updates # catch what are essentially partial pattern-matches 41 | - -Wincomplete-uni-patterns 42 | - -Wredundant-constraints # help remove unnecessary typeclass constraints on functions 43 | - -fwrite-ide-info 44 | - -hiedir=.hie 45 | 46 | dependencies: 47 | - base >= 4.7 && < 5 48 | 49 | 50 | library: 51 | source-dirs: src 52 | dependencies: 53 | - izuna-builder 54 | - filepath 55 | - mtl 56 | - containers 57 | - servant-server 58 | - servant-flatten 59 | - wai-cors 60 | - text 61 | - transformers 62 | - foreign-store 63 | - safe-exceptions 64 | - say 65 | - wai 66 | - warp 67 | - case-insensitive 68 | - http-types 69 | - aeson 70 | - directory 71 | - dhall 72 | - servant-client 73 | - http-client 74 | - http-client-tls 75 | - vector 76 | 77 | 78 | executables: 79 | izuna-server-exe: 80 | main: Main.hs 81 | source-dirs: app 82 | ghc-options: 83 | - -threaded 84 | - -rtsopts 85 | - -with-rtsopts=-N 86 | dependencies: 87 | - izuna-server 88 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # This file contains a template configuration file, which is typically 6 | # placed as .hlint.yaml in the root of your project 7 | 8 | 9 | # Warnings currently triggered by your code 10 | - ignore: {name: "Eta reduce"} 11 | - ignore: {name: "Use if"} 12 | - ignore: {name: "Reduce duplication"} 13 | - ignore: {name: "Use tuple-section"} 14 | - ignore: {name: "Redundant do"} 15 | - ignore: {name : "Redundant <&>"} 16 | #- ignore: {name: "Use fewer imports"} 17 | #- ignore: {name: "Unused LANGUAGE pragma"} 18 | #- ignore: {name: "Use newtype instead of data"} 19 | #- ignore: {name: "Redundant bracket"} 20 | #- ignore: {name: "Use print"} 21 | #- ignore: {name: "Redundant $"} 22 | #- ignore: {name: "Monad law, right identity"} 23 | #- ignore: {name: "Move brackets to avoid $"} 24 | #- ignore: {name: "Collapse lambdas"} 25 | 26 | 27 | # Specify additional command line arguments 28 | # 29 | - arguments: [--cpp-simple, -XQuasiQuotes] 30 | 31 | 32 | # Control which extensions/flags/modules/functions can be used 33 | # 34 | # - extensions: 35 | # - default: false # all extension are banned by default 36 | # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used 37 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module 38 | # 39 | # - flags: 40 | # - {name: -w, within: []} # -w is allowed nowhere 41 | # 42 | # - modules: 43 | # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' 44 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely 45 | # 46 | # - functions: 47 | # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules 48 | 49 | 50 | # Add custom hints for this project 51 | # 52 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" 53 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} 54 | 55 | 56 | # Turn on hints that are off by default 57 | # 58 | # Ban "module X(module X) where", to require a real export list 59 | # - warn: {name: Use explicit module export list} 60 | # 61 | # Replace a $ b $ c with a . b $ c 62 | # - group: {name: dollar, enabled: true} 63 | # 64 | # Generalise map to fmap, ++ to <> 65 | # - group: {name: generalise, enabled: true} 66 | 67 | 68 | # Ignore some builtin hints 69 | # - ignore: {name: Use let} 70 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules 71 | 72 | 73 | # Define some custom infix operators 74 | # - fixity: infixr 3 ~^#^~ 75 | 76 | 77 | # To generate a suitable file for HLint do: 78 | # $ hlint --default > .hlint.yaml 79 | -------------------------------------------------------------------------------- /izuna-builder/src/IzunaBuilder/ProjectInfo/RecoverType.hs: -------------------------------------------------------------------------------- 1 | module IzunaBuilder.ProjectInfo.RecoverType ( getDynFlags 2 | , recoverTypes 3 | ) where 4 | 5 | import qualified CoreMonad as Ghc 6 | import qualified Data.Array as A 7 | import Data.Function ((&)) 8 | import qualified Data.Map as Map 9 | import qualified GHC as Ghc 10 | import qualified GHC.Paths as Ghc 11 | import HieTypes (HieArgs (..), HieType (..)) 12 | import IfaceType 13 | import Name (getOccFS) 14 | import Outputable (showSDoc) 15 | import Var (VarBndr (..)) 16 | 17 | import IzunaBuilder.ProjectInfo.Model 18 | import IzunaBuilder.Type 19 | 20 | -- * get dyn flags 21 | 22 | 23 | getDynFlags :: IO DynFlags 24 | getDynFlags = do 25 | Ghc.runGhc (Just Ghc.libdir) Ghc.getDynFlags 26 | 27 | -- * recover types 28 | 29 | recoverTypes :: DynFlags -> RawModule TypeIndex a -> Map TypeIndex PrintedType 30 | recoverTypes df RawModule{..} = 31 | printed & A.assocs & Map.fromList 32 | where 33 | printed :: A.Array TypeIndex PrintedType 34 | printed = fmap (showSDoc df . pprIfaceType) unflattened 35 | 36 | -- The recursion in 'unflattened' is crucial - it's what gives us sharing 37 | -- between the IfaceType's produced 38 | unflattened :: A.Array TypeIndex IfaceType 39 | unflattened = fmap (go . fmap (unflattened A.!)) _rawModule_hieTypes 40 | 41 | -- Unfold an 'HieType' whose subterms have already been unfolded 42 | go :: HieType IfaceType -> IfaceType 43 | go (HTyVarTy n) = IfaceTyVar (getOccFS n) 44 | go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b) 45 | go (HLitTy l) = IfaceLitTy l 46 | go (HForAllTy ((n,k),af) t) = let b = (getOccFS n, k) 47 | in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t 48 | go (HFunTy a b) = IfaceFunTy VisArg a b 49 | go (HQualTy con b) = IfaceFunTy InvisArg con b 50 | go (HCastTy a) = a 51 | go HCoercionTy = IfaceTyVar "" 52 | go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) 53 | 54 | -- This isn't fully faithful - we can't produce the 'Inferred' case 55 | hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs 56 | hieToIfaceArgs (HieArgs args) = go' args 57 | where 58 | go' [] = IA_Nil 59 | go' ((True ,x):xs) = IA_Arg x Required $ go' xs 60 | go' ((False,x):xs) = IA_Arg x Specified $ go' xs 61 | -------------------------------------------------------------------------------- /izuna-server/izuna-server.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: izuna-server 8 | version: 0.1.0.0 9 | description: Please see the README on GitHub at 10 | homepage: https://github.com/matsumonkie/izuna#readme 11 | bug-reports: https://github.com/matsumonkie/izuna/issues 12 | author: Author name here 13 | maintainer: example@example.com 14 | copyright: 2020 Author name here 15 | license: BSD3 16 | build-type: Simple 17 | 18 | source-repository head 19 | type: git 20 | location: https://github.com/matsumonkie/izuna 21 | 22 | library 23 | exposed-modules: 24 | DevelMain 25 | IzunaServer.Env 26 | IzunaServer.Project.App 27 | IzunaServer.PullRequest.App 28 | IzunaServer.PullRequest.Model 29 | IzunaServer.Server 30 | IzunaServer.Service.Github 31 | other-modules: 32 | Paths_izuna_server 33 | hs-source-dirs: 34 | src 35 | default-extensions: LambdaCase OverloadedStrings NamedFieldPuns QuasiQuotes ScopedTypeVariables TemplateHaskell RecordWildCards EmptyCase FlexibleContexts FlexibleInstances InstanceSigs MultiParamTypeClasses MultiWayIf StrictData TypeApplications 36 | ghc-options: -Wall -fno-warn-name-shadowing -Wincomplete-patterns -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info -hiedir=.hie 37 | build-depends: 38 | aeson 39 | , base >=4.7 && <5 40 | , case-insensitive 41 | , containers 42 | , dhall 43 | , directory 44 | , filepath 45 | , foreign-store 46 | , http-client 47 | , http-client-tls 48 | , http-types 49 | , izuna-builder 50 | , mtl 51 | , safe-exceptions 52 | , say 53 | , servant-client 54 | , servant-flatten 55 | , servant-server 56 | , text 57 | , transformers 58 | , vector 59 | , wai 60 | , wai-cors 61 | , warp 62 | default-language: Haskell2010 63 | 64 | executable izuna-server-exe 65 | main-is: Main.hs 66 | other-modules: 67 | Paths_izuna_server 68 | hs-source-dirs: 69 | app 70 | default-extensions: LambdaCase OverloadedStrings NamedFieldPuns QuasiQuotes ScopedTypeVariables TemplateHaskell RecordWildCards EmptyCase FlexibleContexts FlexibleInstances InstanceSigs MultiParamTypeClasses MultiWayIf StrictData TypeApplications 71 | ghc-options: -Wall -fno-warn-name-shadowing -Wincomplete-patterns -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N 72 | build-depends: 73 | base >=4.7 && <5 74 | , izuna-server 75 | default-language: Haskell2010 76 | -------------------------------------------------------------------------------- /izuna-builder/package.yaml: -------------------------------------------------------------------------------- 1 | name: izuna-builder 2 | version: 0.1.0.0 3 | github: "matsumonkie/izuna" 4 | license: BSD3 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2020 Author name here" 8 | 9 | extra-source-files: 10 | - README.md 11 | 12 | # Metadata used when publishing your package 13 | # synopsis: Short description of your package 14 | # category: Web 15 | 16 | default-extensions: 17 | - LambdaCase 18 | - OverloadedStrings 19 | - NamedFieldPuns 20 | - QuasiQuotes 21 | - ScopedTypeVariables 22 | - TemplateHaskell 23 | - RecordWildCards 24 | - EmptyCase 25 | - FlexibleContexts 26 | - FlexibleInstances 27 | - InstanceSigs 28 | - MultiParamTypeClasses 29 | - MultiWayIf 30 | - StrictData 31 | - TypeApplications # allows you to use visible type application in expressions, eg: show (read @Int "5") 32 | 33 | # To avoid duplicated efforts in documentation and dealing with the 34 | # complications of embedding Haddock markup inside cabal files, it is 35 | # common to point users to the README.md file. 36 | description: Please see the README on GitHub at 37 | 38 | ghc-options: 39 | - -Wall 40 | - -fno-warn-name-shadowing 41 | - -Wincomplete-patterns 42 | - -Wcompat # make code future compatible to adapt to new features 43 | - -Wincomplete-record-updates # catch what are essentially partial pattern-matches 44 | - -Wincomplete-uni-patterns 45 | - -Wredundant-constraints # help remove unnecessary typeclass constraints on functions 46 | - -fwrite-ide-info 47 | - -hiedir=.hie 48 | 49 | dependencies: 50 | - base >= 4.7 && < 5 51 | 52 | library: 53 | source-dirs: src 54 | dependencies: 55 | - containers 56 | - text 57 | - aeson 58 | - servant 59 | - generic-lens 60 | - array 61 | - bytestring 62 | - ghc-paths 63 | - directory 64 | - filepath 65 | - say 66 | - mtl 67 | - wai 68 | - warp 69 | - servant-server 70 | - servant-multipart 71 | - safe-exceptions 72 | - foreign-store 73 | - async 74 | - tar 75 | - html-entities 76 | - ghc 77 | 78 | executables: 79 | izuna-builder-exe: 80 | main: Main.hs 81 | source-dirs: app 82 | ghc-options: 83 | - -threaded 84 | - -rtsopts 85 | - -with-rtsopts=-N 86 | dependencies: 87 | - izuna-builder 88 | 89 | tests: 90 | spec: 91 | main: Spec.hs 92 | source-dirs: test 93 | ghc-options: 94 | - -threaded 95 | - -rtsopts 96 | - -with-rtsopts=-N 97 | dependencies: 98 | - izuna-builder 99 | - hspec 100 | - containers 101 | - text 102 | -------------------------------------------------------------------------------- /izuna-server/src/IzunaServer/Service/Github.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | module IzunaServer.Service.Github where 6 | 7 | 8 | import qualified Data.Aeson as Aeson 9 | import Data.Aeson.Types ((.=)) 10 | import qualified Data.Text as T 11 | import GHC.Generics (Generic) 12 | import qualified Network.HTTP.Client as HTTP 13 | import qualified Network.HTTP.Client.TLS as TLS 14 | import Servant 15 | import qualified Servant.Client as Client 16 | 17 | import IzunaBuilder.NonEmptyString 18 | import IzunaBuilder.Type 19 | import IzunaServer.PullRequest.Model 20 | 21 | 22 | -- * input 23 | 24 | 25 | data GithubPullRequestInfoInput = GithubPullRequestInfoInput 26 | { _prInput_username :: NonEmptyString Username 27 | , _prInput_repository :: NonEmptyString Repo 28 | , _prInput_pullRequestId :: Nat 29 | } 30 | deriving (Show, Generic) 31 | 32 | instance Aeson.ToJSON GithubPullRequestInfoInput where 33 | toJSON GithubPullRequestInfoInput{..} = 34 | Aeson.object [ "query" .= mkQuery 35 | , "variables" .= Aeson.object [] 36 | ] 37 | where 38 | mkQuery :: String 39 | mkQuery = 40 | "query { repository(name: \"" <> toString _prInput_repository <> "\", owner: \"" <> toString _prInput_username <> "\") { pullRequest(number: " <> show _prInput_pullRequestId <> ") { commits(last: 10) { nodes { commit { oid } } } baseRef { target { oid } } } } }" 41 | 42 | 43 | -- * api 44 | 45 | 46 | type GithubRailsRoutesApi = 47 | Header "Authorization" String :> 48 | Header "User-Agent" String :> 49 | ReqBody '[JSON] GithubPullRequestInfoInput :> 50 | Post '[JSON] PullRequestInfo 51 | 52 | 53 | -- * client 54 | 55 | 56 | getPullRequestInfo :: Text -> GithubPullRequestInfoInput -> IO (Maybe PullRequestInfo) 57 | getPullRequestInfo authorizationToken prInput = do 58 | manager <- HTTP.newManager TLS.tlsManagerSettings 59 | Client.runClientM githubRailsRouteClient (clientEnv manager) >>= \case 60 | Left e -> do 61 | putStrLn $ "failed to fetch pull request info for: " <> show prInput <> " - error: " <> show e 62 | return Nothing 63 | Right routeContent -> 64 | return $ Just routeContent 65 | where 66 | baseUrl = 67 | Client.BaseUrl { baseUrlScheme = Client.Https 68 | , baseUrlHost = "api.github.com" 69 | , baseUrlPort = 443 70 | , baseUrlPath = "graphql" 71 | } 72 | githubRailsRouteClient = 73 | Client.client (Proxy :: Proxy GithubRailsRoutesApi) (Just ("bearer " <> T.unpack authorizationToken)) (Just "servant-user-agent") prInput 74 | clientEnv manager = 75 | Client.mkClientEnv manager baseUrl 76 | -------------------------------------------------------------------------------- /izuna-server/src/IzunaServer/Project/App.hs: -------------------------------------------------------------------------------- 1 | module IzunaServer.Project.App ( getProjectInfoHandler 2 | ) where 3 | 4 | -- * imports 5 | 6 | -- ** aeson 7 | 8 | import qualified Data.Aeson as Aeson 9 | 10 | -- ** base 11 | 12 | import qualified Data.Foldable as Foldable 13 | import Data.Functor ((<&>)) 14 | import qualified Data.Traversable as T 15 | 16 | -- ** containers 17 | 18 | import qualified Data.Map as Map 19 | 20 | -- ** directory 21 | 22 | import qualified System.Directory as Dir 23 | 24 | -- ** servant 25 | 26 | import qualified Servant 27 | 28 | -- ** transformers 29 | 30 | import qualified Control.Monad.Except as Except 31 | import qualified Control.Monad.IO.Class as IO 32 | 33 | -- ** local 34 | 35 | import IzunaBuilder.NonEmptyString 36 | import IzunaBuilder.ProjectInfo.Model 37 | import IzunaBuilder.ProjectInfo.Util 38 | import IzunaBuilder.Type 39 | 40 | -- * get project 41 | 42 | 43 | getProjectInfoHandler 44 | :: (IO.MonadIO m, Except.MonadError Servant.ServerError m) 45 | => NonEmptyString Username 46 | -> NonEmptyString Repo 47 | -> NonEmptyString Commit 48 | -> [String] 49 | -> m ModulesInfo 50 | getProjectInfoHandler username repo commit files = do 51 | allFileExist <- IO.liftIO $ T.for files (Dir.doesFileExist . getFilePath) <&> and 52 | case allFileExist of 53 | False -> Servant.throwError Servant.err404 54 | True -> do 55 | eFilesInfo <- IO.liftIO $ 56 | T.for files (\file -> 57 | Aeson.decodeFileStrict' (getFilePath file) <&> (\d -> (file, d)) 58 | ) <&> checkDecodeError 59 | case eFilesInfo of 60 | Left errors -> do 61 | IO.liftIO $ putStrLn $ "For project: " <> projectPath <> " - could not decode file(s): " <> show errors 62 | Servant.throwError Servant.err500 63 | Right filesInfo -> 64 | return $ Map.fromList filesInfo 65 | where 66 | projectPath :: FilePath 67 | projectPath = getProjectPath username repo commit 68 | 69 | getFilePath :: FilePath -> FilePath 70 | getFilePath file = 71 | getJsonPath projectPath file 72 | 73 | checkDecodeError :: [ (FilePath, Maybe ModuleInfo) ] -> Either [FilePath] [ (FilePath, ModuleInfo) ] 74 | checkDecodeError filesInfo = do 75 | Foldable.foldl' go (Right []) filesInfo 76 | where 77 | go :: Either [FilePath] [ (FilePath, ModuleInfo) ] -> (FilePath, Maybe ModuleInfo) -> Either [FilePath] [ (FilePath, ModuleInfo) ] 78 | go acc (filePath, mModuleInfo) = 79 | case (acc, mModuleInfo) of 80 | (Left _, Just _) -> acc 81 | (Left errors, Nothing) -> Left (filePath : errors) 82 | (Right _, Nothing) -> Left [filePath] 83 | (Right valid, Just moduleInfo) -> Right ((filePath, moduleInfo): valid) 84 | -------------------------------------------------------------------------------- /izuna-builder/test/ProjectInfo/AppSpec.hs: -------------------------------------------------------------------------------- 1 | module ProjectInfo.AppSpec where 2 | 3 | import Data.Function ((&)) 4 | import qualified Data.Map as Map 5 | import qualified Data.Maybe as Maybe 6 | import Test.Hspec 7 | 8 | import qualified IzunaBuilder.ProjectInfo.App as App 9 | import IzunaBuilder.ProjectInfo.Model 10 | import qualified IzunaBuilder.ProjectInfo.RecoverType as RecoverType 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "parse hie files to ast" $ do 15 | it "project 0" $ do 16 | ModuleInfo{..} <- getProjectInfo "./izuna-builder/test/fixtures/hie/project0" "src/Lib.hs" 17 | _minfo_types `shouldBe` Map.fromList [(0,"()"),(1,"IO ()"),(2,"String"),(3,"String -> IO ()")] 18 | _minfo_typeRefs `shouldBe` Map.fromList [ (5,[ModuleAst {_mast_span = Span {_span_lineStart = 5, _span_lineEnd = 5, _span_colStart = 0, _span_colEnd = 30}, _mast_specializedType = Just 1, _mast_generalizedType = Nothing, _mast_children = [ModuleAst {_mast_span = Span {_span_lineStart = 5, _span_lineEnd = 5, _span_colStart = 11, _span_colEnd = 19}, _mast_specializedType = Just 3, _mast_generalizedType = Nothing, _mast_children = []},ModuleAst {_mast_span = Span {_span_lineStart = 5, _span_lineEnd = 5, _span_colStart = 20, _span_colEnd = 30}, _mast_specializedType = Just 2, _mast_generalizedType = Nothing, _mast_children = []}]}])] 19 | 20 | it "project 1" $ do 21 | ModuleInfo{..} <- getProjectInfo "./izuna-builder/test/fixtures/hie/project1" "src/Lib.hs" 22 | _minfo_types `shouldBe` Map.fromList [(0,"()"),(1,"IO ()"),(2,"String"),(3,"String -> IO ()"),(4,"Int"),(5,"Int -> Int"),(6,"Int -> Int -> Int"),(7,"'LiftedRep"),(8,"*"),(9,"a"),(10,"Num a"),(11,"a -> a"),(12,"a -> a -> a"),(13,"Num a => a -> a -> a"),(14,"forall a. Num a => a -> a -> a"),(15,"[Int]"),(16,"[Int] -> Int"),(17,"Int -> [Int] -> Int"),(18,"(Int -> Int -> Int) -> Int -> [Int] -> Int"),(19,"* -> *"),(20,"t"),(21,"Foldable t"),(22,"b"),(23,"a"),(24,"a -> b"),(25,"b -> a -> b"),(26,"t a"),(27,"t a -> b"),(28,"b -> t a -> b"),(29,"(b -> a -> b) -> b -> t a -> b"),(30,"forall a. (b -> a -> b) -> b -> t a -> b"),(31,"forall b a. (b -> a -> b) -> b -> t a -> b"),(32,"forall b a. Foldable t => (b -> a -> b) -> b -> t a -> b"),(33,"forall (t :: * -> *) b a.\nFoldable t =>\n(b -> a -> b) -> b -> t a -> b"),(34,"Integer"),(35,"Integer -> String"),(36,"a"),(37,"Show a"),(38,"a -> String"),(39,"Show a => a -> String"),(40,"forall a. Show a => a -> String")] 23 | 24 | getProjectInfo :: FilePath -> FilePath -> IO ModuleInfo 25 | getProjectInfo filePath moduleName = do 26 | df <- RecoverType.getDynFlags 27 | modulesInfo <- App.buildProjectInfo filePath df 28 | modulesInfo & 29 | Map.lookup moduleName & 30 | Maybe.fromMaybe emptyModuleInfo & 31 | return 32 | where 33 | emptyModuleInfo :: ModuleInfo 34 | emptyModuleInfo = 35 | ModuleInfo { _minfo_types = Map.empty 36 | , _minfo_typeRefs = Map.empty 37 | } 38 | -------------------------------------------------------------------------------- /izuna-builder/src/IzunaBuilder/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | 7 | module IzunaBuilder.Server(run, mkApp) where 8 | 9 | import qualified Control.Monad.Except as Except 10 | import qualified Control.Monad.IO.Class as IO 11 | import qualified Control.Monad.Reader as Reader 12 | --import qualified Data.CaseInsensitive as CI 13 | --import Data.Functor ((<&>)) 14 | --import qualified Network.HTTP.Types.Header as HTTP 15 | --import qualified Network.HTTP.Types.Method as HTTP 16 | --import Network.Wai (Middleware) 17 | --import qualified Network.Wai as Wai 18 | import qualified Network.Wai.Handler.Warp as Warp 19 | import qualified Say 20 | import Servant hiding (BadPassword, NoSuchUser) 21 | import Servant.Multipart 22 | 23 | import IzunaBuilder.NonEmptyString 24 | --import IzunaBuilder.ProjectInfo.Model 25 | import IzunaBuilder.ProjectInfo.App 26 | import IzunaBuilder.Type 27 | 28 | -- * run 29 | 30 | run :: Int -> IO () 31 | run port = do 32 | Say.sayString $ "running izuna-builder on port: " <> show port 33 | app :: Application <- mkApp "" 34 | Warp.run port app 35 | 36 | -- * mk app 37 | 38 | mkApp :: String -> IO Application 39 | mkApp env = do 40 | let 41 | context = EmptyContext 42 | webApiProxy = Proxy :: Proxy WebApi 43 | return $ 44 | serveWithContext webApiProxy context $ 45 | hoistServerWithContext webApiProxy (Proxy :: Proxy '[]) (appMToHandler env) apiServer 46 | 47 | -- * api 48 | 49 | type WebApi = 50 | ProjectInfoApi :<|> HealthApi 51 | 52 | apiServer :: ServerT WebApi AppM 53 | apiServer = 54 | projectInfoServer :<|> healthServer 55 | 56 | -- ** save project info 57 | 58 | type ProjectInfoApi = 59 | "api" 60 | :> "projectInfo" 61 | :> Capture "ghcVersion" (NonEmptyString GhcVersion) 62 | :> Capture "username" (NonEmptyString Username) 63 | :> Capture "repo" (NonEmptyString Repo) 64 | :> Capture "commit" (NonEmptyString Commit) 65 | :> CaptureAll "projectRoot" String 66 | :> MultipartForm Tmp (MultipartData Tmp) :> Post '[JSON] () 67 | 68 | 69 | projectInfoServer :: ServerT ProjectInfoApi AppM 70 | projectInfoServer = do 71 | saveProjectInfoHandler 72 | 73 | -- ** health api 74 | 75 | type HealthApi = 76 | "api" :> "health" :> Get '[JSON] String 77 | 78 | healthServer :: ServerT HealthApi AppM 79 | healthServer = do 80 | return "running!" 81 | 82 | 83 | -- * app 84 | 85 | newtype AppM a = 86 | AppM { unAppM :: Except.ExceptT ServerError (Reader.ReaderT String IO) a } 87 | deriving ( Except.MonadError ServerError 88 | , Reader.MonadReader String 89 | , Functor 90 | , Applicative 91 | , Monad 92 | , IO.MonadIO 93 | ) 94 | 95 | appMToHandler 96 | :: String 97 | -> AppM a 98 | -> Handler a 99 | appMToHandler env r = do 100 | eitherErrorOrResult <- IO.liftIO $ flip Reader.runReaderT env . Except.runExceptT . unAppM $ r 101 | case eitherErrorOrResult of 102 | Left error -> throwError error 103 | Right result -> return result 104 | -------------------------------------------------------------------------------- /stack-8.10.1.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 9 | pantry-tree: 10 | size: 325 11 | sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3 12 | original: 13 | hackage: servant-flatten-0.2 14 | - completed: 15 | hackage: servant-server-0.18.2@sha256:56679af62ab8820a2108da6153d9ae9dde37199e62172365bdaea1458c3f7c2d,5482 16 | pantry-tree: 17 | size: 2614 18 | sha256: 3ac7430134439e4b67f0f5333f63b89d0cb7de5e2e07f0af7801c8e223942b9c 19 | original: 20 | hackage: servant-server-0.18.2@sha256:56679af62ab8820a2108da6153d9ae9dde37199e62172365bdaea1458c3f7c2d,5482 21 | - completed: 22 | hackage: servant-0.18.2@sha256:f8c9f0e9891a3ada1337a3c0b369333a3b5a2d0909dd3cd09d79bc26adeaca44,5298 23 | pantry-tree: 24 | size: 2662 25 | sha256: e930e814de1aa4d24274bdf18341a50b7ed38604ae4734f730e09238ac5bf7e2 26 | original: 27 | hackage: servant-0.18.2@sha256:f8c9f0e9891a3ada1337a3c0b369333a3b5a2d0909dd3cd09d79bc26adeaca44,5298 28 | - completed: 29 | hackage: servant-multipart-0.12@sha256:aa81dd0478270ade4a21b75611d5bc9cce8107df2e89c37b9964a3421629825d,2761 30 | pantry-tree: 31 | size: 386 32 | sha256: 51c4e9e8be3ee80689bb6df46aee484a4f434dbeb33f4379ed8d1741fe4631cd 33 | original: 34 | hackage: servant-multipart-0.12@sha256:aa81dd0478270ade4a21b75611d5bc9cce8107df2e89c37b9964a3421629825d,2761 35 | - completed: 36 | hackage: servant-client-0.18.2@sha256:82578ade7468873259bb2fdc9d62290a0f998550900683e1410a237ed4b05410,4591 37 | pantry-tree: 38 | size: 1300 39 | sha256: 6324892c77bedbce32f0d6f1612fc2cb0d82c163d3be39efb951d3cc3792ce4a 40 | original: 41 | hackage: servant-client-0.18.2@sha256:82578ade7468873259bb2fdc9d62290a0f998550900683e1410a237ed4b05410,4591 42 | - completed: 43 | hackage: servant-client-core-0.18.2@sha256:ad63ae0f227373fea7e547d4c2a7b0b69e112ff409a83cbadffc9f6ee049926f,3763 44 | pantry-tree: 45 | size: 1444 46 | sha256: 9e37bc5f8cbb70cf1accb20bd6f83fca4c2ca42472cd0fc4b22183c2c57cbe3b 47 | original: 48 | hackage: servant-client-core-0.18.2@sha256:ad63ae0f227373fea7e547d4c2a7b0b69e112ff409a83cbadffc9f6ee049926f,3763 49 | - completed: 50 | hackage: servant-docs-0.11.8@sha256:1068303ebafa5df9ec936c727959c15b94f3569d52a5c250bb0693036391effc,3282 51 | pantry-tree: 52 | size: 702 53 | sha256: 1ebb15fda9e6aaeed4822545770d4fd7c521e22a13a0acbbf803b9f6b7ed07c9 54 | original: 55 | hackage: servant-docs-0.11.8@sha256:1068303ebafa5df9ec936c727959c15b94f3569d52a5c250bb0693036391effc,3282 56 | - completed: 57 | hackage: servant-foreign-0.15.3@sha256:5c9230a470776bbf1e9f1126906c08ef090044db9e5bb530a9d8f1c96386ea55,2767 58 | pantry-tree: 59 | size: 590 60 | sha256: 4d78b1df6191cdab80466bcb7abe635533e1acebb2b433db2fff0d40fb323939 61 | original: 62 | hackage: servant-foreign-0.15.3@sha256:5c9230a470776bbf1e9f1126906c08ef090044db9e5bb530a9d8f1c96386ea55,2767 63 | snapshots: 64 | - completed: 65 | size: 520867 66 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/8/14.yaml 67 | sha256: 55402c1524b249053913fd87d60062c7c0e816d353e3d842df4cc032432aa0d4 68 | original: nightly-2020-08-14 69 | -------------------------------------------------------------------------------- /izuna-builder/src/IzunaBuilder/HieFile/App.hs: -------------------------------------------------------------------------------- 1 | {-# language BlockArguments #-} 2 | 3 | module IzunaBuilder.HieFile.App ( parseHieFiles 4 | ) where 5 | 6 | -- * import 7 | 8 | 9 | -- ** base 10 | 11 | import Control.Monad.IO.Class ( liftIO ) 12 | import Data.Bool 13 | import Data.Foldable 14 | import Control.Monad (forM) 15 | import Prelude hiding (span) 16 | import System.Exit (exitFailure) 17 | 18 | -- ** generic-lens 19 | import Data.Generics.Labels () 20 | 21 | -- ** ghc 22 | 23 | import HieBin (HieFileResult (HieFileResult, hie_file_result), readHieFile, hie_file_result_version) 24 | import HieTypes (HieFile, hieVersion) 25 | import NameCache (NameCache, initNameCache) 26 | import UniqSupply (mkSplitUniqSupply) 27 | 28 | -- ** directory 29 | 30 | import System.Directory (canonicalizePath, doesDirectoryExist, 31 | doesFileExist, doesPathExist, 32 | listDirectory, withCurrentDirectory) 33 | 34 | -- ** filepath 35 | 36 | import System.FilePath (isExtensionOf) 37 | 38 | -- * get hie files 39 | 40 | 41 | parseHieFiles :: [FilePath] -> IO [HieFile] 42 | parseHieFiles hieDirectories = do 43 | hieFilePaths <- 44 | concat <$> 45 | traverse getHieFilePathsIn 46 | ( if null hieDirectories 47 | then ["./."] 48 | else hieDirectories 49 | ) 50 | 51 | nameCache <- do 52 | uniqSupply <- mkSplitUniqSupply 'z' 53 | return ( initNameCache uniqSupply [] ) 54 | 55 | forM hieFilePaths \hieFilePath -> do 56 | liftIO $ readCompatibleHieFileOrExit nameCache hieFilePath 57 | 58 | 59 | -- * get hie files path in 60 | 61 | 62 | -- | Recursively search for .hie files in given directory 63 | getHieFilePathsIn :: FilePath -> IO [FilePath] 64 | getHieFilePathsIn path = do 65 | exists <- 66 | doesPathExist path 67 | 68 | if exists 69 | then do 70 | isFile <- 71 | doesFileExist path 72 | 73 | if isFile && "hie" `isExtensionOf` path 74 | then do 75 | path' <- 76 | canonicalizePath path 77 | 78 | return [ path' ] 79 | 80 | else do 81 | isDir <- 82 | doesDirectoryExist path 83 | 84 | if isDir 85 | then do 86 | cnts <- 87 | listDirectory path 88 | 89 | withCurrentDirectory path ( foldMap getHieFilePathsIn cnts ) 90 | 91 | else 92 | return [] 93 | 94 | else 95 | return [] 96 | 97 | 98 | -- * readCompatibleHieFileOrExit 99 | 100 | 101 | -- | Read a .hie file, exiting if it's an incompatible version. 102 | readCompatibleHieFileOrExit :: NameCache -> FilePath -> IO HieFile 103 | readCompatibleHieFileOrExit nameCache path = do 104 | (HieFileResult{..}, _) <- readHieFile nameCache path 105 | case (hieVersion == hie_file_result_version) of 106 | True -> 107 | return hie_file_result 108 | 109 | False -> do 110 | putStrLn $ "incompatible hie file: " <> path 111 | putStrLn $ " expected .hie file version " <> show hieVersion <> " but got " <> show hie_file_result_version 112 | putStrLn $ " HieParser must be built with the same GHC version" 113 | <> " as the project it is used on" 114 | exitFailure 115 | -------------------------------------------------------------------------------- /izuna-server/src/IzunaServer/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module IzunaServer.Server(run, mkApp) where 7 | 8 | import qualified Control.Monad.Except as Except 9 | import qualified Control.Monad.IO.Class as IO 10 | import qualified Control.Monad.Reader as Reader 11 | import qualified Network.Wai.Handler.Warp as Warp 12 | import qualified Say 13 | import Servant hiding (BadPassword, NoSuchUser) 14 | import Servant.API.Flatten (Flat) 15 | 16 | import IzunaBuilder.NonEmptyString 17 | import IzunaBuilder.ProjectInfo.Model 18 | import IzunaBuilder.Type 19 | import IzunaServer.Env 20 | import IzunaServer.Project.App 21 | import IzunaServer.PullRequest.App 22 | import IzunaServer.PullRequest.Model 23 | 24 | -- * run 25 | 26 | run :: IO () 27 | run = do 28 | Say.sayString "running izuna-server!" 29 | app <- mkApp 30 | Warp.run 3001 app 31 | 32 | -- * mk app 33 | 34 | mkApp :: IO Application 35 | mkApp = do 36 | env <- getEnv 37 | let 38 | context = EmptyContext 39 | webApiProxy = Proxy :: Proxy WebApi 40 | return $ 41 | serveWithContext webApiProxy context $ 42 | hoistServerWithContext webApiProxy (Proxy :: Proxy '[]) (appMToHandler env) apiServer 43 | 44 | -- * api 45 | 46 | type WebApi = 47 | ProjectInfoApi :<|> PullRequestInfoApi :<|> HealthApi 48 | 49 | apiServer :: ServerT WebApi AppM 50 | apiServer = 51 | projectInfoServer :<|> pullRequestInfoServer :<|> healthServer 52 | 53 | -- ** project info 54 | 55 | type ProjectInfoApi = 56 | Flat ( 57 | "api" :> "projectInfo" 58 | :> Capture "username" (NonEmptyString Username) 59 | :> Capture "repo" (NonEmptyString Repo) 60 | :> Capture "commit" (NonEmptyString Commit) 61 | :> ReqBody '[JSON] [String] 62 | :> Post '[JSON] ModulesInfo 63 | ) 64 | 65 | projectInfoServer :: ServerT ProjectInfoApi AppM 66 | projectInfoServer = do 67 | getProjectInfoHandler 68 | 69 | -- ** pull request info 70 | 71 | type PullRequestInfoApi = 72 | Flat ( 73 | "api" :> "pullRequestInfo" 74 | :> Capture "username" (NonEmptyString Username) 75 | :> Capture "repo" (NonEmptyString Repo) 76 | :> Capture "pullRequestId" Nat 77 | :> Get '[JSON] PullRequestInfo 78 | ) 79 | 80 | pullRequestInfoServer :: ServerT PullRequestInfoApi AppM 81 | pullRequestInfoServer = do 82 | pullRequestInfoHandler 83 | 84 | -- ** health api 85 | 86 | type HealthApi = 87 | "api" :> "health" :> Get '[JSON] String 88 | 89 | healthServer :: ServerT HealthApi AppM 90 | healthServer = do 91 | return "running!" 92 | 93 | 94 | 95 | -- * app 96 | 97 | newtype AppM a = 98 | AppM { unAppM :: Except.ExceptT ServerError (Reader.ReaderT Env IO) a } 99 | deriving ( Except.MonadError ServerError 100 | , Reader.MonadReader Env 101 | , Functor 102 | , Applicative 103 | , Monad 104 | , IO.MonadIO 105 | ) 106 | 107 | appMToHandler 108 | :: Env 109 | -> AppM a 110 | -> Handler a 111 | appMToHandler env r = do 112 | eitherErrorOrResult <- IO.liftIO $ flip Reader.runReaderT env . Except.runExceptT . unAppM $ r 113 | case eitherErrorOrResult of 114 | Left error -> throwError error 115 | Right result -> return result 116 | -------------------------------------------------------------------------------- /chrome-extension/src/background.js: -------------------------------------------------------------------------------- 1 | /*global chrome*/ 2 | 3 | import { IzunaServerService } from './izunaServerService.js'; 4 | import { Constants } from './constants.js'; 5 | import { Cache } from './cache.js'; 6 | 7 | chrome.runtime.onInstalled.addListener(() => { 8 | var keyValue = {}; 9 | keyValue[Constants.ENABLE_IZUNA_KEY] = true; 10 | chrome.storage.sync.set(keyValue); 11 | }); 12 | 13 | chrome.tabs.onUpdated.addListener(debounce((tabId, changeInfo, tab) => { 14 | chrome.declarativeContent.onPageChanged.removeRules(undefined, () => { 15 | chrome.declarativeContent.onPageChanged.addRules([{ 16 | conditions: [ 17 | new chrome.declarativeContent.PageStateMatcher({ 18 | pageUrl: { hostEquals: 'github.com' }, // enable extension icon when we are on github.com only 19 | }) 20 | ], 21 | actions: [ 22 | new chrome.declarativeContent.ShowPageAction() 23 | ] 24 | }]); 25 | }); 26 | 27 | checkTabUpdate(tabId, changeInfo, tab); 28 | }, 1000)); 29 | 30 | function debounce(callback, delay) { 31 | var timer; 32 | return function() { 33 | var args = arguments; 34 | var context = this; 35 | clearTimeout(timer); 36 | timer = setTimeout(() => { callback.apply(context, args); }, delay); 37 | }; 38 | } 39 | 40 | function checkTabUpdate(tabId, changeInfo, tab) { 41 | if(isTabLoaded(changeInfo, tab)) { 42 | const pullRequestInfo = getGithubPullRequestInfo(tab); 43 | if(pullRequestInfo) { 44 | main(Cache, tabId, pullRequestInfo); 45 | } 46 | } 47 | } 48 | 49 | function isTabLoaded(changeInfo, tab) { 50 | const url = new URL(tab.url); 51 | return ( 52 | changeInfo && 53 | changeInfo.status && 54 | changeInfo.status === 'complete' && 55 | tab.active && 56 | tab.status === 'complete' && 57 | url.hostname === 'github.com' 58 | ); 59 | } 60 | 61 | function main(cache, tabId, pullRequestInfo) { 62 | chrome.storage.sync.get(Constants.ENABLE_IZUNA_KEY, (result) => { 63 | if(result[Constants.ENABLE_IZUNA_KEY]) { 64 | const izunaServerService = new IzunaServerService(Constants.IZUNA_HOST_URL, pullRequestInfo); 65 | 66 | izunaServerService.fetchPullRequestCommitsDetails(pullRequestInfo).then(pullRequestDetails => { 67 | chrome.tabs.sendMessage(tabId, { cmd: Constants.PULL_REQUEST_DETAILS_FETCHED }, (files) => { 68 | izunaServerService.fetchFilesInfo(pullRequestDetails, files).then(payload => { 69 | chrome.tabs.sendMessage(tabId, { cmd: Constants.FILES_INFO_FETCHED, payload: payload }, () => {}); 70 | }); 71 | }); 72 | }); 73 | } 74 | }); 75 | } 76 | 77 | /* return the pr info 78 | * eg: 79 | * input: https://github.com/matsumonkie/izuna-example/pull/7/files 80 | * output: { owner: matsumonkie, 81 | * repo: izuna-example, 82 | * pullRequest: 7 83 | * } 84 | */ 85 | function getGithubPullRequestInfo(tab) { 86 | const url = new URL(tab.url); 87 | const pathAction = url.pathname.split('/')[3]; 88 | const prTab = url.pathname.split('/')[5]; 89 | if(pathAction === 'pull' && prTab === 'files') { 90 | const params = url.pathname.split('/'); 91 | const pullRequestInfo = { 92 | user: params[1], 93 | repo: params[2], 94 | pr: params[4] 95 | }; 96 | Object.entries(pullRequestInfo).forEach(([key, value]) => { 97 | if(! value) { throw `Could not retrieve pull request info for key: ${key}`; } 98 | }); 99 | 100 | return pullRequestInfo; 101 | } 102 | 103 | return false; 104 | } 105 | -------------------------------------------------------------------------------- /izuna-builder/izuna-builder.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: izuna-builder 8 | version: 0.1.0.0 9 | description: Please see the README on GitHub at 10 | homepage: https://github.com/matsumonkie/izuna#readme 11 | bug-reports: https://github.com/matsumonkie/izuna/issues 12 | author: Author name here 13 | maintainer: example@example.com 14 | copyright: 2020 Author name here 15 | license: BSD3 16 | build-type: Simple 17 | extra-source-files: 18 | README.md 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/matsumonkie/izuna 23 | 24 | library 25 | exposed-modules: 26 | DevelMain 27 | IzunaBuilder.HieFile.App 28 | IzunaBuilder.Json 29 | IzunaBuilder.NonEmptyString 30 | IzunaBuilder.ProjectInfo.App 31 | IzunaBuilder.ProjectInfo.Model 32 | IzunaBuilder.ProjectInfo.RecoverType 33 | IzunaBuilder.ProjectInfo.Util 34 | IzunaBuilder.Server 35 | IzunaBuilder.Type 36 | other-modules: 37 | Paths_izuna_builder 38 | hs-source-dirs: 39 | src 40 | default-extensions: LambdaCase OverloadedStrings NamedFieldPuns QuasiQuotes ScopedTypeVariables TemplateHaskell RecordWildCards EmptyCase FlexibleContexts FlexibleInstances InstanceSigs MultiParamTypeClasses MultiWayIf StrictData TypeApplications 41 | ghc-options: -Wall -fno-warn-name-shadowing -Wincomplete-patterns -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info -hiedir=.hie 42 | build-depends: 43 | aeson 44 | , array 45 | , async 46 | , base >=4.7 && <5 47 | , bytestring 48 | , containers 49 | , directory 50 | , filepath 51 | , foreign-store 52 | , generic-lens 53 | , ghc 54 | , ghc-paths 55 | , html-entities 56 | , mtl 57 | , safe-exceptions 58 | , say 59 | , servant 60 | , servant-multipart 61 | , servant-server 62 | , tar 63 | , text 64 | , wai 65 | , warp 66 | default-language: Haskell2010 67 | 68 | executable izuna-builder-exe 69 | main-is: Main.hs 70 | other-modules: 71 | Paths_izuna_builder 72 | hs-source-dirs: 73 | app 74 | default-extensions: LambdaCase OverloadedStrings NamedFieldPuns QuasiQuotes ScopedTypeVariables TemplateHaskell RecordWildCards EmptyCase FlexibleContexts FlexibleInstances InstanceSigs MultiParamTypeClasses MultiWayIf StrictData TypeApplications 75 | ghc-options: -Wall -fno-warn-name-shadowing -Wincomplete-patterns -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N 76 | build-depends: 77 | base >=4.7 && <5 78 | , izuna-builder 79 | default-language: Haskell2010 80 | 81 | test-suite spec 82 | type: exitcode-stdio-1.0 83 | main-is: Spec.hs 84 | other-modules: 85 | ProjectInfo.AppSpec 86 | Paths_izuna_builder 87 | hs-source-dirs: 88 | test 89 | default-extensions: LambdaCase OverloadedStrings NamedFieldPuns QuasiQuotes ScopedTypeVariables TemplateHaskell RecordWildCards EmptyCase FlexibleContexts FlexibleInstances InstanceSigs MultiParamTypeClasses MultiWayIf StrictData TypeApplications 90 | ghc-options: -Wall -fno-warn-name-shadowing -Wincomplete-patterns -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info -hiedir=.hie -threaded -rtsopts -with-rtsopts=-N 91 | build-depends: 92 | base >=4.7 && <5 93 | , containers 94 | , hspec 95 | , izuna-builder 96 | , text 97 | default-language: Haskell2010 98 | -------------------------------------------------------------------------------- /izuna-server/src/DevelMain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module DevelMain where 4 | 5 | import Prelude 6 | 7 | import Control.Concurrent 8 | import Control.Exception.Safe 9 | import Control.Monad ((>=>)) 10 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 11 | import Data.Text (Text) 12 | import qualified Data.Text as Text 13 | import Data.Typeable 14 | import Foreign.Store (Store (..), lookupStore, readStore, 15 | storeAction, withStore) 16 | import GHC.Word (Word32) 17 | import Say 18 | import System.IO 19 | 20 | import IzunaServer.Server 21 | 22 | tshow :: Show a => a -> Text 23 | tshow = Text.pack . show 24 | 25 | -- | Start or restart the server. 26 | -- newStore is from foreign-store. 27 | -- A Store holds onto some data across ghci reloads 28 | update :: IO () 29 | update = do 30 | hSetBuffering stdout NoBuffering 31 | hSetBuffering stderr NoBuffering 32 | putStrLn "Updating" 33 | mtidStore <- lookupStore tidStoreNum 34 | case mtidStore of 35 | -- no server running 36 | Nothing -> do 37 | putStrLn "No server is running " 38 | done <- storeAction doneStore newEmptyMVar 39 | tid <- start done 40 | _ <- storeAction (Store tidStoreNum) (newIORef tid) 41 | return () 42 | -- server is already running 43 | Just tidStore -> do 44 | putStrLn "Server is already running " 45 | restartAppInNewThread tidStore 46 | where 47 | doneStore :: Store (MVar ()) 48 | doneStore = Store 0 49 | 50 | -- shut the server down with killThread and wait for the done signal 51 | restartAppInNewThread :: Store (IORef ThreadId) -> IO () 52 | restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do 53 | killThread tid 54 | withStore doneStore takeMVar 55 | readStore doneStore >>= start 56 | 57 | -- | Start the server in a separate thread. 58 | start :: MVar () -- ^ Written to when the thread is killed. 59 | -> IO ThreadId 60 | start done = 61 | myThreadId <* (do 62 | run `catch` \(SomeException e) -> do 63 | say "!!! exception in runAppDevel !!!" 64 | say $ "X exception type: " <> tshow (typeOf e) 65 | say $ "X exception : " <> tshow e 66 | say "runAppDevel terminated" 67 | ) 68 | `catch` 69 | (\(SomeException err) -> do 70 | say "finally action" 71 | hFlush stdout 72 | hFlush stderr 73 | putMVar done () 74 | say $ "Got Exception: " <> tshow err 75 | throwIO err 76 | ) 77 | `finally` 78 | (do 79 | say "finally action" 80 | hFlush stdout 81 | hFlush stderr 82 | putMVar done () 83 | ) 84 | 85 | -- | kill the server 86 | shutdown :: IO () 87 | shutdown = do 88 | mtidStore <- lookupStore tidStoreNum 89 | case mtidStore of 90 | -- no server running 91 | Nothing -> putStrLn "no app running" 92 | Just tidStore -> do 93 | withStore tidStore $ readIORef >=> killThread 94 | putStrLn "App is shutdown" 95 | 96 | tidStoreNum :: Word32 97 | tidStoreNum = 1 98 | 99 | modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () 100 | modifyStoredIORef store f = withStore store $ \ref -> do 101 | v <- readIORef ref 102 | f v >>= writeIORef ref 103 | -------------------------------------------------------------------------------- /izuna-builder/src/DevelMain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module DevelMain where 4 | 5 | import Prelude 6 | 7 | import Control.Concurrent 8 | import Control.Exception.Safe 9 | import Control.Monad ((>=>)) 10 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 11 | import Data.Text (Text) 12 | import qualified Data.Text as Text 13 | import Data.Typeable 14 | import Foreign.Store (Store (..), lookupStore, readStore, 15 | storeAction, withStore) 16 | import GHC.Word (Word32) 17 | import Say 18 | import System.IO 19 | 20 | import IzunaBuilder.Server 21 | 22 | tshow :: Show a => a -> Text 23 | tshow = Text.pack . show 24 | 25 | -- | Start or restart the server. 26 | -- newStore is from foreign-store. 27 | -- A Store holds onto some data across ghci reloads 28 | update :: IO () 29 | update = do 30 | hSetBuffering stdout NoBuffering 31 | hSetBuffering stderr NoBuffering 32 | putStrLn "Updating" 33 | mtidStore <- lookupStore tidStoreNum 34 | case mtidStore of 35 | -- no server running 36 | Nothing -> do 37 | putStrLn "No server is running " 38 | done <- storeAction doneStore newEmptyMVar 39 | tid <- start done 40 | _ <- storeAction (Store tidStoreNum) (newIORef tid) 41 | return () 42 | -- server is already running 43 | Just tidStore -> do 44 | putStrLn "Server is already running " 45 | restartAppInNewThread tidStore 46 | where 47 | doneStore :: Store (MVar ()) 48 | doneStore = Store 0 49 | 50 | -- shut the server down with killThread and wait for the done signal 51 | restartAppInNewThread :: Store (IORef ThreadId) -> IO () 52 | restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do 53 | killThread tid 54 | withStore doneStore takeMVar 55 | readStore doneStore >>= start 56 | 57 | -- | Start the server in a separate thread. 58 | start :: MVar () -- ^ Written to when the thread is killed. 59 | -> IO ThreadId 60 | start done = 61 | myThreadId <* (do 62 | run 3000 `catch` \(SomeException e) -> do 63 | say "!!! exception in runAppDevel !!!" 64 | say $ "X exception type: " <> tshow (typeOf e) 65 | say $ "X exception : " <> tshow e 66 | say "runAppDevel terminated" 67 | ) 68 | `catch` 69 | (\(SomeException err) -> do 70 | say "finally action" 71 | hFlush stdout 72 | hFlush stderr 73 | putMVar done () 74 | say $ "Got Exception: " <> tshow err 75 | throwIO err 76 | ) 77 | `finally` 78 | (do 79 | say "finally action" 80 | hFlush stdout 81 | hFlush stderr 82 | putMVar done () 83 | ) 84 | 85 | -- | kill the server 86 | shutdown :: IO () 87 | shutdown = do 88 | mtidStore <- lookupStore tidStoreNum 89 | case mtidStore of 90 | -- no server running 91 | Nothing -> putStrLn "no app running" 92 | Just tidStore -> do 93 | withStore tidStore $ readIORef >=> killThread 94 | putStrLn "App is shutdown" 95 | 96 | tidStoreNum :: Word32 97 | tidStoreNum = 1 98 | 99 | modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () 100 | modifyStoredIORef store f = withStore store $ \ref -> do 101 | v <- readIORef ref 102 | f v >>= writeIORef ref 103 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![example workflow file path](https://github.com/matsumonkie/izuna/workflows/.github/workflows/main.yml/badge.svg) 2 | 3 | # izuna 4 | 5 | > Enhances Haskell code review for Github 6 | 7 | Izuna brings a richer GitHub interface by showing type annotations directly in your browser. 8 | 9 | ![gif unified demo 1](./unified.gif) 10 | ![gif split demo 2](./split.gif) 11 | 12 | ## Requirements 13 | 14 | As of today, the izuna plugin is only available for Chrome and your Haskell project needs to be using either GHC 8.10.1 or GHC 8.10.2 15 | 16 | ## How do I use it? 17 | 18 | Go to the [chrome webstore](https://chrome.google.com/webstore/detail/izuna/fdddagbfkgicjkeijmbfdcmjeldegfdi) and install the izuna chrome extension. 19 | Then you can either go to one of the [izuna-example](https://github.com/matsumonkie/izuna-example/pulls) pull requests or submit one to see izuna in action. 20 | 21 | To use it for your own project, you'll also need to enable the github action [izuna-action](https://github.com/matsumonkie/izuna-action/). 22 | 23 | For development purpose, you need to install the izuna plugin in chrome by going to `chrome://extensions/` and clicking `load unpacked` (then select the `chrome-extension` folder). 24 | 25 | ## How does it work? 26 | 27 | Izuna makes use of [.hi extended](https://gitlab.haskell.org/ghc/ghc/-/wikis/hie-files) (AKA **hie files**) to recover information about your code. Your project information is then displayed by a plugin in your browser. 28 | 29 | A more detailed worklow is: 30 | 1. Every time you push a commit, a GitHub Action will upload the hie files to a server 31 | 2. The server will then process the hie files 32 | 3. When you visit a pull request from your browser, information about this PR (if any available) will be fetched from the server and displayed in your browser thanks to a plugin. 33 | 34 | ## Features & Roadmap 35 | 36 | ✅: available
37 | 🔧: building
38 | 39 | 40 | | available | feature | description | 41 | |-----------|------------------------------|------------------------------------------------------| 42 | | ✅ | Type annotation | Show type annotation for your haskell code | 43 | | ✅ | Split/Unified diff view mode | Works correctly for unified and split diff view mode | 44 | | ✅ | Chrome support | | 45 | | ✅ | Security | Source code is no longer stored | 46 | | ✅ | Syntax color | Display richer Haskell syntax color | 47 | | 🔧 | GHC 8.10.3 support | only GHC 8.10.1 and GHC 8.10.2 are available atm | 48 | 49 | ## How to build 50 | 51 | ### Github Action 52 | 53 | Please go to the [izuna-action](https://github.com/matsumonkie/izuna-action/) repo for more information. 54 | 55 | ### izuna-builder/izuna-server 56 | 57 | izuna-builder is the core of the project. Its purpose is to receive a hie files tar archive from the github action and extract it. 58 | Then it needs to parse the hie files and recover any useful information. 59 | 60 | Build with: 61 | ```bash 62 | stack build izuna-builder --stack-yaml=stack-8.10.1.yaml --no-nix 63 | ``` 64 | 65 | izuna-server is a simple server that returns the processed hie files for the plugin. 66 | 67 | Build with: 68 | ```bash 69 | stack build izuna-server --stack-yaml=stack-8.10.1.yaml --no-nix 70 | ``` 71 | 72 | ## Inspirations 73 | 74 | Izuna was (more than) inspired by: 75 | - [Haskell-code-explorer](https://github.com/alexwl/haskell-code-explorer) by Alexwl 76 | - [Haddock](https://github.com/haskell/haddock/) 77 | 78 | Many thanks to [Weeder](https://github.com/ocharles/weeder/) by Ocharles and [Stan](https://github.com/kowainik/stan) by Kowainik which helped me understand better how Hie files work. 79 | 80 | 81 | Icons made by [Freepik](https://www.flaticon.com/authors/freepik) 82 | -------------------------------------------------------------------------------- /chrome-extension/src/splitter.js: -------------------------------------------------------------------------------- 1 | /* 2 | * split every char for a given line of code in a github diff 3 | * eg: 4 | * 5 | * input: 6 | * hey 7 | * 8 | * output: 9 | * 10 | * 11 | * h 12 | * 13 | * e 14 | * 15 | * y 16 | * 17 | * 18 | * 19 | * Note that the span with the "izuna-fake-char" class are only here so we can correctly positionate the notification. 20 | * When your text element is even, we can still set its center with this trick 21 | * e.g: 22 | * center is easy to find 23 | * ↓ 24 | * when odd: "hey" 25 | * 26 | * center is not easy to find, we need to add an element between 'h' and 'o' that will behave as its center 27 | * that's the purpose of izuna-fake-char span 28 | * ↓ 29 | * when even: "ho" 30 | * 31 | */ 32 | class SplitterClass { 33 | 34 | constructor(document = document, Node = Node) { 35 | this.document = document; 36 | this.Node = Node; 37 | } 38 | 39 | createSpan(spanType, filePath, location, lineState, lineNumber, columnNumber, textContent) { 40 | var newChar = this.document.createElement('span'); 41 | newChar.setAttribute('class', spanType); 42 | newChar.setAttribute('data-file-path', filePath); 43 | newChar.setAttribute('data-location', location); 44 | newChar.setAttribute('data-state', lineState); 45 | newChar.setAttribute('data-row', lineNumber); 46 | newChar.setAttribute('data-col', columnNumber); 47 | if(textContent) { 48 | newChar.textContent = textContent; 49 | } 50 | return newChar; 51 | } 52 | 53 | split(docFragment, dom, filePath, location, lineState, lineNumber) { 54 | const buildSpans = (node, charPos) => { 55 | if(node.nodeType === this.Node.TEXT_NODE) { 56 | var parent = this.document.createElement('span'); 57 | const characterNodes = Array.from(node.textContent).map((character) => { 58 | const realSpan = this.createSpan(Splitter.REAL_SPAN, filePath, location, lineState, lineNumber, charPos, character); 59 | charPos = charPos + 0.5; 60 | const fakeSpan = this.createSpan(Splitter.FAKE_SPAN, filePath, location, lineState, lineNumber, charPos, null); 61 | charPos = charPos + 0.5; 62 | return [realSpan, fakeSpan]; 63 | }); 64 | 65 | characterNodes.forEach((characterNodes) => { 66 | const [realSpan, fakeSpan] = characterNodes; 67 | parent.appendChild(realSpan); 68 | parent.appendChild(fakeSpan); 69 | }); 70 | 71 | return [parent, charPos]; 72 | } else { 73 | Array.from(node.childNodes).forEach((child) => { 74 | const [newChild, newCharPos] = buildSpans(child, charPos); 75 | charPos = newCharPos; 76 | child.replaceWith(newChild); 77 | }); 78 | 79 | return [node, charPos]; 80 | } 81 | }; 82 | var [newNode] = buildSpans(dom.cloneNode(true), 0); 83 | docFragment.appendChild(newNode); 84 | 85 | return docFragment; 86 | } 87 | 88 | // this is for debug purpose only 89 | show(splitted, margin = '') { 90 | if(splitted.nodeType === this.Node.TEXT_NODE) { 91 | console.log(margin + '[' + splitted.textContent + ']'); 92 | } else { 93 | console.log(margin + splitted.cloneNode().outerHTML); 94 | } 95 | Array.from(splitted.childNodes).forEach((child) => this.show(child, margin + ' ')); 96 | } 97 | } 98 | 99 | const Splitter = { 100 | REAL_SPAN: 'izuna-char', 101 | FAKE_SPAN: 'izuna-fake-char', 102 | SplitterClass: SplitterClass 103 | }; 104 | 105 | export { Splitter }; 106 | -------------------------------------------------------------------------------- /chrome-extension/src/popper.js: -------------------------------------------------------------------------------- 1 | import { createPopper } from '@popperjs/core'; 2 | import { Constants } from './constants.js'; 3 | import { Splitter } from './splitter.js'; 4 | 5 | /* 6 | * create a popper notification and attach it to the correct html dom 7 | */ 8 | class Popper { 9 | 10 | constructor(filesInfo) { 11 | var arrow = document.createElement('div'); 12 | arrow.setAttribute('id', 'arrow'); 13 | arrow.setAttribute('data-popper-arrow', ''); 14 | 15 | var tooltipText = document.createElement('div'); 16 | tooltipText.setAttribute('id', 'tooltipText'); 17 | 18 | var tooltip = document.createElement('pre'); 19 | tooltip.setAttribute('id', 'tooltip'); 20 | tooltip.setAttribute('role', 'tooltip'); 21 | tooltip.appendChild(tooltipText); 22 | tooltip.appendChild(arrow); 23 | 24 | this.tooltip = tooltip; 25 | this.filesInfo = filesInfo; 26 | } 27 | 28 | tooltipOptions () { 29 | return { 30 | placement: 'top', 31 | modifiers: [ 32 | { 33 | name: 'offset', 34 | options: { 35 | offset: [0, 8], 36 | }, 37 | }, 38 | ], 39 | }; 40 | } 41 | 42 | // attach a display notification event on all code span that have type annotations 43 | mkNotificationEvents(diffDom) { 44 | let popperInstance = null; 45 | diffDom.querySelectorAll(`span.${Splitter.REAL_SPAN}`).forEach(span => { 46 | 47 | // show annotation 48 | span.addEventListener('mouseover', () => { 49 | const typeInfo = this.filesInfo.findType(span.dataset.filePath, span.dataset.location, span.dataset.state, span.dataset.col, span.dataset.row); 50 | if(typeInfo) { 51 | const spanAttr = this.buildSpanAttr(span, typeInfo); 52 | const realSpan = diffDom.querySelector(`span${spanAttr.classAttr}${spanAttr.filePathAttr}${spanAttr.rowAttr}${spanAttr.colAttr}${spanAttr.locationAttr}${spanAttr.stateAttr}`); 53 | if(realSpan) { 54 | this.highlightFocusedRegion(diffDom, spanAttr, typeInfo); 55 | popperInstance = createPopper(realSpan, this.tooltip, this.tooltipOptions()); 56 | this.tooltip.querySelector('#tooltipText').innerHTML = typeInfo.typeName; 57 | this.tooltip.setAttribute('data-show', ''); 58 | } 59 | } 60 | }); 61 | 62 | // hide annotation 63 | span.addEventListener('mouseleave', () => { 64 | const typeInfo = this.filesInfo.findType(span.dataset.filePath, span.dataset.location, span.dataset.state, span.dataset.col, span.dataset.row); 65 | if(typeInfo) { 66 | this.tooltip.removeAttribute('data-show'); 67 | if (popperInstance) { 68 | popperInstance.destroy(); 69 | popperInstance = null; 70 | } 71 | document.querySelectorAll(`span.${Constants.IZUNA_HIGHLIGHT_REGION}.${Splitter.REAL_SPAN}`).forEach(span => 72 | span.classList.remove(Constants.IZUNA_HIGHLIGHT_REGION) 73 | ); 74 | } 75 | }); 76 | 77 | }); 78 | } 79 | 80 | buildSpanAttr(span, typeInfo) { 81 | return { 82 | classAttr: `.${Number.isInteger(typeInfo.centerCol) ? Splitter.REAL_SPAN : Splitter.FAKE_SPAN}`, 83 | filePathAttr: `[data-file-path="${span.dataset.filePath}"]`, 84 | rowAttr: `[data-row="${span.dataset.row}"]`, 85 | colAttr: `[data-col="${typeInfo.centerCol}"]`, 86 | locationAttr: `[data-location="${span.dataset.location}"]`, 87 | stateAttr: `[data-state="${span.dataset.state}"]`, 88 | }; 89 | } 90 | 91 | highlightFocusedRegion(diffDom, spanAttr, typeInfo) { 92 | var spansToHighlight = []; 93 | var i = typeInfo.startCol; 94 | while(i <= typeInfo.endCol) { 95 | const dom = diffDom.querySelector(`span.${Splitter.REAL_SPAN}${spanAttr.filePathAttr}${spanAttr.rowAttr}${spanAttr.locationAttr}${spanAttr.stateAttr}[data-col="${i}"]`); 96 | if(dom) { 97 | spansToHighlight.push(dom); 98 | } 99 | i = i + 1; 100 | } 101 | spansToHighlight.forEach(span => { 102 | span.classList.add(Constants.IZUNA_HIGHLIGHT_REGION); 103 | }); 104 | } 105 | } 106 | 107 | export { Popper }; 108 | -------------------------------------------------------------------------------- /chrome-extension/src/contentScript.js: -------------------------------------------------------------------------------- 1 | /*global chrome*/ 2 | 3 | import { Splitter } from './splitter.js'; 4 | import { Popper } from './popper.js'; 5 | import { FilesInfo } from './filesInfo.js'; 6 | import { PullRequestPageService } from './pullRequestPageService.js'; 7 | import { Constants } from './constants.js'; 8 | import { NumBlob } from './numBlob.js'; 9 | 10 | chrome.runtime.onMessage.addListener((msg, sender, sendResponse) => { 11 | const pullRequestPage = new PullRequestPageService(); 12 | if(msg.cmd === Constants.PULL_REQUEST_DETAILS_FETCHED) { 13 | sendResponse(pullRequestPage.getFilesWithExtension('.hs')); 14 | } else if(msg.cmd === Constants.FILES_INFO_FETCHED) { 15 | main(msg.payload, pullRequestPage); 16 | sendResponse({ cmd: Constants.IZUNA_APP_DONE }); 17 | } else { 18 | console.error(`izuna: Unknown command of from background received in contentScript: ${msg}`); 19 | } 20 | }); 21 | 22 | function main (payload, pullRequestPage) { 23 | console.debug(payload); 24 | const diffDoms = pullRequestPage.getDiffsForFileWithExtension('.hs'); 25 | const splitter = new Splitter.SplitterClass(document, Node); 26 | const filesInfo = new FilesInfo(payload); 27 | const popper = new Popper(filesInfo); 28 | const numBlob = new NumBlob.NumBlobClass(); 29 | diffDoms.forEach(diffDom => { 30 | const isHidden = pullRequestPage.diffHidden(diffDom); 31 | if(isHidden) { 32 | watchForLoadDiff(pullRequestPage, splitter, numBlob, popper, payload, diffDom, isHidden); 33 | } else { 34 | handleDiff(pullRequestPage, splitter, numBlob, popper, payload, diffDom); 35 | } 36 | }); 37 | document.body.appendChild(popper.tooltip); 38 | } 39 | 40 | function handleDiff(pullRequestPage, splitter, numBlob, popper, payload, diffDom) { 41 | const splitMode = pullRequestPage.isSplitMode(diffDom); 42 | const filePath = pullRequestPage.getFilePath(diffDom); 43 | const moduleInfo = { 44 | oldModuleInfo: payload.oldPackageInfo[filePath], 45 | newModuleInfo: payload.newPackageInfo[filePath] 46 | }; 47 | generateIzuna(pullRequestPage, splitter, numBlob, popper, diffDom, splitMode, filePath, moduleInfo); 48 | watchDiffForCodeExpansion(pullRequestPage, splitter, numBlob, popper, diffDom, splitMode, filePath, moduleInfo); 49 | } 50 | 51 | /* 52 | * Sometimes Github doesn't show a diff file. There is a `Load diff` button instead. 53 | */ 54 | function watchForLoadDiff (pullRequestPage, splitter, numBlob, popper, payload, diffDom, isHiddenDom) { 55 | const isHiddenContainer = document.querySelector('div.js-diff-load-container'); 56 | const config = { attributes: false, childList: true, subtree: false }; 57 | 58 | const callback = function(mutationsList) { 59 | mutationsList.forEach (mutation => { 60 | const removedNodes = Array.from(mutation.removedNodes); 61 | const deletedDirectly = removedNodes.indexOf(isHiddenDom) > -1; 62 | const deletedByAParent = removedNodes.some(parent => parent.contains(isHiddenDom)); 63 | if(deletedDirectly || deletedByAParent) 64 | handleDiff(pullRequestPage, splitter, numBlob, popper, payload, diffDom); 65 | }); 66 | }; 67 | 68 | const observer = new MutationObserver(callback); 69 | observer.observe(isHiddenContainer, config); 70 | } 71 | 72 | function generateIzuna(pullRequestPage, splitter, numBlob, popper, diffDom, splitMode, filePath, moduleInfo) { 73 | if(moduleInfo.oldModuleInfo || moduleInfo.newPackageInfo) { 74 | var diffRowsDom = pullRequestPage.getRows(filePath, diffDom); 75 | diffRowsDom = pullRequestPage.normalizeDiff(diffRowsDom, splitMode); 76 | Array.from(diffRowsDom).forEach (diffRowDom => { 77 | const oldModuleInfo = moduleInfo.oldModuleInfo; 78 | const newModuleInfo = moduleInfo.newModuleInfo; 79 | 80 | if(splitMode) { // split mode, we need to handle 2 rows, one for the old diff and one for the new diff 81 | const line = numBlob.getNumBlobForSplitMode(diffRowDom); 82 | const codeRows = pullRequestPage.getCodeRowsForSplitMode(diffRowDom); 83 | 84 | handleCodeRow(splitter, filePath, codeRows.leftLineRow.parentNode, codeRows.leftLineRow.codeNode, Constants.LEFT_LOCATION, line.leftLine.lineState, oldModuleInfo, line.leftLine.lineNumber); 85 | handleCodeRow(splitter, filePath, codeRows.rightLineRow.parentNode, codeRows.rightLineRow.codeNode, Constants.RIGHT_LOCATION, line.rightLine.lineState, newModuleInfo, line.rightLine.lineNumber); 86 | } else { // unified mode, we only need to handle 1 row 87 | const line = numBlob.getNumBlobForUnifiedMode(diffRowDom); 88 | const codeRow = pullRequestPage.getCodeRowForUnifiedMode(diffRowDom); 89 | if(codeRow) { 90 | var whichModuleInfo; 91 | if(line.lineState === NumBlob.ADDED) { 92 | whichModuleInfo = newModuleInfo; 93 | } else { 94 | whichModuleInfo = oldModuleInfo; 95 | } 96 | handleCodeRow(splitter, filePath, codeRow.parentNode, codeRow.codeNode, Constants.CENTER_LOCATION, line.lineState, whichModuleInfo, line.lineNumber); 97 | } 98 | } 99 | }); 100 | popper.mkNotificationEvents(diffDom); 101 | } 102 | } 103 | 104 | function handleCodeRow(splitter, filePath, parentNode, codeNode, location, lineState, whichModuleInfo, lineNumber) { 105 | if(codeNode && lineNumber) { 106 | const newCodeNode = splitter.split(new DocumentFragment(), codeNode, filePath, location, lineState, lineNumber); 107 | parentNode.replaceChild(newCodeNode, codeNode); 108 | } 109 | } 110 | 111 | /* 112 | * on github, only the modified part of a file gets shown. If the user wants to see more, he can click on the expand button. 113 | * We watch the whole diff file and anytime child nodes are being added, we re-run izuna on the whole file 114 | */ 115 | function watchDiffForCodeExpansion (pullRequestPage, splitter, numBlob, popper, diffDom, splitMode, filePath, moduleInfo) { 116 | const codeDiffDom = diffDom.querySelector('table.diff-table tbody'); 117 | const config = { attributes: false, childList: true, subtree: false }; 118 | 119 | const callback = function(mutationsList) { 120 | mutationsList.forEach (mutation => { 121 | if (mutation.type === 'childList') { 122 | generateIzuna(pullRequestPage, splitter, numBlob, popper, diffDom, splitMode, filePath, moduleInfo); 123 | } 124 | }); 125 | }; 126 | 127 | const observer = new MutationObserver(callback); 128 | observer.observe(codeDiffDom, config); 129 | } 130 | -------------------------------------------------------------------------------- /chrome-extension/src/pullRequestPageService.js: -------------------------------------------------------------------------------- 1 | const CODE_ROW_CLASSES = ['blob-code-inner', 'blob-code-marker']; 2 | const LINE_ROW_SELECTOR = 'td.blob-code:not(:empty)'; 3 | const IZUNA_ROW_CLASS = 'izuna-row'; 4 | /* 5 | * this service extract parts of the dom for 6 | * a github pull request page dom (e.g: https://github.com/someUser/someRepo/pull/16/files), 7 | */ 8 | export class PullRequestPageService { 9 | 10 | constructor() {} 11 | 12 | // On the pull request page, we want to fetch the path of all the files with the given extension (e.g: ".hs" for haskell files) 13 | getFilesWithExtension(extension) { 14 | return Array.from(document.querySelectorAll('div.file-header div.file-info a')) 15 | .map(e => e.textContent) 16 | .filter(e => e.endsWith(extension)); 17 | } 18 | 19 | // In your browser page, try to find all the file diffs for the given extension 20 | getDiffsForFileWithExtension(extension) { 21 | const diffDoms = document.querySelectorAll(`div.file[data-file-type='${extension}']`); 22 | if (diffDoms.length === 0) { 23 | console.debug(`izuna: Could not find any diff for files with extension: "${extension}" code on this page.`); 24 | } 25 | return diffDoms; 26 | } 27 | 28 | // Sometimes the diff doesn't load and we have a `Load diff` button instead 29 | diffHidden(diffDom) { 30 | return diffDom.querySelector('include-fragment.js-diff-entry-loader'); 31 | } 32 | 33 | // whether we are diffing in split or unified mode 34 | isSplitMode(diffDom) { 35 | return !!diffDom.querySelector('table.file-diff-split'); 36 | } 37 | 38 | /* 39 | * Given a diff dom, extract its file path 40 | * eg: 41 | * input: 42 | * +-------------------------------------------------------------------+ 43 | * | 34 [][][][] myProject/src/main.js | 44 | * +-------------------------------------------------------------------+ 45 | * | 1 | + print("coucou"); | 46 | * | 2 | - print(1 + 1); | 47 | * | 3 | - return 0; | 48 | * +-------------------------------------------------------------------+ 49 | * 50 | * output: 51 | * myProject/src/main.js 52 | */ 53 | getFilePath(diffDom) { 54 | const filePathDom = diffDom.querySelector('.file-header .file-info a[title]'); 55 | if(filePathDom && filePathDom.text) { 56 | return filePathDom.text; 57 | } else { 58 | throw 'Could not fetch file name!'; 59 | } 60 | } 61 | 62 | // extract each rows of code for a given file diff 63 | getRows(filePath, diffDom) { 64 | // `tr[data-hunk]` are the original rows where as `tr.blob-expanded` are the rows that have been manually expanded by the user 65 | const diffRowsDom = diffDom.querySelector('tbody').querySelectorAll('tr[data-hunk], tr.blob-expanded'); 66 | if (diffRowsDom.length === 0) { 67 | console.warn(`izuna: Could not find any diff rows for ${filePath}, this will not affect izuna but is probably an error!`); 68 | } 69 | return diffRowsDom; 70 | } 71 | 72 | /* 73 | * Not all diff rows have the same html structure. This function makes sure every rows are "normalized" 74 | */ 75 | normalizeDiff(diffRowsDom, splitMode) { 76 | return Array.from(diffRowsDom).map (diffRowDom => { 77 | var lineRows; 78 | if (splitMode) { 79 | lineRows = this.getLineRowForSplitMode(diffRowDom); 80 | } else { 81 | lineRows = [ this.getLineRowForUnifiedMode(diffRowDom) ]; 82 | } 83 | Array.from(lineRows).forEach (lineRow => { 84 | if(lineRow) { 85 | var codeRow = this.getCodeRow(lineRow); 86 | // sometimes, a row doesn't have a span.blob-code child. In this case, we need to add an one as a default container 87 | if(! codeRow) { 88 | codeRow = document.createElement('span'); // blob-code class is probably on the parent, leave this one naked 89 | codeRow.classList.add(IZUNA_ROW_CLASS); 90 | // TODO: this doesn't seem to work when expanding diff code... no span are being created 91 | while(lineRow.firstChild) { 92 | const child = lineRow.firstChild; 93 | codeRow.appendChild(lineRow.removeChild(child)); 94 | } 95 | lineRow.appendChild(codeRow); 96 | } 97 | } 98 | }); 99 | 100 | return diffRowDom; 101 | }); 102 | } 103 | 104 | /* 105 | * contain the code row and line state (addition, deletion, unmodified) 106 | * eg: 107 | * 108 | * | 8 | + someCode 109 | * ‾‾‾‾‾‾‾‾‾‾ 110 | * caveats: this can be null! 111 | */ 112 | getLineRowForUnifiedMode(diffRowDom) { 113 | return diffRowDom.querySelector(LINE_ROW_SELECTOR); 114 | } 115 | 116 | /* 117 | * contain the code row and line state (addition, deletion, unmodified) 118 | * eg: 119 | * 120 | * | 8 | unmodifiedCode | 8 | unmodifiedCode 121 | * ‾‾‾‾‾‾‾‾‾‾‾‾‾‾ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾ 122 | * caveat: sometimes one of the column is empty 123 | * eg: 124 | * | | | 8 | unmodifiedCode 125 | * 126 | * 127 | */ 128 | getLineRowForSplitMode(diffRowDom) { 129 | return diffRowDom.querySelectorAll('td.blob-code'); 130 | } 131 | 132 | /* 133 | * contain the code row and line state (addition, deletion, unmodified) 134 | * eg: 135 | * 136 | * | 8 | + someCode 137 | * ‾‾‾‾‾‾‾‾ 138 | */ 139 | getCodeRow(lineRow) { 140 | return lineRow.querySelector(`span.${CODE_ROW_CLASSES.join('.')}, span.${IZUNA_ROW_CLASS}`); 141 | } 142 | 143 | /* 144 | * for the unified mode, there is only one line of code per row, so newCodeNode will be undefined 145 | * 146 | * oldCodeNode 147 | * ↓ 148 | * | 8 | | - someOldCode... 149 | */ 150 | getCodeRowForUnifiedMode(diffRowDom) { 151 | const lineRow = this.getLineRowForUnifiedMode(diffRowDom); 152 | if(!lineRow) { 153 | return null; 154 | } else { 155 | return { 156 | parentNode: lineRow, 157 | codeNode: this.getCodeRow(lineRow) 158 | }; 159 | } 160 | } 161 | 162 | /* 163 | * in split mode oldCodeNode and newCodeNode represents 164 | * respectively the code line from the left and the right, i.e: 165 | * 166 | * leftCodeNode rightCodeNode 167 | * ↓ ↓ 168 | * | 8 | - someOldCode... | 8 | + someNewCode... 169 | * 170 | */ 171 | getCodeRowsForSplitMode(diffRowDom) { 172 | const [ leftLineRow, rightLineRow ] = Array.from(this.getLineRowForSplitMode(diffRowDom)).map(lineRow => { 173 | return { 174 | parentNode: lineRow, 175 | codeNode: this.getCodeRow(lineRow) 176 | }; 177 | }); 178 | 179 | return { 180 | leftLineRow: leftLineRow, 181 | rightLineRow: rightLineRow 182 | }; 183 | } 184 | } 185 | -------------------------------------------------------------------------------- /izuna-builder/src/IzunaBuilder/ProjectInfo/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module IzunaBuilder.ProjectInfo.Model ( RawModule(..) 4 | , ModuleAst(..) 5 | , ModulesInfo 6 | , ModuleInfo(..) 7 | , Span(..) 8 | , isOneLine 9 | ) where 10 | 11 | 12 | -- * imports 13 | 14 | 15 | -- ** aeson 16 | 17 | import qualified Data.Aeson as Aeson 18 | 19 | -- ** ghc 20 | 21 | import GHC.Generics 22 | {- 23 | import qualified BasicTypes as Ghc 24 | import qualified FastString as Ghc 25 | import qualified GhcPlugins as Ghc 26 | import qualified HieTypes as Ghc 27 | import qualified IfaceType as Ghc 28 | -} 29 | 30 | -- ** local 31 | 32 | import IzunaBuilder.Type 33 | 34 | -- * model 35 | 36 | -- ** final 37 | 38 | type ModulesInfo = Map FilePath ModuleInfo 39 | 40 | data ModuleInfo = ModuleInfo 41 | { _minfo_types :: Map TypeIndex PrintedType 42 | , _minfo_typeRefs :: Map Nat [ModuleAst] 43 | } 44 | deriving (Show, Generic) 45 | 46 | data ModuleAst = ModuleAst 47 | { _mast_span :: Span 48 | , _mast_specializedType :: Maybe TypeIndex 49 | , _mast_generalizedType :: Maybe TypeIndex 50 | , _mast_children :: [ModuleAst] 51 | } 52 | deriving (Show, Eq, Generic) 53 | 54 | data Span = Span 55 | { _span_lineStart :: Nat 56 | , _span_lineEnd :: Nat 57 | , _span_colStart :: Nat 58 | , _span_colEnd :: Nat 59 | } 60 | deriving (Show, Eq, Generic) 61 | 62 | isOneLine :: Span -> Bool 63 | isOneLine Span{..} = 64 | _span_lineStart == _span_lineEnd 65 | 66 | 67 | -- ** initial 68 | 69 | data RawModule ast line = RawModule 70 | { _rawModule_hieTypes :: Array TypeIndex HieTypeFlat 71 | , _rawModule_hieAst :: HieAST ast 72 | , _rawModule_fileContent :: line 73 | } 74 | 75 | -- * json 76 | 77 | instance Aeson.ToJSON ModuleInfo where 78 | toJSON = 79 | Aeson.genericToJSON Aeson.defaultOptions { Aeson.fieldLabelModifier = drop $ length ("_minfo_" :: String) } 80 | 81 | instance Aeson.FromJSON ModuleInfo where 82 | parseJSON = 83 | Aeson.genericParseJSON Aeson.defaultOptions { Aeson.fieldLabelModifier = drop $ length ("_minfo_" :: String) } 84 | 85 | instance Aeson.ToJSON ModuleAst where 86 | toJSON = 87 | Aeson.genericToJSON Aeson.defaultOptions { Aeson.fieldLabelModifier = drop $ length ("_mast_" :: String) } 88 | 89 | instance Aeson.FromJSON ModuleAst where 90 | parseJSON = 91 | Aeson.genericParseJSON Aeson.defaultOptions { Aeson.fieldLabelModifier = drop $ length ("_mast_" :: String) } 92 | 93 | instance Aeson.ToJSON Span where 94 | toJSON = 95 | Aeson.genericToJSON Aeson.defaultOptions { Aeson.fieldLabelModifier = drop $ length ("_span_" :: String) } 96 | 97 | instance Aeson.FromJSON Span where 98 | parseJSON = 99 | Aeson.genericParseJSON Aeson.defaultOptions { Aeson.fieldLabelModifier = drop $ length ("_span_" :: String) } 100 | 101 | 102 | -- * other 103 | 104 | {- 105 | instance Aeson.ToJSON ModuleInfo where 106 | toJSON ModuleInfo{..} = 107 | Aeson.object [ "asts" .= _minfo_asts 108 | , "fileContent" .= _minfo_fileContent 109 | ] 110 | 111 | instance Aeson.FromJSON ModuleInfo where 112 | fromJSON ModuleInfo{..} = 113 | Aeson.object [ "asts" .= _minfo_asts 114 | , "fileContent" .= _minfo_fileContent 115 | ] 116 | -} 117 | 118 | {- 119 | instance Aeson.ToJSON (Ghc.IdentifierDetails PrintedType) where 120 | toJSON Ghc.IdentifierDetails{..} = 121 | Aeson.object [ "identType" .= identType 122 | , "identInfo" .= (identInfo & S.elems <&> show <&> T.pack) 123 | ] 124 | 125 | instance Aeson.ToJSON (Ghc.HieType Ghc.TypeIndex) where 126 | toJSON = \case 127 | Ghc.HTyVarTy name -> Aeson.toJSON $ "HTyVarTy: " <> Ghc.nameStableString name 128 | Ghc.HAppTy typeIndex args -> Aeson.toJSON $ "HAppTy: " <> show typeIndex 129 | Ghc.HTyConApp Ghc.IfaceTyCon{..} args -> 130 | Aeson.object [ "hieType" .= ("HTyConApp" :: String) 131 | , "ifaceTyConName" .= (Ghc.nameStableString ifaceTyConName) 132 | , "ifaceTyConInfo.promoted" .= (ifaceTyConInfo & Ghc.ifaceTyConIsPromoted & Ghc.isPromoted) 133 | , "ifaceTyConInfo.sort" .= 134 | ( ifaceTyConInfo & Ghc.ifaceTyConSort & \case 135 | Ghc.IfaceNormalTyCon -> ("IfaceNormalTyCon" :: String) 136 | Ghc.IfaceTupleTyCon _ _ -> ("IfaceTupleTyCon" :: String) 137 | Ghc.IfaceSumTyCon _ -> ("IfaceSumTyCon" :: String) 138 | Ghc.IfaceEqualityTyCon -> ("IfaceEqualityTyCon" :: String) 139 | ) 140 | ] 141 | Ghc.HForAllTy (name, arg) a -> "HForAllTy" -- add serialization for all params below 142 | Ghc.HFunTy a b -> Aeson.String $ T.pack $ "HFunTy:" <> show a <> ":" <> show b 143 | Ghc.HQualTy _ _ -> "HQualTy" 144 | Ghc.HLitTy ifaceTyLit -> "HLitTy" 145 | Ghc.HCastTy a -> "HCastTy" 146 | Ghc.HCoercionTy -> "HCoercionTy" 147 | 148 | instance Aeson.ToJSON (Ghc.HieAST Ghc.TypeIndex) where 149 | toJSON Ghc.Node { nodeInfo, nodeSpan, nodeChildren } = 150 | Aeson.object [ "nodeInfo.nodeAnnotations" .= (nodeInfo & Ghc.nodeAnnotations) 151 | , "nodeInfo.nodeType" .= (nodeInfo & Ghc.nodeType) 152 | , "nodeInfo.nodeIdentifiers" .= (nodeInfo & Ghc.nodeIdentifiers) 153 | , "nodeSpan.file" .= (nodeSpan & Ghc.srcSpanFile & Ghc.unpackFS) 154 | , "nodeSpan.loc" .= ( (show $ Ghc.srcSpanStartLine nodeSpan) <> 155 | ":" <> 156 | (show $ Ghc.srcSpanEndLine nodeSpan) <> 157 | " " <> 158 | (show $ Ghc.srcSpanStartCol nodeSpan) <> 159 | ":" <> 160 | (show $ Ghc.srcSpanEndCol nodeSpan) 161 | ) 162 | , "nodeChildren" .= Aeson.toJSON nodeChildren 163 | ] 164 | 165 | instance Aeson.ToJSON Ghc.FastString where 166 | toJSON = 167 | Aeson.String . T.pack . Ghc.unpackFS 168 | 169 | instance Aeson.ToJSON (Ghc.IdentifierDetails Ghc.TypeIndex) where 170 | toJSON Ghc.IdentifierDetails{..} = 171 | Aeson.object [ "identType" .= identType 172 | , "identInfo" .= (identInfo & S.elems <&> show <&> T.pack) 173 | ] 174 | 175 | instance Aeson.ToJSONKey (Either Ghc.ModuleName Ghc.Name) where 176 | toJSONKey = 177 | Aeson.toJSONKeyText str 178 | where 179 | str :: Either Ghc.ModuleName Ghc.Name -> T.Text 180 | str either = 181 | T.pack $ case either of 182 | Left moduleName -> Ghc.moduleNameString moduleName 183 | Right name -> Ghc.nameStableString name 184 | 185 | instance Aeson.ToJSON Ghc.ModuleName where 186 | toJSON moduleName = 187 | Aeson.String $ T.pack $ Ghc.moduleNameString moduleName 188 | 189 | instance Aeson.ToJSON Ghc.Name where 190 | toJSON name = 191 | Aeson.String $ T.pack $ Ghc.nameStableString name 192 | -} 193 | -------------------------------------------------------------------------------- /izuna-builder/src/IzunaBuilder/Json.hs: -------------------------------------------------------------------------------- 1 | {- 2 | {-# LANGUAGE ApplicativeDo #-} 3 | {-# LANGUAGE BlockArguments #-} 4 | {-# LANGUAGE CPP #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE NamedFieldPuns #-} 9 | {-# LANGUAGE NoImplicitPrelude #-} 10 | {-# LANGUAGE OverloadedLabels #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE PackageImports #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | -} 15 | 16 | module IzunaBuilder.Json where 17 | 18 | {- 19 | -- * imports 20 | 21 | 22 | -- ** aeson 23 | 24 | import Data.Aeson ((.=)) 25 | import qualified Data.Aeson as Aeson 26 | import qualified Data.Aeson.Types as Aeson 27 | 28 | -- ** base 29 | 30 | import Data.Array 31 | import Data.Function ((&)) 32 | import Data.Functor ((<&>)) 33 | import qualified Data.Set as Set 34 | import Prelude hiding (span) 35 | 36 | -- ** text 37 | 38 | import qualified Data.Text as T 39 | 40 | -- ** ghc 41 | 42 | import BasicTypes 43 | import FastString 44 | import GHC 45 | import HieTypes (BindType (RegularBind), ContextInfo (ClassTyDecl, Decl, PatternBind, TyDecl, Use, ValBind), 46 | DeclType (ClassDec, ConDec, DataDec), 47 | HieAST (Node, nodeChildren, nodeInfo, nodeSpan), 48 | HieASTs (..), HieArgs (..), HieFile, 49 | HieFile (HieFile, hie_asts, hie_exports, hie_hs_file, hie_hs_src, hie_module, hie_types), 50 | HieType (..), HieTypeFlat, 51 | IdentifierDetails (IdentifierDetails, identInfo, identType), 52 | NodeInfo (NodeInfo, nodeAnnotations, nodeIdentifiers, nodeType), 53 | Scope (ModuleScope), TypeIndex, hieVersion) 54 | import IfaceType 55 | import Name (nameStableString) 56 | 57 | 58 | -- * aeson hiefile type index 59 | 60 | instance Aeson.ToJSON HieFile where 61 | toJSON HieFile{ hie_hs_file 62 | , hie_types 63 | , hie_exports 64 | , hie_module 65 | , hie_asts = HieASTs asts 66 | } = 67 | Aeson.object [ "hie_hs_file" .= hie_hs_file 68 | , "moduleUnitId" .= show (hie_module & moduleUnitId) 69 | , "moduleName" .= moduleNameString (hie_module & moduleName) 70 | , "hie_types" .= elems hie_types 71 | , "hie_asts" .= asts 72 | ] 73 | 74 | instance Aeson.ToJSON (IdentifierDetails TypeIndex) where 75 | toJSON IdentifierDetails{..} = 76 | Aeson.object [ "identType" .= identType 77 | , "identInfo" .= (identInfo & Set.elems <&> show <&> T.pack) 78 | ] 79 | 80 | instance Aeson.ToJSON (HieAST TypeIndex) where 81 | toJSON Node { nodeInfo, nodeSpan, nodeChildren } = 82 | Aeson.object [ "nodeInfo.nodeAnnotations" .= (nodeInfo & nodeAnnotations) 83 | , "nodeInfo.nodeType" .= (nodeInfo & nodeType) 84 | , "nodeInfo.nodeIdentifiers" .= (nodeInfo & nodeIdentifiers) 85 | , "nodeSpan.file" .= (nodeSpan & srcSpanFile & unpackFS) 86 | , "nodeSpan.loc" .= ( (show $ srcSpanStartLine nodeSpan) <> 87 | ":" <> 88 | (show $ srcSpanEndLine nodeSpan) <> 89 | " " <> 90 | (show $ srcSpanStartCol nodeSpan) <> 91 | ":" <> 92 | (show $ srcSpanEndCol nodeSpan) 93 | ) 94 | , "nodeChildren" .= Aeson.toJSON nodeChildren 95 | ] 96 | 97 | instance Aeson.ToJSON (HieType TypeIndex) where 98 | toJSON = \case 99 | HTyVarTy name -> Aeson.toJSON $ "HTyVarTy: " <> nameStableString name 100 | HAppTy typeIndex args -> Aeson.toJSON $ "HAppTy: " <> show typeIndex 101 | HTyConApp IfaceTyCon{..} args -> 102 | Aeson.object [ "hieType" .= ("HTyConApp" :: String) 103 | , "ifaceTyConName" .= (nameStableString ifaceTyConName) 104 | , "ifaceTyConInfo.promoted" .= (ifaceTyConInfo & ifaceTyConIsPromoted & isPromoted) 105 | , "ifaceTyConInfo.sort" .= 106 | ( ifaceTyConInfo & ifaceTyConSort & \case 107 | IfaceNormalTyCon -> ("IfaceNormalTyCon" :: String) 108 | IfaceTupleTyCon _ _ -> ("IfaceTupleTyCon" :: String) 109 | IfaceSumTyCon _ -> ("IfaceSumTyCon" :: String) 110 | IfaceEqualityTyCon -> ("IfaceEqualityTyCon" :: String) 111 | ) 112 | ] 113 | HForAllTy (name, arg) a -> "HForAllTy" -- add serialization for all params below 114 | HFunTy a b -> Aeson.String $ T.pack $ "HFunTy:" <> show a <> ":" <> show b 115 | HQualTy _ _ -> "HQualTy" 116 | HLitTy ifaceTyLit -> "HLitTy" 117 | HCastTy a -> "HCastTy" 118 | HCoercionTy -> "HCoercionTy" 119 | 120 | instance Aeson.ToJSONKey FastString where 121 | toJSONKey = 122 | Aeson.toJSONKeyText (T.pack . unpackFS) 123 | 124 | instance Aeson.ToJSON FastString where 125 | toJSON = 126 | Aeson.String . T.pack . unpackFS 127 | 128 | instance Aeson.ToJSON ModuleName where 129 | toJSON moduleName = 130 | Aeson.String $ T.pack $ moduleNameString moduleName 131 | 132 | instance Aeson.ToJSON Name where 133 | toJSON name = 134 | Aeson.String $ T.pack $ nameStableString name 135 | 136 | instance Aeson.ToJSONKey (Either ModuleName Name) where 137 | toJSONKey = 138 | Aeson.toJSONKeyText str 139 | where 140 | str :: Either ModuleName Name -> T.Text 141 | str either = 142 | T.pack $ case either of 143 | Left moduleName -> moduleNameString moduleName 144 | Right name -> nameStableString name 145 | 146 | 147 | -- * aeson hiefile printed type 148 | 149 | type PrintedType = String 150 | 151 | instance Aeson.ToJSON (IdentifierDetails PrintedType) where 152 | toJSON IdentifierDetails{..} = 153 | Aeson.object [ "identType" .= identType 154 | , "identInfo" .= (identInfo & Set.elems <&> show <&> T.pack) 155 | ] 156 | 157 | instance Aeson.ToJSON (HieAST PrintedType) where 158 | toJSON Node { nodeInfo, nodeSpan, nodeChildren } = 159 | Aeson.object [ "nodeInfo.nodeAnnotations" .= (nodeInfo & nodeAnnotations) 160 | , "nodeInfo.nodeType" .= (nodeInfo & nodeType) 161 | , "nodeInfo.nodeIdentifiers" .= (nodeInfo & nodeIdentifiers) 162 | , "nodeSpan.file" .= (nodeSpan & srcSpanFile & unpackFS) 163 | , "nodeSpan.loc" .= ( (show $ srcSpanStartLine nodeSpan) <> 164 | ":" <> 165 | (show $ srcSpanEndLine nodeSpan) <> 166 | " " <> 167 | (show $ srcSpanStartCol nodeSpan) <> 168 | ":" <> 169 | (show $ srcSpanEndCol nodeSpan) 170 | ) 171 | , "nodeChildren" .= Aeson.toJSON nodeChildren 172 | ] 173 | 174 | instance Aeson.ToJSON (HieType PrintedType) where 175 | toJSON = \case 176 | HTyVarTy name -> Aeson.toJSON $ "HTyVarTy: " <> nameStableString name 177 | HAppTy typeIndex args -> Aeson.toJSON $ "HAppTy: " <> show typeIndex 178 | HTyConApp IfaceTyCon{..} args -> 179 | Aeson.object [ "hieType" .= ("HTyConApp" :: String) 180 | , "ifaceTyConName" .= (nameStableString ifaceTyConName) 181 | , "ifaceTyConInfo.promoted" .= (ifaceTyConInfo & ifaceTyConIsPromoted & isPromoted) 182 | , "ifaceTyConInfo.sort" .= 183 | ( ifaceTyConInfo & ifaceTyConSort & \case 184 | IfaceNormalTyCon -> ("IfaceNormalTyCon" :: String) 185 | IfaceTupleTyCon _ _ -> ("IfaceTupleTyCon" :: String) 186 | IfaceSumTyCon _ -> ("IfaceSumTyCon" :: String) 187 | IfaceEqualityTyCon -> ("IfaceEqualityTyCon" :: String) 188 | ) 189 | ] 190 | HForAllTy (name, arg) a -> "HForAllTy" -- add serialization for all params below 191 | HFunTy a b -> Aeson.String $ T.pack $ "HFunTy:" <> show a <> ":" <> show b 192 | HQualTy _ _ -> "HQualTy" 193 | HLitTy ifaceTyLit -> "HLitTy" 194 | HCastTy a -> "HCastTy" 195 | HCoercionTy -> "HCoercionTy" 196 | -} 197 | -------------------------------------------------------------------------------- /izuna-builder/src/IzunaBuilder/ProjectInfo/App.hs: -------------------------------------------------------------------------------- 1 | module IzunaBuilder.ProjectInfo.App ( saveProjectInfoHandler 2 | , buildProjectInfo 3 | ) where 4 | 5 | -- * imports 6 | 7 | -- ** aeson 8 | 9 | import qualified Data.Aeson as Aeson 10 | 11 | -- ** base 12 | 13 | import qualified Control.Exception as Exception 14 | import Data.Function ((&)) 15 | import Data.Functor ((<&>)) 16 | import qualified Data.List as List 17 | 18 | -- ** tar 19 | 20 | import qualified Codec.Archive.Tar as Tar 21 | 22 | -- ** transformers 23 | 24 | import qualified Control.Monad as Monad 25 | --import qualified Control.Monad.Except as Except 26 | import qualified Control.Monad.IO.Class as IO 27 | 28 | -- ** filepath 29 | 30 | import System.FilePath.Posix (()) 31 | import qualified System.FilePath.Posix as FilePath 32 | 33 | -- ** directory 34 | 35 | import qualified System.Directory as Dir 36 | 37 | -- ** servant 38 | 39 | import Servant.Multipart (FileData (..), 40 | MultipartData (..), Tmp) 41 | -- ** maybe 42 | 43 | import qualified Data.Maybe as Maybe 44 | 45 | -- ** containers 46 | 47 | import qualified Data.Map as M 48 | 49 | -- ** ghc 50 | 51 | import qualified FastString as Ghc 52 | import qualified GHC.Natural as Ghc 53 | import qualified HieTypes as Ghc 54 | import qualified SrcLoc as Ghc 55 | 56 | -- ** async 57 | 58 | import qualified Control.Concurrent.Async as Async 59 | 60 | --import Debug.Pretty.Simple 61 | 62 | -- ** local 63 | 64 | import IzunaBuilder.HieFile.App 65 | import IzunaBuilder.NonEmptyString 66 | import IzunaBuilder.ProjectInfo.Model 67 | import IzunaBuilder.ProjectInfo.RecoverType 68 | import IzunaBuilder.ProjectInfo.Util 69 | import IzunaBuilder.Type 70 | 71 | -- * handler 72 | 73 | saveProjectInfoHandler 74 | :: (IO.MonadIO m) 75 | => NonEmptyString GhcVersion 76 | -> NonEmptyString Username 77 | -> NonEmptyString Repo 78 | -> NonEmptyString Commit 79 | -> [String] 80 | -> MultipartData Tmp 81 | -> m () 82 | saveProjectInfoHandler _ username repo commit projectRootAsList MultipartData{files} = do 83 | IO.liftIO $ do 84 | df <- getDynFlags 85 | createDirectory projectPath 86 | Monad.forM_ files $ extractHieTar hiePath 87 | _ <- Async.async $ do 88 | projectInfo <- buildProjectInfo hiePath df 89 | _ <- M.traverseWithKey (saveModuleInfo projectPath projectRoot) projectInfo 90 | Dir.removeDirectoryRecursive hiePath 91 | return () 92 | where 93 | projectPath :: FilePath 94 | projectPath = getProjectPath username repo commit 95 | 96 | hiePath :: FilePath 97 | hiePath = getHiePath projectPath 98 | 99 | createDirectory :: FilePath -> IO () 100 | createDirectory directory = 101 | Dir.createDirectoryIfMissing True directory 102 | 103 | extractHieTar :: FilePath -> FileData Tmp -> IO () 104 | extractHieTar targetFolder FileData{..}= 105 | Tar.extract targetFolder fdPayload 106 | 107 | projectRoot :: FilePath 108 | projectRoot = 109 | FilePath.joinPath projectRootAsList 110 | 111 | 112 | -- * build project info 113 | 114 | buildProjectInfo 115 | :: FilePath 116 | -> DynFlags 117 | -> IO ModulesInfo 118 | buildProjectInfo hieDirectory df = do 119 | hieFiles <- getHieFiles 120 | let filePathToRawModule = getFilePathToRawModule hieFiles & M.map removeUselessNodes 121 | return $ M.map (\rawModule -> 122 | ModuleInfo { _minfo_types = recoverTypes df rawModule 123 | , _minfo_typeRefs = buildModuleInfo rawModule 124 | } 125 | ) filePathToRawModule 126 | where 127 | getHieFiles :: IO [HieFile] 128 | getHieFiles = do 129 | hieFiles <- parseHieFiles [ hieDirectory ] 130 | hieFiles & filter (not . generatedFile) & return 131 | where 132 | generatedFile :: HieFile -> Bool 133 | generatedFile Ghc.HieFile {..} = 134 | ".stack-work" `List.isPrefixOf` hie_hs_file 135 | 136 | getFilePathToRawModule :: [HieFile] -> Map FilePath (RawModule TypeIndex ByteString) 137 | getFilePathToRawModule hieFiles = do 138 | convertHieFilesToMap hieFiles 139 | where 140 | convertHieFilesToMap :: [HieFile] -> M.Map FilePath (RawModule TypeIndex ByteString) 141 | convertHieFilesToMap hieFiles = 142 | hieFiles <&> convertHieToRawModule & M.fromList 143 | 144 | buildModuleInfo :: RawModule TypeIndex ByteString -> Map Nat [ModuleAst] 145 | buildModuleInfo rawModule = 146 | rawModule & convertRawModuleToModuleAst & groupByLine 147 | 148 | -- * convert raw module to raw lines 149 | 150 | -- | instead of handling data as a whole, we split it by line of code 151 | -- doing so will help further down the pipe when we need to generate DOM (that can't handle multiline yet) 152 | convertRawModuleToModuleAst :: RawModule TypeIndex ByteString -> ModuleAst 153 | convertRawModuleToModuleAst RawModule{..} = 154 | hieAstToModuleAst _rawModule_hieAst 155 | where 156 | hieAstToModuleAst :: HieAST TypeIndex -> ModuleAst 157 | hieAstToModuleAst Ghc.Node{..} = 158 | ModuleAst { _mast_span = 159 | -- line and column starts at 1 in hie ast 160 | Span { _span_lineStart = Ghc.intToNatural $ Ghc.srcSpanStartLine nodeSpan - 1 161 | , _span_lineEnd = Ghc.intToNatural $ Ghc.srcSpanEndLine nodeSpan - 1 162 | , _span_colStart = Ghc.intToNatural $ colPos $ Ghc.srcSpanStartCol nodeSpan 163 | , _span_colEnd = Ghc.intToNatural $ colPos $ Ghc.srcSpanEndCol nodeSpan 164 | } 165 | , _mast_specializedType = nodeInfo & Ghc.nodeType & specializedAndGeneralizedType & fst 166 | , _mast_generalizedType = nodeInfo & Ghc.nodeType & specializedAndGeneralizedType & snd 167 | , _mast_children = nodeChildren <&> hieAstToModuleAst 168 | } 169 | where 170 | {- | I don't understand this... Sometimes, hie returns either 0 or a negative value the column position for. todo: investigate -} 171 | colPos :: Int -> Int 172 | colPos = \case 173 | 0 -> 0 174 | positiveNumber -> positiveNumber - 1 175 | 176 | specializedAndGeneralizedType :: [TypeIndex] -> (Maybe TypeIndex, Maybe TypeIndex) 177 | specializedAndGeneralizedType = \case 178 | [s, g] -> (Just s, Just g) 179 | [s] -> (Just s, Nothing) 180 | _ -> (Nothing, Nothing) 181 | 182 | -- * save modules info 183 | 184 | saveModuleInfo 185 | :: FilePath 186 | -> FilePath 187 | -> FilePath 188 | -> ModuleInfo 189 | -> IO () 190 | saveModuleInfo projectPath projectRoot filePath projectInfo = do 191 | let (subDir, filename) = FilePath.splitFileName filePath 192 | Dir.createDirectoryIfMissing True (jsonPath subDir) 193 | Exception.try (Aeson.encodeFile (jsonPath subDir filename) projectInfo) >>= \case 194 | Left (exception :: Exception.IOException) -> do 195 | putStrLn $ "Error while saving file:" <> filePath <> " in: " <> projectPath <> " - " <> show exception 196 | return () 197 | Right _ -> return () 198 | where 199 | jsonPath :: FilePath 200 | jsonPath = 201 | getJsonPath projectPath projectRoot 202 | 203 | -- * convert hie to raw module 204 | 205 | 206 | convertHieToRawModule :: HieFile -> (FilePath, RawModule TypeIndex ByteString) 207 | convertHieToRawModule hie@Ghc.HieFile {..} = 208 | ( hie_hs_file 209 | , RawModule { _rawModule_hieTypes = hie_types 210 | , _rawModule_hieAst = hieAstsToAst hie 211 | , _rawModule_fileContent = hie_hs_src 212 | } 213 | ) 214 | where 215 | hieAstsToAst :: HieFile -> HieAST TypeIndex 216 | hieAstsToAst Ghc.HieFile { hie_asts = Ghc.HieASTs asts 217 | , hie_hs_file 218 | } = 219 | Maybe.fromMaybe (emptyHieAst fileFs) mast 220 | where 221 | fileFs :: Ghc.FastString 222 | fileFs = Ghc.mkFastString hie_hs_file 223 | 224 | mast :: Maybe (HieAST TypeIndex) 225 | mast = 226 | case M.size asts == 1 of 227 | True -> M.lookupMin asts <&> snd 228 | False -> M.lookup fileFs asts 229 | 230 | emptyHieAst :: Ghc.FastString -> HieAST TypeIndex 231 | emptyHieAst fileFs = Ghc.Node 232 | { nodeInfo = emptyNodeInfo 233 | , nodeSpan = Ghc.realSrcLocSpan (Ghc.mkRealSrcLoc fileFs 1 0) 234 | , nodeChildren = [] 235 | } 236 | 237 | emptyNodeInfo :: Ghc.NodeInfo TypeIndex 238 | emptyNodeInfo = Ghc.NodeInfo 239 | { nodeAnnotations = mempty 240 | , nodeType = [] 241 | , nodeIdentifiers = mempty 242 | } 243 | 244 | 245 | -- * group by line 246 | 247 | 248 | groupByLine :: ModuleAst -> Map Nat [ModuleAst] 249 | groupByLine moduleAst2 = 250 | List.foldl' go M.empty [moduleAst2] 251 | where 252 | go :: Map Nat [ModuleAst] -> ModuleAst -> Map Nat [ModuleAst] 253 | go acc moduleAst@ModuleAst{..} = 254 | case indexOneLineSpan _mast_span of 255 | Nothing -> List.foldl' go acc _mast_children 256 | Just index -> M.insertWith (flip (++)) index [moduleAst] acc 257 | 258 | indexOneLineSpan :: Span -> Maybe Nat 259 | indexOneLineSpan span@Span{..} = 260 | case isOneLine span of 261 | False -> Nothing 262 | True -> Just _span_lineStart 263 | -- * remove useless nodes 264 | 265 | -- | given a tree, if a node of this tree doesn't contain any informations and doesn't have any 266 | -- children, we get rid of it 267 | removeUselessNodes :: RawModule a b -> RawModule a b 268 | removeUselessNodes rawModule@RawModule{ _rawModule_hieAst = ast } = 269 | rawModule { _rawModule_hieAst = ast { Ghc.nodeChildren = foldr go [] $ Ghc.nodeChildren ast }} 270 | where 271 | go :: HieAST a -> [HieAST a] -> [HieAST a] 272 | go hieAst@Ghc.Node{..} acc = 273 | case (nodeChildren, hasSpecializedType $ nodeInfo & Ghc.nodeType) of 274 | ([], False) -> acc 275 | (_, False) -> foldr go [] nodeChildren ++ acc 276 | _ -> hieAst { Ghc.nodeChildren = foldr go [] nodeChildren } : acc 277 | 278 | hasSpecializedType :: [a] -> Bool 279 | hasSpecializedType = not . List.null 280 | --------------------------------------------------------------------------------