├── doc ├── file.png ├── modules.png └── dependency_decisions.yml ├── public ├── img │ ├── formula.png │ ├── metrix.png │ ├── spinner.gif │ ├── spinner.png │ ├── baresto-logo.png │ ├── auth-background.jpg │ └── toolbar-background.png ├── octicons │ ├── octicons.eot │ ├── octicons.ttf │ ├── octicons.woff │ └── octicons.css └── index.html ├── src ├── Api.js ├── Version.purs ├── Types.js ├── Api │ ├── Common.js │ ├── Schema │ │ ├── Common.purs │ │ ├── Auth.purs │ │ ├── Import.purs │ │ ├── BusinessData │ │ │ ├── Value.purs │ │ │ └── Key.purs │ │ ├── File.purs │ │ ├── Selector.purs │ │ ├── Module.purs │ │ ├── Table.purs │ │ ├── BusinessData.purs │ │ └── Validation.purs │ ├── Schema.purs │ └── Common.purs ├── Lib │ ├── BusinessData.js │ ├── Validation.js │ ├── Validation.purs │ ├── Queue.purs │ ├── Table.purs │ └── BusinessData.purs ├── Main.purs ├── Component │ ├── Handsontable │ │ ├── Utils.js │ │ ├── Utils.purs │ │ └── Options.js │ ├── Common.purs │ ├── FileViewer.js │ ├── Spinner.purs │ ├── ErrorBox.purs │ ├── Body.purs │ ├── Validation.purs │ ├── Handsontable.purs │ ├── Validation │ │ └── Finding.purs │ ├── ModuleBrowser.purs │ ├── App.purs │ ├── File.purs │ └── FileMenu.purs ├── Utils.js ├── Types.purs ├── Utils.purs └── Api.purs ├── latex ├── make.sh └── formula.tex ├── .gitignore ├── sass ├── partials │ ├── _widgets.scss │ ├── _spinner.scss │ ├── _scrollbar.scss │ ├── _splash.scss │ ├── _modal.scss │ ├── _handsontable.scss │ ├── _sheetselector.scss │ ├── _statusbar.scss │ ├── _frameworks.scss │ ├── _content.scss │ ├── _module.scss │ ├── _files.scss │ ├── _controls.scss │ ├── _filemenu.scss │ ├── _validation.scss │ └── _toolbar.scss ├── modules │ ├── _colors.scss │ └── _dimensions.scss └── main.scss ├── lobster.sublime-project ├── set-version.sh ├── bower.json ├── package.json ├── README.md └── gulpfile.js /doc/file.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/metrix-frs/baresto/HEAD/doc/file.png -------------------------------------------------------------------------------- /doc/modules.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/metrix-frs/baresto/HEAD/doc/modules.png -------------------------------------------------------------------------------- /public/img/formula.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/metrix-frs/baresto/HEAD/public/img/formula.png -------------------------------------------------------------------------------- /public/img/metrix.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/metrix-frs/baresto/HEAD/public/img/metrix.png -------------------------------------------------------------------------------- /public/img/spinner.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/metrix-frs/baresto/HEAD/public/img/spinner.gif -------------------------------------------------------------------------------- /public/img/spinner.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/metrix-frs/baresto/HEAD/public/img/spinner.png -------------------------------------------------------------------------------- /src/Api.js: -------------------------------------------------------------------------------- 1 | "use strict" 2 | 3 | // module Api 4 | 5 | exports.apiUrl = process.env.API_URL; 6 | -------------------------------------------------------------------------------- /src/Version.purs: -------------------------------------------------------------------------------- 1 | module Version where 2 | 3 | versionStr :: String 4 | versionStr = "v1.2.0" 5 | -------------------------------------------------------------------------------- /public/img/baresto-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/metrix-frs/baresto/HEAD/public/img/baresto-logo.png -------------------------------------------------------------------------------- /public/octicons/octicons.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/metrix-frs/baresto/HEAD/public/octicons/octicons.eot -------------------------------------------------------------------------------- /public/octicons/octicons.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/metrix-frs/baresto/HEAD/public/octicons/octicons.ttf -------------------------------------------------------------------------------- /public/octicons/octicons.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/metrix-frs/baresto/HEAD/public/octicons/octicons.woff -------------------------------------------------------------------------------- /public/img/auth-background.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/metrix-frs/baresto/HEAD/public/img/auth-background.jpg -------------------------------------------------------------------------------- /public/img/toolbar-background.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/metrix-frs/baresto/HEAD/public/img/toolbar-background.png -------------------------------------------------------------------------------- /latex/make.sh: -------------------------------------------------------------------------------- 1 | pdflatex formula.tex 2 | gs -sDEVICE=pngalpha -o formula.png -r170 formula.pdf 3 | rm formula.log formula.aux formula.pdf 4 | mv formula.png ../public/img/ 5 | -------------------------------------------------------------------------------- /src/Types.js: -------------------------------------------------------------------------------- 1 | // module Types 2 | 3 | "use strict"; 4 | 5 | exports.showDate = function (date) { 6 | return date.toLocaleString(); 7 | } 8 | 9 | exports.showDayImpl = function (date) { 10 | return date.toLocaleDateString(); 11 | } 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /node_modules/ 2 | /bower_components/ 3 | /tmp/ 4 | /dist/ 5 | /output/ 6 | /coverage/ 7 | public/js/*.js 8 | public/css/*.css 9 | public-prod/ 10 | .pulp-cache/ 11 | .psci_modules 12 | .psci 13 | *.tix 14 | *.aux 15 | *.log 16 | latex/*.png 17 | latex/*.pdf 18 | *.sublime-workspace 19 | -------------------------------------------------------------------------------- /sass/partials/_widgets.scss: -------------------------------------------------------------------------------- 1 | .frame { 2 | position: absolute; 3 | left: $panel-padding; 4 | top: $panel-padding; 5 | right: $panel-padding; 6 | bottom: $panel-padding; 7 | overflow-y: auto; 8 | overflow-x: hidden; 9 | border-radius: 3px; 10 | background-color: white; 11 | } 12 | -------------------------------------------------------------------------------- /src/Api/Common.js: -------------------------------------------------------------------------------- 1 | "use strict"; 2 | 3 | // module Api.Common 4 | 5 | exports.filesToFormData = function(files) { 6 | var formData = new FormData(); 7 | for (var i = 0; i < files.length; i++) { 8 | formData.append("file", files[i], files[i].name); 9 | } 10 | return formData; 11 | }; 12 | -------------------------------------------------------------------------------- /src/Lib/BusinessData.js: -------------------------------------------------------------------------------- 1 | "use strict"; 2 | 3 | // module Lib.BusinessData 4 | 5 | exports.stripDecimals = function(val) { 6 | return function(places) { 7 | var num = parseFloat(val); 8 | if (isNaN(num)) { 9 | return val; 10 | } else { 11 | return num.toFixed(places).toString(); 12 | } 13 | }; 14 | }; 15 | -------------------------------------------------------------------------------- /lobster.sublime-project: -------------------------------------------------------------------------------- 1 | { 2 | "folders": 3 | [ 4 | { 5 | "path": ".", 6 | "folder_exclude_patterns": [ 7 | "bower_components", 8 | "node_modules", 9 | "dist", 10 | "output" 11 | ], 12 | "file_exclude_patterns": [ 13 | ] 14 | } 15 | ], 16 | "settings": 17 | { 18 | "tab_size": 2 19 | } 20 | } 21 | -------------------------------------------------------------------------------- /sass/partials/_spinner.scss: -------------------------------------------------------------------------------- 1 | @mixin spinner() { 2 | background-size: contain; 3 | width: 30px; 4 | background-position: left; 5 | height: 30px; 6 | } 7 | 8 | .spinner-on { 9 | display: block; 10 | @include spinner(); 11 | background-image: url("../img/spinner.gif"); 12 | } 13 | 14 | .spinner-off { 15 | @include spinner(); 16 | background-image: url("../img/spinner.png"); 17 | } 18 | -------------------------------------------------------------------------------- /public/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Metrix Baresto 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /src/Main.purs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Component.App as App 4 | import Control.Monad.Aff (later') 5 | import Control.Monad.Eff (Eff) 6 | import Data.Functor.Coproduct (left) 7 | import Halogen (action, parentState, runUI) 8 | import Halogen.Util (awaitBody, runHalogenAff) 9 | import Prelude 10 | import Types (Effects) 11 | 12 | main :: Eff Effects Unit 13 | main = runHalogenAff do 14 | body <- awaitBody 15 | driver <- runUI App.app (parentState App.initialState) body 16 | later' 100 $ driver $ left $ action App.Boot 17 | -------------------------------------------------------------------------------- /latex/formula.tex: -------------------------------------------------------------------------------- 1 | \documentclass[9pt]{article} 2 | 3 | \usepackage{tikz,extsizes,nicefrac,amsmath,pifont} 4 | \usetikzlibrary{arrows,snakes,backgrounds,patterns,matrix,shapes,fit,calc,shadows,plotmarks} 5 | 6 | \usepackage[graphics,tightpage,active]{preview} 7 | \PreviewEnvironment{tikzpicture} 8 | \newlength{\imagewidth} 9 | \newlength{\imagescale} 10 | 11 | \begin{document} 12 | 13 | \begin{tikzpicture} 14 | \node[inner sep=0] { 15 | $\displaystyle\left(\ \int \ge \le = + - \ \right) \in$ 16 | }; 17 | \end{tikzpicture} 18 | 19 | \end{document} 20 | -------------------------------------------------------------------------------- /set-version.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | trap 'exit' ERR 5 | 6 | if [ -z "$1" ]; then 7 | echo "No version supplied" 8 | exit 1 9 | fi 10 | 11 | version="$1" 12 | 13 | sed -ri "s/\"version\": \"[^\s]*\"/\"version\": \"$version\"/" package.json 14 | sed -ri "s/\"version\": \"[^\s]*\"/\"version\": \"$version\"/" bower.json 15 | sed -ri "s/^versionStr = \"v[^\s]*\"/versionStr = \"v$version\"/" src/Version.purs 16 | 17 | git add package.json bower.json src/Version.purs 18 | git commit -m "version $version" 19 | git push 20 | git tag "v$version" 21 | git push origin "v$version" 22 | -------------------------------------------------------------------------------- /src/Lib/Validation.js: -------------------------------------------------------------------------------- 1 | // module Lib.Validation 2 | 3 | "use strict"; 4 | 5 | exports.fastPatch = function (patch) { 6 | return function (current) { 7 | var m = {}; 8 | for (var k in current) { 9 | if (current.hasOwnProperty(k)) { 10 | if (current[k].length > 0) { 11 | m[k] = current[k]; 12 | } 13 | } 14 | } 15 | for (var k in patch) { 16 | if (patch.hasOwnProperty(k)) { 17 | if (patch[k].length > 0) { 18 | m[k] = patch[k]; 19 | } else { 20 | delete m[k]; 21 | } 22 | } 23 | } 24 | return m; 25 | }; 26 | }; 27 | -------------------------------------------------------------------------------- /sass/modules/_colors.scss: -------------------------------------------------------------------------------- 1 | $metrix-lightblue: #EDF2F5; 2 | $metrix-darkblue: #8FADBB; 3 | $metrix-blue: #CAD9E0; 4 | 5 | $metrix-darkgray: #404042; 6 | $panel-gray: #F2F2F2; 7 | 8 | $font-color: #000000; 9 | $font-color-light: #FFFFFF; 10 | 11 | $shaded: #DDDDDD; 12 | $noCell: #000000; 13 | $cellError: #A05030; 14 | $ordinates: #EEEEEE; 15 | $ordinates-selected: #D3D6DD; 16 | $abstractRows: #DDDDDD; 17 | $warn: #DD6600; 18 | 19 | $severityBlocking: #D05030; 20 | $severityNonBlocking: #D0A090; 21 | $severityWarning: #D0A000; 22 | $severityBlockingIFRS: #D05060; 23 | -------------------------------------------------------------------------------- /sass/partials/_scrollbar.scss: -------------------------------------------------------------------------------- 1 | ::-webkit-scrollbar-track { 2 | background-color: rgba(0, 0, 0, 0.02); 3 | } 4 | 5 | ::-webkit-scrollbar { 6 | width: 14px; 7 | height: 14px; 8 | } 9 | ::-webkit-scrollbar-thumb { 10 | height: 6px; 11 | border: 4px solid rgba(0, 0, 0, 0); 12 | background-clip: padding-box; 13 | -webkit-border-radius: 7px; 14 | background-color: rgba(0, 0, 0, 0.15); 15 | -webkit-box-shadow: inset -1px -1px 0px rgba(0, 0, 0, 0.05), inset 1px 1px 0px rgba(0, 0, 0, 0.05); 16 | } 17 | ::-webkit-scrollbar-button { 18 | width: 0; 19 | height: 0; 20 | display: none; 21 | } 22 | ::-webkit-scrollbar-corner { 23 | background-color: transparent; 24 | } 25 | -------------------------------------------------------------------------------- /src/Component/Handsontable/Utils.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | 3 | // module Component.Handsontable.Utils 4 | 5 | exports.attachClickHandler = function (hot) { 6 | return function (selector) { 7 | return function (callback) { 8 | var attach = function (callback) { 9 | var nodeList = document.querySelectorAll(selector) 10 | if (nodeList[1]) { 11 | nodeList[1].addEventListener('click', callback) 12 | } 13 | } 14 | return function () { 15 | hot.addHook('afterRender', function (forced) { 16 | setTimeout(function () { 17 | attach(callback) 18 | }, 200) 19 | }) 20 | } 21 | } 22 | } 23 | } 24 | 25 | exports.forceString = function (val) { 26 | return val.toString() 27 | } 28 | -------------------------------------------------------------------------------- /sass/modules/_dimensions.scss: -------------------------------------------------------------------------------- 1 | $statusbar-height: 50px; 2 | 3 | $toolbar-height: 50px; 4 | $toolsep-width: 2px; 5 | $toolwidth-close: 50px; 6 | $toolwidth-menu: 50px; 7 | $toolwidth-mb: 300px; 8 | $toolwidth-sheets: 700px; 9 | $toolwidth-choose-file: 250px; 10 | $toolwidth-import-xbrl: 40px; 11 | $toolwidth-import-baresto: 75px; 12 | $toolwidth-name-file: 250px; 13 | $toolwidth-create: 50px; 14 | $toolwidth-conf: 70px; 15 | 16 | $filelist-width: 45%; 17 | $panel-padding: 8px; 18 | 19 | $modulebrowser-width: 2 * $toolsep-width 20 | + $toolwidth-close 21 | + $toolwidth-menu 22 | + $toolwidth-mb; 23 | 24 | $validation-height: 400px; 25 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "baresto", 3 | "version": "1.2.0", 4 | "authors": [ 5 | "Moritz Drexl ", 6 | "Ruben Moor " 7 | ], 8 | "ignore": [ 9 | "**/.*", 10 | "node_modules", 11 | "bower_components", 12 | "test", 13 | "tests" 14 | ], 15 | "repository": { 16 | "type": "git", 17 | "url": "git://github.com/metrix-frs/baresto.git" 18 | }, 19 | "dependencies": { 20 | "purescript-halogen": "^0.12.0", 21 | "purescript-affjax": "^3.0.2", 22 | "purescript-profunctor-lenses": "^2.4.0", 23 | "purescript-argonaut-core": "^2.0.1", 24 | "purescript-argonaut-codecs": "^2.0.0", 25 | "purescript-string-parsers": "^2.0.0", 26 | "purescript-random": "^2.0.0", 27 | "purescript-globals": "^2.0.0", 28 | "purescript-handsontable": "^2.0.0" 29 | } 30 | } 31 | -------------------------------------------------------------------------------- /src/Api/Schema/Common.purs: -------------------------------------------------------------------------------- 1 | module Api.Schema.Common where 2 | 3 | import Data.Argonaut.Encode (class EncodeJson, encodeJson) 4 | import Data.Foreign (ForeignError(JSONError), fail) 5 | import Data.Foreign.Class (class IsForeign, read) 6 | import Data.Tuple (Tuple(Tuple)) 7 | import Prelude 8 | 9 | newtype Pair a b = Pair (Tuple a b) 10 | 11 | getPair :: forall a b. Pair a b -> Tuple a b 12 | getPair (Pair t) = t 13 | 14 | instance isForeignPair :: (IsForeign a, IsForeign b) => IsForeign (Pair a b) where 15 | read json = do 16 | list <- read json 17 | case list of 18 | [a, b] -> Pair <$> (Tuple <$> read a <*> read b) 19 | _ -> fail $ JSONError "expected list of two elements" 20 | 21 | instance encodeJsonPair :: (EncodeJson a, EncodeJson b) => EncodeJson (Pair a b) where 22 | encodeJson (Pair (Tuple a b)) = encodeJson 23 | [ encodeJson a 24 | , encodeJson b 25 | ] 26 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "baresto", 3 | "version": "1.2.0", 4 | "authors": [ 5 | "Moritz Drexl ", 6 | "Ruben Moor " 7 | ], 8 | "license": "UNLICENSED", 9 | "repository": { 10 | "type": "git", 11 | "url": "git://github.com/metrix-frs/baresto.git" 12 | }, 13 | "dependencies": { 14 | "virtual-dom": "2.1.1", 15 | "handsontable": "^0.30.1", 16 | "moment": "^2.17.1", 17 | "pikaday": "^1.5.1", 18 | "zeroclipboard": "^2.3.0", 19 | "numbro": "^1.9.3" 20 | }, 21 | "devDependencies": { 22 | "browser-sync": "^2.11.2", 23 | "browserify": "^13.0.0", 24 | "clipboard": "^1.5.10", 25 | "envify": "^3.4.0", 26 | "gulp": "^3.9.1", 27 | "gulp-clean-css": "^2.0.4", 28 | "gulp-purescript": "^1.0.0", 29 | "gulp-sass": "^2.3.1", 30 | "gulp-uglify": "^1.5.3", 31 | "purescript": "^0.10.5", 32 | "vinyl-source-stream": "^1.1.0" 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /sass/partials/_splash.scss: -------------------------------------------------------------------------------- 1 | .splash-background { 2 | position: absolute; 3 | left: 0px; 4 | top: $statusbar-height; 5 | right: 0px; 6 | bottom: 0px; 7 | background-image: url("../img/auth-background.jpg"); 8 | background-position: right bottom; 9 | background-size: cover; 10 | } 11 | 12 | .splash-auth { 13 | position: absolute; 14 | left: 20%; 15 | top: 20%; 16 | width: 257px; 17 | } 18 | 19 | .splash-auth-logo { 20 | position: absolute; 21 | left: 0px; 22 | top: 0px; 23 | right: 0px; 24 | height: 110px; 25 | background-image: url("../img/baresto-logo.png"); 26 | } 27 | 28 | .splash-auth-box { 29 | position: absolute; 30 | left: 10px; 31 | right: 10px; 32 | top: 120px; 33 | background-color: white; 34 | padding: 10px; 35 | box-shadow: 1px 1px 8px 0px rgba(0.7, 0.7, 0.7, 0.3); 36 | 37 | p { 38 | margin: 0px; 39 | } 40 | 41 | input, button { 42 | width: 100%; 43 | box-sizing: border-box; 44 | margin: 10px 0px 0px 0px; 45 | } 46 | } 47 | -------------------------------------------------------------------------------- /sass/main.scss: -------------------------------------------------------------------------------- 1 | @import "modules/colors"; 2 | @import "modules/dimensions"; 3 | 4 | $font: Calibri, Candara, Segoe, 'Segoe UI', Optima, Arial, sans-serif; 5 | 6 | body { 7 | font-family: $font; 8 | font-size: 14px; 9 | font-style: normal; 10 | font-variant: normal; 11 | font-weight: 400; 12 | line-height: 23px; 13 | margin: 0px; 14 | color: $metrix-darkgray; 15 | cursor: default; 16 | } 17 | 18 | .app { 19 | width: 100%; 20 | height: 100%; 21 | } 22 | 23 | @import "partials/controls"; 24 | @import "partials/handsontable"; 25 | @import "partials/modal"; 26 | @import "partials/scrollbar"; 27 | @import "partials/spinner"; 28 | @import "partials/statusbar"; 29 | @import "partials/toolbar"; 30 | @import "partials/module"; 31 | @import "partials/widgets"; 32 | @import "partials/content"; 33 | @import "partials/frameworks"; 34 | @import "partials/files"; 35 | @import "partials/validation"; 36 | @import "partials/filemenu"; 37 | @import "partials/sheetselector"; 38 | @import "partials/splash"; 39 | -------------------------------------------------------------------------------- /src/Component/Common.purs: -------------------------------------------------------------------------------- 1 | module Component.Common where 2 | 3 | import Halogen.HTML.Events.Indexed as E 4 | import Halogen.HTML.Indexed as H 5 | import Halogen (HTML, Action) 6 | import Prelude 7 | import Utils (cls) 8 | 9 | modal :: forall p f. String -> Array (HTML p f) 10 | -> Array (HTML p f) -> HTML p f 11 | modal title body controls = 12 | H.div [ cls "modal-container" ] 13 | [ H.div [ cls "modal" ] $ 14 | [ H.h1_ [ H.text title ] 15 | , H.div [ cls "modal-body" ] body 16 | , H.div [ cls "modal-controls" ] controls 17 | ] 18 | ] 19 | 20 | toolButton :: forall p f. String -> String -> String -> Boolean -> Action f -> HTML p f 21 | toolButton name icon dimClass enabled action = 22 | H.div ( 23 | [ cls $ "toolbutton tooldim-" <> dimClass <> (if enabled then "" else " disabled") 24 | ] <> if enabled then [ E.onClick $ E.input_ action ] else [] 25 | ) 26 | [ H.span 27 | [ cls $ "icon " <> icon 28 | ] [] 29 | , H.div 30 | [ cls "label" ] 31 | [ H.text name ] 32 | ] 33 | -------------------------------------------------------------------------------- /src/Component/Handsontable/Utils.purs: -------------------------------------------------------------------------------- 1 | module Component.Handsontable.Utils 2 | ( toHotCoords 3 | , fromHotCoords 4 | , attachClickHandler 5 | , forceString 6 | ) where 7 | 8 | import Prelude 9 | import Handsontable.Types (Handsontable) 10 | import Control.Monad.Eff (Eff) 11 | import Data.Array (length) 12 | 13 | import Api.Schema.Table (Table(Table), YAxis(YAxisClosed, YAxisCustom)) 14 | 15 | toHotCoords :: Table -> Int -> Int -> {col :: Int, row :: Int} 16 | toHotCoords table c r = { col: c + 2, row: r + (headerHeight table) } 17 | 18 | fromHotCoords :: Table -> Int -> Int -> {col :: Int, row :: Int} 19 | fromHotCoords table c r = { col: c - 2, row: r - (headerHeight table) } 20 | 21 | headerHeight :: Table -> Int 22 | headerHeight (Table tbl) = length tbl.tableXHeader + case tbl.tableYAxis of 23 | YAxisCustom _ _ -> 2 24 | YAxisClosed _ _ -> 1 25 | 26 | foreign import attachClickHandler :: forall eff a. Handsontable String -> String -> Eff eff a -> Eff eff a 27 | 28 | foreign import forceString :: String -> String 29 | -------------------------------------------------------------------------------- /src/Api/Schema/Auth.purs: -------------------------------------------------------------------------------- 1 | module Api.Schema.Auth where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (Maybe) 6 | import Data.Foreign.Class (class IsForeign, readProp) 7 | import Data.Foreign.NullOrUndefined (unNullOrUndefined) 8 | 9 | import Types (UTCTime) 10 | 11 | newtype AuthInfo = AuthInfo 12 | { authUserName :: String 13 | , authContractBegin :: UTCTime 14 | , authContractEnd :: UTCTime 15 | , authContractIsTrial :: Boolean 16 | , authContractInvalidMsg :: Maybe String 17 | } 18 | 19 | instance isForeignAuthInfo :: IsForeign AuthInfo where 20 | read json = do 21 | status <- { authUserName: _ 22 | , authContractBegin: _ 23 | , authContractEnd: _ 24 | , authContractIsTrial: _ 25 | , authContractInvalidMsg: _ 26 | } 27 | <$> readProp "userName" json 28 | <*> readProp "contractBegin" json 29 | <*> readProp "contractEnd" json 30 | <*> readProp "isTrial" json 31 | <*> (unNullOrUndefined <$> readProp "invalidMsg" json) 32 | pure $ AuthInfo status 33 | -------------------------------------------------------------------------------- /doc/dependency_decisions.yml: -------------------------------------------------------------------------------- 1 | --- 2 | - - :whitelist 3 | - MIT 4 | - :who: 5 | :why: 6 | :versions: [] 7 | :when: 2016-04-11 09:16:50.105405128 Z 8 | - - :whitelist 9 | - ISC 10 | - :who: 11 | :why: 12 | :versions: [] 13 | :when: 2016-04-11 09:16:56.361964120 Z 14 | - - :whitelist 15 | - Apache 2.0 16 | - :who: 17 | :why: 18 | :versions: [] 19 | :when: 2016-04-11 09:22:12.897803134 Z 20 | - - :whitelist 21 | - New BSD 22 | - :who: 23 | :why: 24 | :versions: [] 25 | :when: 2016-04-11 09:23:16.208750785 Z 26 | - - :whitelist 27 | - BSD 28 | - :who: 29 | :why: 30 | :versions: [] 31 | :when: 2016-04-11 09:23:42.351817738 Z 32 | - - :whitelist 33 | - Public Domain 34 | - :who: 35 | :why: 36 | :versions: [] 37 | :when: 2016-04-11 09:23:56.021252075 Z 38 | - - :whitelist 39 | - MIT/X11 40 | - :who: 41 | :why: Synonym for MIT 42 | :versions: [] 43 | :when: 2016-04-11 09:24:54.498533877 Z 44 | - - :whitelist 45 | - Simplified BSD 46 | - :who: 47 | :why: 48 | :versions: [] 49 | :when: 2016-04-11 09:25:32.559741579 Z 50 | -------------------------------------------------------------------------------- /src/Lib/Validation.purs: -------------------------------------------------------------------------------- 1 | module Lib.Validation where 2 | 3 | import Prelude 4 | import Data.StrMap as SM 5 | import Api.Schema.Validation (Finding, ValidationResult(ValidationResult)) 6 | import Data.Array (fromFoldable) 7 | import Data.Maybe (Maybe(Nothing, Just)) 8 | 9 | foreign import fastPatch :: forall a 10 | . SM.StrMap (Array a) 11 | -> SM.StrMap (Array a) 12 | -> SM.StrMap (Array a) 13 | 14 | patchValidationResult :: ValidationResult -> ValidationResult -> ValidationResult 15 | patchValidationResult (ValidationResult patch) (ValidationResult current) = 16 | ValidationResult 17 | { vrDpmFindings: fastPatch patch.vrDpmFindings current.vrDpmFindings 18 | , vrHeaderFindings: case patch.vrHeaderFindings of 19 | Nothing -> current.vrHeaderFindings 20 | Just h -> Just h 21 | } 22 | 23 | flattenValidationResult :: ValidationResult -> Array Finding 24 | flattenValidationResult (ValidationResult vr) = 25 | header <> join (fromFoldable vr.vrDpmFindings) 26 | where 27 | header = case vr.vrHeaderFindings of 28 | Just f -> f 29 | Nothing -> [] 30 | -------------------------------------------------------------------------------- /sass/partials/_modal.scss: -------------------------------------------------------------------------------- 1 | .modal-container { 2 | z-index: 20000; 3 | position: fixed; 4 | top: 0px; 5 | left: 0px; 6 | bottom: 0px; 7 | right: 0px; 8 | text-align: center; 9 | background-color: rgba(0, 0, 0, 0.5); 10 | &:before { 11 | content: ''; 12 | display: inline-block; 13 | height: 100%; 14 | vertical-align: middle; 15 | margin-right: -2px; 16 | } 17 | .modal { 18 | color: $metrix-darkgray; 19 | z-index: 25000; 20 | display: inline-block; 21 | text-align: left; 22 | vertical-align: middle; 23 | width: 600px; 24 | background-color: white; 25 | box-shadow: 0px 0px 15px 0px rgba(0,0,0,0.3); 26 | h1 { 27 | margin: 0px; 28 | font-size: 25px; 29 | font-weight: bold; 30 | background-color: $metrix-blue; 31 | padding: 10px; 32 | } 33 | h2 { 34 | margin: 0px; 35 | font-size: 20px; 36 | padding: 10px; 37 | } 38 | p { 39 | margin: 0px 0px 10px 0px; 40 | } 41 | .modal-body { 42 | padding: 10px; 43 | max-height: 600px; 44 | overflow-y: auto; 45 | } 46 | .modal-controls { 47 | text-align: right; 48 | margin: 0px 10px 10px 10px; 49 | } 50 | } 51 | } 52 | -------------------------------------------------------------------------------- /sass/partials/_handsontable.scss: -------------------------------------------------------------------------------- 1 | .hotContainer { 2 | overflow: auto; 3 | position: absolute !important; 4 | top: 0px; 5 | left: 0px; 6 | right: 0px; 7 | bottom: 0px; 8 | } 9 | 10 | .currentRow.yOrdinate, .currentRow.yOrdinateCode, .currentRow.yAbstract, .currentRow.yAbstractCode { 11 | background-color: $ordinates-selected !important; 12 | } 13 | .currentCol.xOrdinateCode { 14 | background-color: $ordinates-selected !important; 15 | } 16 | 17 | .customYMember { 18 | font-family: monospace; 19 | font-size: 11px; 20 | color: #999; 21 | cursor: pointer; 22 | &:hover { 23 | color: #777; 24 | } 25 | } 26 | 27 | div.sheet { 28 | 29 | td.shaded { 30 | background-color: $shaded; 31 | } 32 | 33 | td.noCell { 34 | background-color: $noCell; 35 | } 36 | 37 | td.cellError { 38 | background-color: $cellError; 39 | } 40 | 41 | td.xOrdinate, td.yOrdinate, td.xOrdinateCode, td.yOrdinateCode, td.xNoOrdinate { 42 | background-color: $ordinates; 43 | } 44 | 45 | td.yOrdinateCode { 46 | text-align: right; 47 | } 48 | 49 | td.yAbstract { 50 | background-color: $abstractRows; 51 | font-weight: bold; 52 | } 53 | 54 | td.yAbstractCode { 55 | background-color: $abstractRows; 56 | text-align: right; 57 | } 58 | 59 | } 60 | -------------------------------------------------------------------------------- /sass/partials/_sheetselector.scss: -------------------------------------------------------------------------------- 1 | .sheet-configurator { 2 | position: absolute; 3 | top: $toolbar-height; 4 | right: 0px; 5 | width: $toolwidth-sheets; 6 | max-height: 600px; 7 | overflow-y: scroll; 8 | box-shadow: 0px 0px 10px 0px rgba(0, 0, 0, 0.3); 9 | z-index: 10000; 10 | background-color: white; 11 | padding: 3px; 12 | box-sizing: border-box; 13 | table { 14 | border-collapse: collapse; 15 | width: $toolwidth-sheets - 20px; 16 | td.small { 17 | width: 20px; 18 | } 19 | td { 20 | .subsetMemberId { 21 | font-size: 11px; 22 | font-family: monospace; 23 | color: #999; 24 | padding-right: 8px; 25 | } 26 | .customMemberId { 27 | font-family: monospace; 28 | position: absolute; 29 | right: 5px; 30 | top: 4px; 31 | font-size: 11px; 32 | color: #999; 33 | } 34 | position: relative; 35 | border-bottom: 1px solid $panel-gray; 36 | } 37 | } 38 | button .octicon { 39 | margin-left: 2px; 40 | width: 16px; 41 | text-align: center; 42 | } 43 | input { 44 | width: 60%; 45 | box-sizing: border-box; 46 | } 47 | input[type="checkbox"] { 48 | margin: 0px; 49 | width: auto; 50 | height: auto; 51 | } 52 | } 53 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Baresto 2 | 3 | PureScript UI of the regulatory reporting software 4 | [Baresto](https://baresto.metrix-frs.de/). 5 | 6 | ![Module Browser](doc/modules.png) 7 | 8 | ![File Viewer](doc/file.png) 9 | 10 | ## First Setup 11 | 12 | ### Install Node.js 13 | 14 | Preferably via [NVM](https://github.com/creationix/nvm): 15 | 16 | $ curl -o- https://raw.githubusercontent.com/creationix/nvm/v0.31.0/install.sh | bash 17 | $ nvm install 4 18 | $ nvm alias default 4 19 | 20 | Check version: 21 | 22 | $ node -v 23 | > v4.4.3 24 | 25 | ### Install Bower and Gulp 26 | 27 | $ npm install -g bower 28 | $ npm install -g gulp 29 | 30 | ### Clone and Get Dependencies 31 | 32 | $ git clone git://github.com/metrix-frs/baresto.git 33 | $ cd baresto/ 34 | $ npm install 35 | $ bower update 36 | 37 | ## Build 38 | 39 | $ API_URL= gulp 40 | 41 | ## Watch 42 | 43 | Starts browserSync, reloads when the compiled JS has changed and automatically 44 | compiles and injects CSS. 45 | 46 | $ gulp watch 47 | 48 | ## Serve 49 | 50 | Install [core](https://gitlab.mdrexl.net/holger/core). 51 | 52 | Assuming you have cloned core next to where you have cloned lobster: 53 | 54 | $ cd core/ 55 | $ stack build 56 | $ stack exec server -- -s ../baresto/public 57 | -------------------------------------------------------------------------------- /src/Utils.js: -------------------------------------------------------------------------------- 1 | // module Utils 2 | 3 | 'use strict' 4 | 5 | /* global Event, CustomEvent */ 6 | 7 | var Clipboard = require('clipboard') 8 | 9 | exports.initClipboard = function (selector) { 10 | return function () { 11 | new Clipboard(selector) // eslint-disable-line 12 | } 13 | } 14 | 15 | exports.createEventImpl = function (type) { 16 | return new Event(type) 17 | } 18 | 19 | exports.createErrorEventImpl = function (type) { 20 | return function (msg) { 21 | return new CustomEvent(type, {'detail': msg}) 22 | } 23 | } 24 | 25 | exports.errorEventDetailImpl = function (e) { 26 | return e.detail 27 | } 28 | 29 | exports.getInputFileListImpl = function (id) { 30 | return function () { 31 | var inp = document.getElementById(id) 32 | if ('files' in inp) { 33 | if (inp.files.length > 0) { 34 | return inp.files 35 | } else { 36 | return null 37 | } 38 | } else { 39 | return null 40 | } 41 | } 42 | } 43 | 44 | exports.tryFormatNumber = function (decimals) { 45 | return function (str) { 46 | var number = parseFloat(str) 47 | if (isNaN(number)) { 48 | return str 49 | } else { 50 | return number.toLocaleString('en-US', { 51 | minimumFractionDigits: decimals, 52 | maximumFractionDigits: 20 53 | }) 54 | } 55 | } 56 | } 57 | -------------------------------------------------------------------------------- /sass/partials/_statusbar.scss: -------------------------------------------------------------------------------- 1 | .status { 2 | background-color: white; 3 | height: $statusbar-height; 4 | color: $metrix-darkgray; 5 | position: relative; 6 | .spinnerContainer { 7 | position: absolute; 8 | left: 5px; 9 | top: 15px; 10 | width: 30px; 11 | bottom: 5px; 12 | } 13 | .license { 14 | position: absolute; 15 | right: 155px; 16 | bottom: 5px; 17 | color: #999; 18 | .sep::after { 19 | color: $metrix-darkgray; 20 | content: "\2022"; 21 | padding-left: 10px; 22 | padding-right: 10px; 23 | } 24 | .warn { 25 | color: $warn; 26 | font-weight: bold; 27 | } 28 | } 29 | .menu { 30 | position: absolute; 31 | right: 5px; 32 | bottom: 5px; 33 | button { 34 | margin: 0px 0px 0px 4px; 35 | } 36 | } 37 | .status-metrix { 38 | position: absolute; 39 | left: 35px; 40 | top: 15px; 41 | bottom: 5px; 42 | width: 75px; 43 | background-image: url("../img/metrix.png"); 44 | background-size: contain; 45 | background-position: left; 46 | } 47 | .status-baresto { 48 | position: absolute; 49 | left: 35px; 50 | top: 5px; 51 | bottom: 5px; 52 | width: 94px; 53 | background-image: url("../img/baresto-logo.png"); 54 | background-size: contain; 55 | background-position: left; 56 | } 57 | } 58 | -------------------------------------------------------------------------------- /sass/partials/_frameworks.scss: -------------------------------------------------------------------------------- 1 | ul.frameworks { 2 | list-style: none; 3 | margin: 0px; 4 | padding: 0px; 5 | 6 | $left: 4px; 7 | $label-margin: 5px; 8 | $indent: 16px + $label-margin; 9 | 10 | li { 11 | padding-top: 2px; 12 | padding-bottom: 1px; 13 | background-color: white; 14 | border-bottom: 1px solid $panel-gray; 15 | } 16 | 17 | li.all { 18 | padding-left: $left; 19 | font-weight: bold; 20 | } 21 | 22 | li.framework { 23 | padding-left: $left; 24 | font-weight: bold; 25 | } 26 | 27 | li.taxonomy { 28 | padding-left: $left + $indent; 29 | } 30 | 31 | li.conceptualModule { 32 | padding-left: $left + $indent; 33 | background-color: $metrix-lightblue; 34 | } 35 | 36 | li.conceptualModule.disabled { 37 | .label { 38 | cursor: default; 39 | color: #999; 40 | &:hover { 41 | color: #999; 42 | } 43 | } 44 | } 45 | 46 | li.module { 47 | padding-left: $left + 2 * $indent; 48 | } 49 | 50 | li.selected { 51 | background-color: $metrix-darkblue; 52 | } 53 | 54 | .octicon { 55 | width: 16px; 56 | text-align: center; 57 | @extend .label; 58 | } 59 | 60 | .label { 61 | cursor: pointer; 62 | color: $metrix-darkgray; 63 | margin-left: $label-margin; 64 | 65 | &:hover { 66 | color: black; 67 | } 68 | 69 | } 70 | 71 | } 72 | -------------------------------------------------------------------------------- /src/Component/Handsontable/Options.js: -------------------------------------------------------------------------------- 1 | 'use strict' 2 | 3 | // module Component.Handsontable.Options 4 | 5 | var Handsontable = require('handsontable') 6 | 7 | exports.renderSetClass = function (cls) { 8 | return function (instance, td, row, col, prop, value, cellProperties) { 9 | Handsontable.renderers.TextRenderer.apply(this, arguments) 10 | td.className = cls 11 | } 12 | } 13 | 14 | exports.renderer = function (name) { 15 | return name 16 | } 17 | 18 | exports.renderHtml = function (cls) { 19 | return function (instance, td, row, col, prop, value, cellProperties) { 20 | var html = Handsontable.helper.stringify(value) 21 | td.innerHTML = html 22 | td.className = cls 23 | return td 24 | } 25 | } 26 | 27 | exports.borderImpl = function (r1, c1, r2, c2, top, right, bot, left) { 28 | var obj = { 29 | range: { 30 | from: { 31 | row: r1, 32 | col: c1 33 | }, 34 | to: { 35 | row: r2, 36 | col: c2 37 | } 38 | } 39 | } 40 | if (top != null) { 41 | obj.top = top 42 | } 43 | if (right != null) { 44 | obj.right = right 45 | } 46 | if (bot != null) { 47 | obj.bottom = bot 48 | } 49 | if (left != null) { 50 | obj.left = left 51 | } 52 | return obj 53 | } 54 | 55 | exports.colPropEmpty = {} 56 | 57 | exports.colPropWidth = function (w) { 58 | return { 59 | width: w 60 | } 61 | } 62 | -------------------------------------------------------------------------------- /src/Api/Schema/Import.purs: -------------------------------------------------------------------------------- 1 | module Api.Schema.Import where 2 | 3 | import Prelude 4 | import Data.Foreign.Class (class IsForeign, readProp) 5 | import Api.Schema.BusinessData (UpdateGet) 6 | import Types (ModuleId, UpdateId) 7 | 8 | newtype Warning = Warning 9 | { message :: String 10 | , context :: String 11 | } 12 | 13 | instance isForeignWarning :: IsForeign Warning where 14 | read json = do 15 | msg <- readProp "message" json 16 | ctx <- readProp "context" json 17 | pure $ Warning { message: msg, context: ctx } 18 | 19 | newtype XbrlImportConf = XbrlImportConf 20 | { warnings :: Array Warning 21 | , updateId :: UpdateId 22 | , moduleId :: ModuleId 23 | } 24 | 25 | instance isForeignXbrlImportConf :: IsForeign XbrlImportConf where 26 | read json = do 27 | conf <- { warnings: _ 28 | , updateId: _ 29 | , moduleId: _ 30 | } 31 | <$> readProp "warnings" json 32 | <*> readProp "updateId" json 33 | <*> readProp "moduleId" json 34 | pure $ XbrlImportConf conf 35 | 36 | newtype CsvImportConf = CsvImportConf 37 | { warnings :: Array Warning 38 | , update :: UpdateGet 39 | } 40 | 41 | instance isForeignCsvImportConf :: IsForeign CsvImportConf where 42 | read json = do 43 | conf <- { warnings: _ 44 | , update: _ 45 | } 46 | <$> readProp "warnings" json 47 | <*> readProp "update" json 48 | pure $ CsvImportConf conf 49 | -------------------------------------------------------------------------------- /src/Lib/Queue.purs: -------------------------------------------------------------------------------- 1 | module Lib.Queue 2 | ( emptyQueue 3 | , push 4 | , pop 5 | , Queue() 6 | ) where 7 | 8 | import Prelude 9 | 10 | import Data.Tuple (Tuple(Tuple)) 11 | import Data.Array (snoc, uncons) 12 | import Data.Exists (Exists, runExists, mkExists) 13 | import Data.Maybe (Maybe(Just, Nothing)) 14 | 15 | data QueueF a q = QueueF 16 | { state :: q 17 | , pop :: q -> Maybe (Tuple q a) 18 | , push :: a -> q -> q 19 | } 20 | 21 | data Queue a = Queue (Exists (QueueF a)) 22 | 23 | emptyQueue :: forall a. Queue a 24 | emptyQueue = Queue $ mkExists $ QueueF 25 | { state: [] 26 | , pop: \q -> case uncons q of 27 | Just { head: x, tail: xs } -> Just $ Tuple xs x 28 | Nothing -> Nothing 29 | , push: flip snoc 30 | } 31 | 32 | push :: forall a. a -> Queue a -> Queue a 33 | push x (Queue q) = runExists go q 34 | where 35 | go :: forall q. QueueF a q -> Queue a 36 | go (QueueF q') = Queue $ mkExists $ QueueF $ q' { state = q'.push x q'.state } 37 | 38 | pop :: forall a. Queue a -> { state :: Queue a, value :: Maybe a } 39 | pop queue@(Queue q') = runExists go q' 40 | where 41 | go :: forall q. QueueF a q -> { state :: Queue a, value :: Maybe a } 42 | go (QueueF q) = case q.pop q.state of 43 | Nothing -> 44 | { state: queue 45 | , value: Nothing } 46 | Just (Tuple newQ el) -> 47 | { state: Queue $ mkExists $ QueueF $ q { state = newQ } 48 | , value: Just el } 49 | -------------------------------------------------------------------------------- /src/Component/FileViewer.js: -------------------------------------------------------------------------------- 1 | // module Component.FileViewer 2 | 3 | "use strict"; 4 | 5 | var Queue = function () { 6 | this.queue = []; 7 | this.callback = null; 8 | this.running = false; 9 | }; 10 | 11 | Queue.prototype.push = function (a) { 12 | this.queue.push(a); 13 | if (!this.running) { 14 | this.nextElem(); 15 | } 16 | }; 17 | 18 | Queue.prototype.nextElem = function () { 19 | this.running = false; 20 | if (this.callback) { 21 | var elem = this.queue.shift(); 22 | if (elem) { 23 | this.running = true; 24 | this.callback(elem)(); 25 | } 26 | } 27 | return this.running; 28 | }; 29 | 30 | Queue.prototype.register = function (cb) { 31 | this.callback = cb; 32 | }; 33 | 34 | Queue.prototype.unregister = function () { 35 | this.callback = null; 36 | }; 37 | 38 | exports.newQueue = function () { 39 | return new Queue(); 40 | }; 41 | 42 | exports.registerQueue = function (queue) { 43 | return function (cb) { 44 | return function () { 45 | return queue.register(cb); 46 | }; 47 | }; 48 | }; 49 | 50 | exports.unregisterQueue = function (queue) { 51 | return function () { 52 | return queue.unregister(); 53 | }; 54 | }; 55 | 56 | exports.pushQueue = function (queue) { 57 | return function (elem) { 58 | return function () { 59 | return queue.push(elem); 60 | }; 61 | }; 62 | }; 63 | 64 | exports.nextElemQueue = function (queue) { 65 | return function () { 66 | return queue.nextElem(); 67 | }; 68 | }; 69 | -------------------------------------------------------------------------------- /sass/partials/_content.scss: -------------------------------------------------------------------------------- 1 | .body { 2 | position: absolute; 3 | top: $statusbar-height; 4 | left: 0px; 5 | bottom: 0px; 6 | right: 0px; 7 | } 8 | 9 | .container { 10 | position: absolute; 11 | top: 0px; 12 | left: 0px; 13 | bottom: 0px; 14 | right: 0px; 15 | } 16 | 17 | .content { 18 | position: absolute; 19 | top: $toolbar-height; 20 | left: 0px; 21 | bottom: 0px; 22 | right: 0px; 23 | background-color: $panel-gray; 24 | } 25 | 26 | @mixin panel() { 27 | background-color: $panel-gray; 28 | &:after { 29 | content: ""; 30 | position: absolute; 31 | left: $panel-padding; 32 | top: $panel-padding; 33 | right: $panel-padding; 34 | bottom: $panel-padding; 35 | border-radius: 3px; 36 | box-shadow: inset 0px 0px 5px 0px #777; 37 | pointer-events: none; 38 | z-index: 300; 39 | } 40 | } 41 | 42 | .panel-frameworklist { 43 | @include panel(); 44 | position: absolute; 45 | left: 0px; 46 | top: 0px; 47 | bottom: 0px; 48 | right: $filelist-width; 49 | border-right: 1px solid rgba(0, 0, 0, 0.1); 50 | } 51 | 52 | .panel-filelist { 53 | @include panel(); 54 | position: absolute; 55 | width: $filelist-width; 56 | bottom: 0px; 57 | right: 0px; 58 | top: 0px; 59 | } 60 | 61 | .panel-table { 62 | @include panel(); 63 | position: absolute; 64 | top: 0px; 65 | left: 0px; 66 | right: 0px; 67 | bottom: 0px; 68 | } 69 | 70 | .bd-debug { 71 | position: absolute; 72 | top: 500px; 73 | left: 500px; 74 | right: 0px; 75 | bottom: 0px; 76 | z-index: 999; 77 | } 78 | -------------------------------------------------------------------------------- /src/Api/Schema.purs: -------------------------------------------------------------------------------- 1 | module Api.Schema where 2 | 3 | import Data.Argonaut.Core (jsonEmptyObject) 4 | import Data.Argonaut.Encode (class EncodeJson) 5 | import Data.Argonaut.Encode.Combinators ((:=), (~>)) 6 | import Data.Either (Either(Right, Left)) 7 | import Data.Foreign (ForeignError(JSONError), fail) 8 | import Data.Foreign.Class (class IsForeign, readProp) 9 | import Data.Foreign.NullOrUndefined (unNullOrUndefined) 10 | import Data.Maybe (Maybe(Just, Nothing)) 11 | import Data.Tuple (Tuple(Tuple)) 12 | import Prelude 13 | import Types (ErrorDetail) 14 | 15 | data ServerResponse a 16 | = ServerSuccess a 17 | | ServerError ErrorDetail 18 | 19 | instance isForeignServerResponse :: (IsForeign a) => IsForeign (ServerResponse a) where 20 | read json = do 21 | success <- readProp "success" json 22 | if success 23 | then ServerSuccess <$> readProp "object" json 24 | else do title <- readProp "title" json 25 | body <- readProp "message" json 26 | pure $ ServerError { title: title, body: body } 27 | 28 | newtype JsonEither a b = JsonEither (Either a b) 29 | 30 | runJsonEither :: forall a b. JsonEither a b -> Either a b 31 | runJsonEither (JsonEither x) = x 32 | 33 | instance isForeignJsonEither :: (IsForeign a, IsForeign b) => IsForeign (JsonEither a b) where 34 | read json = do 35 | l <- readProp "Left" json 36 | r <- readProp "Right" json 37 | case Tuple (unNullOrUndefined l) (unNullOrUndefined r) of 38 | Tuple (Just l') Nothing -> pure $ JsonEither $ Left l' 39 | Tuple Nothing (Just r') -> pure $ JsonEither $ Right r' 40 | _ -> fail $ JSONError "expected `Left` or `Right` property" 41 | 42 | newtype Name = Name String 43 | 44 | instance encodeJsonName :: EncodeJson Name where 45 | encodeJson (Name name) = "name" := name 46 | ~> jsonEmptyObject 47 | -------------------------------------------------------------------------------- /sass/partials/_module.scss: -------------------------------------------------------------------------------- 1 | .module-control { 2 | top: 0px; 3 | right: 0px; 4 | left: 0px; 5 | bottom: 0px; 6 | z-index: 1001; 7 | position: absolute; 8 | background-color: $metrix-blue; 9 | 10 | .left { 11 | left: 0px; 12 | } 13 | 14 | .right { 15 | right: 0px; 16 | } 17 | 18 | .nav-button { 19 | position: absolute; 20 | top: 0px; 21 | bottom: 0px; 22 | width: 32px; 23 | text-align: center; 24 | line-height: $toolbar-height; 25 | .mega-octicon { 26 | vertical-align: middle; 27 | } 28 | } 29 | 30 | .current { 31 | position: absolute; 32 | left: 32px; 33 | right: 32px; 34 | top: 0px; 35 | bottom: 0px; 36 | line-height: $toolbar-height; 37 | 38 | p { 39 | vertical-align: middle; 40 | text-align: center; 41 | font-size: 20pt; 42 | font-weight: bold; 43 | margin: 0px; 44 | } 45 | 46 | } 47 | 48 | } 49 | 50 | .modules { 51 | position: fixed; 52 | top: $statusbar-height + $toolbar-height; 53 | right: 0px; 54 | bottom: 0px; 55 | width: $modulebrowser-width; 56 | z-index: 1000; 57 | background-color: white; 58 | box-shadow: 0px 0px 20px 0px rgba(0, 0, 0, 0.3); 59 | overflow-y: auto; 60 | 61 | ul { 62 | list-style: none; 63 | margin: 0px; 64 | padding: 5px 0px 5px 0px; 65 | } 66 | 67 | li { 68 | padding-top: 2px; 69 | } 70 | 71 | li.group { 72 | padding-left: 7px; 73 | font-weight: bold; 74 | } 75 | 76 | li.template { 77 | padding-left: 25px; 78 | } 79 | 80 | li.table { 81 | padding-left: 43px; 82 | } 83 | 84 | li.selected { 85 | background-color: $metrix-darkblue; 86 | } 87 | 88 | .octicon { 89 | width: 16px; 90 | text-align: center; 91 | margin-right: 4px; 92 | } 93 | 94 | .label { 95 | cursor: pointer; 96 | color: $metrix-darkgray; 97 | 98 | &:hover { 99 | color: black; 100 | } 101 | 102 | } 103 | 104 | } 105 | -------------------------------------------------------------------------------- /src/Api/Schema/BusinessData/Value.purs: -------------------------------------------------------------------------------- 1 | module Api.Schema.BusinessData.Value where 2 | 3 | import Data.Argonaut.Encode.Combinators ((:=), (~>)) 4 | import Data.Argonaut.Core (jsonEmptyObject) 5 | import Data.Argonaut.Encode (class EncodeJson) 6 | import Data.Foreign (fail, ForeignError(JSONError)) 7 | import Data.Foreign.Class (class IsForeign, readProp) 8 | import Data.Foreign.NullOrUndefined (unNullOrUndefined) 9 | import Data.Maybe (Maybe) 10 | import Prelude 11 | 12 | type Precision = Maybe Int 13 | 14 | newtype Value = Value 15 | { valueData :: Maybe String 16 | , valuePrecision :: Precision 17 | } 18 | 19 | instance isForeignValue :: IsForeign Value where 20 | read json = do 21 | v <- { valueData: _ 22 | , valuePrecision: _ 23 | } 24 | <$> (unNullOrUndefined <$> readProp "data" json) 25 | <*> (unNullOrUndefined <$> readProp "precision" json) 26 | pure $ Value v 27 | 28 | instance encodeJsonValue :: EncodeJson Value where 29 | encodeJson (Value v) = "data" := v.valueData 30 | ~> "precision" := v.valuePrecision 31 | ~> jsonEmptyObject 32 | 33 | data UpdateValue 34 | = UpdateValueData (Maybe String) 35 | | UpdateValuePrecision Precision 36 | 37 | instance isForeignUpdateValue :: IsForeign UpdateValue where 38 | read json = do 39 | tag <- readProp "tag" json 40 | case tag of 41 | "data" -> UpdateValueData <$> (unNullOrUndefined <$> readProp "data" json) 42 | "precision" -> UpdateValuePrecision <$> (unNullOrUndefined <$> readProp "precision" json) 43 | _ -> fail $ JSONError "`tag` should be `data`, `precision` or `value`" 44 | 45 | instance encodeJsonUpdateValue :: EncodeJson UpdateValue where 46 | encodeJson (UpdateValueData str) = "tag" := "data" 47 | ~> "data" := str 48 | ~> jsonEmptyObject 49 | encodeJson (UpdateValuePrecision p) = "tag" := "precision" 50 | ~> "precision" := p 51 | ~> jsonEmptyObject 52 | 53 | updateValue :: UpdateValue -> Value -> Value 54 | updateValue upd (Value old) = case upd of 55 | UpdateValueData d -> Value $ old { valueData = d } 56 | UpdateValuePrecision p -> Value $ old { valuePrecision = p } 57 | -------------------------------------------------------------------------------- /sass/partials/_files.scss: -------------------------------------------------------------------------------- 1 | ul.files { 2 | list-style: none; 3 | margin: 0px; 4 | padding: 0px; 5 | 6 | $label-margin: 5px; 7 | $left: 4px; 8 | $indent: 16px + $label-margin; 9 | 10 | li { 11 | padding-top: 2px; 12 | padding-bottom: 1px; 13 | position: relative; 14 | 15 | &:hover { 16 | .actions { 17 | display: block; 18 | position: absolute; 19 | right: $label-margin; 20 | top: 2px; 21 | bottom: 0px; 22 | .octicon { 23 | margin: 2px; 24 | color: $metrix-darkblue; 25 | &:hover { 26 | color: lighten($metrix-darkblue, 5%); 27 | } 28 | } 29 | } 30 | } 31 | 32 | .actions { 33 | display: none; 34 | } 35 | 36 | } 37 | 38 | li.module { 39 | padding-left: $left; 40 | background-color: #DDD; 41 | border-bottom: 1px solid #BBB; 42 | } 43 | 44 | li.file { 45 | padding-left: $left; 46 | .hlabel { 47 | font-weight: bold; 48 | } 49 | } 50 | 51 | li.tag-title { 52 | border-top: 1px solid $panel-gray; 53 | padding-left: $left + $indent; 54 | .label { 55 | font-weight: bold; 56 | } 57 | } 58 | 59 | li.tag { 60 | border-top: 1px solid $panel-gray; 61 | padding-left: $left + 2 * $indent; 62 | } 63 | 64 | li.orphan-title { 65 | border-top: 1px solid $panel-gray; 66 | padding-left: $left + $indent; 67 | .label { 68 | font-weight: bold; 69 | } 70 | } 71 | 72 | li.orphan { 73 | border-top: 1px solid $panel-gray; 74 | padding-left: $left + 2 * $indent; 75 | } 76 | 77 | li.sep { 78 | height: 1px; 79 | background-color: #BBB; 80 | padding: 0px; 81 | } 82 | 83 | .octicon { 84 | width: 16px; 85 | text-align: center; 86 | } 87 | 88 | .label { 89 | margin-left: $label-margin; 90 | } 91 | 92 | .hlabel { 93 | @extend .label; 94 | cursor: pointer; 95 | color: $metrix-darkgray; 96 | 97 | &:hover { 98 | color: black; 99 | } 100 | } 101 | 102 | .details { 103 | color: #999; 104 | position: relative; 105 | padding-left: $indent + $label-margin; 106 | margin-right: $left + $label-margin; 107 | margin-top: 2px; 108 | 109 | .edited { 110 | 111 | } 112 | 113 | .created { 114 | position: absolute; 115 | top: 0px; 116 | right: 0px; 117 | } 118 | } 119 | 120 | } 121 | -------------------------------------------------------------------------------- /src/Lib/Table.purs: -------------------------------------------------------------------------------- 1 | module Lib.Table where 2 | 3 | import Prelude 4 | import Api.Schema.Table (Cell, Grid(Grid), Row(Row), Sheet(Sheet), Table(Table), YAxis(YAxisCustom, YAxisClosed), ZAxis(ZAxisSubset, ZAxisCustom, ZAxisClosed, ZAxisSingleton)) 5 | import Data.Array ((!!)) 6 | import Data.Foldable (class Foldable, find) 7 | import Data.Lens (Lens', lens) 8 | import Data.Maybe (Maybe) 9 | import Data.Tuple (snd, fst, Tuple(Tuple)) 10 | import Utils (makeIndexed) 11 | 12 | mapGrid :: forall a. (Int -> Int -> Int -> Cell -> a) -> Grid -> Array (Array (Array a)) 13 | mapGrid f (Grid sheets) = (\(Tuple s sheet) -> mapSheet (f s) sheet) <$> makeIndexed sheets 14 | 15 | mapSheet :: forall a. (Int -> Int -> Cell -> a) -> Sheet -> Array (Array a) 16 | mapSheet f (Sheet rows) = (\(Tuple r row) -> mapRow (f r) row) <$> makeIndexed rows 17 | 18 | mapRow :: forall a. (Int -> Cell -> a) -> Row -> Array a 19 | mapRow f (Row cells) = (\(Tuple c cell) -> f c cell) <$> makeIndexed cells 20 | 21 | boolValueMap :: Array (Tuple String String) 22 | boolValueMap = 23 | [ Tuple "true" "True" 24 | , Tuple "false" "False" 25 | ] 26 | 27 | lookupBySnd :: forall f a b. (Foldable f, Eq b) => b -> f (Tuple a b) -> Maybe a 28 | lookupBySnd v pairs = fst <$> find (\(Tuple a b) -> b == v) pairs 29 | 30 | lookupByFst :: forall f a b. (Foldable f, Eq a) => a -> f (Tuple a b) -> Maybe b 31 | lookupByFst v pairs = snd <$> find (\(Tuple a b) -> a == v) pairs 32 | 33 | data Coord = Coord C R S 34 | 35 | newtype R = R Int 36 | newtype C = C Int 37 | newtype S = S Int 38 | 39 | _col :: Lens' C Int 40 | _col = lens (\(C c) -> c) (\_ c -> C c) 41 | 42 | _row :: Lens' R Int 43 | _row = lens (\(R r) -> r) (\_ r -> R r) 44 | 45 | instance eqS :: Eq S where 46 | eq (S a) (S b) = a == b 47 | 48 | instance eqR :: Eq R where 49 | eq (R a) (R b) = a == b 50 | 51 | instance eqC :: Eq C where 52 | eq (C a) (C b) = a == b 53 | 54 | instance ordR :: Ord R where 55 | compare (R a) (R b) = compare a b 56 | 57 | instance ordC :: Ord C where 58 | compare (C a) (C b) = compare a b 59 | 60 | instance showS :: Show S where 61 | show (S s) = show s 62 | 63 | cellLookup :: Coord -> Table -> Maybe Cell 64 | cellLookup (Coord (C c) (R r) (S s)) (Table tbl) = do 65 | Grid sheets <- pure tbl.tableGrid 66 | Sheet rows <- case tbl.tableZAxis of 67 | ZAxisSingleton -> sheets !! s 68 | ZAxisClosed _ _ -> sheets !! s 69 | ZAxisCustom _ _ -> sheets !! 0 70 | ZAxisSubset _ _ _ -> sheets !! 0 71 | Row cells <- case tbl.tableYAxis of 72 | YAxisClosed _ _ -> rows !! r 73 | YAxisCustom _ _ -> rows !! 0 74 | cells !! c 75 | -------------------------------------------------------------------------------- /sass/partials/_controls.scss: -------------------------------------------------------------------------------- 1 | button { 2 | background-color: $metrix-darkblue; 3 | color: white; 4 | cursor: pointer; 5 | outline: none; 6 | border-radius: 2px; 7 | border: 1px solid rgba(0, 0, 0, 0.3); 8 | box-shadow: 0px 0px 2px 0px rgba(0, 0, 0, 0.3); 9 | text-decoration: none; 10 | height: 24px; 11 | padding: 1px 5px 1px 5px; 12 | margin: 0px 2px 0px 2px; 13 | &:hover { 14 | background-color: lighten($metrix-darkblue, 5%); 15 | } 16 | .octicon { 17 | vertical-align: middle; 18 | width: 16px; 19 | text-align: center; 20 | margin: 2px 3px 2px 0px; 21 | } 22 | .customY { 23 | margin: 0px; 24 | line-height: 16px; 25 | padding: 0px; 26 | .octicon { 27 | margin: 0px; 28 | } 29 | } 30 | } 31 | 32 | input { 33 | border-radius: 2px; 34 | border: 1px solid rgba(0, 0, 0, 0.8); 35 | padding: 0px 5px 0px 5px; 36 | line-height: 20px; 37 | box-shadow: inset 0px 0px 3px 0px rgba(0, 0, 0, 0.4); 38 | background-color: white; 39 | color: $metrix-darkgray; 40 | height: 22px; 41 | outline: none; 42 | padding-left: 3px; 43 | padding-right: 3px; 44 | } 45 | 46 | select { 47 | border: 1px solid rgba(0, 0, 0, 0.3); 48 | border-radius: 2px; 49 | box-shadow: 0px 0px 1px 0px rgba(0, 0, 0, 0.3); 50 | background-color: $panel-gray; 51 | outline: none; 52 | appearance: none; 53 | &:hover { 54 | background-color: lighten($panel-gray, 5%); 55 | } 56 | } 57 | 58 | a { 59 | color: darken($metrix-darkblue, 10%); 60 | &:hover { 61 | color: $metrix-darkblue; 62 | } 63 | } 64 | 65 | a.tooltip { 66 | text-decoration: none; 67 | position: relative; 68 | color: $metrix-darkgray; 69 | span { 70 | z-index: 10; 71 | display: none; 72 | position: absolute; 73 | bottom: 25px; 74 | left: -10px; 75 | width: 320px; 76 | padding: 3px 6px 3px 6px; 77 | box-shadow: 0px 0px 10px 0px rgba(0, 0, 0, 0.5); 78 | } 79 | &:hover { 80 | text-decoration: none; 81 | span { 82 | display: inline; 83 | position: absolute; 84 | color: white; 85 | border: none; 86 | border-radius: 5px; 87 | background-color: $metrix-darkgray; 88 | &:after { 89 | position: absolute; 90 | content: ""; 91 | width: 10px; 92 | height: 10px; 93 | background-color: $metrix-darkgray; 94 | bottom: -3px; 95 | left: 10px; 96 | -webkit-transform: rotate(45deg); 97 | } 98 | } 99 | } 100 | } 101 | 102 | p.msg { 103 | margin: 30px; 104 | } 105 | 106 | input[type="file"] { 107 | &::-webkit-file-upload-button { 108 | visibility: hidden; 109 | } 110 | } 111 | -------------------------------------------------------------------------------- /src/Api/Schema/File.purs: -------------------------------------------------------------------------------- 1 | module Api.Schema.File where 2 | 3 | import Data.Foreign.Class (class IsForeign, readProp) 4 | import Data.Lens (Lens', lens) 5 | import Prelude 6 | import Types (UpdateId, UTCTime, ModuleId, FileId, Label) 7 | 8 | newtype File = File 9 | { fileId :: FileId 10 | , fileModuleId :: ModuleId 11 | , fileLabel :: String 12 | , fileCreated :: UTCTime 13 | , fileChanged :: UTCTime 14 | , fileLastUpdateId :: UpdateId 15 | } 16 | 17 | _File :: Lens' File _ 18 | _File = lens (\(File r) -> r) (\_ r -> File r) 19 | 20 | _fileId :: Lens' File FileId 21 | _fileId = _File <<< lens _.fileId _{ fileId = _ } 22 | 23 | _fileModuleId :: Lens' File ModuleId 24 | _fileModuleId = _File <<< lens _.fileModuleId _{ fileModuleId = _ } 25 | 26 | _fileLabel :: Lens' File Label 27 | _fileLabel = _File <<< lens _.fileLabel _{ fileLabel = _ } 28 | 29 | _fileCreated :: Lens' File UTCTime 30 | _fileCreated = _File <<< lens _.fileCreated _{ fileCreated = _ } 31 | 32 | _fileChanged :: Lens' File UTCTime 33 | _fileChanged = _File <<< lens _.fileChanged _{ fileChanged = _ } 34 | 35 | _fileLastUpdateId :: Lens' File UpdateId 36 | _fileLastUpdateId = _File <<< lens _.fileLastUpdateId _{ fileLastUpdateId = _ } 37 | 38 | instance isForeignFile :: IsForeign File where 39 | read json = do 40 | file <- { fileId: _ 41 | , fileModuleId: _ 42 | , fileLabel: _ 43 | , fileCreated: _ 44 | , fileChanged: _ 45 | , fileLastUpdateId: _ 46 | } 47 | <$> readProp "id" json 48 | <*> readProp "moduleId" json 49 | <*> readProp "label" json 50 | <*> readProp "created" json 51 | <*> readProp "changed" json 52 | <*> readProp "lastUpdateId" json 53 | pure $ File file 54 | 55 | newtype FileDesc = FileDesc 56 | { fileDescId :: FileId 57 | , fileDescLabel :: String 58 | , fileDescModId :: ModuleId 59 | , fileDescModLabel :: String 60 | , fileDescTaxLabel :: String 61 | , fileDescCreated :: UTCTime 62 | , fileDescLastUpdateId :: UpdateId 63 | } 64 | 65 | instance isForeignFileDesc :: IsForeign FileDesc where 66 | read json = do 67 | file <- { fileDescId: _ 68 | , fileDescLabel: _ 69 | , fileDescModId: _ 70 | , fileDescModLabel: _ 71 | , fileDescTaxLabel: _ 72 | , fileDescCreated: _ 73 | , fileDescLastUpdateId: _ 74 | } 75 | <$> readProp "id" json 76 | <*> readProp "label" json 77 | <*> readProp "moduleId" json 78 | <*> readProp "moduleLabel" json 79 | <*> readProp "taxonomyLabel" json 80 | <*> readProp "created" json 81 | <*> readProp "lastUpdateId" json 82 | pure $ FileDesc file 83 | -------------------------------------------------------------------------------- /gulpfile.js: -------------------------------------------------------------------------------- 1 | var gulp = require('gulp') 2 | var purescript = require('gulp-purescript') 3 | var sass = require('gulp-sass') 4 | var browserify = require('browserify') 5 | var envify = require('envify') 6 | var vinyl = require('vinyl-source-stream') 7 | var uglify = require('gulp-uglify') 8 | var cleanCSS = require('gulp-clean-css') 9 | var browserSync = require('browser-sync') 10 | 11 | // Purescript 12 | 13 | var sources = [ 14 | 'src/**/*.purs', 15 | 'bower_components/purescript-*/src/**/*.purs' 16 | ] 17 | 18 | var foreigns = [ 19 | 'src/**/*.js', 20 | 'bower_components/purescript-*/src/**/*.js' 21 | ] 22 | 23 | gulp.task('make', function () { 24 | return purescript.psc({ 25 | src: sources, 26 | ffi: foreigns, 27 | output: 'output', 28 | verboseErrors: false 29 | }) 30 | }) 31 | 32 | gulp.task('dotpsci', function () { 33 | return purescript.psci({ src: sources, ffi: foreigns }) 34 | .pipe(gulp.dest('.')) 35 | }) 36 | 37 | gulp.task('bundle', ['make'], function () { 38 | return purescript.pscBundle({ 39 | src: 'output/**/*.js', 40 | output: 'dist/main.js', 41 | main: 'Main' 42 | }) 43 | }) 44 | 45 | gulp.task('browserify', ['bundle'], function () { 46 | if (process.env['API_URL'] === undefined) { 47 | console.error('Error: API_URL environment variable must be set ("" for development).') 48 | process.exit(1) 49 | } 50 | return browserify('dist/main.js') 51 | .transform(envify) 52 | .require(['moment', 'numbro', 'pikaday', 'zeroclipboard']) 53 | .bundle() 54 | .pipe(vinyl('main.js')) 55 | .pipe(gulp.dest('public/js')) 56 | }) 57 | 58 | // Sass 59 | 60 | gulp.task('sass', function () { 61 | return gulp.src('sass/**/*.scss') 62 | .pipe(sass({ 63 | errLogToConsole: true 64 | })) 65 | .pipe(gulp.dest('public/css')) 66 | }) 67 | 68 | // Handsontable 69 | 70 | gulp.task('handsontable', function () { 71 | return gulp.src('node_modules/handsontable/dist/handsontable.full.min.css') 72 | .pipe(gulp.dest('public/css/')) 73 | }) 74 | 75 | // Watch 76 | 77 | gulp.task('watch', function () { 78 | browserSync.init(null, { 79 | proxy: 'http://localhost:3000', 80 | port: 3001, 81 | open: false 82 | }) 83 | gulp.watch('public/js/main.js', browserSync.reload) 84 | gulp.watch('sass/**/*.scss', function () { 85 | gulp.src('sass/**/*.scss') 86 | .pipe(sass({ 87 | errLogToConsole: true 88 | })).on('error', function (err) { 89 | console.log(err) 90 | this.emit('end') 91 | }) 92 | .pipe(gulp.dest('public/css')) 93 | .pipe(browserSync.stream()) 94 | }) 95 | }) 96 | 97 | // Main tasks 98 | 99 | gulp.task('default', ['browserify', 'sass', 'handsontable']) 100 | 101 | gulp.task('prod', ['default'], function () { 102 | gulp.src('public/css/main.css') 103 | .pipe(cleanCSS()) 104 | .pipe(gulp.dest('public/css/')) 105 | return gulp.src('public/js/main.js') 106 | .pipe(uglify()) 107 | .pipe(gulp.dest('public/js/')) 108 | }) 109 | -------------------------------------------------------------------------------- /src/Types.purs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | import Prelude 4 | import Control.Monad.Aff (Aff) 5 | import Control.Monad.Aff.AVar (AVAR) 6 | import Control.Monad.Eff.Console (CONSOLE) 7 | import Control.Monad.Eff.Exception (EXCEPTION) 8 | import Control.Monad.Eff.Random (RANDOM) 9 | import Control.Monad.Eff.Ref (REF) 10 | import DOM (DOM) 11 | import Data.Either (Either(..)) 12 | import Data.Foldable (foldMap) 13 | import Data.Foreign (ForeignError(JSONError), F, fail) 14 | import Data.Foreign.Class (class IsForeign, read) 15 | import Data.JSDate (JSDate, jsdate) 16 | import Data.String (singleton) 17 | import Data.Tuple (Tuple) 18 | import Global (readInt) 19 | import Handsontable.Types (HOT) 20 | import Network.HTTP.Affjax (AJAX) 21 | import Text.Parsing.StringParser (runParser) 22 | import Text.Parsing.StringParser.Combinators (many1) 23 | import Text.Parsing.StringParser.String (anyDigit, char) 24 | 25 | type Effects = 26 | ( dom :: DOM 27 | , avar :: AVAR 28 | , err :: EXCEPTION 29 | , console :: CONSOLE 30 | , ajax :: AJAX 31 | , hot :: HOT 32 | , random :: RANDOM 33 | , ref :: REF 34 | ) 35 | 36 | type Metrix = Aff Effects 37 | 38 | -- 39 | 40 | type FrameworkId = Int 41 | type TaxonomyId = Int 42 | type ConceptualModuleId = Int 43 | type ModuleId = Int 44 | type TemplateGroupId = Int 45 | type TemplateId = Int 46 | 47 | type FileId = Int 48 | type UpdateId = Int 49 | type TagId = Int 50 | 51 | type TableId = Int 52 | type AxisId = Int 53 | type OrdinateId = Int 54 | type MemberId = Int 55 | type CellId = Int 56 | 57 | type CustomMemberId = String 58 | type SubsetMemberId = Int 59 | type RowKey = String 60 | 61 | type XBRLCode = String 62 | type Label = String 63 | type XBRLCodeSet = Array (Tuple XBRLCode Label) 64 | 65 | -- TODO: Rework this whole UTCTime type to use Date and JSDate correctly. 66 | newtype UTCTime = UTCTime JSDate 67 | 68 | instance isForeignUTCTime :: IsForeign UTCTime where 69 | read json = UTCTime <$> (read json >>= parseJSDate) 70 | 71 | parseJSDate :: String -> F JSDate 72 | parseJSDate str = case runParser pDate str of 73 | Left err -> fail $ JSONError $ "Could not parse date: " <> show err 74 | Right d -> pure d 75 | where 76 | pDate = do 77 | year <- pNumber 78 | char '-' 79 | month <- pNumber 80 | char '-' 81 | day <- pNumber 82 | pure $ jsdate 83 | { year: year 84 | , month: month 85 | , day: day 86 | , hour: 0.0 87 | , minute: 0.0 88 | , second: 0.0 89 | , millisecond: 0.0 90 | } 91 | pNumber = readInt 10 <<< (foldMap singleton) <$> (many1 anyDigit) 92 | 93 | foreign import showDate :: JSDate -> String 94 | foreign import showDayImpl :: JSDate -> String 95 | 96 | showDay :: UTCTime -> String 97 | showDay (UTCTime date) = showDayImpl date 98 | 99 | instance showUTCTime :: Show UTCTime where 100 | show (UTCTime date) = showDate date 101 | 102 | -- 103 | 104 | type ErrorDetail = 105 | { title :: String 106 | , body :: String 107 | } 108 | -------------------------------------------------------------------------------- /src/Component/Spinner.purs: -------------------------------------------------------------------------------- 1 | module Component.Spinner 2 | ( dispatch 3 | , State() 4 | , initialState 5 | , Query() 6 | , spinner 7 | ) where 8 | 9 | import Halogen.HTML.Indexed as H 10 | import Halogen.HTML.Properties.Indexed as P 11 | import Control.Monad.Eff (Eff) 12 | import Control.Monad.Eff.Console (CONSOLE, logShow) 13 | import Control.Monad.Eff.Exception (catchException) 14 | import DOM (DOM) 15 | import DOM.Event.EventTarget (eventListener, addEventListener, dispatchEvent) 16 | import DOM.Event.Types (EventType(..)) 17 | import DOM.HTML (window) 18 | import DOM.HTML.Types (HTMLElement, htmlElementToEventTarget, htmlDocumentToParentNode) 19 | import DOM.HTML.Window (document) 20 | import DOM.Node.ParentNode (querySelector) 21 | import DOM.Node.Types (elementToEventTarget) 22 | import Data.Foldable (for_) 23 | import Data.Maybe (Maybe(..)) 24 | import Data.Nullable (toMaybe) 25 | import Halogen (ComponentDSL, ComponentHTML, Component, modify, action, eventSource_, subscribe, gets, lifecycleComponent) 26 | import Prelude 27 | import Types (Metrix) 28 | import Utils (cls, createEvent) 29 | 30 | spinnerName :: String 31 | spinnerName = "spinner" 32 | 33 | spinnerOn :: EventType 34 | spinnerOn = EventType "spinnerOn" 35 | 36 | spinnerOff :: EventType 37 | spinnerOff = EventType "spinnerOff" 38 | 39 | dispatch :: forall eff. Boolean -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit 40 | dispatch on = do 41 | doc <- window >>= document 42 | maybeElem <- toMaybe <$> querySelector ("#" <> spinnerName) (htmlDocumentToParentNode doc) 43 | for_ maybeElem \el -> catchException logShow do 44 | dispatchEvent (createEvent $ if on then spinnerOn else spinnerOff) (elementToEventTarget el) 45 | pure unit 46 | 47 | -- 48 | 49 | type State = 50 | { calls :: Int 51 | , element :: Maybe HTMLElement 52 | } 53 | 54 | initialState :: State 55 | initialState = 56 | { calls: 0 57 | , element: Nothing 58 | } 59 | 60 | data Query a 61 | = Initialize a 62 | | SetElement (Maybe HTMLElement) a 63 | | Inc a 64 | | Dec a 65 | 66 | spinner :: Component State Query Metrix 67 | spinner = lifecycleComponent 68 | { render 69 | , eval 70 | , initializer: Just (action Initialize) 71 | , finalizer: Nothing 72 | } 73 | 74 | render :: State -> ComponentHTML Query 75 | render st = H.div 76 | [ P.ref \el -> action (SetElement el) 77 | , P.id_ spinnerName 78 | , cls "spinnerContainer" 79 | ] $ if st.calls > 0 80 | then [ H.span [ cls "spinner-on" ] [] ] 81 | else [ H.div [ cls "spinner-off" ] [] ] 82 | 83 | eval :: Query ~> ComponentDSL State Query Metrix 84 | eval (Initialize next) = do 85 | el <- gets _.element 86 | case el of 87 | Nothing -> pure unit 88 | Just el' -> do 89 | let attach typ callback = addEventListener typ 90 | (eventListener \_ -> callback) true (htmlElementToEventTarget el') 91 | subscribe $ eventSource_ (attach spinnerOn) do 92 | pure $ action Inc 93 | subscribe $ eventSource_ (attach spinnerOff) do 94 | pure $ action Dec 95 | pure next 96 | eval (SetElement el next) = do 97 | modify $ _{ element = el } 98 | pure next 99 | eval (Inc next) = do 100 | modify \st -> st { calls = st.calls + 1 } 101 | pure next 102 | eval (Dec next) = do 103 | modify \st -> st { calls = st.calls - 1 } 104 | pure next 105 | -------------------------------------------------------------------------------- /src/Api/Common.purs: -------------------------------------------------------------------------------- 1 | module Api.Common where 2 | 3 | import Api.Schema (ServerResponse(ServerSuccess, ServerError)) 4 | import Control.Monad.Aff (Aff, attempt) 5 | import Control.Monad.Except (runExcept) 6 | import Control.Monad.Except.Trans (ExceptT, throwError) 7 | import Control.Monad.Trans.Class (lift) 8 | import DOM.File.Types (FileList) 9 | import DOM.XHR.Types (FormData) 10 | import Data.Argonaut.Encode (class EncodeJson, encodeJson) 11 | import Data.Argonaut.Printer (printJson) 12 | import Data.Either (Either(Left, Right)) 13 | import Data.Foreign.Class (class IsForeign, readJSON) 14 | import Data.HTTP.Method (Method(POST)) 15 | import Data.Maybe (Maybe(Just)) 16 | import Data.MediaType.Common (applicationJSON) 17 | import Data.Tuple (snd) 18 | import Network.HTTP.Affjax (Affjax, URL, AJAX, defaultRequest, affjax) 19 | import Network.HTTP.Affjax.Request (toRequest) 20 | import Network.HTTP.Affjax.Response (class Respondable) 21 | import Network.HTTP.RequestHeader (RequestHeader(ContentType)) 22 | import Network.HTTP.StatusCode (StatusCode(StatusCode)) 23 | import Prelude 24 | import Types (ErrorDetail) 25 | 26 | foreign import filesToFormData :: FileList -> FormData 27 | 28 | type Api eff a = ExceptT ErrorDetail (Aff (ajax :: AJAX | eff)) a 29 | 30 | postJson :: forall eff a b. (EncodeJson a, Respondable b) => URL -> a -> Affjax eff b 31 | postJson u c = affjax $ defaultRequest 32 | { method = Left POST 33 | , url = u 34 | , content = Just $ snd $ toRequest (printJson (encodeJson c) :: String) 35 | , headers = [ContentType applicationJSON] 36 | } 37 | 38 | uploadFiles :: forall eff b. (Respondable b) => URL -> FileList -> Affjax eff b 39 | uploadFiles u f = affjax $ defaultRequest 40 | { method = Left POST 41 | , url = u 42 | , content = Just $ snd $ toRequest $ filesToFormData f 43 | -- TODO: report purescript-affjax issue about `multipartFormData` and boundary 44 | -- , headers = [ContentType multipartFormData] 45 | } 46 | 47 | succeeded :: StatusCode -> Boolean 48 | succeeded (StatusCode code) = 200 <= code && code < 300 49 | 50 | getJsonResponse :: forall a eff. (IsForeign a) 51 | => String -> Affjax eff String -> Api eff a 52 | getJsonResponse msg affjax = do 53 | result <- lift $ attempt affjax 54 | case result of 55 | Right res -> if succeeded res.status 56 | then case runExcept (readJSON res.response) of 57 | Left e -> throwError 58 | { title: "JSON decode error" 59 | , body: show e 60 | } 61 | Right x -> case x of 62 | ServerError e -> throwError e 63 | ServerSuccess a -> pure a 64 | else throwError 65 | { title: msg 66 | , body: "Probably a server or protocol error. Please consult the log files." 67 | } 68 | Left e -> throwError 69 | { title: "Exception" 70 | , body: show e 71 | } 72 | 73 | getUnitResponse :: forall eff. String -> Affjax eff String -> Api eff Unit 74 | getUnitResponse msg affjax = do 75 | result <- lift $ attempt affjax 76 | case result of 77 | Right res -> if succeeded res.status 78 | then pure unit 79 | else throwError 80 | { title: msg 81 | , body: "Probably a connection or protocol error." 82 | } 83 | Left e -> throwError 84 | { title: "Exception" 85 | , body: show e 86 | } 87 | -------------------------------------------------------------------------------- /src/Component/ErrorBox.purs: -------------------------------------------------------------------------------- 1 | module Component.ErrorBox 2 | ( raise 3 | , State() 4 | , initialState 5 | , Query() 6 | , errorBox 7 | ) where 8 | 9 | import Halogen.HTML.Events.Indexed as E 10 | import Halogen.HTML.Indexed as H 11 | import Halogen.HTML.Properties.Indexed as P 12 | import Component.Common (modal) 13 | import Control.Monad.Eff (Eff) 14 | import Control.Monad.Eff.Console (CONSOLE, logShow) 15 | import Control.Monad.Eff.Exception (catchException) 16 | import DOM (DOM) 17 | import DOM.Event.EventTarget (eventListener, addEventListener, dispatchEvent) 18 | import DOM.Event.Types (EventType(EventType)) 19 | import DOM.HTML (window) 20 | import DOM.HTML.Types (HTMLElement, htmlElementToEventTarget, htmlDocumentToParentNode) 21 | import DOM.HTML.Window (document) 22 | import DOM.Node.ParentNode (querySelector) 23 | import DOM.Node.Types (elementToEventTarget) 24 | import Data.Foldable (for_) 25 | import Data.Maybe (Maybe(Nothing, Just), fromMaybe) 26 | import Data.Nullable (toMaybe) 27 | import Halogen (ComponentDSL, ComponentHTML, Component, modify, action, eventSource, subscribe, gets, lifecycleComponent) 28 | import Prelude 29 | import Types (Metrix, ErrorDetail) 30 | import Utils (errorEventDetail, createErrorEvent) 31 | 32 | errorId :: String 33 | errorId = "error" 34 | 35 | errorEvent :: EventType 36 | errorEvent = EventType "error" 37 | 38 | raise :: forall eff. ErrorDetail -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit 39 | raise detail = do 40 | doc <- window >>= document 41 | maybeElem <- toMaybe <$> querySelector ("#" <> errorId) (htmlDocumentToParentNode doc) 42 | for_ maybeElem \el -> catchException logShow do 43 | dispatchEvent (createErrorEvent errorEvent detail) (elementToEventTarget el) 44 | pure unit 45 | 46 | -- 47 | 48 | type State = 49 | { error :: Maybe ErrorDetail 50 | , element :: Maybe HTMLElement 51 | } 52 | 53 | initialState :: State 54 | initialState = 55 | { error: Nothing 56 | , element: Nothing 57 | } 58 | 59 | data Query a 60 | = Initialize a 61 | | SetElement (Maybe HTMLElement) a 62 | | Open ErrorDetail a 63 | | Close a 64 | 65 | errorBox :: Component State Query Metrix 66 | errorBox = lifecycleComponent 67 | { render 68 | , eval 69 | , initializer: Just (action Initialize) 70 | , finalizer: Nothing 71 | } 72 | 73 | render :: State -> ComponentHTML Query 74 | render st = H.div 75 | [ P.ref \el -> action (SetElement el) 76 | , P.id_ errorId 77 | ] $ case st.error of 78 | Just detail -> 79 | [ modal "Error" 80 | [ H.p_ [ H.b_ [ H.text detail.title ] ] 81 | , H.p_ [ H.text detail.body ] 82 | ] 83 | [ H.button 84 | [ E.onClick (E.input_ Close) ] 85 | [ H.text "Close" ] 86 | ] 87 | ] 88 | Nothing -> 89 | [] 90 | 91 | eval :: Query ~> ComponentDSL State Query Metrix 92 | eval (Initialize next) = do 93 | el <- gets _.element 94 | case el of 95 | Nothing -> pure unit 96 | Just el' -> do 97 | let attach cb = addEventListener errorEvent 98 | (eventListener \e -> cb $ errorEventDetail e) true (htmlElementToEventTarget el') 99 | subscribe $ eventSource attach \detail -> do 100 | pure $ action $ Open $ fromMaybe 101 | { title: "Internal error" 102 | , body: "Error reading event detail." 103 | } detail 104 | pure next 105 | eval (SetElement el next) = do 106 | modify _{ element = el } 107 | pure next 108 | eval (Open detail next) = do 109 | modify _{ error = Just detail } 110 | pure next 111 | eval (Close next) = do 112 | modify _{ error = Nothing } 113 | pure next 114 | -------------------------------------------------------------------------------- /sass/partials/_filemenu.scss: -------------------------------------------------------------------------------- 1 | .menu-content { 2 | position: absolute; 3 | top: $toolbar-height; 4 | right: $toolwidth-close + $toolsep-width; 5 | width: 400px; 6 | height: auto; 7 | box-shadow: 0px 0px 10px 0px rgba(0, 0, 0, 0.3); 8 | z-index: 10000; 9 | background-color: white; 10 | 11 | input.full, button.full { 12 | box-sizing: border-box; 13 | margin: 5px 0px 0px 0px; 14 | width: 100%; 15 | } 16 | 17 | p { 18 | margin: 0px; 19 | } 20 | 21 | ul.menu { 22 | list-style: none; 23 | margin: 0px; 24 | padding: 0px; 25 | background-color: $metrix-blue; 26 | 27 | li { 28 | cursor: pointer; 29 | padding: 8px 15px 8px 15px; 30 | 31 | &:hover { 32 | background-color: $metrix-darkblue; 33 | } 34 | 35 | .octicon { 36 | margin-right: 10px; 37 | } 38 | } 39 | 40 | li.href { 41 | padding: 0px; 42 | 43 | a { 44 | padding: 8px 15px 8px 15px; 45 | text-decoration: none; 46 | color: $metrix-darkgray; 47 | display: block; 48 | } 49 | } 50 | } 51 | 52 | 53 | .entry-content { 54 | padding: 5px; 55 | max-height: 700px; 56 | overflow-y: auto; 57 | max-height: 600px; 58 | 59 | .pagination { 60 | position: relative; 61 | height: 29px; 62 | .octicon { 63 | width: 16px; 64 | text-align: center; 65 | border-radius: 2px; 66 | padding: 3px; 67 | position: absolute; 68 | top: 5px; 69 | border: 1px solid rgba(0, 0, 0, 0.3); 70 | background-color: $metrix-blue; 71 | cursor: pointer; 72 | color: $metrix-darkgray; 73 | &:hover { 74 | color: black; 75 | background-color: lighten($metrix-blue, 5%); 76 | } 77 | } 78 | 79 | .left { 80 | left: 0px; 81 | } 82 | 83 | .right { 84 | right: 0px; 85 | } 86 | 87 | .fromto { 88 | position: absolute; 89 | left: 21px; 90 | right: 21px; 91 | top: 5px; 92 | text-align: center; 93 | } 94 | 95 | .disabled { 96 | background-color: white; 97 | cursor: default; 98 | &:hover { 99 | background-color: white; 100 | color: $metrix-darkgray; 101 | } 102 | } 103 | 104 | } 105 | 106 | ul.updates { 107 | background-color: white; 108 | margin-top: 5px; 109 | margin-bottom: 0px; 110 | padding: 0px; 111 | list-style: none; 112 | cursor: pointer; 113 | li { 114 | &:hover { 115 | background-color: #E5E5E5; 116 | } 117 | padding: 3px; 118 | position: relative; 119 | border-top: 1px solid #D0D0D0; 120 | } 121 | } 122 | 123 | ul.entries { 124 | padding-left: 23px; 125 | li { 126 | padding: 2px; 127 | position: relative; 128 | border: none; 129 | font-size: 13px; 130 | 131 | .location { 132 | margin-left: -5px; 133 | } 134 | 135 | .action { 136 | float: right; 137 | color: #999; 138 | } 139 | } 140 | } 141 | 142 | .label { 143 | color: $metrix-darkgray; 144 | } 145 | 146 | .tags { 147 | position: absolute; 148 | top: 2px; 149 | right: 3px; 150 | } 151 | 152 | .tag { 153 | background-color: $metrix-darkblue; 154 | padding: 2px 4px 2px 4px; 155 | border-radius: 2px; 156 | color: white; 157 | margin-left: 10px; 158 | .octicon { 159 | margin-right: 3px; 160 | } 161 | } 162 | } 163 | 164 | } 165 | -------------------------------------------------------------------------------- /src/Component/Body.purs: -------------------------------------------------------------------------------- 1 | module Component.Body where 2 | 3 | import Component.File as F 4 | import Component.FileSelector as FS 5 | import Component.FileViewer as FV 6 | import Halogen.HTML.Indexed as H 7 | import Api (newFile, apiCallParent) 8 | import Api.Schema.BusinessData (SnapshotDesc(SnapshotDesc)) 9 | import Data.Either (Either) 10 | import Data.Functor.Coproduct (Coproduct, coproduct) 11 | import Data.Generic (class Generic, gEq, gCompare) 12 | import Data.Maybe (Maybe(Just)) 13 | import Halogen (ParentDSL, parentState, ParentHTML, ParentState, Component, ChildF(ChildF), modify, parentComponent) 14 | import Halogen.Component.ChildPath (ChildPath, cpR, cpL) 15 | import Prelude 16 | import Types (Metrix, UpdateId, FileId) 17 | import Utils (cls, peek') 18 | 19 | data SelectorSlot = SelectorSlot 20 | 21 | derive instance genericSelectorSlot :: Generic SelectorSlot 22 | instance eqSelectorSlot :: Eq SelectorSlot where eq = gEq 23 | instance ordSelectorSlot :: Ord SelectorSlot where compare = gCompare 24 | 25 | data ViewerSlot = ViewerSlot FileId 26 | 27 | derive instance genericViewerSlot :: Generic ViewerSlot 28 | instance eqViewerSlot :: Eq ViewerSlot where eq = gEq 29 | instance ordViewerSlot :: Ord ViewerSlot where compare = gCompare 30 | 31 | type ChildState = Either FS.StateP FV.StateP 32 | type ChildQuery = Coproduct FS.QueryP FV.QueryP 33 | type ChildSlot = Either SelectorSlot ViewerSlot 34 | 35 | cpSelector :: ChildPath FS.StateP ChildState FS.QueryP ChildQuery SelectorSlot ChildSlot 36 | cpSelector = cpL 37 | 38 | cpViewer :: ChildPath FV.StateP ChildState FV.QueryP ChildQuery ViewerSlot ChildSlot 39 | cpViewer = cpR 40 | 41 | -- 42 | 43 | data CurrentView 44 | = FileSelector 45 | | FileViewer UpdateId 46 | 47 | type State = 48 | { currentView :: CurrentView 49 | , msg :: String 50 | } 51 | 52 | initialState :: State 53 | initialState = 54 | { currentView: FileSelector 55 | , msg: "ss" 56 | } 57 | 58 | type StateP = ParentState State ChildState Query ChildQuery Metrix ChildSlot 59 | type QueryP = Coproduct Query (ChildF ChildSlot ChildQuery) 60 | 61 | data Query a 62 | = Foo a 63 | 64 | body :: Component StateP QueryP Metrix 65 | body = parentComponent 66 | { render 67 | , eval 68 | , peek: Just peek 69 | } 70 | 71 | render :: State -> ParentHTML ChildState Query ChildQuery Metrix ChildSlot 72 | render st = H.div [ cls "body" ] $ case st.currentView of 73 | FileSelector -> 74 | [ H.slot' cpSelector SelectorSlot \_ -> 75 | { component: FS.selector, initialState: parentState FS.initialState } 76 | ] 77 | FileViewer updateId -> 78 | [ H.slot' cpViewer (ViewerSlot updateId) \_ -> 79 | { component: FV.viewer updateId, initialState: parentState FV.initialState } 80 | ] 81 | 82 | eval :: Query ~> ParentDSL State ChildState Query ChildQuery Metrix ChildSlot 83 | eval (Foo next) = do 84 | pure next 85 | 86 | peek :: forall a. ChildF ChildSlot ChildQuery a -> ParentDSL State ChildState Query ChildQuery Metrix ChildSlot Unit 87 | peek child = do 88 | peek' cpSelector child \s q -> coproduct peekSelector peekFile q 89 | peek' cpViewer child \s q -> coproduct peekViewer (const $ pure unit) q 90 | where 91 | peekSelector q = case q of 92 | FS.CreateFile modId name _ -> 93 | apiCallParent (newFile modId name) \(SnapshotDesc snap) -> 94 | modify _{ currentView = FileViewer snap.snapshotDescUpdateId } 95 | FS.UploadXbrlOpenFile updateId _ -> 96 | modify _{ currentView = FileViewer updateId } 97 | _ -> pure unit 98 | peekFile (ChildF _ q) = case q of 99 | F.Open updateId _ -> 100 | modify _{ currentView = FileViewer updateId } 101 | _ -> pure unit 102 | peekViewer q = case q of 103 | FV.CloseFile _ -> 104 | modify _{ currentView = FileSelector } 105 | _ -> pure unit 106 | -------------------------------------------------------------------------------- /src/Api/Schema/Selector.purs: -------------------------------------------------------------------------------- 1 | module Api.Schema.Selector where 2 | 3 | import Data.Foreign.Class (class IsForeign, readProp) 4 | import Data.Lens (Lens', lens) 5 | import Prelude 6 | import Types (ModuleId, ConceptualModuleId, TaxonomyId, FrameworkId) 7 | 8 | newtype Framework = Framework 9 | { frameworkId :: FrameworkId 10 | , frameworkLabel :: String 11 | , taxonomies :: Array Taxonomy 12 | } 13 | 14 | _Framework :: Lens' Framework _ 15 | _Framework = lens (\(Framework r) -> r) (\_ r -> Framework r) 16 | 17 | _frameworkId :: Lens' Framework FrameworkId 18 | _frameworkId = _Framework <<< lens _.frameworkId _{ frameworkId = _ } 19 | 20 | _frameworkLabel :: Lens' Framework String 21 | _frameworkLabel = _Framework <<< lens _.frameworkLabel _{ frameworkLabel = _ } 22 | 23 | _taxonomies :: Lens' Framework (Array Taxonomy) 24 | _taxonomies = _Framework <<< lens _.taxonomies _{ taxonomies = _ } 25 | 26 | instance isForeignFramework :: IsForeign Framework where 27 | read json = do 28 | frm <- { frameworkId: _, frameworkLabel: _, taxonomies: _ } 29 | <$> readProp "id" json 30 | <*> readProp "label" json 31 | <*> readProp "taxonomies" json 32 | pure $ Framework frm 33 | 34 | newtype Taxonomy = Taxonomy 35 | { taxonomyId :: TaxonomyId 36 | , taxonomyLabel :: String 37 | , conceptualModules :: Array ConceptualModule 38 | } 39 | 40 | _Taxonomy :: Lens' Taxonomy _ 41 | _Taxonomy = lens (\(Taxonomy r) -> r) (\_ r -> Taxonomy r) 42 | 43 | _taxonomyId :: Lens' Taxonomy TaxonomyId 44 | _taxonomyId = _Taxonomy <<< lens _.taxonomyId _{taxonomyId = _ } 45 | 46 | _taxonomyLabel :: Lens' Taxonomy String 47 | _taxonomyLabel = _Taxonomy <<< lens _.taxonomyLabel _{ taxonomyLabel = _ } 48 | 49 | _conceptualModules :: Lens' Taxonomy (Array ConceptualModule) 50 | _conceptualModules = _Taxonomy <<< lens _.conceptualModules _{ conceptualModules = _ } 51 | 52 | instance isForeignTaxonomy :: IsForeign Taxonomy where 53 | read json = do 54 | tax <- { taxonomyId: _, taxonomyLabel: _, conceptualModules: _ } 55 | <$> readProp "id" json 56 | <*> readProp "label" json 57 | <*> readProp "concepts" json 58 | pure $ Taxonomy tax 59 | 60 | newtype ConceptualModule = ConceptualModule 61 | { conceptId :: ConceptualModuleId 62 | , conceptLabel :: String 63 | , conceptAllowed :: Boolean 64 | , moduleEntries :: Array ModuleEntry 65 | } 66 | 67 | _ConceptualModule :: Lens' ConceptualModule _ 68 | _ConceptualModule = lens (\(ConceptualModule r) -> r) (\_ r -> ConceptualModule r) 69 | 70 | _conceptId :: Lens' ConceptualModule ConceptualModuleId 71 | _conceptId = _ConceptualModule <<< lens _.conceptId _{conceptId = _ } 72 | 73 | _conceptLabel :: Lens' ConceptualModule String 74 | _conceptLabel = _ConceptualModule <<< lens _.conceptLabel _{ conceptLabel = _ } 75 | 76 | _conceptAllowed :: Lens' ConceptualModule Boolean 77 | _conceptAllowed = _ConceptualModule <<< lens _.conceptAllowed _{ conceptAllowed = _ } 78 | 79 | _moduleEntries :: Lens' ConceptualModule (Array ModuleEntry) 80 | _moduleEntries = _ConceptualModule <<< lens _.moduleEntries _{ moduleEntries = _ } 81 | 82 | instance isForeignConceptualModule :: IsForeign ConceptualModule where 83 | read json = do 84 | con <- { conceptId: _ 85 | , conceptLabel: _ 86 | , conceptAllowed: _ 87 | , moduleEntries: _ 88 | } 89 | <$> readProp "id" json 90 | <*> readProp "label" json 91 | <*> readProp "allowed" json 92 | <*> readProp "modules" json 93 | pure $ ConceptualModule con 94 | 95 | newtype ModuleEntry = ModuleEntry 96 | { moduleEntryId :: ModuleId 97 | , moduleEntryLabel :: String 98 | } 99 | 100 | instance isForeignModuleEntry :: IsForeign ModuleEntry where 101 | read json = do 102 | mod <- { moduleEntryId: _, moduleEntryLabel: _ } 103 | <$> readProp "id" json 104 | <*> readProp "label" json 105 | pure $ ModuleEntry mod 106 | -------------------------------------------------------------------------------- /src/Api/Schema/Module.purs: -------------------------------------------------------------------------------- 1 | module Api.Schema.Module where 2 | 3 | import Data.Foreign.Class (class IsForeign, readProp) 4 | import Data.Lens (Lens', lens) 5 | import Prelude 6 | import Types (TableId, TemplateId, TemplateGroupId, ModuleId) 7 | 8 | newtype Module = Module 9 | { moduleId :: ModuleId 10 | , moduleLabel :: String 11 | , templateGroups :: Array TemplateGroup 12 | } 13 | 14 | _Module :: Lens' Module _ 15 | _Module = lens (\(Module r) -> r) (\_ r -> Module r) 16 | 17 | _moduleId :: Lens' Module ModuleId 18 | _moduleId = _Module <<< lens _.moduleId _{moduleId = _ } 19 | 20 | _moduleLabel :: Lens' Module String 21 | _moduleLabel = _Module <<< lens _.moduleLabel _{ moduleLabel = _ } 22 | 23 | _templateGroups :: Lens' Module (Array TemplateGroup) 24 | _templateGroups = _Module <<< lens _.templateGroups _{ templateGroups = _ } 25 | 26 | instance isForeignModule :: IsForeign Module where 27 | read json = do 28 | mod <- { moduleId: _, moduleLabel: _, templateGroups: _ } 29 | <$> readProp "id" json 30 | <*> readProp "label" json 31 | <*> readProp "templateGroups" json 32 | pure $ Module mod 33 | 34 | newtype TemplateGroup = TemplateGroup 35 | { templateGroupId :: TemplateGroupId 36 | , templateGroupLabel :: String 37 | , templates :: Array Template 38 | } 39 | 40 | _TemplateGroup :: Lens' TemplateGroup _ 41 | _TemplateGroup = lens (\(TemplateGroup r) -> r) (\_ r -> TemplateGroup r) 42 | 43 | _templateGroupId :: Lens' TemplateGroup TemplateGroupId 44 | _templateGroupId = _TemplateGroup <<< lens _.templateGroupId _{templateGroupId = _ } 45 | 46 | _templateGroupLabel :: Lens' TemplateGroup String 47 | _templateGroupLabel = _TemplateGroup <<< lens _.templateGroupLabel _{ templateGroupLabel = _ } 48 | 49 | _templates :: Lens' TemplateGroup (Array Template) 50 | _templates = _TemplateGroup <<< lens _.templates _{ templates = _ } 51 | 52 | instance isForeignTemplateGroup :: IsForeign TemplateGroup where 53 | read json = do 54 | grp <- { templateGroupId: _, templateGroupLabel: _, templates: _ } 55 | <$> readProp "id" json 56 | <*> readProp "label" json 57 | <*> readProp "templates" json 58 | pure $ TemplateGroup grp 59 | 60 | newtype Template = Template 61 | { templateId :: TemplateId 62 | , templateCode :: String 63 | , templateLabel :: String 64 | , templateTables :: Array TableEntry 65 | } 66 | 67 | _Template :: Lens' Template _ 68 | _Template = lens (\(Template r) -> r) (\_ r -> Template r) 69 | 70 | _templateId :: Lens' Template TemplateId 71 | _templateId = _Template <<< lens _.templateId _{ templateId = _ } 72 | 73 | _templateCode :: Lens' Template String 74 | _templateCode = _Template <<< lens _.templateCode _{ templateCode = _ } 75 | 76 | _templateLabel :: Lens' Template String 77 | _templateLabel = _Template <<< lens _.templateLabel _{ templateLabel = _ } 78 | 79 | _templateTables :: Lens' Template (Array TableEntry) 80 | _templateTables = _Template <<< lens _.templateTables _{ templateTables = _ } 81 | 82 | instance isForeignTemplate :: IsForeign Template where 83 | read json = do 84 | tpl <- { templateId: _ 85 | , templateCode: _ 86 | , templateLabel: _ 87 | , templateTables: _ 88 | } 89 | <$> readProp "id" json 90 | <*> readProp "code" json 91 | <*> readProp "label" json 92 | <*> readProp "tables" json 93 | pure $ Template tpl 94 | 95 | newtype TableEntry = TableEntry 96 | { tableEntryId :: TableId 97 | , tableEntryCode :: String 98 | } 99 | 100 | _TableEntry :: Lens' TableEntry _ 101 | _TableEntry = lens (\(TableEntry r) -> r) (\_ r -> TableEntry r) 102 | 103 | _tableEntryId :: Lens' TableEntry TableId 104 | _tableEntryId = _TableEntry <<< lens _.tableEntryId _{ tableEntryId = _ } 105 | 106 | _tableEntryCode :: Lens' TableEntry String 107 | _tableEntryCode = _TableEntry <<< lens _.tableEntryCode _{ tableEntryCode = _ } 108 | 109 | instance isForeignTableEntry :: IsForeign TableEntry where 110 | read json = do 111 | tbl <- { tableEntryId: _ 112 | , tableEntryCode: _ 113 | } 114 | <$> readProp "id" json 115 | <*> readProp "code" json 116 | pure $ TableEntry tbl 117 | -------------------------------------------------------------------------------- /src/Component/Validation.purs: -------------------------------------------------------------------------------- 1 | module Component.Validation where 2 | 3 | import Prelude 4 | import Halogen.HTML.Events.Indexed as E 5 | import Halogen.HTML.Indexed as H 6 | import Api (validate, apiCall) 7 | import Api.Schema.Validation (ValidationResult, emptyValidationResult) 8 | import Component.Validation.Finding (renderFinding) 9 | import Data.Lens (Lens', lens, (%~)) 10 | import Data.Maybe (Maybe(Nothing, Just)) 11 | import Halogen (ComponentDSL, ComponentHTML, Component, modify, gets, action, lifecycleComponent) 12 | import Lib.Validation (patchValidationResult, flattenValidationResult) 13 | import Types (Metrix, UpdateId) 14 | import Utils (maxOrd, cls, paginate) 15 | 16 | type State = 17 | { open :: Boolean 18 | , updateId :: UpdateId 19 | , results :: ValidationResult 20 | , page :: Int 21 | } 22 | 23 | initialState :: UpdateId -> State 24 | initialState updateId = 25 | { open: false 26 | , updateId: updateId 27 | , results: emptyValidationResult 28 | , page: 1 29 | } 30 | 31 | _results :: Lens' State ValidationResult 32 | _results = lens _.results _{ results = _ } 33 | 34 | _page :: Lens' State Int 35 | _page = lens _.page _{ page = _ } 36 | 37 | data Query a 38 | = Init a 39 | | Open a 40 | | Close a 41 | | PageNext a 42 | | PagePrev a 43 | | SetUpdateId UpdateId a 44 | | Patch ValidationResult a 45 | | ValidateAll UpdateId a 46 | 47 | validation :: Component State Query Metrix 48 | validation = lifecycleComponent 49 | { render 50 | , eval 51 | , initializer: Just (action Init) 52 | , finalizer: Nothing 53 | } 54 | 55 | render :: State -> ComponentHTML Query 56 | render st = H.div_ 57 | [ if st.open 58 | then let pagination = paginate 25 (flattenValidationResult st.results) st.page in 59 | H.div 60 | [ cls "validation-open" ] $ 61 | [ H.span 62 | [ cls "navigation octicon octicon-chevron-down" 63 | , E.onClick $ E.input_ Close 64 | ] [] 65 | , H.span 66 | [ cls "pagination" ] 67 | [ if st.page > 1 then 68 | H.span 69 | [ cls "navigation octicon octicon-chevron-left" 70 | , E.onClick $ E.input_ PagePrev 71 | ] [] 72 | else 73 | H.span 74 | [ cls "navigation octicon octicon-chevron-left disabled" ] [] 75 | , H.span 76 | [ cls "fromto" ] 77 | [ H.b_ [ H.text $ show pagination.from ] 78 | , H.text " to " 79 | , H.b_ [ H.text $ show pagination.to ] 80 | , H.text " out of " 81 | , H.b_ [ H.text $ show pagination.total ] 82 | ] 83 | , if st.page < pagination.pages then 84 | H.span 85 | [ cls "navigation octicon octicon-chevron-right" 86 | , E.onClick $ E.input_ PageNext 87 | ] [] 88 | else 89 | H.span 90 | [ cls "navigation octicon octicon-chevron-right disabled" ] [] 91 | ] 92 | , H.div [ cls "validation-content" ] 93 | [ H.ul_ $ renderFinding <$> pagination.items 94 | ] 95 | ] 96 | else H.div_ 97 | [ H.div 98 | [ cls "validation-closed" 99 | , E.onClick $ E.input_ Open 100 | ] 101 | [ H.span [ cls "navigation octicon octicon-chevron-up" ] [] 102 | , H.text "Validation" 103 | ] 104 | ] 105 | ] 106 | 107 | -- TODO: report purescript-halogen issue about type inference 108 | htmlProblem :: forall f. Int -> ComponentHTML f 109 | htmlProblem x = H.li_ ([H.br_ :: ComponentHTML f, H.text "hl" ] <> [H.li_ [], H.br_]) 110 | 111 | eval :: Query ~> ComponentDSL State Query Metrix 112 | eval (Init next) = do 113 | updateId <- gets _.updateId 114 | apiCall (validate updateId) \results -> 115 | modify _{ results = results } 116 | pure next 117 | 118 | eval (Open next) = do 119 | modify _{ open = true } 120 | pure next 121 | 122 | eval (Close next) = do 123 | modify _{ open = false } 124 | pure next 125 | 126 | eval (PageNext next) = do 127 | modify $ _page %~ \p -> p + 1 128 | pure next 129 | 130 | eval (PagePrev next) = do 131 | modify $ _page %~ \p -> maxOrd 1 (p - 1) 132 | pure next 133 | 134 | eval (SetUpdateId updateId next) = do 135 | modify _{ updateId = updateId } 136 | pure next 137 | 138 | eval (Patch patch next) = do 139 | modify $ _results %~ patchValidationResult patch 140 | pure next 141 | 142 | eval (ValidateAll updateId next) = do 143 | modify _{ updateId = updateId } 144 | apiCall (validate updateId) \results -> 145 | modify _{ results = results } 146 | pure next 147 | -------------------------------------------------------------------------------- /sass/partials/_validation.scss: -------------------------------------------------------------------------------- 1 | .validation-closed { 2 | position: fixed; 3 | bottom: -2px; 4 | left: -2px; 5 | border-radius: 2px; 6 | box-shadow: 0px 0px 10px 0px rgba(0, 0, 0, 0.3); 7 | background-color: $metrix-blue; 8 | z-index: 1200; 9 | padding: 5px 5px 7px 7px; 10 | border: 1px solid rgba(0, 0, 0, 0.3); 11 | font-size: 16px; 12 | font-weight: bold; 13 | color: $metrix-darkgray; 14 | cursor: pointer; 15 | &:hover { 16 | color: black; 17 | background-color: lighten($metrix-blue, 5%); 18 | } 19 | .octicon { 20 | margin-right: 5px; 21 | } 22 | } 23 | 24 | .validation-open { 25 | position: fixed; 26 | bottom: 0px; 27 | left: 0px; 28 | right: 0px; 29 | height: $validation-height; 30 | z-index: 1200; 31 | background-color: white; 32 | box-shadow: 0px 0px 10px 0px rgba(0, 0, 0, 0.3); 33 | 34 | .severity { 35 | padding: 5px; 36 | } 37 | .blocking { 38 | color: $severityBlocking; 39 | } 40 | .non-blocking { 41 | color: $severityNonBlocking; 42 | } 43 | .warning { 44 | color: $severityWarning; 45 | } 46 | .blocking-for-IFRS { 47 | color: $severityBlockingIFRS; 48 | } 49 | 50 | .navigation { 51 | width: 16px; 52 | text-align: center; 53 | border-radius: 2px; 54 | padding: 3px; 55 | margin: 5px 0px 0px 5px; 56 | border: 1px solid rgba(0, 0, 0, 0.3); 57 | background-color: $metrix-blue; 58 | cursor: pointer; 59 | color: $metrix-darkgray; 60 | &:hover { 61 | color: black; 62 | background-color: lighten($metrix-blue, 5%); 63 | } 64 | } 65 | 66 | .fromto { 67 | margin: 5px 0px 0px 5px; 68 | display: inline-block; 69 | min-width: 160px; 70 | text-align: center; 71 | } 72 | 73 | .disabled { 74 | background-color: white; 75 | cursor: default; 76 | &:hover { 77 | background-color: white; 78 | color: $metrix-darkgray; 79 | } 80 | } 81 | 82 | .validation-content { 83 | position: absolute; 84 | top: 33px; 85 | left: 0px; 86 | right: 0px; 87 | bottom: 0px; 88 | overflow-y: auto; 89 | border-top: 1px solid #BBB; 90 | 91 | ul { 92 | list-style: none; 93 | margin: 0px; 94 | padding: 0px; 95 | } 96 | 97 | li { 98 | padding: 3px; 99 | border-bottom: 1px solid $panel-gray; 100 | 101 | &:hover { 102 | background-color: $panel-gray; 103 | } 104 | 105 | } 106 | 107 | } 108 | 109 | } 110 | 111 | .formula { 112 | .op { 113 | font-size: 20px; 114 | margin: 0px 1px 0px 1px; 115 | } 116 | .lop { 117 | background-image: url("../img/formula.png"); 118 | background-repeat: no-repeat; 119 | height: 53px; 120 | } 121 | .lop-lparen { 122 | width: 15px; 123 | background-position: -2px 0px; 124 | } 125 | .lop-rparen { 126 | width: 15px; 127 | background-position: -150px 0px; 128 | } 129 | .lop-ge { 130 | width: 17px; 131 | background-position: -51px 0px; 132 | } 133 | .lop-le { 134 | width: 17px; 135 | background-position: -70px 0px; 136 | } 137 | .lop-eq { 138 | width: 18px; 139 | background-position: -86px -2px; 140 | } 141 | .lop-plus { 142 | width: 18px; 143 | background-position: -108px 0px; 144 | } 145 | .lop-minus { 146 | width: 18px; 147 | background-position: -126px 0px; 148 | } 149 | .lop-elem { 150 | width: 18px; 151 | background-position: -171px -2px; 152 | } 153 | div { 154 | display: inline-block; 155 | vertical-align: middle; 156 | } 157 | .hole, .param, .value { 158 | background-color: darken($panel-gray, 7%); 159 | margin: 4px; 160 | position: relative; 161 | line-height: 16px; 162 | padding: 0px 4px 0px 4px; 163 | border: 1px solid rgba(0,0,0,0.5); 164 | border-radius: 2px; 165 | text-align: center; 166 | .holetable { 167 | color: gray; 168 | font-size: 12px; 169 | padding-left: 12px; 170 | padding-right: 12px; 171 | } 172 | .holecoords { 173 | padding-top: 2px; 174 | color: gray; 175 | font-size: 12px; 176 | } 177 | .decimals { 178 | position: absolute; 179 | top: -1px; 180 | right: -1px; 181 | font-size: 10px; 182 | color: darken($panel-gray, 7%); 183 | background-color: rgba(0,0,0,0.5); 184 | border-radius: 2px; 185 | line-height: 10px; 186 | padding: 1px 1px 1px 2px; 187 | } 188 | } 189 | .data { 190 | font-weight: bold; 191 | .missing { 192 | color: gray; 193 | font-style: italic; 194 | } 195 | } 196 | .val { 197 | font-weight: bold; 198 | color: #AA0E91; 199 | font-style: italic; 200 | } 201 | } 202 | -------------------------------------------------------------------------------- /src/Utils.purs: -------------------------------------------------------------------------------- 1 | module Utils 2 | ( maxInt 3 | , cls 4 | , readId 5 | , makeIndexed 6 | , getIndices 7 | , minOrd 8 | , maxOrd 9 | , getEntropy 10 | , initClipboard 11 | , createEvent 12 | , createErrorEvent 13 | , errorEventDetail 14 | , shorten 15 | , peek' 16 | , getInputFileList 17 | , Pagination 18 | , paginate 19 | , tryFormatNumber 20 | , fromChars 21 | , non 22 | ) where 23 | 24 | import Prelude 25 | import Data.String as Str 26 | import Halogen.HTML.Core as H 27 | import Halogen.HTML.Properties.Indexed as P 28 | import Math as Math 29 | import Control.Monad.Eff (Eff) 30 | import Control.Monad.Eff.Random (RANDOM, randomInt) 31 | import DOM (DOM) 32 | import DOM.Event.Types (Event, EventType(..)) 33 | import DOM.File.Types (FileList) 34 | import Data.Array (drop, take, length, (!!), (..), zip) 35 | import Data.Foldable (class Foldable, foldMap) 36 | import Data.Int (toNumber, ceil, fromNumber) 37 | import Data.Lens (Iso', iso) 38 | import Data.Maybe (Maybe(Just, Nothing), fromMaybe) 39 | import Data.Nullable (Nullable, toMaybe) 40 | import Data.String (fromCharArray, singleton, toCharArray) 41 | import Data.Tuple (Tuple(Tuple), fst) 42 | import Data.Unfoldable (replicateA) 43 | import Global (readInt) 44 | import Halogen (ParentDSL, ChildF(ChildF)) 45 | import Halogen.Component.ChildPath (ChildPath, prjSlot, prjQuery) 46 | import Types (ErrorDetail) 47 | 48 | maxInt :: Int -> Int -> Int 49 | maxInt x y = fromMaybe 0 $ fromNumber $ Math.max (toNumber x) (toNumber y) 50 | 51 | cls :: forall r i. String -> P.IProp (class :: P.I | r) i 52 | cls = P.class_ <<< H.className 53 | 54 | readId :: String -> Int 55 | readId str = case fromNumber (readInt 10 str) of 56 | Nothing -> 0 57 | Just x -> x 58 | 59 | makeIndexed :: forall a. Array a -> Array (Tuple Int a) 60 | makeIndexed xs = zip (0 .. length xs) xs 61 | 62 | getIndices :: forall a. Array a -> Array Int 63 | getIndices xs = map fst $ makeIndexed xs 64 | 65 | minOrd :: forall a. (Ord a) => a -> a -> a 66 | minOrd x y = case compare x y of 67 | LT -> x 68 | _ -> y 69 | 70 | maxOrd :: forall a. (Ord a) => a -> a -> a 71 | maxOrd x y = case compare x y of 72 | GT -> x 73 | _ -> y 74 | 75 | -- | Collect n/2 bytes of entropy using JS's `Math.random()` 76 | -- and return in hexadecimal form. 77 | getEntropy :: forall e. Int -> Eff (random :: RANDOM | e) String 78 | getEntropy n = fromCharArray <$> replicateA n do 79 | i <- randomInt 0 15 80 | pure $ fromMaybe '0' $ alphabet !! i 81 | where 82 | alphabet = toCharArray "0123456789abcdef" 83 | 84 | foreign import initClipboard :: forall e. String -> Eff (dom :: DOM | e) Unit 85 | 86 | foreign import createEventImpl :: String -> Event 87 | 88 | createEvent :: EventType -> Event 89 | createEvent (EventType typ) = createEventImpl typ 90 | 91 | foreign import createErrorEventImpl :: String -> ErrorDetail -> Event 92 | 93 | createErrorEvent :: EventType -> ErrorDetail -> Event 94 | createErrorEvent (EventType typ) detail = createErrorEventImpl typ detail 95 | 96 | foreign import errorEventDetailImpl :: Event -> Nullable ErrorDetail 97 | 98 | 99 | errorEventDetail :: Event -> Maybe ErrorDetail 100 | errorEventDetail = toMaybe <<< errorEventDetailImpl 101 | 102 | shorten :: String -> Int -> Maybe String 103 | shorten s len = let short = Str.take len s in 104 | if s == short then Nothing 105 | else Just short 106 | 107 | -- TODO: purescript-halogen PR 108 | peek' :: forall s s' s'' f f' f'' g p p' a 109 | . ChildPath s'' s' f'' f' p' p 110 | -> ChildF p f' a 111 | -> (p' -> f'' a -> ParentDSL s s' f f' g p Unit) 112 | -> ParentDSL s s' f f' g p Unit 113 | peek' cp (ChildF s q) action = case Tuple (prjSlot cp s) (prjQuery cp q) of 114 | Tuple (Just s') (Just q') -> action s' q' 115 | _ -> pure unit 116 | 117 | foreign import getInputFileListImpl :: forall eff. String -> Eff (dom :: DOM | eff) (Nullable FileList) 118 | 119 | -- | Get the input field with the given id. Only returns `Just` if at least one file 120 | -- has been selected. 121 | getInputFileList :: forall eff. String -> Eff (dom :: DOM | eff) (Maybe FileList) 122 | getInputFileList i = toMaybe <$> getInputFileListImpl i 123 | 124 | -- Pagination 125 | 126 | type Pagination a = 127 | { pages :: Int 128 | , page :: Int 129 | , from :: Int 130 | , to :: Int 131 | , total :: Int 132 | , items :: Array a 133 | } 134 | 135 | paginate :: forall a. Int -> Array a -> Int -> Pagination a 136 | paginate segmentLength xs currentPage = 137 | { pages: pages 138 | , page: page 139 | , from: minOrd (offset + 1) len 140 | , to: minOrd (offset + segmentLength) len 141 | , total: len 142 | , items: take segmentLength $ drop offset xs 143 | } 144 | where 145 | len = length xs 146 | offset = segmentLength * (page - 1) 147 | pages = maxOrd (ceil $ toNumber len / toNumber segmentLength) 1 148 | page = minOrd pages currentPage 149 | 150 | -- Number formatting 151 | 152 | foreign import tryFormatNumber :: Int -> String -> String 153 | 154 | -- Char <-> String 155 | 156 | fromChars :: forall f. Foldable f => f Char -> String 157 | fromChars = foldMap singleton 158 | 159 | -- non Iso 160 | 161 | non :: forall a. Eq a => a -> Iso' (Maybe a) a 162 | non def = iso (fromMaybe def) go 163 | where go a | a == def = Nothing 164 | | otherwise = Just a 165 | -------------------------------------------------------------------------------- /src/Component/Handsontable.purs: -------------------------------------------------------------------------------- 1 | module Component.Handsontable where 2 | 3 | import Prelude 4 | import Halogen.HTML.Indexed as H 5 | import Halogen.HTML.Properties.Indexed as P 6 | import Api.Schema.Table (Table(Table), YAxis(YAxisCustom, YAxisClosed)) 7 | import Component.Handsontable.Options (tableOptions) 8 | import Component.Handsontable.Utils (attachClickHandler, forceString, fromHotCoords, toHotCoords) 9 | import Control.Monad.Aff.Free (fromEff) 10 | import DOM.HTML.Types (HTMLElement) 11 | import Data.Array (length) 12 | import Data.Foldable (for_) 13 | import Data.Maybe (Maybe(Nothing, Just)) 14 | import Data.Tuple (Tuple(Tuple)) 15 | import Halogen (ComponentDSL, ComponentHTML, Component, action, eventSource_, subscribe, eventSource, modify, get, lifecycleComponent) 16 | import Handsontable (populateFromArray, handsontableNode, destroy, render) as Hot 17 | import Handsontable.Hooks (onAfterRender, onAfterChange) as Hot 18 | import Handsontable.Types (Handsontable, ChangeSource(ChangeSpliceRow, ChangeSpliceCol, ChangePaste, ChangeAutofill, ChangeLoadData, ChangePopulateFromArray, ChangeEdit, ChangeEmpty, ChangeAlter), Direction(DirectionDown), PopulateMethod(Overwrite)) as Hot 19 | import Lib.BusinessData (BusinessData, getCustomYMembersBySheet, getFactTable) 20 | import Lib.Table (C(..), Coord(..), R(..), S) 21 | import Types (Metrix) 22 | import Utils (getIndices, initClipboard, cls) 23 | 24 | type State = 25 | { hotInstance :: Maybe (Hot.Handsontable String) 26 | , hotRoot :: Maybe HTMLElement 27 | } 28 | 29 | initialState :: State 30 | initialState = 31 | { hotInstance: Nothing 32 | , hotRoot: Nothing 33 | } 34 | 35 | type Changes = Array (Tuple Coord String) 36 | 37 | data Query a 38 | = Init a 39 | | SetRoot (Maybe HTMLElement) a 40 | | Edit Changes a 41 | | AddRow a 42 | | DeleteRow Int a 43 | | Rebuild S Table BusinessData a 44 | 45 | handsontable :: S -> Table -> BusinessData -> Component State Query Metrix 46 | handsontable propS propTable propBusinessData = lifecycleComponent 47 | { render 48 | , eval 49 | , initializer: Just (action Init) 50 | , finalizer: Nothing 51 | } 52 | where 53 | 54 | render :: State -> ComponentHTML Query 55 | render = const $ H.div 56 | [ cls "hotContainer" 57 | , P.ref \el -> action (SetRoot el) 58 | ] [] 59 | 60 | eval :: Query ~> ComponentDSL State Query Metrix 61 | eval (Init next) = do 62 | build propS propTable propBusinessData 63 | pure next 64 | 65 | eval (SetRoot el next) = do 66 | modify _{ hotRoot = el } 67 | pure next 68 | 69 | eval (Edit changes next) = do 70 | pure next 71 | 72 | eval (AddRow next) = do 73 | pure next 74 | 75 | eval (DeleteRow index next) = do 76 | pure next 77 | 78 | eval (Rebuild s table bd next) = do 79 | build s table bd 80 | pure next 81 | 82 | build :: S -> Table -> BusinessData -> ComponentDSL State Query Metrix Unit 83 | build s table@(Table tbl) bd = do 84 | st <- get 85 | case st.hotRoot of 86 | Nothing -> pure unit 87 | Just el -> do 88 | case st.hotInstance of 89 | Nothing -> pure unit 90 | Just hot -> fromEff $ Hot.destroy hot 91 | 92 | hot <- fromEff $ Hot.handsontableNode el (tableOptions s table bd) 93 | modify _{ hotInstance = Just hot } 94 | 95 | subscribe $ eventSource (\cb -> Hot.onAfterChange hot (\c s' -> cb (Tuple c s'))) \(Tuple changes source) -> do 96 | let procChange change = let coord = fromHotCoords table change.col change.row 97 | in Tuple (Coord (C coord.col) (R coord.row) s) (forceString change.new) 98 | go = pure $ action $ Edit $ procChange <$> changes 99 | no = pure $ action $ Edit [] 100 | case source of 101 | Hot.ChangeAlter -> no 102 | Hot.ChangeEmpty -> no 103 | Hot.ChangeEdit -> go 104 | Hot.ChangePopulateFromArray -> no 105 | Hot.ChangeLoadData -> no 106 | Hot.ChangeAutofill -> go 107 | Hot.ChangePaste -> go 108 | Hot.ChangeSpliceCol -> no 109 | Hot.ChangeSpliceRow -> no 110 | 111 | case tbl.tableYAxis of 112 | YAxisClosed _ _ -> pure unit 113 | YAxisCustom axId _ -> do 114 | fromEff $ Hot.onAfterRender hot \_ -> initClipboard ".clipboard" 115 | subscribe $ eventSource_ (attachClickHandler hot "#newCustomY") do 116 | pure $ action AddRow 117 | for_ (getIndices $ getCustomYMembersBySheet axId s table bd) \i -> 118 | subscribe $ eventSource_ (attachClickHandler hot ("#delCustomY" <> show i)) do 119 | pure $ action $ DeleteRow i 120 | 121 | case getFactTable s table bd of 122 | Just vals | length vals > 0 -> do 123 | fromEff $ Hot.populateFromArray (toHotCoords table 0 0) vals Nothing Nothing Hot.Overwrite Hot.DirectionDown [] hot 124 | pure unit 125 | _ -> fromEff $ Hot.render hot 126 | 127 | -- TODO: adjust resize 128 | 129 | -- resize :: Eff _ Unit 130 | -- resize = do 131 | -- body <- DOM.document DOM.globalWindow >>= DOM.body 132 | -- w <- DOM.innerWidth DOM.globalWindow 133 | -- h <- DOM.innerHeight DOM.globalWindow 134 | -- els <- DOM.nodeListToArray =<< DOM.querySelectorAll ".hotContainer" body 135 | -- for_ els \el -> do 136 | -- DOM.setStyleAttr "width" (show (w - 20.0) <> "px") el 137 | -- DOM.setStyleAttr "height" (show (h - 300.0) <> "px") el 138 | -------------------------------------------------------------------------------- /src/Api/Schema/BusinessData/Key.purs: -------------------------------------------------------------------------------- 1 | module Api.Schema.BusinessData.Key 2 | ( Key(..) 3 | , IsRowKey(..) 4 | , YLocation(..) 5 | , ZLocation(..) 6 | , parseKeyF 7 | ) where 8 | 9 | import Control.Alt ((<|>)) 10 | import Data.Either (Either(Right, Left)) 11 | import Data.Foldable (foldl) 12 | import Data.Foreign (F, ForeignError(JSONError), fail) 13 | import Data.Function (on) 14 | import Data.String (toCharArray) 15 | import Prelude 16 | import Text.Parsing.StringParser (Parser, runParser) 17 | import Text.Parsing.StringParser.Combinators (many1, ()) 18 | import Text.Parsing.StringParser.String (oneOf, string) 19 | import Types (OrdinateId, SubsetMemberId, CustomMemberId, AxisId, CellId) 20 | import Utils (fromChars) 21 | 22 | data Key 23 | = KeyHeaderFact CellId 24 | | KeyFact CellId IsRowKey YLocation ZLocation 25 | | KeySubsetZSelected AxisId SubsetMemberId 26 | | KeyCustomZMember AxisId CustomMemberId 27 | | KeyCustomRow AxisId ZLocation CustomMemberId -- value: order 28 | 29 | data IsRowKey 30 | = RowKey 31 | | NoRowKey 32 | 33 | data YLocation 34 | = YLocClosed 35 | | YLocCustom AxisId CustomMemberId 36 | 37 | data ZLocation 38 | = ZLocSingle 39 | | ZLocClosed OrdinateId 40 | | ZLocCustom AxisId CustomMemberId 41 | | ZLocSubset AxisId SubsetMemberId 42 | 43 | instance showKey :: Show Key where 44 | show (KeyHeaderFact c) = "a" <> showCell c 45 | show (KeyFact c r y z) = "b" <> showCell c <> show r <> show y <> show z 46 | show (KeySubsetZSelected a s) = "c" <> showAxis a <> showSM s 47 | show (KeyCustomZMember a c) = "d" <> showAxis a <> showCM c 48 | show (KeyCustomRow a z c) = "e" <> showAxis a <> show z <> showCM c 49 | 50 | instance showIsRowKey :: Show IsRowKey where 51 | show (RowKey) = "f" 52 | show (NoRowKey) = "g" 53 | 54 | instance showYLocation :: Show YLocation where 55 | show (YLocClosed) = "h" 56 | show (YLocCustom a c) = "i" <> showAxis a <> showCM c 57 | 58 | instance showZLocation :: Show ZLocation where 59 | show (ZLocSingle) = "j" 60 | show (ZLocClosed o) = "k" <> showOrd o 61 | show (ZLocCustom a c) = "l" <> showAxis a <> showCM c 62 | show (ZLocSubset a s) = "m" <> showAxis a <> showSM s 63 | 64 | showCell :: CellId -> String 65 | showCell c = "n" <> show c 66 | 67 | showAxis :: AxisId -> String 68 | showAxis a = "o" <> show a 69 | 70 | showCM :: CustomMemberId -> String 71 | showCM c = "p<" <> c <> ">" 72 | 73 | showSM :: SubsetMemberId -> String 74 | showSM s = "q" <> show s 75 | 76 | showOrd :: OrdinateId -> String 77 | showOrd o = "r" <> show o 78 | 79 | -- Eq 80 | 81 | instance eqKey :: Eq Key where 82 | eq = eq `on` show 83 | 84 | instance eqZLocation :: Eq ZLocation where 85 | eq = eq `on` show 86 | 87 | -- Ord 88 | 89 | instance ordKey :: Ord Key where 90 | compare = compare `on` show 91 | 92 | instance ordZLocation :: Ord ZLocation where 93 | compare = compare `on` show 94 | 95 | -- Read 96 | 97 | parseKeyF :: String -> F Key 98 | parseKeyF str = case runParser key str of 99 | Left err -> fail $ JSONError $ "Failed parsing key: " <> show err 100 | Right a -> pure a 101 | 102 | key :: Parser Key 103 | key = 104 | string "a" *> (KeyHeaderFact <$> cellId) 105 | <|> string "b" *> (KeyFact <$> cellId <*> rowKey <*> yLocation <*> zLocation) 106 | <|> string "c" *> (KeySubsetZSelected <$> axisId <*> subsetMemberId) 107 | <|> string "d" *> (KeyCustomZMember <$> axisId <*> customMemberId) 108 | <|> string "e" *> (KeyCustomRow <$> axisId <*> zLocation <*> customMemberId) 109 | "Key" 110 | 111 | rowKey :: Parser IsRowKey 112 | rowKey = 113 | string "f" *> pure RowKey 114 | <|> string "g" *> pure NoRowKey 115 | "RowKey" 116 | 117 | yLocation :: Parser YLocation 118 | yLocation = 119 | string "h" *> pure YLocClosed 120 | <|> string "i" *> (YLocCustom <$> axisId <*> customMemberId) 121 | "YLocation" 122 | 123 | zLocation :: Parser ZLocation 124 | zLocation = 125 | string "j" *> pure ZLocSingle 126 | <|> string "k" *> (ZLocClosed <$> ordinateId) 127 | <|> string "l" *> (ZLocCustom <$> axisId <*> customMemberId) 128 | <|> string "m" *> (ZLocSubset <$> axisId <*> subsetMemberId) 129 | "ZLocation" 130 | 131 | cellId :: Parser CellId 132 | cellId = 133 | string "n" *> integer 134 | 135 | axisId :: Parser AxisId 136 | axisId = 137 | string "o" *> integer 138 | 139 | customMemberId :: Parser CustomMemberId 140 | customMemberId = 141 | string "p" *> string "<" *> hex <* string ">" 142 | 143 | subsetMemberId :: Parser SubsetMemberId 144 | subsetMemberId = 145 | string "q" *> integer 146 | 147 | ordinateId :: Parser OrdinateId 148 | ordinateId = 149 | string "r" *> integer 150 | 151 | -- Generic parse stuff 152 | 153 | pDigit :: Parser Int 154 | pDigit = 155 | (string "0" *> pure 0) 156 | <|> (string "1" *> pure 1) 157 | <|> (string "2" *> pure 2) 158 | <|> (string "3" *> pure 3) 159 | <|> (string "4" *> pure 4) 160 | <|> (string "5" *> pure 5) 161 | <|> (string "6" *> pure 6) 162 | <|> (string "7" *> pure 7) 163 | <|> (string "8" *> pure 8) 164 | <|> (string "9" *> pure 9) 165 | 166 | hex :: Parser String 167 | hex = fromChars <$> (many1 $ oneOf $ toCharArray "0123456789abcdef") 168 | 169 | integer :: Parser Int 170 | integer = foldl addDigit 0 <$> many1 pDigit 171 | where addDigit num d = 10 * num + d 172 | -------------------------------------------------------------------------------- /sass/partials/_toolbar.scss: -------------------------------------------------------------------------------- 1 | .toolbar { 2 | position: relative; 3 | width: 100%; 4 | height: $toolbar-height; 5 | background-color: $metrix-blue; 6 | border-bottom: 1px solid darken($metrix-blue, 5%); 7 | background-image: url("../img/toolbar-background.png"); 8 | background-size: contain; 9 | background-position: center; 10 | background-repeat: no-repeat; 11 | } 12 | 13 | .tool { 14 | position: absolute; 15 | top: 0px; 16 | bottom: 0px; 17 | z-index: 1004; 18 | background-color: $metrix-blue; 19 | p { 20 | margin: -1px 0px -2px 1px; 21 | } 22 | input { 23 | width: 100%; 24 | box-sizing: border-box; 25 | } 26 | } 27 | 28 | .toolsep { 29 | @extend .tool; 30 | width: 0px; 31 | border-right: 1px solid lighten($metrix-blue, 5%); 32 | border-left: 1px solid darken($metrix-blue, 10%); 33 | } 34 | 35 | .toolbutton { 36 | @extend .tool; 37 | cursor: pointer; 38 | color: #4D595D; 39 | &:hover { 40 | background-color: lighten($metrix-blue, 5%); 41 | color: $metrix-darkgray; 42 | } 43 | &:active { 44 | background-color: lighten($metrix-blue, 7%); 45 | color: black; 46 | } 47 | .icon { 48 | position: absolute; 49 | top: 4px; 50 | left: 50%; 51 | transform: translate(-50%,0px); 52 | font-size: 26px; 53 | line-height: 26px; 54 | } 55 | .label { 56 | position: absolute; 57 | bottom: 4px; 58 | line-height: 9px; 59 | font-size: 9px; 60 | left: 0px; 61 | right: 0px; 62 | text-align: center; 63 | text-transform: uppercase; 64 | } 65 | } 66 | 67 | .disabled { 68 | color: lighten(#4D595D, 30%); 69 | &:hover { 70 | color: lighten(#4D595D, 30%); 71 | } 72 | } 73 | 74 | // -- 75 | 76 | .tooldim-choose-file { 77 | width: $toolwidth-choose-file; 78 | left: 0px; 79 | padding: 3px; 80 | input { 81 | width: $toolwidth-choose-file - 6px; 82 | } 83 | } 84 | 85 | .tooldim-import-xbrl { 86 | width: $toolwidth-import-xbrl; 87 | left: $toolwidth-choose-file; 88 | } 89 | 90 | .tooldim-import-baresto { 91 | width: $toolwidth-import-baresto; 92 | left: $toolwidth-choose-file 93 | + $toolwidth-import-xbrl; 94 | } 95 | 96 | .tooldim-sep-xbrl { 97 | left: $toolwidth-choose-file 98 | + $toolwidth-import-xbrl 99 | + $toolwidth-import-baresto; 100 | } 101 | 102 | .tooldim-name-file { 103 | width: $toolwidth-name-file; 104 | left: $toolwidth-choose-file 105 | + $toolwidth-import-xbrl 106 | + $toolwidth-import-baresto 107 | + $toolsep-width; 108 | padding: 3px; 109 | input { 110 | width: $toolwidth-name-file - 6px; 111 | } 112 | } 113 | 114 | .tooldim-create { 115 | width: $toolwidth-create; 116 | left: $toolwidth-choose-file 117 | + $toolwidth-import-xbrl 118 | + $toolwidth-import-baresto 119 | + $toolsep-width 120 | + $toolwidth-name-file; 121 | } 122 | 123 | .tooldim-sep-create { 124 | left: $toolwidth-choose-file 125 | + $toolwidth-import-xbrl 126 | + $toolwidth-import-baresto 127 | + $toolsep-width 128 | + $toolwidth-name-file 129 | + $toolwidth-create; 130 | } 131 | 132 | // -- 133 | 134 | .tooldim-close { 135 | width: $toolwidth-close; 136 | right: 0px; 137 | } 138 | 139 | .tooldim-sep-close { 140 | right: $toolwidth-close; 141 | } 142 | 143 | .tooldim-menu { 144 | width: $toolwidth-menu; 145 | right: $toolwidth-close 146 | + $toolsep-width; 147 | } 148 | 149 | .tooldim-sep-menu { 150 | right: $toolwidth-close 151 | + $toolsep-width 152 | + $toolwidth-menu; 153 | } 154 | 155 | .tooldim-mb { 156 | position: absolute; 157 | top: 0px; 158 | bottom: 0px; 159 | width: $toolwidth-mb; 160 | right: $toolwidth-close 161 | + $toolsep-width 162 | + $toolwidth-menu 163 | + $toolsep-width; 164 | } 165 | 166 | .tooldim-sep-mb { 167 | right: $toolwidth-close 168 | + $toolsep-width 169 | + $toolwidth-menu 170 | + $toolsep-width 171 | + $toolwidth-mb; 172 | } 173 | 174 | .tooldim-sheets { 175 | width: $toolwidth-sheets; 176 | right: $toolwidth-close 177 | + $toolsep-width 178 | + $toolwidth-menu 179 | + $toolsep-width 180 | + $toolwidth-mb 181 | + $toolsep-width; 182 | box-sizing: border-box; 183 | padding: 3px; 184 | .tooldim-conf { 185 | right: 0px; 186 | width: $toolwidth-conf; 187 | } 188 | } 189 | 190 | .tooldim-sep-sheets { 191 | right: $toolwidth-close 192 | + $toolsep-width 193 | + $toolwidth-menu 194 | + $toolsep-width 195 | + $toolwidth-mb 196 | + $toolsep-width 197 | + $toolwidth-sheets; 198 | } 199 | 200 | // -- 201 | 202 | .tooldim-fileinfo { 203 | right: $toolwidth-close 204 | + $toolsep-width 205 | + $toolwidth-menu 206 | + $toolsep-width 207 | + $toolwidth-mb 208 | + $toolsep-width 209 | + $toolwidth-sheets 210 | + $toolsep-width; 211 | left: 0px; 212 | overflow: hidden; 213 | .name { 214 | float: left; 215 | min-width: 150px; 216 | padding-left: 3px; 217 | line-height: $toolbar-height; 218 | font-size: 20pt; 219 | position: relative; 220 | top: -8px; 221 | font-weight: bold; 222 | margin: 0px 10px 0px 0px; 223 | } 224 | .saved { 225 | position: absolute; 226 | bottom: -1px; 227 | left: 3px; 228 | color: lighten(#4D595D, 30%); 229 | 230 | .octicon { 231 | width: 16px; 232 | text-align: center; 233 | color: #8DC63F; 234 | } 235 | 236 | .octicon-x { 237 | color: darken(red, 20%); 238 | } 239 | 240 | .spinner { 241 | margin: 2px; 242 | box-sizing: border-box; 243 | position: relative; 244 | top: 2px; 245 | width: 12px; 246 | height: 12px; 247 | border: 2px solid lighten(#4D595D, 30%); 248 | border-right-color: transparent; 249 | border-radius: 50%; 250 | -webkit-animation: spin 0.5s linear infinite; 251 | display: inline-block; 252 | } 253 | } 254 | .module { 255 | float: left; 256 | padding: 3px; 257 | } 258 | } 259 | 260 | 261 | @-webkit-keyframes spin { 262 | from { 263 | -webkit-transform: rotate(0deg); 264 | } 265 | 50% { 266 | -webkit-transform: rotate(180deg); 267 | } 268 | to { 269 | -webkit-transform: rotate(360deg); 270 | } 271 | } 272 | -------------------------------------------------------------------------------- /src/Api/Schema/Table.purs: -------------------------------------------------------------------------------- 1 | module Api.Schema.Table where 2 | 3 | import Api.Schema.Common (getPair) 4 | import Data.Foreign (ForeignError(JSONError), fail) 5 | import Data.Foreign.Class (class IsForeign, readProp, read) 6 | import Data.Foreign.NullOrUndefined (unNullOrUndefined) 7 | import Data.Maybe (Maybe) 8 | import Prelude 9 | import Types (OrdinateId, MemberId, XBRLCodeSet, AxisId, CellId, TableId) 10 | 11 | type XHeader = Array (Array XHeaderCell) 12 | type Ordinates = Array Ordinate 13 | 14 | newtype Table = Table 15 | { tableId :: TableId 16 | , tableName :: String 17 | , tableGrid :: Grid 18 | , tableIsHeader :: Boolean 19 | , tableXHeader :: XHeader 20 | , tableXOrdinates :: Ordinates 21 | , tableZAxis :: ZAxis 22 | , tableYAxis :: YAxis 23 | } 24 | 25 | instance isForeignTable :: IsForeign Table where 26 | read json = do 27 | tbl <- { tableId: _ 28 | , tableName: _ 29 | , tableGrid: _ 30 | , tableIsHeader: _ 31 | , tableXHeader: _ 32 | , tableXOrdinates: _ 33 | , tableZAxis: _ 34 | , tableYAxis: _ 35 | } 36 | <$> readProp "id" json 37 | <*> readProp "name" json 38 | <*> readProp "grid" json 39 | <*> readProp "isHeader" json 40 | <*> readProp "xHeader" json 41 | <*> readProp "xOrdinates" json 42 | <*> readProp "zAxis" json 43 | <*> readProp "yAxis" json 44 | pure $ Table tbl 45 | 46 | data Grid = Grid (Array Sheet) 47 | 48 | instance isForeignGrid :: IsForeign Grid where 49 | read json = Grid <$> read json 50 | 51 | data Sheet = Sheet (Array Row) 52 | 53 | instance isForeignSheet :: IsForeign Sheet where 54 | read json = Sheet <$> read json 55 | 56 | data Row = Row (Array Cell) 57 | 58 | instance isForeignRow :: IsForeign Row where 59 | read json = Row <$> read json 60 | 61 | data Cell 62 | = ShadedCell 63 | | FactCell CellId DataType 64 | | YMemberCell CellId 65 | | NoCell 66 | 67 | instance isForeignCell :: IsForeign Cell where 68 | read json = do 69 | cellType <- readProp "type" json 70 | case cellType of 71 | "shaded" -> pure ShadedCell 72 | "fact" -> FactCell <$> readProp "id" json <*> readProp "dataType" json 73 | "yMember" -> YMemberCell <$> readProp "id" json 74 | "noCell" -> pure NoCell 75 | _ -> fail $ JSONError "expected `shaded`, `fact`, `yMember` or `noCell`" 76 | 77 | newtype XHeaderCell = XHeaderCell 78 | { colspan :: Int 79 | , ordinate :: Maybe Ordinate 80 | } 81 | 82 | instance isForeignXHeaderCell :: IsForeign XHeaderCell where 83 | read json = do 84 | cell <- { colspan: _, ordinate: _ } 85 | <$> readProp "colspan" json 86 | <*> (unNullOrUndefined <$> readProp "ordinate" json) 87 | pure $ XHeaderCell cell 88 | 89 | data ZAxis 90 | = ZAxisSingleton 91 | | ZAxisClosed AxisId Ordinates 92 | | ZAxisCustom AxisId String 93 | | ZAxisSubset AxisId String (Array SubsetMemberOption) 94 | 95 | instance isForeignZAxis :: IsForeign ZAxis where 96 | read json = do 97 | axisType <- readProp "type" json 98 | case axisType of 99 | "singleton" -> pure ZAxisSingleton 100 | "closed" -> ZAxisClosed <$> readProp "id" json 101 | <*> readProp "ordinates" json 102 | "custom" -> ZAxisCustom <$> readProp "id" json 103 | <*> readProp "label" json 104 | "subset" -> ZAxisSubset <$> readProp "id" json 105 | <*> readProp "label" json 106 | <*> readProp "options" json 107 | _ -> fail $ JSONError "expected `singleton`, `closed`, `custom` or `subset`" 108 | 109 | data YAxis 110 | = YAxisClosed AxisId Ordinates 111 | | YAxisCustom AxisId String 112 | 113 | instance isForeignYAxis :: IsForeign YAxis where 114 | read json = do 115 | axisType <- readProp "type" json 116 | case axisType of 117 | "closed" -> YAxisClosed <$> readProp "id" json 118 | <*> readProp "ordinates" json 119 | "custom" -> YAxisCustom <$> readProp "id" json 120 | <*> readProp "label" json 121 | _ -> fail $ JSONError "expected `closed` or `custom`" 122 | 123 | data DataType 124 | = BooleanData 125 | | DateData 126 | | IntegerData 127 | | MonetaryData 128 | | PercentageData 129 | | CodeData XBRLCodeSet 130 | | StringData 131 | | NumberData 132 | 133 | instance isForeignDataType :: IsForeign DataType where 134 | read json = do 135 | dataType <- readProp "type" json 136 | case dataType of 137 | "boolean" -> pure BooleanData 138 | "date" -> pure DateData 139 | "integer" -> pure IntegerData 140 | "monetary" -> pure MonetaryData 141 | "percentage" -> pure PercentageData 142 | "code" -> CodeData <<< map getPair <$> readProp "xbrlCodeSet" json 143 | "string" -> pure StringData 144 | "number" -> pure NumberData 145 | _ -> fail $ JSONError "unexpected data type" 146 | 147 | newtype SubsetMemberOption = SubsetMemberOption 148 | { memberId :: MemberId 149 | , memberLabel :: String 150 | , memberLevel :: Int 151 | } 152 | 153 | instance isForeignMember :: IsForeign SubsetMemberOption where 154 | read json = do 155 | m <- { memberId: _, memberLabel: _, memberLevel: _ } 156 | <$> readProp "id" json 157 | <*> readProp "label" json 158 | <*> readProp "level" json 159 | pure $ SubsetMemberOption m 160 | 161 | newtype Ordinate = Ordinate 162 | { ordinateLabel :: String 163 | , ordinateId :: OrdinateId 164 | , ordinateCode :: String 165 | , ordinateIsAbstract :: Boolean 166 | , ordinateLevel :: Int 167 | } 168 | 169 | instance isForeignOrdinate :: IsForeign Ordinate where 170 | read json = do 171 | ord <- { ordinateLabel: _ 172 | , ordinateId: _ 173 | , ordinateCode: _ 174 | , ordinateIsAbstract: _ 175 | , ordinateLevel: _ 176 | } 177 | <$> readProp "label" json 178 | <*> readProp "id" json 179 | <*> readProp "code" json 180 | <*> readProp "abstract" json 181 | <*> readProp "level" json 182 | pure $ Ordinate ord 183 | -------------------------------------------------------------------------------- /src/Api.purs: -------------------------------------------------------------------------------- 1 | module Api where 2 | 3 | import Prelude 4 | import Component.ErrorBox as ErrorBox 5 | import Component.Spinner as Spinner 6 | import Api.Common (Api, getJsonResponse, getUnitResponse, uploadFiles, postJson) 7 | import Api.Schema (JsonEither, Name(Name)) 8 | import Api.Schema.Auth (AuthInfo) 9 | import Api.Schema.BusinessData (SnapshotDesc, UpdateDesc, UpdatePostResult, UpdatePost, TagDesc) 10 | import Api.Schema.File (File, FileDesc) 11 | import Api.Schema.Import (CsvImportConf, XbrlImportConf) 12 | import Api.Schema.Module (Module) 13 | import Api.Schema.Selector (Framework) 14 | import Api.Schema.Table (Table) 15 | import Api.Schema.Validation (ValidationResult) 16 | import Control.Monad.Aff.Free (class Affable, fromAff, fromEff) 17 | import Control.Monad.Except.Trans (runExceptT) 18 | import DOM.File.Types (FileList) 19 | import Data.Either (Either(Right, Left)) 20 | import Data.Foreign.Null (Null) 21 | import Halogen.Component (ParentDSL, ComponentDSL, liftQuery) 22 | import Network.HTTP.Affjax (get) 23 | import Types (FileId, ModuleId, TableId, TagId, UpdateId, Effects) 24 | 25 | apiCall 26 | :: forall a s f g 27 | . ( Affable Effects g 28 | , Monad g ) 29 | => Api _ a 30 | -> (a -> ComponentDSL s f g Unit) 31 | -> ComponentDSL s f g Unit 32 | apiCall call onSuccess = do 33 | fromEff $ Spinner.dispatch true 34 | result <- fromAff $ runExceptT call 35 | fromEff $ Spinner.dispatch false 36 | case result of 37 | Left err -> fromEff $ ErrorBox.raise err 38 | Right x -> onSuccess x 39 | 40 | apiCallParent 41 | :: forall a s s' f f' g p 42 | . ( Affable Effects g 43 | , Monad g ) 44 | => Api _ a 45 | -> (a -> ParentDSL s s' f f' g p Unit) 46 | -> ParentDSL s s' f f' g p Unit 47 | apiCallParent call onSuccess = do 48 | liftQuery $ fromEff $ Spinner.dispatch true 49 | result <- liftQuery $ fromAff $ runExceptT call 50 | liftQuery $ fromEff $ Spinner.dispatch false 51 | case result of 52 | Left err -> liftQuery $ fromEff $ ErrorBox.raise err 53 | Right x -> onSuccess x 54 | 55 | -- 56 | 57 | foreign import apiUrl :: String 58 | 59 | prefix :: String 60 | prefix = apiUrl <> "/api/v0.1/" 61 | 62 | -- Api.Table 63 | 64 | getTable :: forall eff. ModuleId -> TableId -> Api eff Table 65 | getTable modId tableId = getJsonResponse "Could not fetch table." $ 66 | get $ prefix <> "table/get/" <> show modId <> "/" <> show tableId 67 | 68 | getHeader :: forall eff. Api eff Table 69 | getHeader = getJsonResponse "Could not fetch header." $ 70 | get $ prefix <> "table/header/DE" 71 | 72 | -- Api.Module 73 | 74 | getModule :: forall eff. ModuleId -> Api eff Module 75 | getModule modId = getJsonResponse "Could not load templates of module." $ 76 | get $ prefix <> "module/get/" <> show modId 77 | 78 | -- Api.BusinessData 79 | 80 | newFile :: forall eff. ModuleId -> String -> Api eff SnapshotDesc 81 | newFile modId name = getJsonResponse "Could not create file." $ 82 | postJson (prefix <> "businessdata/file/new/" <> show modId) (Name name) 83 | 84 | deleteFile :: forall eff. FileId -> Api eff Unit 85 | deleteFile fileId = getUnitResponse "Error deleting file." $ 86 | get $ prefix <> "businessdata/file/delete/" <> show fileId 87 | 88 | renameFile :: forall eff. FileId -> String -> Api eff String 89 | renameFile fileId newName = getJsonResponse "Error renaming file." $ 90 | postJson (prefix <> "businessdata/file/rename/" <> show fileId) (Name newName) 91 | 92 | listFiles :: forall eff. Api eff (Array File) 93 | listFiles = getJsonResponse "Could not get files." $ 94 | get $ prefix <> "businessdata/file/all" 95 | 96 | getFileOrphans :: forall eff. FileId -> Api eff (Array UpdateDesc) 97 | getFileOrphans fileId = getJsonResponse "Could not get auto saves." $ 98 | get $ prefix <> "businessdata/file/orphans/" <> show fileId 99 | 100 | getFileTags :: forall eff. FileId -> Api eff (Array TagDesc) 101 | getFileTags fileId = getJsonResponse "Could not get file tags." $ 102 | get $ prefix <> "businessdata/file/tags/" <> show fileId 103 | 104 | -- 105 | 106 | newTag :: forall eff. UpdateId -> String -> Api eff TagDesc 107 | newTag updateId name = getJsonResponse "Could not create tag." $ 108 | postJson (prefix <> "businessdata/tag/new/" <> show updateId) (Name name) 109 | 110 | deleteTag :: forall eff. TagId -> Api eff Unit 111 | deleteTag tagId = getUnitResponse "Could not delete tag." $ 112 | get $ prefix <> "businessdata/tag/delete/" <> show tagId 113 | 114 | renameTag :: forall eff. TagId -> String -> Api eff String 115 | renameTag tagId newName = getJsonResponse "Could not rename tag." $ 116 | postJson (prefix <> "businessdata/tag/rename/" <> show tagId) (Name newName) 117 | 118 | -- 119 | 120 | getUpdateSnapshot :: forall eff. UpdateId -> Api eff SnapshotDesc 121 | getUpdateSnapshot updateId = getJsonResponse "Could not load file." $ 122 | get $ prefix <> "businessdata/update/snapshot/" <> show updateId 123 | 124 | postUpdate :: forall eff. UpdatePost -> Api eff UpdatePostResult 125 | postUpdate upd = getJsonResponse "Could not send update." $ 126 | postJson (prefix <> "businessdata/update") upd 127 | 128 | getFileDetails :: UpdateId -> forall eff. Api eff FileDesc 129 | getFileDetails updateId = getJsonResponse "Could not get file details." $ 130 | get $ prefix <> "businessdata/update/file/" <> show updateId 131 | 132 | getUpdatePast :: forall eff. UpdateId -> Api eff (Array UpdateDesc) 133 | getUpdatePast updateId = getJsonResponse "Could not get revisions." $ 134 | get $ prefix <> "businessdata/update/past/" <> show updateId 135 | 136 | pruneOrphan :: forall eff. UpdateId -> Api eff Unit 137 | pruneOrphan updateId = getUnitResponse "Could not delete orphan." $ 138 | get $ prefix <> "businessdata/update/prune/" <> show updateId 139 | 140 | -- 141 | 142 | uploadXbrl :: forall eff. FileList -> Api eff XbrlImportConf 143 | uploadXbrl files = getJsonResponse "Could not upload XBRL file." $ 144 | uploadFiles (prefix <> "xbrl/import") files 145 | 146 | uploadBaresto :: forall eff. FileList -> Api eff File 147 | uploadBaresto files = getJsonResponse "Could not upload Baresto file." $ 148 | uploadFiles (prefix <> "baresto/import") files 149 | 150 | uploadCsv :: forall eff. UpdateId -> FileList -> Api eff CsvImportConf 151 | uploadCsv lastUpdateId files = getJsonResponse "Could not upload CSV file." $ 152 | uploadFiles (prefix <> "csv/import/" <> show lastUpdateId) files 153 | 154 | -- Api.Selector 155 | 156 | listFrameworks :: forall eff. Api eff (Array Framework) 157 | listFrameworks = getJsonResponse "Could not get frameworks." $ 158 | get $ prefix <> "selector/frameworks" 159 | 160 | -- Api.Validate 161 | 162 | validate :: forall eff. UpdateId -> Api eff ValidationResult 163 | validate updateId = getJsonResponse "Could not validate." $ 164 | get $ prefix <> "validate/byUpdateId/" <> show updateId 165 | 166 | -- Api.Auth 167 | 168 | login :: forall eff. String -> String -> Api eff (JsonEither String AuthInfo) 169 | login customerId pw = getJsonResponse "Could not login." $ 170 | get $ prefix <> "auth/login/?customerId=" <> customerId <> "&password=" <> pw 171 | 172 | logout :: forall eff. Api eff Unit 173 | logout = getUnitResponse "Error logging out." $ 174 | get $ prefix <> "auth/logout" 175 | 176 | loginStatus :: forall eff. Api eff (Null AuthInfo) 177 | loginStatus = getJsonResponse "Could not get login status." $ 178 | get $ prefix <> "auth/status" 179 | -------------------------------------------------------------------------------- /src/Api/Schema/BusinessData.purs: -------------------------------------------------------------------------------- 1 | module Api.Schema.BusinessData where 2 | 3 | import Prelude 4 | import Data.Map as M 5 | import Api.Schema.BusinessData.Key (Key, parseKeyF) 6 | import Api.Schema.BusinessData.Value (Value(Value), UpdateValue(UpdateValuePrecision, UpdateValueData)) 7 | import Api.Schema.Common (Pair(Pair)) 8 | import Api.Schema.Validation (ValidationType, HoleCoords, ValidationResult) 9 | import Data.Argonaut.Core (jsonEmptyObject) 10 | import Data.Argonaut.Encode (class EncodeJson, encodeJson) 11 | import Data.Argonaut.Encode.Combinators ((:=), (~>)) 12 | import Data.Foreign (ForeignError(JSONError), fail) 13 | import Data.Foreign.Class (class IsForeign, readProp, read) 14 | import Data.Foreign.Keys (keys) 15 | import Data.Foreign.NullOrUndefined (unNullOrUndefined) 16 | import Data.List (toUnfoldable) 17 | import Data.Map (fromFoldable) 18 | import Data.Maybe (Maybe) 19 | import Data.Traversable (traverse) 20 | import Data.Tuple (Tuple(Tuple)) 21 | import Types (UTCTime, UpdateId, TagId) 22 | 23 | newtype Update = Update (Array (Tuple Key UpdateValue)) 24 | 25 | instance isForeignUpdate :: IsForeign Update where 26 | read json = do 27 | list <- read json 28 | let mkPair (Pair (Tuple k v)) = Tuple <$> parseKeyF k <*> read v 29 | Update <$> traverse mkPair list 30 | 31 | instance encodeJsonUpdate :: EncodeJson Update where 32 | encodeJson (Update m) = encodeJson (showKeys <$> m) 33 | where showKeys (Tuple k v) = Pair $ Tuple (show k) v 34 | 35 | newtype Snapshot = Snapshot (M.Map Key Value) 36 | 37 | instance isForeignSnapshot :: IsForeign Snapshot where 38 | read json = do 39 | ks <- keys json 40 | let mkPair k = Tuple <$> parseKeyF k <*> readProp k json 41 | kvs <- traverse mkPair ks 42 | pure $ Snapshot $ fromFoldable kvs 43 | 44 | snapshotToUpdate :: Snapshot -> Update 45 | snapshotToUpdate (Snapshot m) = Update $ join $ toUpdates <$> (toUnfoldable $ M.toList m) 46 | where toUpdates (Tuple k (Value v)) = 47 | [Tuple k (UpdateValueData v.valueData)] 48 | <> [Tuple k (UpdateValuePrecision v.valuePrecision)] 49 | 50 | -- 51 | 52 | newtype UpdatePost = UpdatePost 53 | { updatePostParentId :: UpdateId 54 | , updatePostUpdate :: Update 55 | , updatePostValidationType :: ValidationType 56 | } 57 | 58 | instance encodeJsonUpdatePost :: EncodeJson UpdatePost where 59 | encodeJson (UpdatePost p) = "parentId" := p.updatePostParentId 60 | ~> "update" := p.updatePostUpdate 61 | ~> "validationType" := p.updatePostValidationType 62 | ~> jsonEmptyObject 63 | 64 | newtype UpdatePostResult = UpdatePostResult 65 | { uprUpdateDesc :: UpdateDesc 66 | , uprValidationResult :: ValidationResult 67 | } 68 | 69 | instance isForeignUpdatePostResult :: IsForeign UpdatePostResult where 70 | read json = do 71 | upr <- { uprUpdateDesc: _ 72 | , uprValidationResult: _ 73 | } 74 | <$> readProp "updateDesc" json 75 | <*> readProp "validationResult" json 76 | pure $ UpdatePostResult upr 77 | 78 | newtype UpdateGet = UpdateGet 79 | { updateGetId :: UpdateId 80 | , updateGetCreated :: UTCTime 81 | , updateGetParentId :: Maybe UpdateId 82 | , updateGetUpdate :: Update 83 | } 84 | 85 | instance isForeignUpdateGet :: IsForeign UpdateGet where 86 | read json = do 87 | upd <- { updateGetId: _ 88 | , updateGetCreated: _ 89 | , updateGetParentId: _ 90 | , updateGetUpdate: _ 91 | } 92 | <$> readProp "updateId" json 93 | <*> readProp "created" json 94 | <*> (unNullOrUndefined <$> readProp "parentId" json) 95 | <*> readProp "update" json 96 | pure $ UpdateGet upd 97 | 98 | newtype SnapshotDesc = SnapshotDesc 99 | { snapshotDescUpdateId :: UpdateId 100 | , snapshotDescCreated :: UTCTime 101 | , snapshotDescParentId :: Maybe UpdateId 102 | , snapshotDescSnapshot :: Snapshot 103 | } 104 | 105 | instance isForeignSnapshotDesc :: IsForeign SnapshotDesc where 106 | read json = do 107 | upd <- { snapshotDescUpdateId: _ 108 | , snapshotDescCreated: _ 109 | , snapshotDescParentId: _ 110 | , snapshotDescSnapshot: _ 111 | } 112 | <$> readProp "updateId" json 113 | <*> readProp "created" json 114 | <*> (unNullOrUndefined <$> readProp "parentId" json) 115 | <*> readProp "snapshot" json 116 | pure $ SnapshotDesc upd 117 | 118 | newtype UpdateDesc = UpdateDesc 119 | { updateDescUpdateId :: UpdateId 120 | , updateDescCreated :: UTCTime 121 | , updateDescAuthor :: String 122 | , updateDescTags :: Array TagDesc 123 | , updateDescChanges :: Array UpdateChange 124 | } 125 | 126 | instance isForeignUpdateDesc :: IsForeign UpdateDesc where 127 | read json = do 128 | desc <- { updateDescUpdateId: _ 129 | , updateDescCreated: _ 130 | , updateDescAuthor: _ 131 | , updateDescTags: _ 132 | , updateDescChanges: _ 133 | } 134 | <$> readProp "updateId" json 135 | <*> readProp "created" json 136 | <*> readProp "author" json 137 | <*> readProp "tags" json 138 | <*> readProp "changes" json 139 | pure $ UpdateDesc desc 140 | 141 | newtype UpdateChange = UpdateChange 142 | { updateChangeLoc :: ChangeLocationHuman 143 | , updateChangeOld :: Value 144 | , updateChangeNew :: Value 145 | } 146 | 147 | instance isForeignUpdateEntry :: IsForeign UpdateChange where 148 | read json = do 149 | entry <- { updateChangeLoc: _ 150 | , updateChangeOld: _ 151 | , updateChangeNew: _ 152 | } 153 | <$> readProp "location" json 154 | <*> readProp "old" json 155 | <*> readProp "new" json 156 | pure $ UpdateChange entry 157 | 158 | data ChangeLocationHuman 159 | = HumanHeaderFact String -- label 160 | | HumanFact String HoleCoords -- table coords 161 | | HumanSubsetZ String String -- table member 162 | | HumanCustomZ String -- table 163 | | HumanCustomRow String String String -- table member sheet 164 | 165 | instance isForeignUpdateEntryHuman :: IsForeign ChangeLocationHuman where 166 | read json = do 167 | typ <- readProp "type" json 168 | case typ of 169 | "header" -> HumanHeaderFact <$> readProp "label" json 170 | "fact" -> HumanFact <$> readProp "table" json 171 | <*> readProp "coords" json 172 | "subsetZ" -> HumanSubsetZ <$> readProp "table" json 173 | <*> readProp "member" json 174 | "customZ" -> HumanCustomZ <$> readProp "table" json 175 | "customRow" -> HumanCustomRow <$> readProp "table" json 176 | <*> readProp "member" json 177 | <*> readProp "sheet" json 178 | _ -> fail $ JSONError "expected `header`, `fact`, `subsetZ`, `customZ` or `customRow`" 179 | 180 | newtype TagDesc = TagDesc 181 | { tagDescTagId :: TagId 182 | , tagDescUpdateId :: UpdateId 183 | , tagDescTagName :: String 184 | , tagDescCreated :: UTCTime 185 | } 186 | 187 | instance isForeignTagDesc :: IsForeign TagDesc where 188 | read json = do 189 | desc <- { tagDescTagId: _ 190 | , tagDescUpdateId: _ 191 | , tagDescTagName: _ 192 | , tagDescCreated: _ 193 | } 194 | <$> readProp "tagId" json 195 | <*> readProp "updateId" json 196 | <*> readProp "name" json 197 | <*> readProp "created" json 198 | pure $ TagDesc desc 199 | -------------------------------------------------------------------------------- /src/Component/Validation/Finding.purs: -------------------------------------------------------------------------------- 1 | module Component.Validation.Finding 2 | ( renderFinding 3 | , renderHoleCoords 4 | ) where 5 | 6 | import Halogen.HTML.Indexed as H 7 | import Halogen.HTML.Properties.Indexed as P 8 | import Api.Schema.BusinessData.Value (Value(Value)) 9 | import Api.Schema.Table (DataType(..)) 10 | import Api.Schema.Validation (Finding(Finding), Formula(FBinary, FUnary, FSet, FModuleParam, FString, FNumber, FBoolean, FIfThenElse, FMember, FSum, FHole), Hole(Hole), HoleCoordX(HCX), HoleCoordY(HCYCustom, HCYClosed), HoleCoordZ(HCZSubset, HCZCustom, HCZClosed, HCZSingleton), HoleCoords(HoleCoords)) 11 | import Data.Foldable (intercalate) 12 | import Data.Maybe (fromMaybe, Maybe(Nothing, Just)) 13 | import Data.String (take, null) 14 | import Data.Tuple (Tuple(Tuple)) 15 | import Halogen (ComponentHTML) 16 | import Lib.Table (boolValueMap, lookupByFst) 17 | import Prelude 18 | import Utils (cls, tryFormatNumber) 19 | 20 | renderFinding :: forall f. Finding -> ComponentHTML f 21 | renderFinding (Finding f) = H.li_ $ 22 | [ H.span 23 | [ cls $ "severity octicon octicon-primitive-dot " <> show f.finSeverity 24 | , P.title $ show f.finSeverity 25 | ] [] 26 | , H.b_ [ H.text $ f.finCode <> ": " ] 27 | , H.text msg 28 | , H.br_ :: ComponentHTML f 29 | ] <> case f.finFormula of 30 | Just formula -> 31 | [ renderFormula formula 32 | ] 33 | Nothing -> [] 34 | where 35 | msg = if null f.finNarrative 36 | then f.finMessage 37 | else f.finMessage <> ": " <> f.finNarrative 38 | 39 | renderFormula :: forall f. Formula -> ComponentHTML f 40 | renderFormula f = H.div [ cls "formula" ] $ renderTerm f 41 | 42 | renderTerm :: forall f. Formula -> Array (ComponentHTML f) 43 | renderTerm f' = case f' of 44 | FHole h -> 45 | [ renderHole h 46 | ] 47 | FSum hs -> 48 | intercalate [opv ", "] (pure <<< renderHole <$> hs) 49 | FMember _ label -> 50 | [ renderValue label 51 | ] 52 | FUnary op f -> 53 | [ opv op 54 | , opv "(" 55 | ] <> renderTerm f <> 56 | [ opv ")" 57 | ] 58 | FBinary op lhs rhs -> 59 | let left = if binaryNeedParen op lhs 60 | then paren lhs 61 | else renderTerm lhs 62 | right = if binaryNeedParen op rhs 63 | then paren rhs 64 | else renderTerm rhs 65 | in left <> [ opv op ] <> right 66 | FIfThenElse cond t e -> 67 | [ opv "if " 68 | ] <> paren cond <> 69 | [ opv " then " 70 | ] <> paren t <> 71 | [ opv " else " 72 | ] <> paren e 73 | FBoolean v -> 74 | [ renderValue (show v) 75 | ] 76 | FNumber v -> 77 | [ renderValue $ tryFormatNumber 2 v 78 | ] 79 | FString v -> 80 | [ renderValue v 81 | ] 82 | FModuleParam p v -> 83 | [ renderModuleParam p v 84 | ] 85 | FSet fs -> 86 | [ opv "[" 87 | ] <> intercalate [opv ","] (renderTerm <$> fs) <> 88 | [ opv "]" 89 | ] 90 | where 91 | opv v = case v of 92 | "(" -> H.div [ cls "lop lop-lparen" ] [] 93 | ")" -> H.div [ cls "lop lop-rparen" ] [] 94 | ">=" -> H.div [ cls "lop lop-ge" ] [] 95 | "<=" -> H.div [ cls "lop lop-le" ] [] 96 | "=" -> H.div [ cls "lop lop-eq" ] [] 97 | "+" -> H.div [ cls "lop lop-plus" ] [] 98 | "-" -> H.div [ cls "lop lop-minus" ] [] 99 | "elem" -> H.div [ cls "lop lop-elem" ] [] 100 | _ -> H.span [ cls "op" ] [ H.text v ] 101 | paren term = if needParen term 102 | then 103 | [ opv "(" 104 | ] <> renderTerm term <> 105 | [ opv ")" 106 | ] 107 | else 108 | renderTerm term 109 | 110 | binaryNeedParen :: String -> Formula -> Boolean 111 | binaryNeedParen op f = case Tuple op $ getTermOp f of 112 | Tuple "+" (Just "+") -> false 113 | Tuple "=" (Just _) -> false 114 | Tuple "+" (Just "*") -> false 115 | Tuple "-" (Just "*") -> false 116 | Tuple "+" (Just "div") -> false 117 | Tuple "-" (Just "div") -> false 118 | _ -> true 119 | 120 | needParen :: Formula -> Boolean 121 | needParen f = case f of 122 | FHole _ -> false 123 | FSum _ -> true 124 | FMember _ _ -> false 125 | FUnary _ _ -> false 126 | FBinary _ _ _ -> true 127 | FIfThenElse _ _ _ -> false 128 | FBoolean _ -> false 129 | FNumber _ -> false 130 | FString _ -> false 131 | FModuleParam _ _ -> false 132 | FSet _ -> false 133 | 134 | 135 | getTermOp :: Formula -> Maybe String 136 | getTermOp f = case f of 137 | FUnary op _ -> Just op 138 | FBinary op _ _ -> Just op 139 | _ -> Nothing 140 | 141 | renderValue :: forall f. String -> ComponentHTML f 142 | renderValue value = H.div [ cls "value" ] 143 | [ H.span [ cls "val" ] [ H.text value ] 144 | ] 145 | 146 | renderModuleParam :: forall f. String -> String -> ComponentHTML f 147 | renderModuleParam p v = H.div [ cls "param" ] 148 | [ H.text "" 149 | , H.br_ 150 | , H.text v 151 | , H.br_ 152 | , H.text p 153 | ] 154 | 155 | renderHole :: forall f. Hole -> ComponentHTML f 156 | renderHole (Hole h) = H.div [ cls "hole" ] 157 | [ H.span [ cls "holetable" ] 158 | [ H.text h.holeTemplate ] 159 | , H.br_ 160 | , H.div [ cls "data" ] 161 | [ let default = case h.holeDataType of 162 | BooleanData -> "false" 163 | DateData -> "" 164 | IntegerData -> "0" 165 | MonetaryData -> "0.00" 166 | PercentageData -> "0.00" 167 | CodeData _ -> "" 168 | StringData -> "" 169 | NumberData -> "0" 170 | in case h.holeData of 171 | Value v -> case v.valueData of 172 | Nothing -> H.span [ cls "missing", P.title "Not filled in, using default." ] [ H.text default ] 173 | Just d -> H.text $ case h.holeDataType of 174 | BooleanData -> fromMaybe "" $ lookupByFst d boolValueMap 175 | DateData -> d 176 | IntegerData -> tryFormatNumber 0 d 177 | MonetaryData -> tryFormatNumber 2 d 178 | PercentageData -> tryFormatNumber 2 d 179 | CodeData cd -> fromMaybe d $ lookupByFst d cd 180 | StringData -> d 181 | NumberData -> tryFormatNumber 0 d 182 | ] 183 | , H.div [ cls "decimals", P.title "Precision (decimal places of absolute error)" ] 184 | [ H.text $ case h.holeData of 185 | Value v -> case h.holeDataType of 186 | MonetaryData -> show $ fromMaybe 2 $ v.valuePrecision 187 | PercentageData -> show $ fromMaybe 4 $ v.valuePrecision 188 | _ -> "" 189 | ] 190 | , H.br_ 191 | , H.span [ cls "holecoords" ] 192 | [ renderHoleCoords h.holeCoords ] 193 | ] 194 | 195 | renderHoleCoords :: forall f. HoleCoords -> ComponentHTML f 196 | renderHoleCoords (HoleCoords x y z) = H.span_ 197 | let xStr = case x of 198 | HCX i ord -> ord 199 | yStr = case y of 200 | HCYClosed i ord -> ord 201 | HCYCustom cmId rowKeys -> take 8 cmId 202 | zStr = case z of 203 | HCZSingleton -> Nothing 204 | HCZClosed i ord -> Just ord 205 | HCZCustom cmId cm -> Just $ take 8 cmId 206 | HCZSubset smId sm -> Just $ show smId 207 | in [ H.text "(" 208 | , H.b_ [ H.text "r" ] 209 | , H.text yStr 210 | , H.text ", " 211 | , H.b_ [ H.text "c" ] 212 | , H.text xStr 213 | ] <> ( 214 | case zStr of 215 | Just z' -> 216 | [ H.text ", " 217 | , H.b_ [ H.text "s" ] 218 | , H.text z' 219 | ] 220 | Nothing -> 221 | [] 222 | ) <> 223 | [ H.text ")" 224 | ] 225 | -------------------------------------------------------------------------------- /src/Api/Schema/Validation.purs: -------------------------------------------------------------------------------- 1 | module Api.Schema.Validation where 2 | 3 | import Data.StrMap as SM 4 | import Api.Schema.BusinessData.Value (Value) 5 | import Api.Schema.Table (DataType) 6 | import Control.Monad.Except (runExcept) 7 | import Data.Argonaut.Core (fromString) 8 | import Data.Argonaut.Encode (class EncodeJson) 9 | import Data.Either (either) 10 | import Data.Foreign (Foreign, ForeignError(JSONError), fail, unsafeReadTagged) 11 | import Data.Foreign.Class (class IsForeign, readProp, read) 12 | import Data.Foreign.NullOrUndefined (unNullOrUndefined) 13 | import Data.Maybe (Maybe(Nothing)) 14 | import Data.Tuple (Tuple) 15 | import Prelude 16 | import Types (SubsetMemberId, CustomMemberId, RowKey) 17 | 18 | data ValidationType 19 | = VTNone 20 | | VTWhole 21 | | VTUpdate 22 | 23 | instance encodeJsonValidationType :: EncodeJson ValidationType where 24 | encodeJson VTNone = fromString "none" 25 | encodeJson VTWhole = fromString "whole" 26 | encodeJson VTUpdate = fromString "update" 27 | 28 | newtype ValidationResult = ValidationResult 29 | { vrDpmFindings :: SM.StrMap (Array Finding) 30 | , vrHeaderFindings :: Maybe (Array Finding) 31 | } 32 | 33 | emptyValidationResult :: ValidationResult 34 | emptyValidationResult = ValidationResult 35 | { vrDpmFindings: SM.empty 36 | , vrHeaderFindings: Nothing 37 | } 38 | 39 | newtype RuleMap = RuleMap (SM.StrMap (Array Finding)) 40 | 41 | instance isForeignRuleMap :: IsForeign RuleMap where 42 | read json = do 43 | (obj :: SM.StrMap Foreign) <- unsafeReadTagged "Object" json 44 | -- TODO: report purescript-maps StrMap functions traverse, union, foldM not stack-safe 45 | pure $ RuleMap $ obj <#> \val -> either (const []) id (runExcept $ read val) 46 | 47 | instance isForeignValidationResult :: IsForeign ValidationResult where 48 | read json = do 49 | (RuleMap dpm) <- readProp "dpm" json 50 | header <- unNullOrUndefined <$> readProp "header" json 51 | pure $ ValidationResult 52 | { vrDpmFindings: dpm 53 | , vrHeaderFindings: header 54 | } 55 | 56 | newtype Finding = Finding 57 | { finCode :: String 58 | , finMessage :: String 59 | , finTableBasedFormula :: Maybe String 60 | , finFormula :: Maybe Formula 61 | , finSeverity :: Severity 62 | , finNarrative :: String -- DPM 2.6 style narratives: verbose error messages 63 | } 64 | 65 | instance isForeignFinding :: IsForeign Finding where 66 | read json = do 67 | fin <- { finCode: _ 68 | , finMessage: _ 69 | , finTableBasedFormula: _ 70 | , finFormula: _ 71 | , finSeverity: _ 72 | , finNarrative: _ 73 | } 74 | <$> readProp "code" json 75 | <*> readProp "message" json 76 | <*> (unNullOrUndefined <$> readProp "tableBasedFormula" json) 77 | <*> (unNullOrUndefined <$> readProp "formula" json) 78 | <*> readProp "severity" json 79 | <*> readProp "narrative" json 80 | pure $ Finding fin 81 | 82 | newtype Hole = Hole 83 | { holeData :: Value 84 | , holeDataType :: DataType 85 | , holeCoords :: HoleCoords 86 | , holeTemplate :: String 87 | } 88 | 89 | instance isForeignHole :: IsForeign Hole where 90 | read json = do 91 | h <- { holeData: _ 92 | , holeDataType: _ 93 | , holeCoords: _ 94 | , holeTemplate: _ 95 | } 96 | <$> readProp "data" json 97 | <*> readProp "dataType" json 98 | <*> readProp "coords" json 99 | <*> readProp "template" json 100 | pure $ Hole h 101 | 102 | type PlainOrd = Tuple Int String 103 | type CustomYOrd = Tuple CustomMemberId (Array String) 104 | type CustomZOrd = Tuple CustomMemberId String 105 | type SubsetZOrd = SubsetMemberId 106 | 107 | data HoleCoords = HoleCoords HoleCoordX HoleCoordY HoleCoordZ 108 | 109 | instance isForeignHoleCoords :: IsForeign HoleCoords where 110 | read json = HoleCoords <$> readProp "x" json 111 | <*> readProp "y" json 112 | <*> readProp "z" json 113 | 114 | data HoleCoordX = HCX Int String 115 | 116 | instance isForeignHoleCoordX :: IsForeign HoleCoordX where 117 | read json = HCX <$> readProp "i" json 118 | <*> readProp "ord" json 119 | 120 | data HoleCoordY 121 | = HCYClosed Int String 122 | | HCYCustom CustomMemberId (Array RowKey) 123 | 124 | instance isForeignHoleCoordY :: IsForeign HoleCoordY where 125 | read json = do 126 | typ <- readProp "type" json 127 | case typ of 128 | "closed" -> HCYClosed <$> readProp "i" json 129 | <*> readProp "ord" json 130 | "custom" -> HCYCustom <$> readProp "customMemberId" json 131 | <*> readProp "rowKeys" json 132 | _ -> fail $ JSONError "expected `closed` or `custom`" 133 | 134 | data HoleCoordZ 135 | = HCZSingleton 136 | | HCZClosed Int String 137 | | HCZCustom CustomMemberId String 138 | | HCZSubset SubsetMemberId String 139 | 140 | instance isForeignHoleCoordZ :: IsForeign HoleCoordZ where 141 | read json = do 142 | typ <- readProp "type" json 143 | case typ of 144 | "singleton" -> pure HCZSingleton 145 | "closed" -> HCZClosed <$> readProp "i" json 146 | <*> readProp "ord" json 147 | "custom" -> HCZCustom <$> readProp "customMemberId" json 148 | <*> readProp "customMember" json 149 | "subset" -> HCZSubset <$> readProp "subsetMemberId" json 150 | <*> readProp "subsetMember" json 151 | _ -> fail $ JSONError "expected `singleton`, `closed`, `custom` or `subset`" 152 | 153 | type ModuleParamValue = String 154 | 155 | data Formula 156 | = FHole Hole 157 | | FSum (Array Hole) 158 | | FMember String String -- code label 159 | | FUnary String Formula 160 | | FBinary String Formula Formula 161 | | FIfThenElse Formula Formula Formula 162 | | FBoolean Boolean 163 | | FNumber String 164 | | FString String 165 | | FModuleParam String ModuleParamValue 166 | | FSet (Array Formula) 167 | 168 | instance isForeignFormula :: IsForeign Formula where 169 | read json = do 170 | typ <- readProp "type" json 171 | case typ of 172 | "hole" -> FHole <$> readProp "hole" json 173 | "sum" -> FSum <$> readProp "holes" json 174 | "member" -> FMember <$> readProp "code" json <*> readProp "label" json 175 | "unary" -> FUnary <$> readProp "op" json <*> readProp "f" json 176 | "binary" -> FBinary <$> readProp "op" json <*> readProp "lhs" json <*> readProp "rhs" json 177 | "ifThenElse" -> FIfThenElse <$> readProp "cond" json <*> readProp "then" json <*> readProp "else" json 178 | "boolean" -> FBoolean <$> readProp "val" json 179 | "number" -> FNumber <$> readProp "val" json 180 | "string" -> FString <$> readProp "val" json 181 | "moduleParam" -> FModuleParam <$> readProp "name" json <*> readProp "val" json 182 | "set" -> FSet <$> readProp "fs" json 183 | _ -> fail $ JSONError "invalid formula type" 184 | 185 | data Severity 186 | = Blocking 187 | | BlockingIFRS 188 | | NonBlocking 189 | | Warning 190 | 191 | instance showSeverity :: Show Severity where 192 | show Blocking = "blocking" 193 | show BlockingIFRS = "blocking-for-IFRS" 194 | show NonBlocking = "non-blocking" 195 | show Warning = "warning" 196 | 197 | instance isForeignSeverity :: IsForeign Severity where 198 | read json = do 199 | typ <- readProp "type" json 200 | case typ of 201 | "blocking" -> pure Blocking 202 | "blockingIFRS" -> pure BlockingIFRS 203 | "nonblocking" -> pure NonBlocking 204 | "warning" -> pure Warning 205 | _ -> fail $ JSONError "invalid severity type" 206 | -------------------------------------------------------------------------------- /src/Component/ModuleBrowser.purs: -------------------------------------------------------------------------------- 1 | module Component.ModuleBrowser where 2 | 3 | import Prelude 4 | import Data.Map as M 5 | import Halogen.HTML.Events.Indexed as E 6 | import Halogen.HTML.Indexed as H 7 | import Api.Schema.Module (Module, Template, TemplateGroup, _templateGroups, _tableEntryCode, _tableEntryId, _templateTables, _templateLabel, _templates, _templateGroupLabel, _templateGroupId) 8 | import Data.Array (length, index, findIndex, concat) 9 | import Data.Lens (Lens', _Just, lens, (%~), (^.)) 10 | import Data.Lens.At (at) 11 | import Data.Maybe (Maybe(Just, Nothing), fromMaybe) 12 | import Halogen (ComponentHTML, ComponentDSL, Component, component, modify) 13 | import Types (TemplateGroupId, Metrix, TableId) 14 | import Utils (cls, non, shorten) 15 | 16 | type TableSelect = 17 | { id :: TableId 18 | , header :: Boolean 19 | , code :: String 20 | , label :: String 21 | } 22 | 23 | headerSelect :: TableSelect 24 | headerSelect = 25 | { id: 0 26 | , header: true 27 | , code: "Header DE" 28 | , label: "" 29 | } 30 | 31 | type ModuleBrowserInfo = 32 | { mod :: Module 33 | , open :: Boolean 34 | , groupOpen :: M.Map TemplateGroupId Boolean 35 | , selectedTable :: Maybe TableSelect 36 | } 37 | 38 | type State = Maybe ModuleBrowserInfo 39 | 40 | _mod :: Lens' ModuleBrowserInfo Module 41 | _mod = lens _.mod _{ mod = _ } 42 | 43 | _groupOpen :: Lens' ModuleBrowserInfo (M.Map TemplateGroupId Boolean) 44 | _groupOpen = lens _.groupOpen _{ groupOpen = _ } 45 | 46 | _selectedTable :: Lens' ModuleBrowserInfo (Maybe TableSelect) 47 | _selectedTable = lens _.selectedTable _{ selectedTable = _ } 48 | 49 | initialState :: State 50 | initialState = Nothing 51 | 52 | data Query a 53 | = Boot Module a 54 | | SelectTable TableSelect a 55 | | ToggleGroupOpen TemplateGroupId a 56 | | ToggleOpen a 57 | 58 | moduleBrowser :: Component State Query Metrix 59 | moduleBrowser = component 60 | { render 61 | , eval 62 | } 63 | 64 | render :: State -> ComponentHTML Query 65 | render st = H.div_ 66 | [ case st of 67 | Nothing -> H.text "" 68 | Just mbInfo -> renderModuleBrowser mbInfo 69 | ] 70 | 71 | eval :: Query ~> ComponentDSL State Query Metrix 72 | eval (Boot mod next) = do 73 | modify $ const $ Just 74 | { mod: mod 75 | , open: true 76 | , groupOpen: (M.empty :: M.Map TemplateGroupId Boolean) 77 | , selectedTable: Nothing 78 | } 79 | pure next 80 | 81 | eval (SelectTable tSelect next) = do 82 | modify $ map _{ selectedTable = Just tSelect } 83 | pure next 84 | 85 | eval (ToggleGroupOpen gId next) = do 86 | modify $ _Just <<< _groupOpen <<< at gId <<< non true %~ (not :: Boolean -> Boolean) 87 | pure next 88 | 89 | eval (ToggleOpen next) = do 90 | modify $ map \info -> info { open = not info.open } 91 | pure next 92 | 93 | renderModuleBrowser :: ModuleBrowserInfo -> ComponentHTML Query 94 | renderModuleBrowser info = H.div 95 | [ cls "tooldim-mb" ] $ 96 | [ H.div 97 | [ cls "module-control" 98 | ] case info.selectedTable of 99 | Nothing -> 100 | [ H.text "" ] 101 | Just tSelect -> 102 | let next = goRelativeModuloLen tSelect ((+) 1) (flattenTables info.mod) 103 | prev = goRelativeModuloLen tSelect (\i -> i - 1) (flattenTables info.mod) 104 | in 105 | [ H.div 106 | [ cls "toolbutton left nav-button" 107 | , E.onClick $ E.input_ $ SelectTable prev 108 | ] 109 | [ H.span [ cls "mega-octicon octicon-triangle-left" ] [] 110 | ] 111 | , H.div 112 | [ cls "toolbutton current" 113 | , E.onClick $ E.input_ ToggleOpen 114 | ] 115 | [ H.p_ [ H.text tSelect.code ] 116 | ] 117 | , H.div 118 | [ cls "toolbutton right nav-button" 119 | , E.onClick $ E.input_ $ SelectTable next 120 | ] 121 | [ H.span [ cls "mega-octicon octicon-triangle-right" ] [] 122 | ] 123 | ] 124 | ] <> if info.open 125 | then [ H.div [ cls "modules" ] 126 | [ H.ul_ $ 127 | [renderHeader] <> 128 | (concat $ renderTemplateGroup <$> (info.mod ^. _templateGroups)) 129 | ] 130 | ] 131 | else [] 132 | where 133 | renderHeader :: ComponentHTML Query 134 | renderHeader = H.li [ cls $ "table" <> if selected then " selected" else "" ] 135 | [ H.span 136 | [ cls "label" 137 | , E.onClick $ E.input_ $ SelectTable headerSelect 138 | ] 139 | [ H.span [ cls "octicon octicon-browser" ] [] 140 | , H.text "German Header" 141 | ] 142 | ] 143 | where 144 | selected = case info.selectedTable of 145 | Just sel -> sel.header 146 | Nothing -> false 147 | 148 | renderTemplateGroup :: TemplateGroup -> Array (ComponentHTML Query) 149 | renderTemplateGroup g = 150 | [ H.li [ cls "group" ] 151 | [ H.span 152 | [ cls "label" 153 | , E.onClick $ E.input_ $ ToggleGroupOpen gId 154 | ] 155 | [ H.span [ cls $ "octicon octicon-chevron-" <> if open then "down" else "right" ] [] 156 | , H.text (g ^. _templateGroupLabel) 157 | ] 158 | ] 159 | ] <> if open then concat $ renderTemplate <$> (g ^. _templates) else [] 160 | where 161 | gId = g ^. _templateGroupId 162 | open = fromMaybe true $ M.lookup gId info.groupOpen 163 | 164 | renderTemplate :: Template -> Array (ComponentHTML Query) 165 | renderTemplate t = 166 | [ H.li [ cls "template" ] 167 | [ H.span [ cls "octicon octicon-primitive-dot" ] [] 168 | , case shorten (t ^. _templateLabel) 45 of 169 | Nothing -> 170 | H.text (t ^. _templateLabel) 171 | Just short -> 172 | H.a [ cls "tooltip" ] 173 | [ H.span_ [ H.text (t ^. _templateLabel) ] 174 | , H.text short 175 | , H.b_ [ H.text "..." ] 176 | ] 177 | ] 178 | ] <> (renderTable <$> (t ^. _templateTables)) 179 | where 180 | renderTable tbl = H.li 181 | [ cls $ "table" <> if selected tbl then " selected" else "" ] 182 | [ H.span 183 | [ cls "label" 184 | , E.onClick $ E.input_ $ SelectTable { id: tbl ^. _tableEntryId 185 | , header: false 186 | , code: tbl ^. _tableEntryCode 187 | , label: t ^. _templateLabel 188 | } 189 | ] 190 | [ H.span [ cls "octicon octicon-browser" ] [] 191 | , H.text (tbl ^. _tableEntryCode) 192 | ] 193 | ] 194 | selected tbl = case info.selectedTable of 195 | Just sel -> (tbl ^. _tableEntryId) == sel.id 196 | Nothing -> false 197 | 198 | -- 199 | 200 | flattenTables :: Module -> Array TableSelect 201 | flattenTables mod = [headerSelect] <> (concat $ goGroup <$> (mod ^. _templateGroups)) 202 | where goGroup g = concat $ goTemplate <$> (g ^. _templates) 203 | goTemplate t = goTable (t ^. _templateLabel) <$> (t ^. _templateTables) 204 | goTable lbl t = 205 | { id: t ^. _tableEntryId 206 | , header: false 207 | , code: t ^. _tableEntryCode 208 | , label: lbl 209 | } 210 | 211 | goRelativeModuloLen :: TableSelect -> (Int -> Int) -> Array TableSelect -> TableSelect 212 | goRelativeModuloLen x dir xs = fromMaybe x do 213 | i <- findIndex (\x' -> x.id == x'.id) xs 214 | index xs $ (dir i) `realMod` (length xs) 215 | where realMod a b = let r = a `mod` b in if r < 0 then r + b else r 216 | -------------------------------------------------------------------------------- /src/Component/App.purs: -------------------------------------------------------------------------------- 1 | module Component.App where 2 | 3 | import Component.Body as Body 4 | import Component.ErrorBox as ErrorBox 5 | import Component.Spinner as Spinner 6 | import Halogen.HTML.Events.Indexed as E 7 | import Halogen.HTML.Indexed as H 8 | import Halogen.HTML.Properties.Indexed as P 9 | import Api (logout, apiCallParent, login, loginStatus) 10 | import Api.Schema (runJsonEither) 11 | import Api.Schema.Auth (AuthInfo(AuthInfo)) 12 | import Component.Common (modal) 13 | import Data.Either (Either(Left, Right)) 14 | import Data.Foldable (intercalate) 15 | import Data.Foreign.Null (unNull) 16 | import Data.Functor.Coproduct (Coproduct) 17 | import Data.Generic (class Generic, gEq, gCompare) 18 | import Data.Maybe (Maybe(Nothing, Just)) 19 | import Halogen (ParentDSL, parentState, ParentHTML, ParentState, Component, ChildF, parentComponent, modify, get) 20 | import Halogen.Component.ChildPath (ChildPath, cpL, cpR, (:>)) 21 | import Prelude 22 | import Types (Metrix, showDay) 23 | import Utils (cls) 24 | import Version (versionStr) 25 | 26 | -- 27 | 28 | data SpinnerSlot = SpinnerSlot 29 | 30 | derive instance genericSpinnerSlot :: Generic SpinnerSlot 31 | instance eqSpinnerSlot :: Eq SpinnerSlot where eq = gEq 32 | instance ordSpinnerSlot :: Ord SpinnerSlot where compare = gCompare 33 | 34 | data ErrorBoxSlot = ErrorBoxSlot 35 | 36 | derive instance genericErrorBoxSlot :: Generic ErrorBoxSlot 37 | instance eqErrorBoxSlot :: Eq ErrorBoxSlot where eq = gEq 38 | instance ordErrorBoxSlot :: Ord ErrorBoxSlot where compare = gCompare 39 | 40 | data BodySlot = BodySlot 41 | 42 | derive instance genericBodySlot :: Generic BodySlot 43 | instance eqBodySlot :: Eq BodySlot where eq = gEq 44 | instance ordBodySlot :: Ord BodySlot where compare = gCompare 45 | 46 | type ChildState = Either Spinner.State (Either ErrorBox.State Body.StateP) 47 | type ChildQuery = Coproduct Spinner.Query (Coproduct ErrorBox.Query Body.QueryP) 48 | type ChildSlot = Either SpinnerSlot (Either ErrorBoxSlot BodySlot) 49 | 50 | cpSpinner :: ChildPath Spinner.State ChildState Spinner.Query ChildQuery SpinnerSlot ChildSlot 51 | cpSpinner = cpL 52 | 53 | cpErrorBox :: ChildPath ErrorBox.State ChildState ErrorBox.Query ChildQuery ErrorBoxSlot ChildSlot 54 | cpErrorBox = cpR :> cpL 55 | 56 | cpBody :: ChildPath Body.StateP ChildState Body.QueryP ChildQuery BodySlot ChildSlot 57 | cpBody = cpR :> cpR 58 | 59 | -- 60 | 61 | data AuthStatus 62 | = CheckingLicense 63 | | Authenticated AuthInfo 64 | | LoggedOut 65 | 66 | type State = 67 | { authStatus :: AuthStatus 68 | , authError :: Maybe String 69 | , customerId :: String 70 | , licenseKey :: String 71 | , aboutOpen :: Boolean 72 | } 73 | 74 | initialState :: State 75 | initialState = 76 | { authStatus: CheckingLicense 77 | , authError: Nothing 78 | , customerId: "" 79 | , licenseKey: "" 80 | , aboutOpen: false 81 | } 82 | 83 | data Query a 84 | = Boot a 85 | | Authenticate a 86 | | SetCustomerId String a 87 | | SetLicenseKey String a 88 | | AboutOpen a 89 | | AboutClose a 90 | | LogOut a 91 | 92 | type StateP = ParentState State ChildState Query ChildQuery Metrix ChildSlot 93 | type QueryP = Coproduct Query (ChildF ChildSlot ChildQuery) 94 | 95 | app :: Component StateP QueryP Metrix 96 | app = parentComponent 97 | { render 98 | , eval 99 | , peek: Nothing 100 | } 101 | 102 | render :: State -> ParentHTML ChildState Query ChildQuery Metrix ChildSlot 103 | render st = H.div [ cls "app" ] $ 104 | [ H.slot' cpErrorBox ErrorBoxSlot \_ -> 105 | { component: ErrorBox.errorBox, initialState: ErrorBox.initialState } 106 | , H.div [ cls "status" ] $ 107 | [ H.slot' cpSpinner SpinnerSlot \_ -> 108 | { component: Spinner.spinner, initialState: Spinner.initialState } 109 | , case st.authStatus of 110 | Authenticated _ -> H.div [ cls "status-baresto" ] [] 111 | _ -> H.div [ cls "status-metrix" ] [] 112 | , case st.authStatus of 113 | Authenticated (AuthInfo authInfo) -> 114 | let sep = [ H.span [ cls "sep" ] [] ] in 115 | H.div 116 | [ cls "license" ] $ intercalate sep $ 117 | ( case authInfo.authContractInvalidMsg of 118 | Nothing -> [] 119 | Just msg -> [ [ H.span [ cls "warn" ] [ H.text msg ] ] ] 120 | ) <> 121 | ( if authInfo.authContractIsTrial 122 | then [ [ H.span [ cls "warn" ] [ H.text "Test licence" ] ] ] 123 | else [] 124 | ) <> 125 | [ [ H.text $ "Licence valid: " <> showDay authInfo.authContractBegin <> " to " <> showDay authInfo.authContractEnd ] 126 | , [ H.text $ "User: " <> authInfo.authUserName ] 127 | ] 128 | _ -> H.div_ [] 129 | , H.div [ cls "menu" ] 130 | [ case st.authStatus of 131 | Authenticated _ -> 132 | H.button 133 | [ E.onClick (E.input_ $ LogOut) ] 134 | [ H.span [ cls "octicon octicon-sign-out" ] [] 135 | , H.text "Logout" 136 | ] 137 | _ -> 138 | H.div_ [] 139 | , H.button 140 | [ E.onClick $ E.input_ AboutOpen ] 141 | [ H.span [ cls "octicon octicon-info" ] [] 142 | , H.text "About" 143 | ] 144 | ] 145 | ] 146 | , case st.authStatus of 147 | Authenticated _ -> 148 | H.slot' cpBody BodySlot \_ -> 149 | { component: Body.body, initialState: parentState Body.initialState } 150 | LoggedOut -> 151 | renderAuthForm st.customerId st.licenseKey st.authError 152 | CheckingLicense -> H.div_ [] 153 | ] <> ( 154 | if st.aboutOpen 155 | then 156 | [ modal "About" 157 | [ H.p_ [ H.b_ [ H.text $ "Metrix Baresto " <> versionStr ] ] 158 | , H.p_ [ H.text "For feedback, contact us at " 159 | , H.a [ P.href "mailto:info@metrix-frs.de" ] 160 | [ H.text "info@metrix-frs.de" ] 161 | , H.text " or visit " 162 | , H.a [ P.href "http://www.metrix-frs.de" ] 163 | [ H.text "metrix-frs.de" ] 164 | , H.text "." 165 | ] 166 | ] 167 | [ H.button 168 | [ E.onClick $ E.input_ AboutClose ] 169 | [ H.text "Close" ] 170 | ] 171 | ] 172 | else 173 | [] 174 | ) 175 | 176 | eval :: Query ~> ParentDSL State ChildState Query ChildQuery Metrix ChildSlot 177 | eval (Boot next) = do 178 | apiCallParent loginStatus \status -> case unNull status of 179 | Just authInfo -> 180 | modify _{ authStatus = Authenticated authInfo } 181 | Nothing -> 182 | modify _{ authStatus = LoggedOut } 183 | pure next 184 | 185 | eval (Authenticate next) = do 186 | st <- get 187 | apiCallParent (login st.customerId st.licenseKey) \res -> case runJsonEither res of 188 | Right authInfo -> 189 | modify _{ authStatus = Authenticated authInfo 190 | , authError = Nothing } 191 | Left errMsg -> 192 | modify _{ authError = Just errMsg } 193 | pure next 194 | 195 | eval (SetCustomerId customerId next) = do 196 | modify _{ customerId = customerId} 197 | pure next 198 | 199 | eval (SetLicenseKey key next) = do 200 | modify _{ licenseKey = key } 201 | pure next 202 | 203 | eval (AboutOpen next) = do 204 | modify _{ aboutOpen = true } 205 | pure next 206 | 207 | eval (AboutClose next) = do 208 | modify _{ aboutOpen = false } 209 | pure next 210 | 211 | eval (LogOut next) = do 212 | apiCallParent logout \_ -> 213 | modify _{ authStatus = LoggedOut 214 | , customerId = "" 215 | , licenseKey = "" } 216 | pure next 217 | 218 | renderAuthForm :: String -> String -> Maybe String -> ParentHTML ChildState Query ChildQuery Metrix ChildSlot 219 | renderAuthForm customerId licenseKey authError = 220 | H.div [ cls "splash-background" ] 221 | [ H.div [ cls "splash-auth" ] 222 | [ H.div [ cls "splash-auth-logo" ] [] 223 | , H.div [ cls "splash-auth-box" ] $ 224 | [ H.p_ [ H.text "Please enter your customer id and license key:" ] 225 | , H.input 226 | [ E.onValueChange $ E.input SetCustomerId 227 | , P.value customerId 228 | , P.placeholder "ID" 229 | ] 230 | , H.input 231 | [ E.onValueChange $ E.input SetLicenseKey 232 | , P.value licenseKey 233 | , P.placeholder "License Key" 234 | ] 235 | , H.button 236 | [ E.onClick (E.input_ Authenticate) ] 237 | [ H.text "Authenticate" ] 238 | ] <> ( 239 | case authError of 240 | Just err -> 241 | [ H.p_ [ H.text $ "Auth error: " <> err ] 242 | ] 243 | Nothing -> 244 | [] 245 | ) 246 | ] 247 | ] 248 | -------------------------------------------------------------------------------- /public/octicons/octicons.css: -------------------------------------------------------------------------------- 1 | @font-face { 2 | font-family: 'octicons'; 3 | src: url('octicons.eot?#iefix') format('embedded-opentype'), 4 | url('octicons.woff') format('woff'), 5 | url('octicons.ttf') format('truetype'), 6 | url('octicons.svg#octicons') format('svg'); 7 | font-weight: normal; 8 | font-style: normal; 9 | } 10 | 11 | /* 12 | 13 | .octicon is optimized for 16px. 14 | .mega-octicon is optimized for 32px but can be used larger. 15 | 16 | */ 17 | .octicon, .mega-octicon { 18 | font: normal normal normal 16px/1 octicons; 19 | display: inline-block; 20 | text-decoration: none; 21 | text-rendering: auto; 22 | -webkit-font-smoothing: antialiased; 23 | -moz-osx-font-smoothing: grayscale; 24 | -webkit-user-select: none; 25 | -moz-user-select: none; 26 | -ms-user-select: none; 27 | user-select: none; 28 | } 29 | .mega-octicon { font-size: 32px; } 30 | 31 | .octicon-alert:before { content: '\f02d'} /*  */ 32 | .octicon-arrow-down:before { content: '\f03f'} /*  */ 33 | .octicon-arrow-left:before { content: '\f040'} /*  */ 34 | .octicon-arrow-right:before { content: '\f03e'} /*  */ 35 | .octicon-arrow-small-down:before { content: '\f0a0'} /*  */ 36 | .octicon-arrow-small-left:before { content: '\f0a1'} /*  */ 37 | .octicon-arrow-small-right:before { content: '\f071'} /*  */ 38 | .octicon-arrow-small-up:before { content: '\f09f'} /*  */ 39 | .octicon-arrow-up:before { content: '\f03d'} /*  */ 40 | .octicon-microscope:before, 41 | .octicon-beaker:before { content: '\f0dd'} /*  */ 42 | .octicon-bell:before { content: '\f0de'} /*  */ 43 | .octicon-bold:before { content: '\f0e2'} /*  */ 44 | .octicon-book:before { content: '\f007'} /*  */ 45 | .octicon-bookmark:before { content: '\f07b'} /*  */ 46 | .octicon-briefcase:before { content: '\f0d3'} /*  */ 47 | .octicon-broadcast:before { content: '\f048'} /*  */ 48 | .octicon-browser:before { content: '\f0c5'} /*  */ 49 | .octicon-bug:before { content: '\f091'} /*  */ 50 | .octicon-calendar:before { content: '\f068'} /*  */ 51 | .octicon-check:before { content: '\f03a'} /*  */ 52 | .octicon-checklist:before { content: '\f076'} /*  */ 53 | .octicon-chevron-down:before { content: '\f0a3'} /*  */ 54 | .octicon-chevron-left:before { content: '\f0a4'} /*  */ 55 | .octicon-chevron-right:before { content: '\f078'} /*  */ 56 | .octicon-chevron-up:before { content: '\f0a2'} /*  */ 57 | .octicon-circle-slash:before { content: '\f084'} /*  */ 58 | .octicon-circuit-board:before { content: '\f0d6'} /*  */ 59 | .octicon-clippy:before { content: '\f035'} /*  */ 60 | .octicon-clock:before { content: '\f046'} /*  */ 61 | .octicon-cloud-download:before { content: '\f00b'} /*  */ 62 | .octicon-cloud-upload:before { content: '\f00c'} /*  */ 63 | .octicon-code:before { content: '\f05f'} /*  */ 64 | .octicon-color-mode:before { content: '\f065'} /*  */ 65 | .octicon-comment-add:before, 66 | .octicon-comment:before { content: '\f02b'} /*  */ 67 | .octicon-comment-discussion:before { content: '\f04f'} /*  */ 68 | .octicon-credit-card:before { content: '\f045'} /*  */ 69 | .octicon-dash:before { content: '\f0ca'} /*  */ 70 | .octicon-dashboard:before { content: '\f07d'} /*  */ 71 | .octicon-database:before { content: '\f096'} /*  */ 72 | .octicon-clone:before, 73 | .octicon-desktop-download:before { content: '\f0dc'} /*  */ 74 | .octicon-device-camera:before { content: '\f056'} /*  */ 75 | .octicon-device-camera-video:before { content: '\f057'} /*  */ 76 | .octicon-device-desktop:before { content: '\f27c'} /*  */ 77 | .octicon-device-mobile:before { content: '\f038'} /*  */ 78 | .octicon-diff:before { content: '\f04d'} /*  */ 79 | .octicon-diff-added:before { content: '\f06b'} /*  */ 80 | .octicon-diff-ignored:before { content: '\f099'} /*  */ 81 | .octicon-diff-modified:before { content: '\f06d'} /*  */ 82 | .octicon-diff-removed:before { content: '\f06c'} /*  */ 83 | .octicon-diff-renamed:before { content: '\f06e'} /*  */ 84 | .octicon-ellipsis:before { content: '\f09a'} /*  */ 85 | .octicon-eye-unwatch:before, 86 | .octicon-eye-watch:before, 87 | .octicon-eye:before { content: '\f04e'} /*  */ 88 | .octicon-file-binary:before { content: '\f094'} /*  */ 89 | .octicon-file-code:before { content: '\f010'} /*  */ 90 | .octicon-file-directory:before { content: '\f016'} /*  */ 91 | .octicon-file-media:before { content: '\f012'} /*  */ 92 | .octicon-file-pdf:before { content: '\f014'} /*  */ 93 | .octicon-file-submodule:before { content: '\f017'} /*  */ 94 | .octicon-file-symlink-directory:before { content: '\f0b1'} /*  */ 95 | .octicon-file-symlink-file:before { content: '\f0b0'} /*  */ 96 | .octicon-file-text:before { content: '\f011'} /*  */ 97 | .octicon-file-zip:before { content: '\f013'} /*  */ 98 | .octicon-flame:before { content: '\f0d2'} /*  */ 99 | .octicon-fold:before { content: '\f0cc'} /*  */ 100 | .octicon-gear:before { content: '\f02f'} /*  */ 101 | .octicon-gift:before { content: '\f042'} /*  */ 102 | .octicon-gist:before { content: '\f00e'} /*  */ 103 | .octicon-gist-secret:before { content: '\f08c'} /*  */ 104 | .octicon-git-branch-create:before, 105 | .octicon-git-branch-delete:before, 106 | .octicon-git-branch:before { content: '\f020'} /*  */ 107 | .octicon-git-commit:before { content: '\f01f'} /*  */ 108 | .octicon-git-compare:before { content: '\f0ac'} /*  */ 109 | .octicon-git-merge:before { content: '\f023'} /*  */ 110 | .octicon-git-pull-request-abandoned:before, 111 | .octicon-git-pull-request:before { content: '\f009'} /*  */ 112 | .octicon-globe:before { content: '\f0b6'} /*  */ 113 | .octicon-graph:before { content: '\f043'} /*  */ 114 | .octicon-heart:before { content: '\2665'} /* ♥ */ 115 | .octicon-history:before { content: '\f07e'} /*  */ 116 | .octicon-home:before { content: '\f08d'} /*  */ 117 | .octicon-horizontal-rule:before { content: '\f070'} /*  */ 118 | .octicon-hubot:before { content: '\f09d'} /*  */ 119 | .octicon-inbox:before { content: '\f0cf'} /*  */ 120 | .octicon-info:before { content: '\f059'} /*  */ 121 | .octicon-issue-closed:before { content: '\f028'} /*  */ 122 | .octicon-issue-opened:before { content: '\f026'} /*  */ 123 | .octicon-issue-reopened:before { content: '\f027'} /*  */ 124 | .octicon-italic:before { content: '\f0e4'} /*  */ 125 | .octicon-jersey:before { content: '\f019'} /*  */ 126 | .octicon-key:before { content: '\f049'} /*  */ 127 | .octicon-keyboard:before { content: '\f00d'} /*  */ 128 | .octicon-law:before { content: '\f0d8'} /*  */ 129 | .octicon-light-bulb:before { content: '\f000'} /*  */ 130 | .octicon-link:before { content: '\f05c'} /*  */ 131 | .octicon-link-external:before { content: '\f07f'} /*  */ 132 | .octicon-list-ordered:before { content: '\f062'} /*  */ 133 | .octicon-list-unordered:before { content: '\f061'} /*  */ 134 | .octicon-location:before { content: '\f060'} /*  */ 135 | .octicon-gist-private:before, 136 | .octicon-mirror-private:before, 137 | .octicon-git-fork-private:before, 138 | .octicon-lock:before { content: '\f06a'} /*  */ 139 | .octicon-logo-github:before { content: '\f092'} /*  */ 140 | .octicon-mail:before { content: '\f03b'} /*  */ 141 | .octicon-mail-read:before { content: '\f03c'} /*  */ 142 | .octicon-mail-reply:before { content: '\f051'} /*  */ 143 | .octicon-mark-github:before { content: '\f00a'} /*  */ 144 | .octicon-markdown:before { content: '\f0c9'} /*  */ 145 | .octicon-megaphone:before { content: '\f077'} /*  */ 146 | .octicon-mention:before { content: '\f0be'} /*  */ 147 | .octicon-milestone:before { content: '\f075'} /*  */ 148 | .octicon-mirror-public:before, 149 | .octicon-mirror:before { content: '\f024'} /*  */ 150 | .octicon-mortar-board:before { content: '\f0d7'} /*  */ 151 | .octicon-mute:before { content: '\f080'} /*  */ 152 | .octicon-no-newline:before { content: '\f09c'} /*  */ 153 | .octicon-octoface:before { content: '\f008'} /*  */ 154 | .octicon-organization:before { content: '\f037'} /*  */ 155 | .octicon-package:before { content: '\f0c4'} /*  */ 156 | .octicon-paintcan:before { content: '\f0d1'} /*  */ 157 | .octicon-pencil:before { content: '\f058'} /*  */ 158 | .octicon-person-add:before, 159 | .octicon-person-follow:before, 160 | .octicon-person:before { content: '\f018'} /*  */ 161 | .octicon-pin:before { content: '\f041'} /*  */ 162 | .octicon-plug:before { content: '\f0d4'} /*  */ 163 | .octicon-repo-create:before, 164 | .octicon-gist-new:before, 165 | .octicon-file-directory-create:before, 166 | .octicon-file-add:before, 167 | .octicon-plus:before { content: '\f05d'} /*  */ 168 | .octicon-primitive-dot:before { content: '\f052'} /*  */ 169 | .octicon-primitive-square:before { content: '\f053'} /*  */ 170 | .octicon-pulse:before { content: '\f085'} /*  */ 171 | .octicon-question:before { content: '\f02c'} /*  */ 172 | .octicon-quote:before { content: '\f063'} /*  */ 173 | .octicon-radio-tower:before { content: '\f030'} /*  */ 174 | .octicon-repo-delete:before, 175 | .octicon-repo:before { content: '\f001'} /*  */ 176 | .octicon-repo-clone:before { content: '\f04c'} /*  */ 177 | .octicon-repo-force-push:before { content: '\f04a'} /*  */ 178 | .octicon-gist-fork:before, 179 | .octicon-repo-forked:before { content: '\f002'} /*  */ 180 | .octicon-repo-pull:before { content: '\f006'} /*  */ 181 | .octicon-repo-push:before { content: '\f005'} /*  */ 182 | .octicon-rocket:before { content: '\f033'} /*  */ 183 | .octicon-rss:before { content: '\f034'} /*  */ 184 | .octicon-ruby:before { content: '\f047'} /*  */ 185 | .octicon-search-save:before, 186 | .octicon-search:before { content: '\f02e'} /*  */ 187 | .octicon-server:before { content: '\f097'} /*  */ 188 | .octicon-settings:before { content: '\f07c'} /*  */ 189 | .octicon-shield:before { content: '\f0e1'} /*  */ 190 | .octicon-log-in:before, 191 | .octicon-sign-in:before { content: '\f036'} /*  */ 192 | .octicon-log-out:before, 193 | .octicon-sign-out:before { content: '\f032'} /*  */ 194 | .octicon-squirrel:before { content: '\f0b2'} /*  */ 195 | .octicon-star-add:before, 196 | .octicon-star-delete:before, 197 | .octicon-star:before { content: '\f02a'} /*  */ 198 | .octicon-stop:before { content: '\f08f'} /*  */ 199 | .octicon-repo-sync:before, 200 | .octicon-sync:before { content: '\f087'} /*  */ 201 | .octicon-tag-remove:before, 202 | .octicon-tag-add:before, 203 | .octicon-tag:before { content: '\f015'} /*  */ 204 | .octicon-tasklist:before { content: '\f0e5'} /*  */ 205 | .octicon-telescope:before { content: '\f088'} /*  */ 206 | .octicon-terminal:before { content: '\f0c8'} /*  */ 207 | .octicon-text-size:before { content: '\f0e3'} /*  */ 208 | .octicon-three-bars:before { content: '\f05e'} /*  */ 209 | .octicon-thumbsdown:before { content: '\f0db'} /*  */ 210 | .octicon-thumbsup:before { content: '\f0da'} /*  */ 211 | .octicon-tools:before { content: '\f031'} /*  */ 212 | .octicon-trashcan:before { content: '\f0d0'} /*  */ 213 | .octicon-triangle-down:before { content: '\f05b'} /*  */ 214 | .octicon-triangle-left:before { content: '\f044'} /*  */ 215 | .octicon-triangle-right:before { content: '\f05a'} /*  */ 216 | .octicon-triangle-up:before { content: '\f0aa'} /*  */ 217 | .octicon-unfold:before { content: '\f039'} /*  */ 218 | .octicon-unmute:before { content: '\f0ba'} /*  */ 219 | .octicon-versions:before { content: '\f064'} /*  */ 220 | .octicon-watch:before { content: '\f0e0'} /*  */ 221 | .octicon-remove-close:before, 222 | .octicon-x:before { content: '\f081'} /*  */ 223 | .octicon-zap:before { content: '\26A1'} /* ⚡ */ 224 | -------------------------------------------------------------------------------- /src/Component/File.purs: -------------------------------------------------------------------------------- 1 | module Component.File where 2 | 3 | import Prelude 4 | import Halogen.HTML.Events.Indexed as E 5 | import Halogen.HTML.Indexed as H 6 | import Halogen.HTML.Properties.Indexed as P 7 | import Api (getFileOrphans, apiCall, getFileTags, renameTag, renameFile, pruneOrphan, deleteTag, apiUrl) 8 | import Api.Schema.BusinessData (TagDesc(TagDesc), UpdateDesc(UpdateDesc)) 9 | import Api.Schema.File (File(File), _fileLabel, _fileCreated, _fileChanged, _fileId, _fileLastUpdateId) 10 | import Component.Common (modal) 11 | import Data.Array (filter) 12 | import Data.Foldable (find) 13 | import Data.Lens (Lens', lens, (%~), (.~), (^.)) 14 | import Data.Maybe (Maybe(Just, Nothing)) 15 | import Halogen (ComponentDSL, ComponentHTML, Component, modify, gets, action, lifecycleComponent) 16 | import Types (Metrix, TagId, UpdateId) 17 | import Utils (cls) 18 | 19 | data Renaming 20 | = RNone 21 | | RFile String 22 | | RTag TagId String 23 | 24 | data DeleteConfirm 25 | = DNone 26 | | DFile 27 | | DTag TagId 28 | | DOrphan UpdateId 29 | 30 | type State = 31 | { file :: File 32 | , tagsOpen :: Boolean 33 | , tags :: Array TagDesc 34 | , orphans :: Array UpdateDesc 35 | , fetchedTags :: Boolean 36 | , deleteConfirm :: DeleteConfirm 37 | , renaming :: Renaming 38 | } 39 | 40 | _file :: Lens' State File 41 | _file = lens _.file _{ file = _ } 42 | 43 | _tags :: Lens' State (Array TagDesc) 44 | _tags = lens _.tags _{ tags = _ } 45 | 46 | _orphans :: Lens' State (Array UpdateDesc) 47 | _orphans = lens _.orphans _{ orphans = _ } 48 | 49 | initialState :: File -> State 50 | initialState f = 51 | { file: f 52 | , tagsOpen: false 53 | , tags: [] 54 | , orphans: [] 55 | , fetchedTags: false 56 | , deleteConfirm: DNone 57 | , renaming: RNone 58 | } 59 | 60 | data Query a 61 | = Init a 62 | | Open UpdateId a 63 | | DeleteFile a 64 | | DeleteFileYes a 65 | | DeleteTag TagId a 66 | | DeleteTagYes a 67 | | DeleteOrphan UpdateId a 68 | | DeleteOrphanYes a 69 | | DeleteNo a 70 | | RenameFileStart a 71 | | RenameFileSetNewName String a 72 | | RenameFileDone a 73 | | RenameTagStart TagId a 74 | | RenameTagSetNewName String a 75 | | RenameTagDone a 76 | | TagsOpen a 77 | | TagsClose a 78 | 79 | file :: Component State Query Metrix 80 | file = lifecycleComponent 81 | { render 82 | , eval 83 | , initializer: Just (action Init) 84 | , finalizer: Nothing 85 | } 86 | 87 | render :: State -> ComponentHTML Query 88 | render st = H.div_ $ 89 | [ H.li 90 | [ cls "file" ] $ 91 | [ H.span 92 | [ cls $ "hlabel octicon octicon-chevron-" <> if st.tagsOpen then "down" else "right" 93 | , E.onClick $ E.input_ $ if st.tagsOpen then TagsClose else TagsOpen 94 | ] [] 95 | ] <> ( 96 | case st.renaming of 97 | RFile name -> 98 | [ H.input 99 | [ E.onValueChange $ E.input RenameFileSetNewName 100 | , P.value name 101 | ] 102 | , H.button 103 | [ E.onClick $ E.input_ RenameFileDone ] 104 | [ H.text "Ok" ] 105 | ] 106 | _ -> 107 | [ H.span 108 | [ cls "hlabel" 109 | , E.onClick $ E.input_ $ Open (st.file ^. _fileLastUpdateId) 110 | ] 111 | [ H.text (st.file ^. _fileLabel) 112 | ] 113 | ] 114 | ) <> 115 | [ H.div 116 | [ cls "actions" ] 117 | [ H.span 118 | [ cls "hlabel octicon octicon-pencil" 119 | , E.onClick $ E.input_ RenameFileStart 120 | ] [] 121 | , H.a 122 | [ P.href $ apiUrl <> "/api/v0.1/baresto/export/" <> show (st.file ^. _fileId) 123 | , P.target "_blank" 124 | ] 125 | [ H.span 126 | [ cls "hlabel octicon octicon-arrow-down" 127 | , P.title "Export as baresto file" 128 | ] [] 129 | ] 130 | , H.span 131 | [ cls "hlabel octicon octicon-x" 132 | , E.onClick $ E.input_ DeleteFile 133 | ] [] 134 | ] 135 | , H.div [ cls "details" ] 136 | [ H.div [ cls "edited" ] 137 | [ H.text $ "Last edited: " <> show (st.file ^. _fileChanged) 138 | ] 139 | , H.div [ cls "created" ] 140 | [ H.text $ "Created: " <> show (st.file ^. _fileCreated) 141 | ] 142 | ] 143 | ] <> ( 144 | case st.deleteConfirm of 145 | DFile -> 146 | [ modal "Delete File" 147 | [ H.p_ [ H.text "Really delete? All data will be lost and there is no way to recover!" ] ] 148 | [ H.button 149 | [ E.onClick $ E.input_ DeleteNo ] 150 | [ H.text "No" ] 151 | , H.button 152 | [ E.onClick $ E.input_ DeleteFileYes ] 153 | [ H.text "Yes" ] 154 | ] 155 | ] 156 | DTag _ -> 157 | [ modal "Delete Tag" 158 | [ H.p_ [ H.text "Are you sure you want to delete this tag?" ] ] 159 | [ H.button 160 | [ E.onClick $ E.input_ DeleteNo ] 161 | [ H.text "No" ] 162 | , H.button 163 | [ E.onClick $ E.input_ DeleteTagYes ] 164 | [ H.text "Yes" ] 165 | ] 166 | ] 167 | DOrphan _ -> 168 | [ modal "Delete Autosave" 169 | [ H.p_ [ H.text "Really delete? All data will be lost and there is no way to recover!" ] ] 170 | [ H.button 171 | [ E.onClick $ E.input_ DeleteNo ] 172 | [ H.text "No" ] 173 | , H.button 174 | [ E.onClick $ E.input_ DeleteOrphanYes ] 175 | [ H.text "Yes" ] 176 | ] 177 | ] 178 | _ -> 179 | [ ] 180 | ) 181 | ] <> ( 182 | if st.tagsOpen 183 | then 184 | [ H.li 185 | [ cls "tag-title" ] 186 | [ H.span 187 | [ cls "label octicon octicon-tag" ] 188 | [] 189 | , H.span 190 | [ cls "label" ] 191 | [ H.text "Tags" 192 | ] 193 | ] 194 | ] <> (renderTag st <$> st.tags) <> 195 | [ H.li 196 | [ cls "orphan-title" ] 197 | [ H.span 198 | [ cls "label octicon octicon-watch" ] 199 | [] 200 | , H.span 201 | [ cls "label" ] 202 | [ H.text "Autosaves" 203 | ] 204 | ] 205 | ] <> (renderOrphan st <$> st.orphans) 206 | else 207 | [] 208 | ) <> 209 | [ H.li 210 | [ cls "sep" 211 | ] [] 212 | ] 213 | 214 | renderTag :: State -> TagDesc -> ComponentHTML Query 215 | renderTag st (TagDesc tag) = 216 | H.li 217 | [ cls "tag" ] $ 218 | ( case st.renaming of 219 | RTag tagId name | tagId == tag.tagDescTagId -> 220 | [ H.input 221 | [ E.onValueChange $ E.input RenameTagSetNewName 222 | , P.value name 223 | ] 224 | , H.button 225 | [ E.onClick $ E.input_ RenameTagDone ] 226 | [ H.text "Ok" ] 227 | ] 228 | _ -> 229 | [ H.span 230 | [ cls "hlabel" 231 | , E.onClick $ E.input_ $ Open tag.tagDescUpdateId 232 | ] 233 | [ H.text tag.tagDescTagName ] 234 | ] 235 | ) <> 236 | [ H.div 237 | [ cls "actions" ] 238 | [ H.span 239 | [ cls "hlabel octicon octicon-pencil" 240 | , E.onClick $ E.input_ $ RenameTagStart tag.tagDescTagId 241 | ] [] 242 | , H.span 243 | [ cls "hlabel octicon octicon-x" 244 | , E.onClick $ E.input_ $ DeleteTag tag.tagDescTagId 245 | ] [] 246 | ] 247 | ] 248 | 249 | renderOrphan :: State -> UpdateDesc -> ComponentHTML Query 250 | renderOrphan st (UpdateDesc upd) = 251 | H.li 252 | [ cls "orphan" ] 253 | [ H.span 254 | [ cls "hlabel" 255 | , E.onClick $ E.input_ $ Open upd.updateDescUpdateId 256 | ] 257 | [ H.text $ show upd.updateDescCreated 258 | ] 259 | , H.div 260 | [ cls "actions" ] 261 | [ H.span 262 | [ cls "hlabel octicon octicon-x" 263 | , E.onClick $ E.input_ $ DeleteOrphan upd.updateDescUpdateId 264 | ] [] 265 | ] 266 | ] 267 | 268 | eval :: Query ~> ComponentDSL State Query Metrix 269 | eval (Init next) = do 270 | pure next 271 | 272 | -- peeked by Body 273 | eval (Open _ next) = do 274 | pure next 275 | 276 | eval (DeleteFile next) = do 277 | modify $ _{ deleteConfirm = DFile } 278 | pure next 279 | 280 | eval (DeleteFileYes next) = do 281 | pure next 282 | 283 | eval (DeleteTag tagId next) = do 284 | modify $ _{ deleteConfirm = DTag tagId } 285 | pure next 286 | 287 | eval (DeleteTagYes next) = do 288 | del <- gets _.deleteConfirm 289 | case del of 290 | DTag tagId -> apiCall (deleteTag tagId) \_ -> do 291 | modify $ _{ deleteConfirm = DNone } 292 | modify $ _tags %~ filter (\(TagDesc t) -> t.tagDescTagId /= tagId) 293 | (File f) <- gets _.file 294 | apiCall (getFileOrphans f.fileId) \orphans -> 295 | modify $ _{ orphans = orphans } 296 | _ -> pure unit 297 | pure next 298 | 299 | eval (DeleteOrphan updId next) = do 300 | modify $ _{ deleteConfirm = DOrphan updId } 301 | pure next 302 | 303 | eval (DeleteOrphanYes next) = do 304 | del <- gets _.deleteConfirm 305 | case del of 306 | DOrphan updId -> apiCall (pruneOrphan updId) \_ -> do 307 | modify $ _{ deleteConfirm = DNone } 308 | modify $ _orphans %~ filter (\(UpdateDesc u) -> u.updateDescUpdateId /= updId) 309 | _ -> pure unit 310 | pure next 311 | 312 | eval (DeleteNo next) = do 313 | modify $ _{ deleteConfirm = DNone } 314 | pure next 315 | 316 | eval (RenameFileStart next) = do 317 | (File f) <- gets _.file 318 | modify $ _{ renaming = RFile f.fileLabel } 319 | pure next 320 | 321 | eval (RenameFileSetNewName name next) = do 322 | modify $ _{ renaming = RFile name } 323 | pure next 324 | 325 | eval (RenameFileDone next) = do 326 | renaming <- gets _.renaming 327 | (File f) <- gets _.file 328 | case renaming of 329 | RFile newName -> apiCall (renameFile f.fileId newName) \resultName -> 330 | modify $ _file <<< _fileLabel .~ resultName 331 | _ -> pure unit 332 | modify $ _{ renaming = RNone } 333 | pure next 334 | 335 | eval (RenameTagStart tagId next) = do 336 | tags <- gets _.tags 337 | case find (\(TagDesc t) -> t.tagDescTagId == tagId) tags of 338 | Nothing -> pure unit 339 | Just (TagDesc t) -> modify $ _{ renaming = RTag tagId t.tagDescTagName } 340 | pure next 341 | 342 | eval (RenameTagSetNewName tagName next) = do 343 | renaming <- gets _.renaming 344 | case renaming of 345 | RTag tagId _ -> modify $ _{ renaming = RTag tagId tagName } 346 | _ -> pure unit 347 | pure next 348 | 349 | eval (RenameTagDone next) = do 350 | renaming <- gets _.renaming 351 | case renaming of 352 | RTag tagId newName -> apiCall (renameTag tagId newName) \resultName -> do 353 | let rename (TagDesc t) = TagDesc $ if t.tagDescTagId == tagId 354 | then t { tagDescTagName = resultName } 355 | else t 356 | modify $ _tags %~ map rename 357 | modify $ _{ renaming = RNone } 358 | _ -> pure unit 359 | pure next 360 | 361 | eval (TagsOpen next) = do 362 | modify $ _{ tagsOpen = true } 363 | fetched <- gets _.fetchedTags 364 | when (not fetched) $ do 365 | (File f) <- gets _.file 366 | apiCall (getFileTags f.fileId) \tags -> 367 | modify $ _{ tags = tags } 368 | apiCall (getFileOrphans f.fileId) \orphans -> 369 | modify $ _{ orphans = orphans } 370 | modify $ _{ fetchedTags = true } 371 | pure next 372 | 373 | eval (TagsClose next) = do 374 | modify $ _{ tagsOpen = false } 375 | pure next 376 | -------------------------------------------------------------------------------- /src/Lib/BusinessData.purs: -------------------------------------------------------------------------------- 1 | module Lib.BusinessData 2 | ( CustomYMemberStore() 3 | , CustomZMemberStore() 4 | , SubsetZMemberStore() 5 | , SubsetMember() 6 | , CustomMember() 7 | , BusinessData() 8 | , emptyBusinessData 9 | , _BusinessData 10 | , _snapshot 11 | , _customYMembers 12 | , _customZMembers 13 | , _subsetZMembers 14 | , Edit(..) 15 | , editToUpdate 16 | , applyUpdate 17 | , doesSheetExist 18 | , getMaxSheet 19 | , sheetToZLocation 20 | , gridHeight 21 | , getCellTable 22 | , getFactTable 23 | , getCustomYMembers 24 | , getCustomYMembersBySheet 25 | , getCustomZMembers 26 | , getSubsetZMembers 27 | , isSubsetZMemberSelected 28 | ) where 29 | 30 | import Prelude 31 | import Data.Array as Array 32 | import Data.Map as M 33 | import Api.Schema.BusinessData (Update(Update)) 34 | import Api.Schema.BusinessData.Key (IsRowKey(RowKey, NoRowKey), Key(KeySubsetZSelected, KeyHeaderFact, KeyFact, KeyCustomZMember, KeyCustomRow), YLocation(YLocCustom, YLocClosed), ZLocation(ZLocSubset, ZLocCustom, ZLocClosed, ZLocSingle)) 35 | import Api.Schema.BusinessData.Value (Value(Value), updateValue, UpdateValue(UpdateValueData)) 36 | import Api.Schema.Table (Cell(YMemberCell, FactCell, NoCell), DataType(BooleanData, CodeData, PercentageData, MonetaryData), Ordinate(Ordinate), Table(Table), YAxis(YAxisCustom, YAxisClosed), ZAxis(ZAxisSubset, ZAxisCustom, ZAxisClosed, ZAxisSingleton)) 37 | import Control.Monad.State (execState) 38 | import Data.Array ((!!), length, filter, snoc) 39 | import Data.Foldable (foldl) 40 | import Data.Lens (Lens', lens, use, (%=), (.=), (.~), (^.)) 41 | import Data.Lens.At (at) 42 | import Data.Maybe (fromMaybe, Maybe(Just, Nothing), isJust) 43 | import Data.String (null) 44 | import Data.Tuple (Tuple(Tuple), lookup) 45 | import Lib.Table (lookupBySnd, C(C), Coord(Coord), R(R), S(S), cellLookup, boolValueMap) 46 | import Types (SubsetMemberId, AxisId, CellId, CustomMemberId) 47 | import Utils (getIndices, maxInt, non) 48 | 49 | type CustomMember = Tuple CustomMemberId String 50 | type SubsetMember = Tuple SubsetMemberId String 51 | 52 | type CustomYMemberStore = M.Map (Tuple AxisId ZLocation) (Array CustomMember) 53 | type CustomZMemberStore = M.Map AxisId (Array CustomMember) 54 | type SubsetZMemberStore = M.Map AxisId (Array SubsetMember) 55 | 56 | newtype BusinessData = BusinessData 57 | { snapshot :: M.Map Key String 58 | , customYMembers :: CustomYMemberStore 59 | , customZMembers :: CustomZMemberStore 60 | , subsetZMembers :: SubsetZMemberStore 61 | } 62 | 63 | _BusinessData :: Lens' BusinessData _ 64 | _BusinessData = lens (\(BusinessData r) -> r) (\_ r -> BusinessData r) 65 | 66 | _snapshot :: Lens' BusinessData (M.Map Key String) 67 | _snapshot = _BusinessData <<< lens _.snapshot _{ snapshot = _ } 68 | 69 | _customYMembers :: Lens' BusinessData CustomYMemberStore 70 | _customYMembers = _BusinessData <<< lens _.customYMembers _{ customYMembers = _ } 71 | 72 | _customZMembers :: Lens' BusinessData CustomZMemberStore 73 | _customZMembers = _BusinessData <<< lens _.customZMembers _{ customZMembers = _ } 74 | 75 | _subsetZMembers :: Lens' BusinessData SubsetZMemberStore 76 | _subsetZMembers = _BusinessData <<< lens _.subsetZMembers _{ subsetZMembers = _ } 77 | 78 | emptyBusinessData :: BusinessData 79 | emptyBusinessData = BusinessData 80 | { snapshot: M.empty 81 | , customYMembers: M.empty 82 | , customZMembers: M.empty 83 | , subsetZMembers: M.empty 84 | } 85 | 86 | -- Update 87 | 88 | data Edit 89 | = SetFacts Table (Array (Tuple Coord String)) 90 | | NewCustomRow AxisId ZLocation CustomMemberId 91 | | NewCustomZMember AxisId CustomMemberId 92 | | RenameCustomZMember AxisId Int String 93 | | DeleteCustomRow AxisId ZLocation Int 94 | | DeleteCustomZMember AxisId Int 95 | | SelectSubsetZMember AxisId SubsetMemberId 96 | | DeselectSubsetZMember AxisId SubsetMemberId 97 | 98 | foreign import stripDecimals :: String -> Int -> String 99 | 100 | editToUpdate :: Edit -> BusinessData -> Maybe Update 101 | editToUpdate bde bd = case bde of 102 | SetFacts table changes -> 103 | let list = join $ (go table) <$> changes 104 | in if Array.null list 105 | then Nothing 106 | else Just $ Update list 107 | NewCustomRow axId zLoc cm -> 108 | single (KeyCustomRow axId zLoc cm) $ Just "customY" 109 | NewCustomZMember axId cm -> 110 | single (KeyCustomZMember axId cm) $ Just "" 111 | RenameCustomZMember axId index name -> do 112 | (Tuple cm _) <- getCustomZMembers axId bd !! index 113 | single (KeyCustomZMember axId cm) $ Just name 114 | DeleteCustomRow axId zLoc index -> do 115 | (Tuple cm _) <- getCustomYMembers axId zLoc bd !! index 116 | single (KeyCustomRow axId zLoc cm) Nothing 117 | DeleteCustomZMember axId index -> do 118 | (Tuple cm _) <- getCustomZMembers axId bd !! index 119 | single (KeyCustomZMember axId cm) Nothing 120 | SelectSubsetZMember axId sm -> 121 | single (KeySubsetZSelected axId sm) $ Just "selected" 122 | DeselectSubsetZMember axId sm -> 123 | single (KeySubsetZSelected axId sm) Nothing 124 | where 125 | go :: Table -> Tuple Coord String -> Array (Tuple Key UpdateValue) 126 | go table (Tuple coord new) = case getKey coord table bd of 127 | Just key -> 128 | let old = getBDValue key bd 129 | convNew = if null new then Nothing else Just $ conv new 130 | in if old == convNew 131 | then [] 132 | else [Tuple key (UpdateValueData convNew)] 133 | Nothing -> [] 134 | where 135 | conv v = case cellLookup coord table of 136 | Just (FactCell _ dType) -> case dType of 137 | CodeData pairs -> 138 | fromMaybe v $ lookupBySnd v pairs 139 | BooleanData -> 140 | fromMaybe v $ lookupBySnd v boolValueMap 141 | MonetaryData -> v 142 | PercentageData -> v 143 | _ -> v 144 | Just _ -> v 145 | Nothing -> v 146 | 147 | single :: Key -> Maybe String -> Maybe Update 148 | single key new = 149 | let old = getBDValue key bd in 150 | if old == new 151 | then Nothing 152 | else Just $ Update [Tuple key (UpdateValueData new)] 153 | 154 | applyUpdate :: Update -> BusinessData -> BusinessData 155 | applyUpdate (Update list) bd' = foldl go bd' list 156 | where 157 | go bd (Tuple key upd) = bd # execState do 158 | old <- use $ _snapshot <<< at key 159 | let new = case updateValue upd (Value { valueData: old, valuePrecision: Nothing }) of 160 | Value v -> v.valueData 161 | _snapshot <<< at key .= new 162 | case key of 163 | KeyCustomRow axId zLoc cm -> 164 | _customYMembers <<< at (Tuple axId zLoc) <<< non [] %= case upd of 165 | UpdateValueData (Just new') -> flip snoc (Tuple cm new') 166 | UpdateValueData Nothing -> filter (\(Tuple cm' (_ :: String)) -> cm /= cm') 167 | _ -> id 168 | KeyCustomZMember axId cm -> 169 | _customZMembers <<< at axId <<< non [] %= case Tuple old upd of 170 | Tuple (Just _) (UpdateValueData (Just new')) -> 171 | map (\(Tuple cm' val) -> if cm == cm' then (Tuple cm' new') else (Tuple cm' val)) 172 | Tuple Nothing (UpdateValueData (Just new')) -> 173 | flip snoc (Tuple cm new') 174 | Tuple (Just _) (UpdateValueData Nothing) -> 175 | filter (\(Tuple cm' (_ :: String)) -> cm /= cm') 176 | _ -> 177 | id 178 | KeySubsetZSelected axId sm -> 179 | _subsetZMembers <<< at axId <<< non [] %= case upd of 180 | UpdateValueData (Just new') -> flip snoc (Tuple sm new') 181 | UpdateValueData Nothing -> filter (\(Tuple sm' (_ :: String)) -> sm /= sm') 182 | _ -> id 183 | _ -> pure unit 184 | 185 | -- Interface 186 | 187 | doesSheetExist :: S -> Table -> BusinessData -> Boolean 188 | doesSheetExist (S s) (Table tbl) bd = 189 | case tbl.tableZAxis of 190 | ZAxisCustom axisId _ -> isJust $ (getCustomZMembers axisId bd) !! s 191 | ZAxisSubset axisId _ _ -> isJust $ (getSubsetZMembers axisId bd) !! s 192 | ZAxisClosed _ ords -> isJust $ ords !! s 193 | ZAxisSingleton -> s == 0 194 | 195 | getMaxSheet :: Table -> BusinessData -> S 196 | getMaxSheet (Table tbl) bd = S $ maxInt 0 $ 197 | case tbl.tableZAxis of 198 | ZAxisCustom axisId _ -> length (getCustomZMembers axisId bd) - 1 199 | ZAxisSubset axisId _ _ -> length (getSubsetZMembers axisId bd) - 1 200 | ZAxisClosed _ ords -> length ords - 1 201 | ZAxisSingleton -> 0 202 | 203 | sheetToZLocation :: S -> Table -> BusinessData -> Maybe ZLocation 204 | sheetToZLocation (S s) (Table tbl) bd = case tbl.tableZAxis of 205 | ZAxisSingleton -> pure ZLocSingle 206 | ZAxisClosed _ ords -> do 207 | (Ordinate ord) <- ords !! s 208 | pure $ ZLocClosed (ord.ordinateId) 209 | ZAxisCustom axId _ -> do 210 | (Tuple cmId _) <- getCustomZMembers axId bd !! s 211 | pure $ ZLocCustom axId cmId 212 | ZAxisSubset axId _ _ -> do 213 | (Tuple smId _) <- getSubsetZMembers axId bd !! s 214 | pure $ ZLocSubset axId smId 215 | 216 | gridHeight :: S -> Table -> BusinessData -> Maybe Int 217 | gridHeight s table@(Table tbl) bd = do 218 | zLoc <- sheetToZLocation s table bd 219 | case tbl.tableYAxis of 220 | YAxisClosed _ ords -> pure $ length ords 221 | YAxisCustom axId _ -> pure $ length $ getCustomYMembers axId zLoc bd 222 | 223 | getCellTable :: S -> Table -> BusinessData -> Maybe (Array (Array Cell)) 224 | getCellTable s table@(Table tbl) bd = do 225 | zLoc <- sheetToZLocation s table bd 226 | pure $ case tbl.tableYAxis of 227 | YAxisClosed _ ords -> row <$> getIndices ords 228 | YAxisCustom axId _ -> row <$> getIndices (getCustomYMembers axId zLoc bd) 229 | where 230 | row r = cell r <$> getIndices tbl.tableXOrdinates 231 | cell r c = fromMaybe NoCell $ cellLookup (Coord (C c) (R r) s) table 232 | 233 | getFactTable :: S -> Table -> BusinessData -> Maybe (Array (Array String)) 234 | getFactTable s table@(Table tbl) bd = do 235 | zLoc <- sheetToZLocation s table bd 236 | pure $ case tbl.tableYAxis of 237 | YAxisClosed _ ords -> row <$> getIndices ords 238 | YAxisCustom axId _ -> row <$> getIndices (getCustomYMembers axId zLoc bd) 239 | where 240 | row r = cell r <$> getIndices tbl.tableXOrdinates 241 | cell r c = getFact (Coord (C c) (R r) s) table bd 242 | 243 | getFact :: Coord -> Table -> BusinessData -> String 244 | getFact coord table@(Table tbl) bd = case getKey coord table bd of 245 | Nothing -> "" 246 | Just key -> conv $ fromMaybe "" $ getBDValue key bd 247 | where 248 | conv k = case cellLookup coord table of 249 | Just (FactCell _ (CodeData pairs)) -> 250 | fromMaybe k $ lookup k pairs 251 | Just (FactCell _ BooleanData) -> 252 | fromMaybe k $ lookup k boolValueMap 253 | Just _ -> k 254 | Nothing -> k 255 | 256 | getKey :: Coord -> Table -> BusinessData -> Maybe Key 257 | getKey coord@(Coord _ (R r) (S s)) table@(Table tbl) bd = 258 | case cellLookup coord table of 259 | Just (FactCell cellId _) -> if tbl.tableIsHeader 260 | then Just $ KeyHeaderFact cellId 261 | else go cellId NoRowKey 262 | Just (YMemberCell cellId) -> go cellId RowKey 263 | _ -> Nothing 264 | where 265 | go :: CellId -> IsRowKey -> Maybe Key 266 | go cellId isRowKey = do 267 | zLoc <- sheetToZLocation (S s) table bd 268 | yLoc <- case tbl.tableYAxis of 269 | YAxisClosed _ _ -> pure YLocClosed 270 | YAxisCustom axId _ -> do 271 | (Tuple cmId _) <- getCustomYMembers axId zLoc bd !! r 272 | pure $ YLocCustom axId cmId 273 | pure $ KeyFact cellId isRowKey yLoc zLoc 274 | 275 | getCustomYMembers :: AxisId -> ZLocation -> BusinessData -> Array CustomMember 276 | getCustomYMembers axId zLoc bd = 277 | fromMaybe [] $ bd ^. _customYMembers <<< at (Tuple axId zLoc) 278 | 279 | getCustomYMembersBySheet :: AxisId -> S -> Table -> BusinessData -> Array CustomMember 280 | getCustomYMembersBySheet axId s table bd = case sheetToZLocation s table bd of 281 | Just zLoc -> getCustomYMembers axId zLoc bd 282 | Nothing -> [] 283 | 284 | getCustomZMembers :: AxisId -> BusinessData -> Array CustomMember 285 | getCustomZMembers axId bd = 286 | fromMaybe [] $ bd ^. _customZMembers <<< at axId 287 | 288 | getSubsetZMembers :: AxisId -> BusinessData -> Array SubsetMember 289 | getSubsetZMembers axId bd = 290 | fromMaybe [] $ bd ^. _subsetZMembers <<< at axId 291 | 292 | isSubsetZMemberSelected :: AxisId -> SubsetMemberId -> BusinessData -> Boolean 293 | isSubsetZMemberSelected axId memId bd = 294 | isJust $ getBDValue (KeySubsetZSelected axId memId) bd 295 | 296 | -- Internal helper 297 | 298 | getBDValue :: Key -> BusinessData -> Maybe String 299 | getBDValue key bd = bd ^. _snapshot <<< at key 300 | 301 | setBDValue :: Key -> String -> BusinessData -> BusinessData 302 | setBDValue key value bd = bd # _snapshot <<< at key .~ Just value 303 | -------------------------------------------------------------------------------- /src/Component/FileMenu.purs: -------------------------------------------------------------------------------- 1 | module Component.FileMenu where 2 | 3 | import Prelude 4 | import Halogen.HTML.Events.Indexed as E 5 | import Halogen.HTML.Indexed as H 6 | import Halogen.HTML.Properties.Indexed as P 7 | import Api (apiUrl, newTag, apiCall, uploadCsv, getUpdatePast) 8 | import Api.Schema.BusinessData (UpdateChange(UpdateChange), UpdateGet, TagDesc(TagDesc), UpdateDesc(UpdateDesc), ChangeLocationHuman(..)) 9 | import Api.Schema.BusinessData.Value (Value(Value)) 10 | import Api.Schema.Import (CsvImportConf(CsvImportConf), Warning(Warning)) 11 | import Component.Common (modal, toolButton) 12 | import Component.Validation.Finding (renderHoleCoords) 13 | import Control.Monad.Aff.Free (fromEff) 14 | import Data.Array (snoc) 15 | import Data.Lens (Lens', lens, (%~)) 16 | import Data.Maybe (Maybe(Nothing, Just)) 17 | import Data.String (take) 18 | import Data.Tuple (Tuple(Tuple)) 19 | import Halogen (ComponentDSL, ComponentHTML, Component, component, modify, get, gets) 20 | import Types (Metrix, UpdateId) 21 | import Utils (cls, paginate, maxOrd, getInputFileList) 22 | 23 | data Location 24 | = LocationHome 25 | | LocationImportCsv 26 | | LocationPast Int (Array UpdateDesc) -- page and updates 27 | 28 | type State = 29 | { open :: Boolean 30 | , location :: Location 31 | , csvImportResponse :: Maybe CsvImportConf 32 | , newTagName :: String 33 | , lastUpdateId :: UpdateId 34 | } 35 | 36 | _location :: Lens' State Location 37 | _location = lens _.location _{ location = _ } 38 | 39 | initialState :: UpdateId -> State 40 | initialState updateId = 41 | { open: false 42 | , location: LocationHome 43 | , csvImportResponse: Nothing 44 | , newTagName: "" 45 | , lastUpdateId: updateId 46 | } 47 | 48 | data Query a 49 | = Open a 50 | | Close a 51 | | GoHome a 52 | | GoImportCsv a 53 | | GoPast a 54 | | UploadCsv a 55 | | UploadCsvConfirm UpdateGet a 56 | | UploadCsvClose a 57 | | NewTagSetName String a 58 | | NewTagCreate a 59 | | PastPagePrev a 60 | | PastPageNext a 61 | | OpenUpdate UpdateId a 62 | | SetLastUpdateId UpdateId a 63 | 64 | fileMenu :: Component State Query Metrix 65 | fileMenu = component 66 | { render 67 | , eval 68 | } 69 | 70 | render :: State -> ComponentHTML Query 71 | render st = H.div_ $ 72 | [ toolButton "Menu" "octicon octicon-three-bars" "menu" true (if st.open then Close else Open) 73 | ] <> if st.open 74 | then [ renderMenu st ] 75 | else [] 76 | 77 | eval :: Query ~> ComponentDSL State Query Metrix 78 | eval (Open next) = do 79 | modify $ _{ open = true } 80 | pure next 81 | 82 | eval (Close next) = do 83 | modify $ _{ open = false 84 | , location = LocationHome 85 | } 86 | pure next 87 | 88 | eval (GoHome next) = do 89 | modify $ _{ location = LocationHome } 90 | pure next 91 | 92 | eval (GoImportCsv next) = do 93 | modify $ _{ location = LocationImportCsv } 94 | pure next 95 | 96 | eval (GoPast next) = do 97 | updateId <- gets _.lastUpdateId 98 | apiCall (getUpdatePast updateId) \past -> 99 | modify $ _{ location = LocationPast 1 past } 100 | pure next 101 | 102 | eval (UploadCsv next) = do 103 | mFiles <- fromEff $ getInputFileList "csvFile" 104 | updateId <- gets _.lastUpdateId 105 | case mFiles of 106 | Nothing -> pure unit 107 | Just files -> apiCall (uploadCsv updateId files) \resp -> 108 | modify $ _{ csvImportResponse = Just resp } 109 | pure next 110 | 111 | -- peeked by FileViewer 112 | eval (UploadCsvConfirm _ next) = do 113 | modify _{ open = false 114 | , location = LocationHome 115 | , csvImportResponse = Nothing 116 | } 117 | pure next 118 | 119 | eval (UploadCsvClose next) = do 120 | modify _{ csvImportResponse = Nothing } 121 | pure next 122 | 123 | eval (NewTagSetName name next) = do 124 | modify _{ newTagName = name } 125 | pure next 126 | 127 | eval (NewTagCreate next) = do 128 | st <- get 129 | if st.newTagName /= "" 130 | then apiCall (newTag st.lastUpdateId st.newTagName) \tag -> 131 | case st.location of 132 | LocationPast page past -> do 133 | let go (UpdateDesc upd) = UpdateDesc $ 134 | if upd.updateDescUpdateId == st.lastUpdateId 135 | then upd { updateDescTags = snoc upd.updateDescTags tag } 136 | else upd 137 | modify $ _{ location = LocationPast page (go <$> past) } 138 | modify $ _{ newTagName = "" } 139 | _ -> pure unit 140 | else pure unit 141 | pure next 142 | 143 | eval (PastPagePrev next) = do 144 | modify $ _location %~ \l -> case l of 145 | LocationPast p past -> LocationPast (maxOrd 1 (p - 1)) past 146 | LocationHome -> LocationHome 147 | LocationImportCsv -> LocationImportCsv 148 | pure next 149 | 150 | eval (PastPageNext next) = do 151 | modify $ _location %~ \l -> case l of 152 | LocationPast p past -> LocationPast (p + 1) past 153 | LocationHome -> LocationHome 154 | LocationImportCsv -> LocationImportCsv 155 | pure next 156 | 157 | -- peeked by FileViewer 158 | eval (OpenUpdate updateId next) = do 159 | modify _{ open = false 160 | , location = LocationHome 161 | , lastUpdateId = updateId 162 | } 163 | pure next 164 | 165 | eval (SetLastUpdateId updateId next) = do 166 | modify $ _{ lastUpdateId = updateId } 167 | pure next 168 | 169 | renderMenu :: State -> ComponentHTML Query 170 | renderMenu st = H.div [ cls "menu-content" ] $ 171 | case st.location of 172 | LocationHome -> 173 | [ H.ul 174 | [ cls "menu" ] 175 | [ H.li 176 | [ E.onClick $ E.input_ GoPast ] 177 | [ H.span [ cls "octicon octicon-git-commit" ] [] 178 | , H.text "Version History" 179 | ] 180 | , H.li 181 | [ cls "href" ] 182 | [ H.a 183 | [ P.href $ apiUrl <> "/api/v0.1/xbrl/create/" <> show st.lastUpdateId 184 | , P.target "_blank" 185 | ] 186 | [ H.span [ cls "octicon octicon-file-code" ] [] 187 | , H.text "Export XBRL" 188 | ] 189 | ] 190 | , H.li 191 | [ cls "href" ] 192 | [ H.a 193 | [ P.href $ apiUrl <> "/api/v0.1/xbrl/createExtraNet/" <> show st.lastUpdateId 194 | , P.target "_blank" 195 | ] 196 | [ H.span [ cls "octicon octicon-file-code" ] [] 197 | , H.text "Export Zipped XBRL for ExtraNet" 198 | ] 199 | ] 200 | , H.li 201 | [ E.onClick $ E.input_ GoImportCsv ] 202 | [ H.span [ cls "octicon octicon-repo-push" ] [] 203 | , H.text "Import CSV" 204 | ] 205 | , H.li 206 | [ cls "href" ] 207 | [ H.a 208 | [ P.href $ apiUrl <> "/api/v0.1/csv/create/" <> show st.lastUpdateId 209 | , P.target "_blank" 210 | ] 211 | [ H.span [ cls "octicon octicon-file-symlink-file" ] [] 212 | , H.text "Export CSV" 213 | ] 214 | ] 215 | ] 216 | ] 217 | LocationImportCsv -> case st.csvImportResponse of 218 | Nothing -> 219 | [ H.ul 220 | [ cls "menu" ] 221 | [ H.li 222 | [ E.onClick $ E.input_ GoHome ] 223 | [ H.span [ cls "octicon octicon-arrow-left" ] [] 224 | , H.text "Back" 225 | ] 226 | ] 227 | , H.div [ cls "entry-content" ] 228 | [ H.p_ [ H.text "Please select the CSV file to import:" ] 229 | , H.input 230 | [ cls "full" 231 | , P.inputType P.InputFile 232 | , P.id_ "csvFile" 233 | ] 234 | , H.button 235 | [ cls "full" 236 | , E.onClick $ E.input_ UploadCsv ] 237 | [ H.span [ cls "octicon octicon-repo-push" ] [] 238 | , H.text "Import CSV" 239 | ] 240 | ] 241 | ] 242 | Just (CsvImportConf conf) -> 243 | [ modal "Import CSV" 244 | [ H.p_ [ H.text "Csv successfully imported!" ] 245 | , H.h2_ [ H.text "Warnings:" ] 246 | , H.ul_ $ renderCsvWarning <$> conf.warnings 247 | ] 248 | [ H.button 249 | [ E.onClick $ E.input_ (UploadCsvConfirm conf.update) ] 250 | [ H.text "Ok" ] 251 | ] 252 | ] 253 | LocationPast page past -> 254 | let pagination = paginate 100 past page in 255 | [ H.ul 256 | [ cls "menu" ] 257 | [ H.li 258 | [ E.onClick $ E.input_ GoHome ] 259 | [ H.span [ cls "octicon octicon-arrow-left" ] [] 260 | , H.text "Back" 261 | ] 262 | ] 263 | , H.div [ cls "entry-content" ] 264 | [ H.input 265 | [ cls "full" 266 | , E.onValueChange $ E.input NewTagSetName 267 | , P.value st.newTagName 268 | , P.placeholder "Tag Name" 269 | ] 270 | , H.button 271 | [ cls "full" 272 | , E.onClick $ E.input_ NewTagCreate ] 273 | [ H.text "Create Tag" ] 274 | , H.div 275 | [ cls "pagination" ] 276 | [ if page > 1 then 277 | H.div 278 | [ cls "left octicon octicon-chevron-left" 279 | , E.onClick $ E.input_ PastPagePrev 280 | ] [] 281 | else 282 | H.div 283 | [ cls "left octicon octicon-chevron-left disabled" ] [] 284 | , H.div 285 | [ cls "fromto" ] 286 | [ H.b_ [ H.text $ show pagination.from ] 287 | , H.text " to " 288 | , H.b_ [ H.text $ show pagination.to ] 289 | , H.text " out of " 290 | , H.b_ [ H.text $ show pagination.total ] 291 | ] 292 | , if page < pagination.pages then 293 | H.div 294 | [ cls "right octicon octicon-chevron-right" 295 | , E.onClick $ E.input_ PastPageNext 296 | ] [] 297 | else 298 | H.div 299 | [ cls "right octicon octicon-chevron-right disabled" ] [] 300 | ] 301 | , H.ul [ cls "updates" ] $ renderUpdate <$> pagination.items 302 | ] 303 | ] 304 | 305 | renderCsvWarning :: Warning -> ComponentHTML Query 306 | renderCsvWarning (Warning w) = H.li_ 307 | [ H.b_ [ H.text "Message: " ] 308 | , H.text w.message 309 | , H.br_ 310 | , H.b_ [ H.text "Context: " ] 311 | , H.text w.context 312 | ] 313 | 314 | renderUpdate :: UpdateDesc -> ComponentHTML Query 315 | renderUpdate (UpdateDesc upd) = H.li 316 | [ E.onClick $ E.input_ (OpenUpdate upd.updateDescUpdateId) 317 | ] 318 | [ H.span 319 | [ cls "label" ] 320 | [ H.b_ [ H.text $ show upd.updateDescCreated ] 321 | , H.text " by " 322 | , H.b_ [ H.text $ upd.updateDescAuthor ] 323 | ] 324 | , H.div 325 | [ cls "tags" 326 | ] (renderTag <$> upd.updateDescTags) 327 | , H.ul [ cls "entries" ] $ renderUpdateEntry <$> upd.updateDescChanges 328 | ] 329 | where 330 | renderTag (TagDesc tag) = 331 | H.span [ cls "tag" ] 332 | [ H.span [ cls "octicon octicon-tag" ] [] 333 | , H.text tag.tagDescTagName 334 | ] 335 | renderUpdateEntry e@(UpdateChange entry) = 336 | case entry.updateChangeLoc of 337 | HumanHeaderFact label -> entryLayout 338 | [ H.text $ "Header, " <> label ] 339 | [ renderChange e ] 340 | HumanFact table coords -> entryLayout 341 | [ H.text $ table <> ", " 342 | , renderHoleCoords coords 343 | ] 344 | [ renderChange e ] 345 | HumanSubsetZ table member -> entryLayout 346 | [ H.text $ table <> ", z axis member '" <> member <> "'" ] 347 | [ renderAddDelete e "selected" "deselected" ] 348 | HumanCustomZ table -> entryLayout 349 | [ H.text $ table <> ", z axis member" ] 350 | [ renderChange e ] 351 | HumanCustomRow table member sheet -> entryLayout 352 | [ H.text $ table <> ", row '" <> take 8 member <> "'" <> (if sheet /= "" then " on sheet '" <> take 8 sheet <> "'" else "") ] 353 | [ renderAddDelete e "added" "deleted" ] 354 | entryLayout location action = H.li_ 355 | [ H.div [ cls "location" ] $ 356 | [ H.div [ cls "action" ] action 357 | ] <> location 358 | ] 359 | renderChange (UpdateChange entry) = H.text $ 360 | let old = case entry.updateChangeOld of 361 | Value v -> v.valueData 362 | new = case entry.updateChangeNew of 363 | Value v -> v.valueData 364 | in case Tuple old new of 365 | Tuple Nothing (Just new') -> "added '" <> new' <> "'" 366 | Tuple (Just old') Nothing -> "deleted '" <> old' <> "'" 367 | Tuple (Just old') (Just new') -> "'" <> old' <> "' > '" <> new' <> "'" 368 | _ -> "" 369 | renderAddDelete (UpdateChange entry) add del = H.text $ 370 | let old = case entry.updateChangeOld of 371 | Value v -> v.valueData 372 | new = case entry.updateChangeNew of 373 | Value v -> v.valueData 374 | in case Tuple old new of 375 | Tuple Nothing (Just _) -> add 376 | Tuple (Just _) Nothing -> del 377 | _ -> "" 378 | --------------------------------------------------------------------------------