├── .gitignore ├── .travis.yml ├── Build.hs ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── LICENSE ├── NOTICE ├── README.md ├── Setup.hs ├── client-stack.yaml ├── makefile ├── package.yaml ├── src ├── common │ ├── HaskellDo.hs │ ├── HaskellDo │ │ ├── CodeMirror │ │ │ ├── State.hs │ │ │ ├── Types.hs │ │ │ └── View.hs │ │ ├── Compilation │ │ │ ├── State.hs │ │ │ ├── Types.hs │ │ │ └── View.hs │ │ ├── Materialize │ │ │ └── View.hs │ │ ├── State.hs │ │ ├── Style │ │ │ └── View.hs │ │ ├── Toolbar │ │ │ ├── FileSystemTree.hs │ │ │ ├── State.hs │ │ │ ├── Types.hs │ │ │ └── View.hs │ │ ├── Types.hs │ │ └── View.hs │ ├── Main.hs │ └── Ulmus.hs ├── docker │ ├── Dockerfile │ └── setup.sh ├── ghc-specific │ ├── AxiomUtils.hs │ └── Foreign │ │ ├── CodeMirror.hs │ │ ├── Highlight.hs │ │ ├── JQuery.hs │ │ ├── Materialize.hs │ │ └── MathJax.hs └── ghcjs-specific │ ├── AxiomUtils.hs │ └── Foreign │ ├── CodeMirror.hs │ ├── Highlight.hs │ ├── JQuery.hs │ ├── Materialize.hs │ └── MathJax.hs ├── stack.yaml ├── static └── out.jsexe │ ├── banner.png │ ├── favicon.ico │ └── index.html └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .build-dist 2 | release.zip 3 | # Created by https://www.gitignore.io/api/haskell 4 | 5 | ### Haskell ### 6 | dist 7 | dist-* 8 | cabal-dev 9 | *.o 10 | *.hi 11 | *.chi 12 | *.chs.h 13 | *.dyn_o 14 | *.dyn_hi 15 | .hpc 16 | .hsenv 17 | .cabal-sandbox/ 18 | cabal.sandbox.config 19 | *.prof 20 | *.aux 21 | *.hp 22 | *.eventlog 23 | .stack-work/ 24 | cabal.project.local 25 | .HTF/ 26 | static/out.jsexe/*js* 27 | static/out.jsexe/*stats* 28 | static/out.jsexe/*webapp* 29 | 30 | # End of https://www.gitignore.io/api/haskell 31 | 32 | *.swp 33 | *.swo 34 | *.DS_Store 35 | /.idea 36 | /.ideaHaskellLib 37 | /haskell-do.iml 38 | /out 39 | 40 | *.cabal 41 | 42 | lastproject 43 | builds/ 44 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This is the simple Travis configuration, which is intended for use 2 | # on applications which do not require cross-platform and 3 | # multiple-GHC-version support. For more information and other 4 | # options, see: 5 | # 6 | # https://docs.haskellstack.org/en/stable/travis_ci/ 7 | # 8 | # Copy these contents into the root directory of your Github project in a file 9 | # named .travis.yml 10 | 11 | # Use new container infrastructure to enable caching 12 | sudo: true 13 | 14 | # Do not choose a language; we provide our own build tools. 15 | language: generic 16 | 17 | 18 | services: 19 | - docker 20 | 21 | # we comment this because GHCJS is not bootable in TravisCI 22 | # Automatic binary upload 23 | # before_deploy: 24 | # "mkdir builds && stack Build.hs -p" 25 | 26 | # deploy: 27 | # provider: releases 28 | # api_key: 29 | # secure: "Wd+8Dn3qE12bWw+338QF7wq/aMgbFItDwuVtu2+nRV0Iz89w1ZSoeSG9j4YriPu+EWpKiAu6Thmwix0VNenAVWBTe/i5GpLOwOHNFMEbCmI4JC6qoioPr9nSdr26QHr8NXLriCafFFODx+B9v5kN7496w/kDWta9//o6gFuZos2g2VDtctzTH6uKr5jkPEdQb7BYIz7MAWXIPSkC+bw3tz/SwqsRqf0NarSXH7HrBJ+GWNo9CgcJ3e611oxkiN8SDMkXSQ/bA2F5O5qXmlIef7odOvqWH1uMHf0uSJyNIT/CctAHZ240UOXVH0O2Il6Ojq4HJhLSNhkNVvSp128tX6lbPxIpd/xBaNVKoCc3DY4EWaZ+PyduwSVSnMePgXxE721OWtjS43p8UG3QiIZGPlTq89q5IWL41egdfH6rVp8xPBmI2oMLgdFBtmc4Ii37wbRvGkl3Qw4VBEIbM2P16eaYGzbSSJjwkxrQLOwgwpy1Lzz3vIUdxi03PxexiWYQaiaZXrDlngpKKByRRSe/QNLipv4WV3x4HA8vLSLdPmM4iQr0wYqFYIOHC4cT7BS7+LHDnjGE5RAGf8wUCmsWfko7juJCzwV2Hq3LxozYbX0/7PK3rGsBkSiy3/vjJhkaJGdGizpu6rMXXORVd3zfTukNYWMpBzKu8MNltQNakjI=" 30 | # file_glob: true 31 | # file: 32 | # - "builds/*.zip" 33 | # skip_cleanup: true 34 | # on: 35 | # tags: true 36 | 37 | # Caching so the next build will be fast too. 38 | cache: 39 | directories: 40 | - $HOME/.stack 41 | - $HOME/.ghcjs 42 | 43 | # Ensure necessary system libraries are present 44 | addons: 45 | apt: 46 | packages: 47 | - libgmp-dev 48 | 49 | before_install: 50 | # Download and unpack the stack executable 51 | - mkdir -p ~/.local/bin 52 | - export PATH=$HOME/.local/bin:$PATH 53 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 54 | - curl -sL https://deb.nodesource.com/setup_4.x | sudo -E bash - && sudo apt install -y nodejs && sudo ln -s /usr/local/bin/nodejs /usr/local/bin/node 55 | 56 | install: 57 | # Build dependencies 58 | - stack --no-terminal --install-ghc test --only-dependencies 59 | 60 | script: 61 | # Build the package, its tests, and its docs and run the tests 62 | - stack --no-terminal test --haddock --no-haddock-deps 63 | # Build the Docker image 64 | - docker build -t theam/haskell-do src/docker/ 65 | -------------------------------------------------------------------------------- /Build.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | -- stack --resolver lts-8.11 --install-ghc runghc --package turtle-1.3.2 --package foldl --package text-1.2.2.2 --package system-filepath-0.4.13.3 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | import Prelude hiding (FilePath) 6 | import Turtle 7 | import Control.Monad (when) 8 | import Data.Text as T 9 | import Data.Text (Text) 10 | import System.Info (os) 11 | import Data.Char (isNumber) 12 | import Data.List (isInfixOf) 13 | import qualified Control.Foldl as Foldl 14 | import Filesystem.Path.CurrentOS 15 | import Filesystem 16 | 17 | clientStackYaml = "client-stack.yaml" 18 | serverStackYaml = "stack.yaml" 19 | 20 | main = do 21 | projectDirectory <- pwdAsText 22 | BuildCommand all gui core orchestrator run pkg <- options "Haskell.do build file" buildSwitches 23 | if all 24 | then buildAll projectDirectory 25 | else do 26 | when gui $ buildGUI projectDirectory 27 | when core $ buildCore projectDirectory 28 | when orchestrator $ buildOrchestrator projectDirectory 29 | when run $ runHaskellDo projectDirectory 30 | when pkg $ buildAndPackage projectDirectory 31 | 32 | 33 | buildSwitches :: Parser BuildCommand 34 | buildSwitches = BuildCommand 35 | <$> switch "all" 'a' "Build all subprojects, without running Haskell.do" 36 | <*> switch "gui" 'g' "Build GUI" 37 | <*> switch "core" 'c' "Build processing/compilation core" 38 | <*> switch "orchestrator" 'o' "Build orchestrator" 39 | <*> switch "run" 'r' "Run Haskell.do" 40 | <*> switch "package" 'p' "Package Haskell.do for release (caution: removes .stack-work before re-building)" 41 | 42 | buildAll projectDirectory = do 43 | buildCore projectDirectory 44 | buildGUI projectDirectory 45 | buildOrchestrator projectDirectory 46 | 47 | buildCore :: Text -> IO () 48 | buildCore pdir = do 49 | echo "Building core" 50 | exitCode <- shell ("stack build --stack-yaml=" <> serverStackYaml) "" 51 | when (exitCode /= ExitSuccess) (error "Core: Build failed") 52 | return () 53 | 54 | 55 | buildGUI pdir = 56 | if isWindows os 57 | then die "GHCJS currently does not support Windows, please try from a *nix machine." 58 | else do 59 | echo "Building GUI" 60 | shell "mkdir -p static" "" 61 | Just directory <- fold (inshell ("stack path --stack-yaml=" <> clientStackYaml <> " --local-install-root") Turtle.empty) Foldl.head 62 | Just coreBinDirectory <- fold (inshell "stack path --local-install-root" Turtle.empty) Foldl.head 63 | exitCode <- shell ("stack build --stack-yaml=" <> clientStackYaml) "" 64 | when (exitCode /= ExitSuccess) (error "GUI: Build failed") 65 | shell "rm -rf static/out.jsexe/*.js" "" 66 | shell "rm -rf static/out.jsexe/*.externs" "" 67 | shell "rm -rf static/out.jsexe/*.stats" "" 68 | shell "rm -rf static/out.jsexe/*.webapp" "" 69 | shell ("cp -R " <> lineToText directory <> "/bin/haskell-do.jsexe/*.js static/out.jsexe") "" 70 | shell ("cp -R static " <> lineToText coreBinDirectory <> "/bin") "" 71 | return () 72 | 73 | buildAndPackage projectDirectory = do 74 | removeTree ".stack-work" 75 | shell "mkdir -p .build-dist" "" 76 | removeTree ".build-dist" 77 | shell "mkdir -p builds" "" 78 | shell "rm -rf builds/*" "" 79 | buildAll projectDirectory 80 | let currentOS = System.Info.os 81 | packageYamlContent <- Prelude.readFile "package.yaml" 82 | let osName = if isOSX currentOS 83 | then "darwin" 84 | else "linux-x86_64" 85 | version = T.dropWhile (not . isNumber) 86 | . T.dropWhile (/= ':') 87 | . Prelude.head 88 | . Prelude.filter (T.isInfixOf "version:") 89 | $ T.lines (T.pack packageYamlContent) 90 | 91 | createDirectory True ".build-dist" 92 | rename "static" (".build-dist" "static") 93 | (_, binPath) <- shellStrict "stack exec which haskell-do" "" 94 | case textToLine binPath of 95 | Just path -> copyFile (fromText . lineToText $ path) (".build-dist" "haskell-do") 96 | Nothing -> return () 97 | shell ("cd .build-dist; zip -r ../builds/haskell-do_" <> osName <> "_v" <> version <> ".zip *") "" 98 | rename (".build-dist" "static") "static" 99 | 100 | buildOrchestrator pdir = 101 | echo "" 102 | 103 | 104 | runHaskellDo pdir = do 105 | echo "Running Haskell.do" 106 | shell ("stack exec haskell-do --stack-yaml=" <> serverStackYaml <> " -- 8080") "" 107 | return () 108 | 109 | -- Helpers 110 | isWindows operatingSystem = "mingw" `T.isPrefixOf` T.pack operatingSystem 111 | isOSX operatingSystem = "darwin" `T.isPrefixOf` T.pack operatingSystem 112 | 113 | makeTextPath = T.pack . encodeString . fromText 114 | 115 | pwdAsText :: IO Text 116 | pwdAsText = T.pack . encodeString <$> pwd 117 | 118 | data BuildCommand = BuildCommand 119 | { buildCommandAll :: Bool 120 | , buildCommandGui :: Bool 121 | , buildCommandCore :: Bool 122 | , buildCommandOrchestrator :: Bool 123 | , buildCommandRun :: Bool 124 | , buildCommandPackage :: Bool 125 | } 126 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | In the interest of fostering an open and welcoming environment, we as contributors and maintainers pledge to making participation in our project and our community a harassment-free experience for everyone, regardless of age, body size, disability, ethnicity, gender identity and expression, level of experience, nationality, personal appearance, race, religion, or sexual identity and orientation. 6 | 7 | ## Our Standards 8 | 9 | Examples of behavior that contributes to creating a positive environment include: 10 | 11 | * Using welcoming and inclusive language 12 | * Being respectful of differing viewpoints and experiences 13 | * Gracefully accepting constructive criticism 14 | * Focusing on what is best for the community 15 | * Showing empathy towards other community members 16 | 17 | Examples of unacceptable behavior by participants include: 18 | 19 | * The use of sexualized language or imagery and unwelcome sexual attention or advances 20 | * Trolling, insulting/derogatory comments, and personal or political attacks 21 | * Public or private harassment 22 | * Publishing others' private information, such as a physical or electronic address, without explicit permission 23 | * Other conduct which could reasonably be considered inappropriate in a professional setting 24 | 25 | ## Our Responsibilities 26 | 27 | Project maintainers are responsible for clarifying the standards of acceptable behavior and are expected to take appropriate and fair corrective action in response to any instances of unacceptable behavior. 28 | 29 | Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct, or to ban temporarily or permanently any contributor for other behaviors that they deem inappropriate, threatening, offensive, or harmful. 30 | 31 | ## Scope 32 | 33 | This Code of Conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. Examples of representing a project or community include using an official project e-mail address, posting via an official social media account, or acting as an appointed representative at an online or offline event. Representation of a project may be further defined and clarified by project maintainers. 34 | 35 | ## Enforcement 36 | 37 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by contacting the project team at hello@theam.io. The project team will review and investigate all complaints, and will respond in a way that it deems appropriate to the circumstances. The project team is obligated to maintain confidentiality with regard to the reporter of an incident. Further details of specific enforcement policies may be posted separately. 38 | 39 | Project maintainers who do not follow or enforce the Code of Conduct in good faith may face temporary or permanent repercussions as determined by other members of the project's leadership. 40 | 41 | ## Attribution 42 | 43 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, available at [http://contributor-covenant.org/version/1/4][version] 44 | 45 | [homepage]: http://contributor-covenant.org 46 | [version]: http://contributor-covenant.org/version/1/4/ 47 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to HaskellDO 2 | 3 | # Getting Started 4 | * Create a [GitHub](https://github.com) account if you do not already have one 5 | * Check if a ticket for your issue exists, if not create one 6 | * Make sure your ticket details the issue and the steps to reproduce the bug 7 | * If your ticket proposes a new feature for haskell.do, please provide an explanation of the feature, what problem it solves, and possible use cases 8 | * Fork the repository on GitHub 9 | 10 | # Changing HaskellDO 11 | * Create a branch from `master` to work on your feature with a descriptive name 12 | * Make commits frequently with descriptive comments (detailed below) 13 | * Add tests to ensure proper functionality 14 | * Please do not submit until all tests are passed 15 | 16 | Commit messages should stick to the following format: `(issue number) issue name description` 17 | 18 | E.g: 19 | 20 | ``` 21 | Example issue 22 | Steps to recreate: 23 | - Put toast in oven 24 | - Turn oven off 25 | - ???? 26 | 27 | An issue would then here go into detail describing the issue, and perhaps even suggesting a fix 28 | ``` 29 | 30 | # Making Small Changes 31 | When changing things like documentation, it is not always necessary to create a ticket. Instead simply add the documentation, and send a PR with a message of the following form: 32 | 33 | ``` 34 | (doc) Added documentation to 35 | lacked proper documentation on how works. 36 | 37 | This commit adds documentation describing , and provides various examples. 38 | ``` 39 | 40 | # Submitting Changes 41 | * Push your changes to the branch in your fork of the repository 42 | * Submit a pull request 43 | * The haskell.do team will review your PR as quickly and provide feedback 44 | * After receiving feedback, either make the required changes, or your branch will be merged 45 | 46 | Thanks for contributing to haskell.do, happy hacking! 47 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | https://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | Copyright 2017 The Agile Monkeys S.L. 180 | 181 | Licensed under the Apache License, Version 2.0 (the "License"); 182 | you may not use this file except in compliance with the License. 183 | You may obtain a copy of the License at 184 | 185 | https://www.apache.org/licenses/LICENSE-2.0 186 | 187 | Unless required by applicable law or agreed to in writing, software 188 | distributed under the License is distributed on an "AS IS" BASIS, 189 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 190 | See the License for the specific language governing permissions and 191 | limitations under the License. 192 | -------------------------------------------------------------------------------- /NOTICE: -------------------------------------------------------------------------------- 1 | Haskell.do 2 | 3 | Copyright 2016-2017 The Agile Monkeys S.L. 4 | 5 | This product includes software developet at 6 | The Agile Monkeys S.L. (http://www.theagilemonkeys.com) 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![Banner](static/out.jsexe/banner.png) 2 | 3 | [![Gitter](https://badges.gitter.im/theam/haskell-do.svg)](https://gitter.im/theam/haskell-do?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge) 4 | [![Build Status](https://travis-ci.org/theam/haskell-do.svg?branch=develop)](https://travis-ci.org/theam/haskell-do) 5 | [![Open Source Helpers](https://www.codetriage.com/theam/haskell-do/badges/users.svg)](https://www.codetriage.com/theam/haskell-do) 6 | 7 | [haskell.do](http://haskell.do) is a Haskell code editor, centered around interactive development. You can get it on [the website](http://haskell.do). 8 | 9 | Pull Requests are greatly appreciated, check out [our contributing guidelines](CONTRIBUTING.md). 10 | 11 | ## Building from source 12 | 13 | The only *3rd-party* requirements to build [haskell.do](http://haskell.do) are [Stack](http://haskellstack.org/) and [NodeJS](https://nodejs.org/) (due to GHCJS). 14 | 15 | `git clone https://github.com/theam/haskell-do && cd haskell-do` 16 | 17 | `stack setup --stack-yaml=client-stack.yaml` to setup GHCJS (note that it isn't supported on Windows) 18 | 19 | `stack Build.hs -h` for detailed usage of the build file. 20 | 21 | `stack Build.hs -a` for building project. 22 | 23 | `stack Build.hs -r` for running [haskell.do](http://haskell.do) on port `8080`. 24 | 25 | 26 | ## Docker-related 27 | 28 | `haskell-do` can be executed within a Docker container. For convenience, the building and execution commands are provided within the Makefile. 29 | 30 | NB : These instructions assume the user has already created a docker machine called "dev". 31 | 32 | NB 2 : OSX users usually need to run the following command to configure VirtualBox in order to set up port forwarding: 33 | 34 | VBoxManage modifyvm "dev" --natpf1 "tcp-port8080,tcp,,8080,,8080" 35 | 36 | Once that is done, Docker can be configured and started: 37 | 38 | docker-machine start dev 39 | 40 | eval $(docker-machine env dev) 41 | 42 | Then, the `haskell-do` image can be built and run: 43 | 44 | make docker 45 | 46 | make docker-run 47 | 48 | If everything went well, it is now possible to point a browser to `http://localhost:8080` and work with `haskell-do`. 49 | 50 | 51 | 52 | ## Contributing 53 | 54 | Would you like to contribute? Make sure that you've read our [contributor guidelines](https://github.com/theam/haskell-do/blob/master/CONTRIBUTING.md). 55 | We'd like to hear from you and your ideas, get in touch with other contributors through: 56 | 57 | - [Gitter](https://gitter.im/theam/haskell-do) 58 | - [The issues page](https://github.com/theam/haskell-do/blob/master/CONTRIBUTING.md) 59 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /client-stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.19 2 | compiler: ghcjs-0.2.1.9007019_ghc-8.0.1 3 | compiler-check: match-exact 4 | 5 | setup-info: 6 | ghcjs: 7 | source: 8 | ghcjs-0.2.1.9007019_ghc-8.0.1: 9 | url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz 10 | sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9 11 | 12 | packages: 13 | - location: '.' 14 | - extra-dep: true 15 | location: 16 | git: https://github.com/transient-haskell/transient 17 | commit: f38fd2869b045564445edcc0fa3274490a750219 18 | - extra-dep: true 19 | location: 20 | git: https://github.com/transient-haskell/transient-universe 21 | commit: f5ce492ff31808e05dca85957f9ce6a1a48c7a62 22 | - extra-dep: true 23 | location: 24 | git: https://github.com/geraldus/ghcjs-perch 25 | commit: 6c238f6ab9624eb1e950059d602aaff35446476b 26 | - extra-dep: true 27 | location: 28 | git: https://github.com/transient-haskell/axiom 29 | commit: ee39119817ff05ed7385ced4c8c0e7ee0ed7f682 30 | 31 | 32 | extra-deps: 33 | - datetime-0.3.1 34 | 35 | flags: {} 36 | 37 | extra-package-dbs: [] 38 | -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | IMAGE_NAME:=theam/haskell-do 2 | 3 | docker: 4 | docker build -t ${IMAGE_NAME} src/docker/ 5 | 6 | docker-run: 7 | docker run -p 8080:8080 -d ${IMAGE_NAME} 8 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: haskell-do 2 | version: 0.9.5 3 | synopsis: The Haskell code editor focused on interactive development 4 | description: Please see README.md 5 | homepage: https://github.com/theam/haskell-do#readme 6 | license: Apache-2.0 7 | author: Theam 8 | maintainer: nick@theam.io 9 | copyright: 2017 Theam 10 | category: Editor 11 | extra-source-files: 12 | - README.md 13 | 14 | dependencies: 15 | - base >= 4.7 && < 5 16 | - flow == 1.0.7 17 | - transient == 0.5.4 18 | - transient-universe == 0.4.3 19 | - axiom == 0.4.5 20 | - clay 21 | - text == 1.2.2.1 22 | - process 23 | - directory 24 | - filepath 25 | - system-fileio 26 | - datetime 27 | 28 | ghc-options: 29 | - -Wall 30 | - -Werror 31 | - -fprint-potential-instances 32 | 33 | when: 34 | - condition: impl(ghcjs) 35 | then: 36 | dependencies: ghcjs-base 37 | source-dirs: src/ghcjs-specific 38 | else: 39 | source-dirs: src/ghc-specific 40 | 41 | default-extensions: 42 | - CPP 43 | - OverloadedStrings 44 | 45 | library: 46 | source-dirs: src/common 47 | other-modules: 48 | - AxiomUtils 49 | - Foreign.Highlight 50 | - Foreign.JQuery 51 | - Foreign.Materialize 52 | - Foreign.CodeMirror 53 | - HaskellDo.Compilation.State 54 | - HaskellDo.Compilation.Types 55 | - HaskellDo.Compilation.View 56 | - HaskellDo.Materialize.View 57 | - HaskellDo.CodeMirror.State 58 | - HaskellDo.CodeMirror.Types 59 | - HaskellDo.CodeMirror.View 60 | - HaskellDo.State 61 | - HaskellDo.Style.View 62 | - HaskellDo.Toolbar.State 63 | - HaskellDo.Toolbar.Types 64 | - HaskellDo.Toolbar.View 65 | - HaskellDo.Toolbar.FileSystemTree 66 | - HaskellDo.Types 67 | - HaskellDo.View 68 | - Ulmus 69 | exposed-modules: 70 | - HaskellDo 71 | 72 | executables: 73 | haskell-do: 74 | other-modules: 75 | - AxiomUtils 76 | - Foreign.Highlight 77 | - Foreign.JQuery 78 | - Foreign.Materialize 79 | - Foreign.CodeMirror 80 | - HaskellDo.Compilation.State 81 | - HaskellDo.Compilation.Types 82 | - HaskellDo.Compilation.View 83 | - HaskellDo.Materialize.View 84 | - HaskellDo.CodeMirror.State 85 | - HaskellDo.CodeMirror.Types 86 | - HaskellDo.CodeMirror.View 87 | - HaskellDo.State 88 | - HaskellDo.Style.View 89 | - HaskellDo.Toolbar.State 90 | - HaskellDo.Toolbar.Types 91 | - HaskellDo.Toolbar.View 92 | - HaskellDo.Toolbar.FileSystemTree 93 | - HaskellDo.Types 94 | - HaskellDo.View 95 | - Ulmus 96 | - HaskellDo 97 | source-dirs: src/common 98 | main: Main.hs 99 | 100 | tests: 101 | spec: 102 | main: Spec.hs 103 | source-dirs: 104 | - test 105 | - src/common 106 | dependencies: 107 | - hspec == 2.* 108 | - QuickCheck 109 | - quickcheck-io 110 | - mockery 111 | -------------------------------------------------------------------------------- /src/common/HaskellDo.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo 17 | ( run 18 | ) where 19 | 20 | import qualified Ulmus 21 | 22 | import HaskellDo.View 23 | import HaskellDo.State 24 | import qualified HaskellDo.CodeMirror.View as CodeMirror 25 | import qualified HaskellDo.Style.View as Style 26 | 27 | initializeHeaders :: IO () 28 | initializeHeaders = do 29 | CodeMirror.initialize 30 | Style.initialize 31 | 32 | -- | Executes Haskell.do in designated 'port' 33 | run :: Integer -> IO () 34 | run appPort = Ulmus.initializeApp Ulmus.AppConfig 35 | { Ulmus._update = update 36 | , Ulmus._view = view 37 | , Ulmus._updateDisplays = updateDisplays 38 | , Ulmus._initialState = initialAppState 39 | , Ulmus._port = appPort 40 | , Ulmus._setup = initializeHeaders 41 | } 42 | -------------------------------------------------------------------------------- /src/common/HaskellDo/CodeMirror/State.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo.CodeMirror.State where 17 | 18 | import Transient.Move 19 | import HaskellDo.CodeMirror.Types 20 | import Data.DateTime 21 | 22 | initialState :: State 23 | initialState = State 24 | { content = "" 25 | , lastSave = startOfTime 26 | } 27 | 28 | update :: Action -> State -> Cloud State 29 | update (NewContent newContent) state = do 30 | return (state { content = newContent } ) 31 | -------------------------------------------------------------------------------- /src/common/HaskellDo/CodeMirror/Types.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo.CodeMirror.Types where 17 | import Data.DateTime 18 | 19 | data Action 20 | = NewContent String 21 | deriving (Read, Show) 22 | 23 | data State = State 24 | { content :: String 25 | , lastSave :: DateTime 26 | } deriving (Read, Show) 27 | -------------------------------------------------------------------------------- /src/common/HaskellDo/CodeMirror/View.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo.CodeMirror.View where 17 | 18 | import Prelude hiding (div, id) 19 | import Control.Monad.IO.Class 20 | 21 | import GHCJS.HPlay.View hiding (addHeader, atr, id) 22 | import AxiomUtils 23 | 24 | import HaskellDo.CodeMirror.Types 25 | import Foreign.CodeMirror 26 | 27 | initialize :: IO () 28 | initialize = do 29 | addHeader $ do 30 | link ! atr "rel" "stylesheet" 31 | ! href "https://cdn.jsdelivr.net/simplemde/latest/simplemde.min.css" 32 | script ("var codeMirror;" :: String) 33 | script ! src "https://cdn.jsdelivr.net/simplemde/latest/simplemde.min.js" 34 | $ noHtml 35 | makeCodeMirrorFromId "mainEditor" 36 | 37 | view :: State -> Widget Action 38 | view _ = do 39 | _ <- textArea "" `fire` OnKeyUp 40 | newContent <- liftIO getMDEContent 41 | return (NewContent newContent) 42 | -------------------------------------------------------------------------------- /src/common/HaskellDo/Compilation/State.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo.Compilation.State where 17 | 18 | import Flow 19 | import Control.Monad 20 | import Control.Monad.IO.Class 21 | import qualified System.Process as System 22 | import qualified System.Exit as System 23 | import qualified Data.Text as Text 24 | import System.Directory 25 | import System.FilePath ((), takeDirectory, takeFileName, dropTrailingPathSeparator) 26 | 27 | import Transient.Move 28 | 29 | import HaskellDo.Compilation.Types 30 | 31 | initialState :: State 32 | initialState = State 33 | { compiledOutput = "" 34 | , compilationError = "No project has been loaded yet, try opening one?" 35 | , projectPath = "" 36 | , workingFile = "src/Main.hs" 37 | , dirtyCompile = True 38 | } 39 | 40 | lastProjectFile :: FilePath 41 | lastProjectFile = "lastproject" 42 | 43 | templateURL :: String 44 | templateURL = "https://raw.githubusercontent.com/theam/stack-templates/master/haskell-do-new.hsfiles" 45 | 46 | update :: Action -> State -> Cloud State 47 | update (WriteWorkingFile content) state = localIO $ do 48 | unless (null $ projectPath state) (writeWorkingFile content state) 49 | return state 50 | update Compile state = do 51 | localIO $ writeFile lastProjectFile $ projectPath state 52 | compile state 53 | 54 | writeWorkingFile :: String -> State -> IO () 55 | writeWorkingFile content state = do 56 | let fullPath = projectPath state workingFile state 57 | fileExists <- doesFileExist fullPath 58 | when fileExists (writeCode fullPath content) 59 | 60 | writeCode :: FilePath -> String -> IO () 61 | writeCode path code = do 62 | let fileContent = "{-# OPTIONS_GHC -F -pgmF inlitpp #-}\n" ++ 63 | "```haskell hide top\n" ++ 64 | "import Inliterate.Import\n" ++ 65 | "```\n" ++ 66 | code 67 | writeFile path fileContent 68 | 69 | 70 | compile :: State -> Cloud State 71 | compile state = local $ liftIO $ buildHtmlCode state 72 | 73 | 74 | buildHtmlCode :: State -> IO State 75 | buildHtmlCode state = do 76 | putStrLn $ "Attempting to build " ++ projectPath state 77 | (exitCode, _, err) <- runCommand "build" (projectPath state) 78 | case exitCode of 79 | System.ExitFailure _ -> 80 | if isCommonError err 81 | then buildOutput state 82 | else return state { compilationError = err, dirtyCompile = True } 83 | System.ExitSuccess -> 84 | buildOutput state 85 | where 86 | isCommonError err = 87 | "package database" `Text.isInfixOf` Text.pack err 88 | 89 | buildOutput :: State -> IO State 90 | buildOutput state = do 91 | (exitCode, out, _) <- runCommand "exec run-test" (projectPath state) 92 | case exitCode of 93 | System.ExitFailure _ -> 94 | return state { compiledOutput = "Compiling" } 95 | System.ExitSuccess -> 96 | return state { compiledOutput = preprocessOutput out, compilationError = "", dirtyCompile = True } 97 | 98 | 99 | preprocessOutput :: String -> String 100 | preprocessOutput out = 101 | Text.pack out 102 | |> remove "class=\"container\"" 103 | |> remove bootstrapCSSTag 104 | |> remove bootstrapThemeCSSTag 105 | |> remove jQueryJSTag 106 | |> remove bootstrapJSTag 107 | |> Text.unpack 108 | where 109 | remove s = Text.replace s "" 110 | 111 | makeNewProject :: String -> IO () 112 | makeNewProject path = do 113 | let p = dropTrailingPathSeparator path 114 | let projectName = takeFileName p 115 | let parentDir = takeDirectory p 116 | putStrLn path 117 | putStrLn projectName 118 | putStrLn parentDir 119 | 120 | exists <- doesDirectoryExist path 121 | if exists then do 122 | isEmpty <- null <$> listDirectory path 123 | when isEmpty $ do 124 | _ <- runCommand ("new " ++ projectName ++ " " ++ templateURL ++ " --bare") path 125 | return () 126 | else do 127 | _ <- runCommand ("new " ++ projectName ++ " " ++ templateURL) parentDir 128 | return () 129 | 130 | runCommand :: String -> FilePath -> IO (System.ExitCode, String, String) 131 | runCommand command projPath = do 132 | putStrLn $ "Executing: cd " ++ projPath ++ " && " ++ stackCommand ++ " " ++ command 133 | System.readCreateProcessWithExitCode (System.shell 134 | $ "cd " ++ projPath ++ " && " ++ stackCommand ++ " " ++ command 135 | ) "" 136 | where 137 | stackCommand = "stack" 138 | 139 | 140 | bootstrapCSSTag :: Text.Text 141 | bootstrapCSSTag = "" 142 | 143 | bootstrapThemeCSSTag :: Text.Text 144 | bootstrapThemeCSSTag = "" 145 | 146 | bootstrapJSTag :: Text.Text 147 | bootstrapJSTag = "" 148 | 149 | jQueryJSTag :: Text.Text 150 | jQueryJSTag = "" 151 | -------------------------------------------------------------------------------- /src/common/HaskellDo/Compilation/Types.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo.Compilation.Types where 17 | 18 | data State = State 19 | { compiledOutput :: String 20 | , compilationError :: String 21 | , projectPath :: String 22 | , workingFile :: String 23 | , dirtyCompile :: Bool 24 | } deriving (Read, Show) 25 | 26 | data Action 27 | = Compile 28 | | WriteWorkingFile String 29 | deriving (Read, Show) 30 | -------------------------------------------------------------------------------- /src/common/HaskellDo/Compilation/View.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo.Compilation.View where 17 | 18 | import Control.Monad.IO.Class 19 | import Control.Monad (when) 20 | import Prelude hiding (div, id) 21 | 22 | import AxiomUtils 23 | import Foreign.Highlight 24 | import GHCJS.HPlay.View hiding (atr, id) 25 | import qualified Ulmus 26 | 27 | import HaskellDo.Compilation.Types 28 | import Foreign.JQuery 29 | 30 | outputDisplay :: State -> Widget () 31 | outputDisplay state = rawHtml $ 32 | div ! id "output-frame" $ noHtml `setContents` compiledOutput state 33 | 34 | errorDisplay :: State -> Widget () 35 | errorDisplay state 36 | | null (compilationError state) = return () 37 | | otherwise = rawHtml $ 38 | pre 39 | ! atr "class" "card-panel red darken-1 white-text" 40 | ! atr "role" "alert" 41 | $ code (compilationError state) 42 | 43 | updateDisplays :: State -> Widget () 44 | updateDisplays state = 45 | when (dirtyCompile state) $ do 46 | Ulmus.newWidget "outputDisplay" (outputDisplay state) 47 | Ulmus.newWidget "errorDisplay" (errorDisplay state) 48 | liftIO $ activateScriptTags "#output-frame" 49 | liftIO $ setHeightFromElement ".error-placeholder" "#errorDisplay" 50 | liftIO highlightCode 51 | -------------------------------------------------------------------------------- /src/common/HaskellDo/Materialize/View.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo.Materialize.View where 17 | 18 | import Prelude hiding (div, id) 19 | 20 | import GHCJS.HPlay.View hiding (addHeader, atr) 21 | import AxiomUtils 22 | 23 | container :: Perch -> Perch 24 | container = div ! atr "class" "container" 25 | 26 | row :: Perch -> Perch 27 | row = div ! atr "class" "row" 28 | 29 | col :: String -> Int -> Perch -> Perch 30 | col size number = div ! atr "class" colClass 31 | where 32 | colClass = "col " ++ size ++ show number 33 | -------------------------------------------------------------------------------- /src/common/HaskellDo/State.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | {-# LANGUAGE LambdaCase #-} 17 | module HaskellDo.State where 18 | 19 | import Control.Exception (try, SomeException) 20 | import Control.Monad (when) 21 | import Data.DateTime 22 | 23 | import Transient.Move 24 | 25 | import System.FilePath (()) 26 | 27 | import HaskellDo.Types 28 | import qualified HaskellDo.CodeMirror.State as CodeMirror 29 | import qualified HaskellDo.CodeMirror.Types as CodeMirror 30 | import qualified Foreign.CodeMirror as CodeMirror 31 | import qualified HaskellDo.Compilation.State as Compilation 32 | import qualified HaskellDo.Compilation.Types as Compilation 33 | import qualified HaskellDo.Toolbar.State as Toolbar 34 | import qualified HaskellDo.Toolbar.Types as Toolbar 35 | import qualified Foreign.JQuery as JQuery 36 | import qualified Foreign.MathJax as MathJax 37 | 38 | initialAppState :: AppState 39 | initialAppState = AppState 40 | { codeMirrorState = CodeMirror.initialState 41 | , compilationState = Compilation.initialState 42 | , toolbarState = Toolbar.initialState 43 | } 44 | 45 | update :: Action -> AppState -> Cloud AppState 46 | update action appState = _preUpdate action appState >>= _update action >>= _postUpdate action 47 | 48 | _preUpdate :: Action -> AppState -> Cloud AppState 49 | _preUpdate _ appState = do 50 | let cs = compilationState appState 51 | newCS = cs { Compilation.dirtyCompile = False } 52 | return appState { compilationState = newCS } 53 | 54 | _postUpdate :: Action -> AppState -> Cloud AppState 55 | _postUpdate _ = return 56 | 57 | saveEvery :: Integer 58 | saveEvery = 3 -- seconds 59 | 60 | _update :: Action -> AppState -> Cloud AppState 61 | _update (CodeMirrorAction action) appState = do 62 | newCodeMirrorState <- CodeMirror.update action (codeMirrorState appState) 63 | let newContent = CodeMirror.content newCodeMirrorState 64 | 65 | compileShortcutPressed <- localIO CodeMirror.cmdOrCtrlReturnPressed 66 | 67 | currentTime <- localIO getCurrentTime 68 | let lastSave = CodeMirror.lastSave $ codeMirrorState appState 69 | 70 | newState <- if diffSeconds currentTime lastSave > saveEvery 71 | then do 72 | _ <- atRemote $ Compilation.update 73 | (Compilation.WriteWorkingFile newContent) 74 | (compilationState appState) 75 | 76 | return appState { 77 | codeMirrorState = newCodeMirrorState { CodeMirror.lastSave = currentTime } 78 | } 79 | else 80 | return appState { 81 | codeMirrorState = newCodeMirrorState 82 | } 83 | 84 | if compileShortcutPressed 85 | then do 86 | _ <- atRemote $ Compilation.update 87 | (Compilation.WriteWorkingFile newContent) 88 | (compilationState appState) 89 | 90 | update (ToolbarAction Toolbar.Compile) newState 91 | else return newState 92 | 93 | _update (ToolbarAction Toolbar.Compile) appState = do 94 | let tbState = toolbarState appState 95 | if Toolbar.projectOpened tbState 96 | then do 97 | localIO $ JQuery.show ".dimmedBackground" 98 | newCompilationState <- atRemote $ Compilation.update 99 | Compilation.Compile 100 | (compilationState appState) 101 | localIO $ JQuery.hide ".dimmedBackground" 102 | localIO $ MathJax.typeset "outputDisplay" 103 | return appState 104 | { compilationState = newCompilationState 105 | } 106 | else do 107 | localIO Toolbar.shakeErrorDisplay 108 | return appState 109 | 110 | _update (ToolbarAction Toolbar.LoadProject) appState = do 111 | localIO $ JQuery.hide "#dependencyMessage" 112 | let tbState = toolbarState appState 113 | let cmpState = compilationState appState 114 | let projectPath = Compilation.projectPath (compilationState appState) 115 | let filePath = Compilation.workingFile (compilationState appState) 116 | atRemote $ localIO $ 117 | when (Toolbar.createProject tbState) (Compilation.makeNewProject projectPath) 118 | readAtRemote (projectPath filePath) >>= \case 119 | Left _ -> do 120 | let newTbState = tbState { Toolbar.projectOpened = False } 121 | let newCmpState = cmpState 122 | { Compilation.compilationError = "Couldn't find Haskell.do project at " 123 | ++ projectPath 124 | ++ ". Was it created correctly?" 125 | } 126 | localIO $ CodeMirror.setMDEContent "" 127 | localIO $ JQuery.setHtmlForId "#outputDisplay" "" 128 | return appState 129 | { toolbarState = newTbState 130 | , compilationState = newCmpState 131 | } 132 | Right contents -> do 133 | let editorState = codeMirrorState appState 134 | let parsedContents = unlines . drop 4 $ lines contents 135 | let newEditorState = editorState { CodeMirror.content = parsedContents } 136 | let newTbState = tbState { Toolbar.projectOpened = True } 137 | let newCmpState = cmpState { Compilation.compilationError = "" } 138 | localIO $ CodeMirror.setMDEContent parsedContents 139 | localIO $ JQuery.hide "#errorDisplay" -- Hide error while dependencies load 140 | localIO $ JQuery.setHtmlForId "#outputDisplay" "" 141 | let stateAfterOpening = appState 142 | { codeMirrorState = newEditorState 143 | , toolbarState = newTbState 144 | , compilationState = newCmpState 145 | } 146 | localIO $ JQuery.show "#dependencyMessage" 147 | newState <- update (ToolbarAction Toolbar.Compile) stateAfterOpening 148 | localIO $ JQuery.hide "#dependencyMessage" 149 | localIO $ JQuery.show "#errorDisplay" -- Show it after they finished 150 | return newState 151 | 152 | _update (ToolbarAction Toolbar.LoadPackageYaml) appState = do 153 | let projectPath = Compilation.projectPath (compilationState appState) 154 | contents <- atRemote $ localIO $ readFile (projectPath "package.yaml") 155 | let tbState = toolbarState appState 156 | let tbState' = tbState { Toolbar.projectConfig = contents } 157 | localIO $ JQuery.setValueForId "#packageTextArea event textArea" contents 158 | _ <- Toolbar.update Toolbar.LoadPackageYaml tbState 159 | return appState { toolbarState = tbState' } 160 | 161 | _update (ToolbarAction Toolbar.SavePackage) appState = do 162 | let projectPath = Compilation.projectPath (compilationState appState) 163 | let tbState = toolbarState appState 164 | atRemote $ localIO $ writeFile (projectPath "package.yaml") (Toolbar.projectConfig tbState) 165 | _ <- Toolbar.update Toolbar.ClosePackageModal tbState 166 | localIO $ JQuery.show "#dependencyMessage" 167 | newState <- update (ToolbarAction Toolbar.Compile) appState 168 | localIO $ JQuery.hide "#dependencyMessage" 169 | return newState 170 | 171 | _update (ToolbarAction action) appState = do 172 | newToolbarState <- Toolbar.update action (toolbarState appState) 173 | let cs = compilationState appState 174 | let newCompilationState = cs 175 | { Compilation.projectPath = Toolbar.projectPath newToolbarState 176 | } 177 | return appState { compilationState = newCompilationState, toolbarState = newToolbarState } 178 | 179 | readAtRemote :: FilePath -> Cloud (Either String String) 180 | readAtRemote path = atRemote . localIO $ 181 | maybeRead path 182 | >>= \case 183 | Nothing -> return (Left $ "Could not open file " ++ path) 184 | Just txt -> return (Right txt) 185 | 186 | maybeRead :: FilePath -> IO (Maybe String) 187 | maybeRead path = 188 | try (readFile path) 189 | >>= handleRead 190 | 191 | handleRead :: Either SomeException String -> IO (Maybe String) 192 | handleRead = \case 193 | Left _ -> return Nothing 194 | Right txt -> return (Just txt) 195 | 196 | -------------------------------------------------------------------------------- /src/common/HaskellDo/Style/View.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo.Style.View (initialize) where 17 | 18 | import Clay 19 | import GHCJS.HPlay.View hiding (addHeader, height, (!), width) 20 | import qualified Data.Text.Lazy as Text 21 | 22 | import AxiomUtils 23 | 24 | initialize :: IO () 25 | initialize = addHeader $ 26 | nelem "style" `child` mdeStyle 27 | 28 | mdeStyle :: String 29 | mdeStyle = Text.unpack . Clay.render $ do 30 | "html, body" ? do 31 | backgroundColor "#ccc" 32 | height (pct 100.0) 33 | ".editor-container" ? do 34 | backgroundColor "#fff" 35 | marginTop (pct 5) 36 | marginLeft (pct 2) 37 | marginRight (pct 2) 38 | minHeight (pct 100.0) 39 | bottom (px 0) 40 | paddingTop (px 75) 41 | paddingLeft (px 60) 42 | paddingRight (px 60) 43 | position relative 44 | zIndex 1 45 | ".CodeMirror" ? do 46 | fontFamily [] [monospace] 47 | borderWidth (px 0) 48 | ".fixed-action-btn" ? do 49 | position fixed 50 | top (pct 2) 51 | right (pct 2) 52 | ".dimmedBackground" ? do 53 | height (pct 100) 54 | width (pct 100) 55 | position absolute 56 | top (pct 0) 57 | left (pct 0) 58 | zIndex 999 59 | backgroundColor "#FFF" 60 | opacity 0.8 61 | ".loader-align" ? do 62 | position absolute 63 | left (pct 50) 64 | top (pct 50) 65 | ".loader-align-inner" ? do 66 | position relative 67 | left (pct $ -50) 68 | top (pct $ -50) 69 | "#outputdiv" ? do 70 | position relative 71 | zIndex 1 72 | "#packageTextArea event textarea" ? do 73 | fontFamily [] [monospace] 74 | boxSizing borderBox 75 | overflow auto 76 | height (pct 100) 77 | "#dependencyMessage" ? do 78 | margin (px 0) auto (px 0) auto 79 | ".fs-tree .collection-item span" ? do 80 | marginLeft (px 5) 81 | "#errorDisplay" ? do 82 | position fixed 83 | left (pct 1) 84 | bottom (pct 0) 85 | maxWidth (pct 98) 86 | zIndex 2 87 | "#errorDisplay pre" ? do 88 | maxHeight (vh 40) 89 | overflow auto 90 | -------------------------------------------------------------------------------- /src/common/HaskellDo/Toolbar/FileSystemTree.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo.Toolbar.FileSystemTree (widget) where 17 | 18 | import Prelude hiding (div, id, span) 19 | 20 | import GHCJS.HPlay.View hiding (addHeader, atr, id, wlink) 21 | import AxiomUtils 22 | import qualified Ulmus 23 | 24 | import System.FilePath ((), takeDirectory, dropTrailingPathSeparator) 25 | 26 | import HaskellDo.Toolbar.Types 27 | 28 | widget :: State -> Widget Action 29 | widget state = Ulmus.newWidget "fsTree" $ 30 | if null pp then 31 | return $ NewPath "" 32 | else 33 | if directoryExists state 34 | then 35 | let dirElements = map directoryItem directories 36 | fileElements = map fileItem files 37 | 38 | elements = dirElements ++ fileElements 39 | final = tools : elements 40 | 41 | in foldl1 (<|>) final 42 | else 43 | noWidget 44 | where 45 | (directories, files) = directoryList state 46 | pp = projectPath state 47 | 48 | folderIcon = i ! atr "class" "material-icons amber-text text-darken-1" $ ("folder" :: String) 49 | fileIcon = i ! atr "class" "material-icons blue-grey-text text-lighten-2" $ ("insert_drive_file" :: String) 50 | backIcon = i ! atr "class" "material-icons amber-text text-lighten-1" $ ("arrow_back" :: String) 51 | newDirIcon = i ! atr "class" "material-icons amber-text text-lighten-1" $ ("create_new_folder" :: String) 52 | 53 | directoryItem name = item (NewPath $ pp name) folderIcon name 54 | fileItem = item (NewPath pp) fileIcon 55 | 56 | tools = Ulmus.newWidget "fsTree-tools" $ 57 | backItem <|> newDirectoryItem 58 | 59 | backItem = tool (NewPath $ parentDirectory pp) backIcon ("Back" :: String) ! atr "class" "valign-wrapper left" 60 | newDirectoryItem = tool NewDirectoryModal newDirIcon ("New Directory" :: String) ! atr "class" "valign-wrapper right" 61 | 62 | parentDirectory :: FilePath -> FilePath 63 | parentDirectory = takeDirectory . dropTrailingPathSeparator 64 | 65 | item :: Action -> Perch -> String -> Widget Action 66 | item action icon name = wlink action (li ! atr "class" "valign-wrapper" $ icon >> span name) ! atr "class" "collection-item" 67 | 68 | tool :: Action -> Perch -> String -> Widget Action 69 | tool action icon name = wlink action (icon >> span name) ! atr "class" "valign-wrapper" 70 | 71 | -------------------------------------------------------------------------------- /src/common/HaskellDo/Toolbar/State.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo.Toolbar.State where 17 | 18 | import System.Directory (listDirectory, doesFileExist, doesDirectoryExist, getHomeDirectory, createDirectory) 19 | import System.FilePath (()) 20 | 21 | import Control.Monad (filterM, unless) 22 | 23 | import Transient.Move 24 | 25 | import HaskellDo.Toolbar.Types 26 | import Foreign.Materialize 27 | import Foreign.JQuery 28 | 29 | initialState :: State 30 | initialState = State 31 | { projectPath = "" 32 | , lastProject = "" 33 | , projectConfig = "" 34 | , projectOpened = False 35 | , createProject = False 36 | , directoryExists = False 37 | , directoryList = ([], []) 38 | , newDirectoryPath = "" 39 | } 40 | 41 | 42 | lastProjectFile :: FilePath 43 | lastProjectFile = "lastproject" 44 | 45 | update :: Action -> State -> Cloud State 46 | update OpenProject state = do 47 | localIO $ openModal "#openProjectModal" 48 | update (NewPath (projectPath state)) state 49 | 50 | update NewDirectoryModal state = do 51 | localIO $ openModal "#newDirectoryModal" 52 | return state 53 | 54 | update LoadPackageYaml state = do 55 | localIO $ if projectOpened state 56 | then openModal "#packageEditorModal" 57 | else shakeErrorDisplay 58 | return state 59 | 60 | update ClosePackageModal state = do 61 | localIO $ closeModal "#packageEditorModal" 62 | return state 63 | 64 | update (NewDirectory path) state = return $ state { newDirectoryPath = projectPath state path } 65 | 66 | update CreateNewDirectory state = do 67 | let path = newDirectoryPath state 68 | exists <- atRemote . localIO $ doesDirectoryExist path 69 | 70 | unless exists $ 71 | atRemote . localIO $ createDirectory path 72 | 73 | update (NewPath (projectPath state)) state 74 | 75 | update (NewPath newPath) state = do 76 | path <- pathOrLastOrHome newPath 77 | localIO $ setValueForId "#pathInput event input" path 78 | 79 | exists <- atRemote . localIO $ doesDirectoryExist path 80 | let newState = state { directoryExists = exists, projectPath = path } 81 | 82 | if exists 83 | then do 84 | (directories, files) <- directoriesAndFiles path 85 | 86 | let newState' = newState { directoryList = (directories, files) } 87 | 88 | isProject <- atRemote $ localIO $ doesFileExist (path "package.yaml") 89 | updateProjectAvailability newState' path isProject 90 | else do 91 | let newState' = newState { directoryList = ([], []), createProject = True } 92 | return newState' 93 | where 94 | pathOrLastOrHome path = if null path 95 | then do 96 | exists <- atRemote . localIO $ doesFileExist lastProjectFile 97 | home <- atRemote . localIO $ getHomeDirectory 98 | -- if lastProjectFile exists and is not empty, use it 99 | -- otherwise use the home directory 100 | if exists 101 | then do 102 | content <- atRemote . localIO $ readFile lastProjectFile 103 | return $ if null content then home else content 104 | else 105 | return home 106 | else 107 | return path 108 | 109 | directoriesAndFiles path = do 110 | list <- atRemote . localIO $ listDirectory path 111 | let visible = filter ((/= '.') . head) list 112 | directories <- atRemote . localIO $ filterM (doesDirectoryExist . (path )) visible 113 | files <- atRemote . localIO $ filterM (doesFileExist . (path )) visible 114 | 115 | return (directories, files) 116 | 117 | updateProjectAvailability currentState _ True = do 118 | localIO $ setHtmlForId "#creationDisplay" "" 119 | localIO $ setHtmlForId "#closeModalButton event .material-icons" "input" 120 | return $ currentState { createProject = False } 121 | 122 | updateProjectAvailability currentState path False = do 123 | localIO $ setHtmlForId "#creationDisplay" ("

No project found at " ++ path ++ ", it will be created.

") 124 | localIO $ setHtmlForId "#closeModalButton event .material-icons" "playlist_add" 125 | return $ currentState { createProject = True } 126 | 127 | update (NewPackage newConfig) state = return state { projectConfig = newConfig } 128 | 129 | update ToggleEditor state = do 130 | localIO toggleEditor 131 | return state 132 | 133 | update ToggleError state = do 134 | localIO toggleError 135 | return state 136 | 137 | update _ state = return state 138 | 139 | shakeErrorDisplay :: IO () 140 | shakeErrorDisplay = shake "#errorDisplay" 141 | -------------------------------------------------------------------------------- /src/common/HaskellDo/Toolbar/Types.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo.Toolbar.Types where 17 | 18 | data State = State 19 | { projectPath :: String 20 | , lastProject :: String 21 | , projectConfig :: String 22 | , projectOpened :: Bool 23 | , createProject :: Bool 24 | , directoryExists :: Bool 25 | , directoryList :: ([String], [String]) -- (directories, files) 26 | , newDirectoryPath :: String 27 | } deriving (Read, Show) 28 | 29 | data Action 30 | = Compile 31 | | OpenProject 32 | | LoadPackageYaml 33 | | NewPath String 34 | | NewPackage String 35 | | NewDirectoryModal 36 | | NewDirectory String 37 | | CreateNewDirectory 38 | | LoadProject 39 | | SavePackage 40 | | ClosePackageModal 41 | | ToggleEditor 42 | | ToggleError 43 | deriving (Read, Show) 44 | -------------------------------------------------------------------------------- /src/common/HaskellDo/Toolbar/View.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo.Toolbar.View where 17 | 18 | import Prelude hiding (div, id) 19 | 20 | import GHCJS.HPlay.View hiding (addHeader, atr, id, wlink) 21 | import AxiomUtils 22 | import qualified Ulmus 23 | 24 | import qualified HaskellDo.Toolbar.FileSystemTree as FileSystemTree 25 | 26 | import Control.Monad.IO.Class 27 | 28 | import HaskellDo.Toolbar.Types 29 | import Foreign.JQuery 30 | 31 | toolbar :: Widget () 32 | toolbar = rawHtml $ do 33 | div ! atr "class" "fixed-action-btn horizontal" $ do 34 | a ! atr "class" "btn-floating btn-large purple" $ 35 | i ! atr "class" "material-icons" $ 36 | ("menu" :: String) 37 | ul $ do 38 | li ! id "openProjectButton" $ noHtml 39 | li ! id "compileButton" $ noHtml 40 | li ! id "packageEditorButton" $ noHtml 41 | li ! id "toggleEditorButton" $ noHtml 42 | li ! id "toggleErrorButton" $ noHtml 43 | packageEditorModal -- Apparently, if we put this line 44 | openProjectModal -- under this one. The open project modal doesn't work 45 | modalPromptPlaceholder "newDirectoryModal" "New Directory" "Choose a name for the new directory" 46 | 47 | openProjectModal :: Perch 48 | openProjectModal = 49 | div ! id "openProjectModal" ! atr "class" "modal modal-fixed-footer" $ do 50 | div ! atr "class" "modal-content" $ do 51 | h4 ("Open project" :: String) 52 | div $ do 53 | b ("Path to Stack project" :: String) 54 | div ! id "pathInput" $ noHtml 55 | p ! atr "class" "grey-text lighten-4" $ ("Path must be absolute, without ~ or environment variables." :: String) 56 | div ! id "creationDisplay" $ noHtml 57 | ul ! atr "class" "fs-tree collection" $ do 58 | div ! atr "class" "collection-item row" $ 59 | li ! id "fsTree-tools" $ noHtml 60 | div ! id "fsTree" $ noHtml 61 | 62 | div ! atr "class" "modal-footer" $ 63 | div ! id "closeModalButton" $ noHtml 64 | 65 | modalPromptPlaceholder :: String -> String -> String -> Perch 66 | modalPromptPlaceholder id' htitle text = 67 | div ! id id' ! atr "class" "modal" $ do 68 | div ! atr "class" "modal-content" $ do 69 | if (not . null) htitle then h4 htitle else noHtml 70 | div $ do 71 | if (not . null) text then label text else noHtml 72 | div ! atr "class" "input-container" $ noHtml 73 | 74 | div ! atr "class" "modal-footer" $ 75 | div ! id (id' ++ "closeButton") $ noHtml 76 | 77 | modalPrompt :: String -> (String -> Action) -> Action -> State -> Widget Action 78 | modalPrompt id' inputAction buttonAction _ = inputWidget <|> closeButtonWidget 79 | where 80 | inputWidget = Ulmus.newWidget (id' ++ " .input-container") $ do 81 | _ <- getString Nothing 82 | `fire` OnKeyUp 83 | projPath <- liftIO $ getValueFromId ("#" ++ id' ++ " event input") 84 | return (inputAction projPath) 85 | 86 | closeButtonWidget = Ulmus.newWidget (id' ++ "closeButton") $ wlink buttonAction $ 87 | a ! atr "class" "modal-action modal-close waves-effect btn-flat waves-purple" $ 88 | i ! atr "class" "material-icons" $ ("input" :: String) 89 | 90 | packageEditorModal :: Perch 91 | packageEditorModal = 92 | div ! id "packageEditorModal" ! atr "class" "modal bottom-sheet" $ do 93 | div ! atr "class" "modal-content" $ do 94 | h4 ("Project settings" :: String) 95 | div $ 96 | div ! id "packageTextArea" $ noHtml 97 | div ! atr "class" "modal-footer" $ do 98 | p ! atr "class" "red-text" $ ("Dependencies will be downloaded after confirming" :: String) 99 | div ! id "cancelPackageEditorButton" $ noHtml 100 | div ! id "closePackageEditorButton" $ noHtml 101 | 102 | openProjectButton :: State -> Widget Action 103 | openProjectButton _ = Ulmus.newWidget "openProjectButton" $ wlink OpenProject $ 104 | a ! atr "class" "btn-floating purple darken-2 tooltipped" ! atr "data-position" "bottom" ! atr "data-tooltip" "New/Open" ! atr "data-delay" "50" $ 105 | i ! atr "class" "material-icons" $ ("folder_open" :: String) 106 | 107 | packageEditorButton :: State -> Widget Action 108 | packageEditorButton _ = Ulmus.newWidget "packageEditorButton" $ wlink LoadPackageYaml $ 109 | a ! atr "class" "btn-floating purple darken-2 tooltipped" ! atr "data-position" "bottom" ! atr "data-tooltip" "Project settings" ! atr "data-delay" "50"$ 110 | i ! atr "class" "material-icons" $ ("build" :: String) 111 | 112 | 113 | compileButton :: State -> Widget Action 114 | compileButton _ = Ulmus.newWidget "compileButton" $ wlink Compile $ 115 | a ! atr "class" "btn-floating purple darken-2 tooltipped" ! atr "data-position" "bottom" ! atr "data-tooltip" "Compile [Ctrl+Return]" ! atr "data-delay" "50"$ 116 | i ! atr "class" "material-icons" $ ("play_arrow" :: String) 117 | 118 | toggleEditorButton :: State -> Widget Action 119 | toggleEditorButton _ = Ulmus.newWidget "toggleEditorButton" $ wlink ToggleEditor $ 120 | a ! atr "class" "btn-floating purple darken-2 tooltipped" ! atr "data-position" "bottom" ! atr "data-tooltip" "Toggle editor" ! atr "data-delay" "50"$ 121 | i ! atr "class" "material-icons" $ ("remove_red_eye" :: String) 122 | 123 | toggleErrorButton :: State -> Widget Action 124 | toggleErrorButton _ = Ulmus.newWidget "toggleErrorButton" $ wlink ToggleError $ 125 | a ! atr "class" "btn-floating purple darken-2 tooltipped" ! atr "data-position" "bottom" ! atr "data-tooltip" "Toggle error" ! atr "data-delay" "50"$ 126 | i ! atr "class" "material-icons" $ ("error" :: String) 127 | 128 | 129 | closeModalButton :: State -> Widget Action 130 | closeModalButton _ = Ulmus.newWidget "closeModalButton" $ wlink LoadProject $ 131 | a ! atr "class" "modal-action modal-close waves-effect btn-flat waves-purple" $ 132 | i ! atr "class" "material-icons" $ ("input" :: String) 133 | 134 | closePackageEditorButton :: State -> Widget Action 135 | closePackageEditorButton _ = Ulmus.newWidget "closePackageEditorButton" $ wlink SavePackage $ 136 | a ! atr "class" "modal-action modal-close waves-effect btn-flat waves-purple" $ 137 | i ! atr "class" "material-icons" $ ("playlist_add_check" :: String) 138 | 139 | cancelPackageEditorButton :: State -> Widget Action 140 | cancelPackageEditorButton _ = Ulmus.newWidget "cancelPackageEditorButton" $ wlink ClosePackageModal $ 141 | a ! atr "class" "modal-action modal-close waves-effect btn-flat waves-purple" $ 142 | i ! atr "class" "material-icons" $ ("clear" :: String) 143 | 144 | pathInput :: State -> Widget Action 145 | pathInput state = Ulmus.newWidget "pathInput" $ do 146 | let pr = if lastProject state == "" 147 | then Nothing 148 | else Just $ lastProject state 149 | _ <- getString pr 150 | ! atr "placeholder" "/path/to/your/project" 151 | `fire` OnKeyUp 152 | projPath <- liftIO $ getValueFromId "#pathInput event input" 153 | return $ NewPath projPath 154 | 155 | packageTextArea :: State -> Widget Action 156 | packageTextArea _ = Ulmus.newWidget "packageTextArea" $ do 157 | _ <- getMultilineText "" ! atr "rows" "20" `fire` OnKeyUp 158 | newConfig <- liftIO $ getValueFromId "#packageTextArea event textarea" 159 | return $ NewPackage newConfig 160 | 161 | creationDisplay :: State -> Widget () 162 | creationDisplay _ = Ulmus.newWidget "creationDisplay" $ 163 | rawHtml $ p ! atr "class" "red-text" $ ("" :: String) 164 | 165 | updateDisplays :: State -> Widget Action 166 | updateDisplays = FileSystemTree.widget 167 | -------------------------------------------------------------------------------- /src/common/HaskellDo/Types.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module HaskellDo.Types where 17 | 18 | import qualified HaskellDo.CodeMirror.Types as CodeMirror 19 | import qualified HaskellDo.Compilation.Types as Compilation 20 | import qualified HaskellDo.Toolbar.Types as Toolbar 21 | 22 | data AppState = AppState 23 | { codeMirrorState :: CodeMirror.State 24 | , compilationState :: Compilation.State 25 | , toolbarState :: Toolbar.State 26 | } deriving (Read, Show) 27 | 28 | 29 | data Action 30 | = CodeMirrorAction CodeMirror.Action 31 | | ToolbarAction Toolbar.Action 32 | deriving (Read, Show) 33 | -------------------------------------------------------------------------------- /src/common/HaskellDo/View.hs: -------------------------------------------------------------------------------- 1 | 2 | {- 3 | - Copyright (c) 2017 The Agile Monkeys S.L. 4 | - 5 | - Licensed under the Apache License, Version 2.0 (the "License"); 6 | - you may not use this file except in compliance with the License. 7 | - You may obtain a copy of the License at 8 | - 9 | - http://www.apache.org/licenses/LICENSE-2.0 10 | - 11 | - Unless required by applicable law or agreed to in writing, software 12 | - distributed under the License is distributed on an "AS IS" BASIS, 13 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | - See the License for the specific language governing permissions and 15 | - limitations under the License. 16 | -} 17 | module HaskellDo.View where 18 | 19 | import Prelude hiding (id, div) 20 | 21 | import GHCJS.HPlay.View 22 | import Transient.Internals ((**>)) 23 | import qualified Ulmus 24 | 25 | import HaskellDo.Types 26 | import qualified HaskellDo.Materialize.View as Materialize 27 | import qualified HaskellDo.CodeMirror.View as CodeMirror 28 | import qualified HaskellDo.Compilation.View as Compilation 29 | import qualified HaskellDo.Toolbar.View as Toolbar 30 | import qualified HaskellDo.Toolbar.Types as Toolbar 31 | import qualified HaskellDo.Toolbar.FileSystemTree as FileSystemTree 32 | 33 | view :: AppState -> Widget Action 34 | view appState = Ulmus.withWidgets (widgets appState) $ 35 | div ! atr "class" "editor-container" $ do 36 | Materialize.row $ do 37 | Materialize.col "s" 6 $ 38 | Ulmus.widgetPlaceholder "editor" 39 | Materialize.col "s" 6 ! id "outputdiv" $ do 40 | Ulmus.widgetPlaceholder "outputDisplay" 41 | loaderOverlay 42 | Materialize.row $ 43 | Materialize.col "s" 12 $ div ! atr "class" "error-placeholder" $ noHtml 44 | Ulmus.widgetPlaceholder "errorDisplay" 45 | 46 | loaderOverlay :: Perch 47 | loaderOverlay = 48 | div ! atr "class" "dimmedBackground" $ 49 | div ! atr "class" "loader-align center-align" $ 50 | div ! atr "class" "loader-align-inner" $ do 51 | div ! atr "class" "preloader-wrapper big active" $ 52 | div ! atr "class" "spinner-layer spinner-blue-only" $ do 53 | div ! atr "class" "circle-clipper left" $ 54 | div ! atr "class" "circle" $ noHtml 55 | div ! atr "class" "gap-patch" $ 56 | div ! atr "class" "circle" $ noHtml 57 | div ! atr "class" "circle-clipper right" $ 58 | div ! atr "class" "circle" $ noHtml 59 | p ! atr "class" "grey-text center-align" ! atr "id" "dependencyMessage" $ ("Downloading dependencies" :: String) 60 | widgets :: AppState -> Widget Action 61 | widgets state = do 62 | Toolbar.toolbar 63 | Toolbar.creationDisplay (toolbarState state) 64 | showDisplays state 65 | codeMirrorWidget 66 | **> packageTextAreaWidget 67 | **> openProjectButtonWidget 68 | **> packageEditorButtonWidget 69 | **> toggleEditorButtonWidget 70 | **> toggleErrorButtonWidget 71 | **> compileButtonWidget 72 | **> pathInputWidget 73 | **> closeModalButtonWidget 74 | **> closePackageEditorButtonWidget 75 | **> cancelPackageEditorButtonWidget 76 | **> fsTreeWidget 77 | **> modalPrompt "newDirectoryModal" Toolbar.NewDirectory Toolbar.CreateNewDirectory 78 | where 79 | modalPrompt id' inputAction buttonAction = Ulmus.mapAction ToolbarAction $ 80 | Toolbar.modalPrompt id' inputAction buttonAction (toolbarState state) 81 | 82 | codeMirrorWidget = Ulmus.newWidget "editor" $ 83 | Ulmus.mapAction CodeMirrorAction $ 84 | CodeMirror.view $ codeMirrorState state 85 | 86 | openProjectButtonWidget = Ulmus.mapAction ToolbarAction $ 87 | Toolbar.openProjectButton (toolbarState state) 88 | 89 | packageEditorButtonWidget = Ulmus.mapAction ToolbarAction $ 90 | Toolbar.packageEditorButton (toolbarState state) 91 | 92 | compileButtonWidget = Ulmus.mapAction ToolbarAction $ 93 | Toolbar.compileButton (toolbarState state) 94 | 95 | toggleEditorButtonWidget = Ulmus.mapAction ToolbarAction $ 96 | Toolbar.toggleEditorButton (toolbarState state) 97 | 98 | toggleErrorButtonWidget = Ulmus.mapAction ToolbarAction $ 99 | Toolbar.toggleErrorButton (toolbarState state) 100 | 101 | pathInputWidget = Ulmus.mapAction ToolbarAction $ 102 | Toolbar.pathInput (toolbarState state) 103 | 104 | packageTextAreaWidget = Ulmus.mapAction ToolbarAction $ 105 | Toolbar.packageTextArea (toolbarState state) 106 | 107 | fsTreeWidget = Ulmus.mapAction ToolbarAction $ 108 | FileSystemTree.widget (toolbarState state) 109 | 110 | closeModalButtonWidget = Ulmus.mapAction ToolbarAction $ 111 | Toolbar.closeModalButton (toolbarState state) 112 | 113 | closePackageEditorButtonWidget = Ulmus.mapAction ToolbarAction $ 114 | Toolbar.closePackageEditorButton (toolbarState state) 115 | 116 | cancelPackageEditorButtonWidget = Ulmus.mapAction ToolbarAction $ 117 | Toolbar.cancelPackageEditorButton (toolbarState state) 118 | 119 | 120 | showDisplays :: AppState -> Widget () 121 | showDisplays state = do 122 | Ulmus.newWidget "outputDisplay" $ Compilation.outputDisplay (compilationState state) 123 | Ulmus.newWidget "errorDisplay" $ Compilation.errorDisplay (compilationState state) 124 | 125 | updateDisplays :: AppState -> Widget Action 126 | updateDisplays state = do 127 | Compilation.updateDisplays (compilationState state) 128 | Ulmus.mapAction ToolbarAction $ 129 | Toolbar.updateDisplays (toolbarState state) 130 | -------------------------------------------------------------------------------- /src/common/Main.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module Main where 17 | 18 | import HaskellDo 19 | import System.Environment (getArgs) 20 | import System.Directory 21 | 22 | defaultPort :: Integer 23 | defaultPort = 3001 24 | 25 | main :: IO () 26 | main = do 27 | args <- getArgs 28 | hdopath <- findExecutable "haskell-do" 29 | case hdopath of 30 | Just p -> do 31 | let parentDir = reverse . dropWhile (/= '/') . reverse 32 | x <- listDirectory $ parentDir p 33 | print x 34 | setCurrentDirectory (parentDir p) 35 | Nothing -> 36 | #ifdef ghcjs_HOST_OS 37 | return () 38 | #else 39 | error "haskell.do must be on PATH" 40 | #endif 41 | let port = case args of 42 | [x] -> read x :: Integer 43 | _ -> defaultPort 44 | showWelcomeMessage 45 | let msg = " Open the following URL in your browser: http://localhost:" ++ show port ++ " " 46 | putStrLn $ replicate (length msg) '=' 47 | putStrLn msg 48 | putStrLn $ replicate (length msg) '=' 49 | run port 50 | 51 | showWelcomeMessage :: IO () 52 | showWelcomeMessage = putStrLn $ 53 | "\n" 54 | ++ " ________________\n" 55 | ++ "´ , , ` ,--. ,--. ,--.,--. ,--.\n" 56 | ++ "| /\\| | \\ | | ,---. ,--,--. ,---. | |,-. ,---. | || | ,-| | ,---.\n" 57 | ++ "| /\\\\| | /\\ | | .-. |' ,-. |( .-' | /| .-. :| || | ' .-. || .-. |\n" 58 | ++ "| ( `| |´//) | | | | |\\ '-' |.-' `)| \\ \\\\ --.| || |.--.\\ `-' |' '-' '\n" 59 | ++ "| \\ | |/// | `--' `--' `--`--'`----' `--'`--'`----'`--'`--''--' `---' `---'\n" 60 | ++ "| \\| |/ |\n" 61 | ++ "\\________________/\n" 62 | -------------------------------------------------------------------------------- /src/common/Ulmus.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module Ulmus where 17 | 18 | import Prelude hiding (div, id) 19 | import Data.IORef 20 | import Data.Typeable 21 | import Control.Monad.IO.Class 22 | 23 | import GHCJS.HPlay.View hiding (at, id) 24 | import Transient.Base hiding (getState, setState) 25 | import Transient.Move 26 | 27 | import AxiomUtils 28 | 29 | type Update action appState = action -> appState -> Cloud appState 30 | type View action appState = appState -> Widget action 31 | type UpdateDisplays action appState = appState -> Widget action 32 | 33 | data AppConfig action appState = AppConfig 34 | { _update :: Update action appState 35 | , _view :: View action appState 36 | , _updateDisplays :: UpdateDisplays action appState 37 | , _initialState :: appState 38 | , _port :: Integer 39 | , _setup :: IO () 40 | } 41 | 42 | webApp :: Integer -> Cloud () -> IO () 43 | webApp appPort app = do 44 | node <- createNode "localhost" appPort 45 | _ <- keep' $ initWebApp node app 46 | return () 47 | 48 | initializeApp :: (Show appState, Show action, Read appState, Read action, Typeable appState, Typeable action) 49 | => AppConfig action appState 50 | -> IO () 51 | initializeApp (AppConfig update view updateDisplays initialAppState appPort setup) = do 52 | setup 53 | webApp appPort $ do 54 | step view 55 | loop (step updateDisplays) 56 | where 57 | step f = do 58 | currentState <- local $ getState initialAppState 59 | nextAction <- local (render $ f currentState) 60 | currentState' <- local $ getState initialAppState 61 | newState <- update nextAction currentState' 62 | local (setState newState) 63 | loop f = f >> loop f 64 | 65 | widgetPlaceholder :: String -> Perch 66 | widgetPlaceholder id' = 67 | div 68 | ! id id' 69 | $ noHtml 70 | 71 | updateWidget :: String -> Widget () -> TransIO () 72 | updateWidget s f = render $ at ("#" ++ s) Insert f 73 | 74 | 75 | withWidgets :: Widget a -> Perch -> Widget a 76 | withWidgets widgets perch = rawHtml perch **> widgets 77 | 78 | 79 | newWidget :: String -> Widget a -> Widget a 80 | newWidget s = at ("#" ++ s) Insert 81 | 82 | mapAction :: (actionA -> actionB) -> Widget actionA -> Widget actionB 83 | mapAction actionConstructor widget = do 84 | action <- widget 85 | return $ actionConstructor action 86 | --------------------------------------------- State manipulation ------------------------------- 87 | 88 | getState :: (Typeable appState) => appState -> TransIO appState 89 | getState initialAppState = getRData <|> setAndReturn 90 | where 91 | setAndReturn = do 92 | setState initialAppState 93 | return initialAppState 94 | 95 | 96 | setState :: (Typeable appState) => appState -> TransIO () 97 | setState = setRData 98 | 99 | --------------------------------------------- State References in the TransIO monad ------------ 100 | newtype Ref a = Ref (IORef a) 101 | 102 | -- | An state reference that can be updated (similar to STRef in the state monad) 103 | -- 104 | -- Initialized the first time it is set. 105 | setRData :: Typeable a => a -> TransIO () 106 | setRData x = do 107 | Ref ref <- getSData 108 | liftIO $ atomicModifyIORef ref $ const (x,()) 109 | <|> do 110 | ref <- liftIO (newIORef x) 111 | setData $ Ref ref 112 | 113 | getRData :: Typeable a => TransIO a 114 | getRData= do 115 | Ref ref <- getSData 116 | liftIO $ readIORef ref 117 | -------------------------------------------------------------------------------- /src/docker/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM phusion/baseimage:0.9.22 2 | 3 | ENV HASKELL_DO_VER=0.9.3 4 | 5 | # # CMD ["/sbin/my_init"] 6 | 7 | COPY setup.sh . 8 | 9 | RUN ./setup.sh 10 | 11 | 12 | RUN wget https://github.com/theam/haskell-do/releases/download/v${HASKELL_DO_VER}/haskell-do_linux_x86_64_v${HASKELL_DO_VER}.zip && \ 13 | unzip haskell-do_linux_x86_64_v${HASKELL_DO_VER}.zip && \ 14 | rm haskell-do_linux_x86_64_v${HASKELL_DO_VER}.zip 15 | 16 | 17 | RUN mv haskell-do /usr/local/bin && \ 18 | mv static/ usr/local/bin 19 | 20 | # # cleanup apt caches 21 | RUN apt-get clean && rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* 22 | 23 | # expose haskell-do port 24 | EXPOSE 8080 25 | 26 | # run haskell-do when image is started 27 | CMD haskell-do 8080 -------------------------------------------------------------------------------- /src/docker/setup.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | printf "\n=== APT-Installing dependencies :\n" 4 | apt-get update && apt-get install -y --no-install-recommends build-essential wget unzip sudo 5 | 6 | printf "\n=== Setting up FP Complete APT repository :\n" 7 | # # get FP Complete public key 8 | apt-key adv --keyserver hkp://keyserver.ubuntu.com:80 --recv-keys 575159689BEFB442 9 | # Ubuntu 14 APT repo for FP Complete 10 | echo 'deb http://download.fpcomplete.com/ubuntu xenial main' | sudo tee /etc/apt/sources.list.d/fpco.list 11 | 12 | printf "\n=== APT-Installing dependencies : \n" 13 | apt-get update -y && apt-get install -y --no-install-recommends \ 14 | libgmp-dev stack && \ 15 | stack upgrade 16 | 17 | 18 | export PATH=$(stack --stack-yaml stack.yaml path --local-install-root):$PATH 19 | 20 | 21 | printf "\n=== Environment :\n" 22 | printenv 23 | -------------------------------------------------------------------------------- /src/ghc-specific/AxiomUtils.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module AxiomUtils where 17 | 18 | import GHCJS.HPlay.View hiding (id, atr) 19 | 20 | setContents :: Perch -> String -> Perch 21 | setContents element _ = element 22 | 23 | addHeader :: Perch -> IO () 24 | addHeader _ = return () 25 | 26 | atr :: String -> String -> (String, String) 27 | atr = (,) 28 | 29 | id :: String -> (String, String) 30 | id = atr "id" 31 | 32 | at :: String -> UpdateMethod -> Widget a -> Widget a 33 | at _ _ w = w 34 | 35 | wlink :: a -> Perch -> Widget a 36 | wlink _ _ = empty 37 | -------------------------------------------------------------------------------- /src/ghc-specific/Foreign/CodeMirror.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module Foreign.CodeMirror where 17 | 18 | getMDEContent :: IO String 19 | getMDEContent = return "" 20 | 21 | setMDEContent :: String -> IO () 22 | setMDEContent _ = return () 23 | 24 | makeCodeMirrorFromId :: String -> IO () 25 | makeCodeMirrorFromId _ = return () 26 | 27 | cmdOrCtrlReturnPressed :: IO Bool 28 | cmdOrCtrlReturnPressed = return False 29 | -------------------------------------------------------------------------------- /src/ghc-specific/Foreign/Highlight.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module Foreign.Highlight where 17 | 18 | highlightCode :: IO () 19 | highlightCode = return () 20 | -------------------------------------------------------------------------------- /src/ghc-specific/Foreign/JQuery.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module Foreign.JQuery where 17 | 18 | getValueFromId :: String -> IO String 19 | getValueFromId _ = return "" 20 | 21 | setValueForId :: String -> String -> IO () 22 | setValueForId _ _ = return () 23 | 24 | setHtmlForId :: String -> String -> IO () 25 | setHtmlForId _ _ = return () 26 | 27 | activateScriptTags :: String -> IO () 28 | activateScriptTags _ = return () 29 | 30 | setHeightFromElement :: String -> String -> IO () 31 | setHeightFromElement _ _ = return () 32 | 33 | show :: String -> IO () 34 | show _ = return () 35 | 36 | hide :: String -> IO () 37 | hide _ = return () 38 | 39 | shake :: String -> IO () 40 | shake _ = return () 41 | -------------------------------------------------------------------------------- /src/ghc-specific/Foreign/Materialize.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module Foreign.Materialize where 17 | 18 | openModal :: String -> IO () 19 | openModal _ = return () 20 | 21 | closeModal :: String -> IO () 22 | closeModal _ = return () 23 | 24 | makeModals :: IO () 25 | makeModals = return () 26 | 27 | initTooltips :: IO () 28 | initTooltips = return () 29 | 30 | toggleEditor :: IO () 31 | toggleEditor = return () 32 | 33 | toggleError :: IO () 34 | toggleError = return () 35 | -------------------------------------------------------------------------------- /src/ghc-specific/Foreign/MathJax.hs: -------------------------------------------------------------------------------- 1 | module Foreign.MathJax where 2 | 3 | typeset :: String -> IO () 4 | typeset _ = return () 5 | 6 | -------------------------------------------------------------------------------- /src/ghcjs-specific/AxiomUtils.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module AxiomUtils where 17 | 18 | import GHCJS.HPlay.View (setHtml, Attribute, Perch, Widget, BrowserEvent(..), a, (!), href, pass) 19 | import qualified GHCJS.HPlay.View 20 | import GHCJS.Types 21 | import Data.JSString 22 | 23 | setContents :: Perch -> String -> Perch 24 | setContents element content = element `setHtml` (pack content :: JSString) 25 | 26 | addHeader :: Perch -> IO () 27 | addHeader = GHCJS.HPlay.View.addHeader 28 | 29 | atr :: String -> String -> Attribute 30 | atr propName propValue = GHCJS.HPlay.View.atr propName (pack propValue :: JSString) 31 | 32 | id :: String -> Attribute 33 | id = atr "id" 34 | 35 | at :: String -> GHCJS.HPlay.View.UpdateMethod -> GHCJS.HPlay.View.Widget a -> GHCJS.HPlay.View.Widget a 36 | at s = GHCJS.HPlay.View.at (pack s :: JSString) 37 | 38 | wlink :: a -> Perch -> Widget a 39 | wlink x v = do 40 | _ <- (a ! href "#" $ v) `pass` OnClick 41 | return x 42 | -------------------------------------------------------------------------------- /src/ghcjs-specific/Foreign/CodeMirror.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module Foreign.CodeMirror where 17 | 18 | import GHCJS.Types 19 | import Data.JSString 20 | 21 | getMDEContent :: IO String 22 | getMDEContent = unpack <$> js_getMDEContent 23 | 24 | foreign import javascript unsafe "simpleMDE.getValue()" 25 | js_getMDEContent :: IO JSString 26 | 27 | setMDEContent :: String -> IO () 28 | setMDEContent = js_setMDEContent . pack 29 | 30 | foreign import javascript unsafe "simpleMDE.setValue($1)" 31 | js_setMDEContent :: JSString -> IO () 32 | 33 | foreign import javascript unsafe "$r = cmdOrCtrlReturnPressed;" 34 | cmdOrCtrlReturnPressed :: IO Bool 35 | 36 | makeCodeMirrorFromId :: String -> IO () 37 | makeCodeMirrorFromId = js_makeCodeMirrorFromId . pack 38 | 39 | foreign import javascript unsafe 40 | "function initMDE() {\ 41 | var taId = $('#editor event textarea').attr('id');\ 42 | var ta = document.getElementById(taId);\ 43 | if (typeof CodeMirror !== 'undefined') {\ 44 | if (ta !== null) {\ 45 | simpleMDE=CodeMirror.fromTextArea(ta, {\ 46 | mode: 'gfm',\ 47 | theme: 'default'\ 48 | });\ 49 | } else {\ 50 | window.setTimeout(initMDE, 10);\ 51 | }\ 52 | } else {\ 53 | window.setTimeout(initMDE, 10);\ 54 | }\ 55 | };\ 56 | initMDE();" 57 | 58 | js_makeCodeMirrorFromId :: JSString -> IO () 59 | -------------------------------------------------------------------------------- /src/ghcjs-specific/Foreign/Highlight.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module Foreign.Highlight where 17 | 18 | foreign import javascript unsafe "setTimeout(function() {$('.haskell').each(function(i, block){ hljs.highlightBlock(block);}) }, 0);" 19 | highlightCode :: IO () 20 | -------------------------------------------------------------------------------- /src/ghcjs-specific/Foreign/JQuery.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module Foreign.JQuery where 17 | 18 | import GHCJS.Types 19 | import Data.JSString 20 | 21 | foreign import javascript unsafe "$($1).val()" 22 | js_getValueFromId :: JSString -> IO JSString 23 | 24 | foreign import javascript unsafe "$($1).val($2);" 25 | js_setValueForId :: JSString -> JSString -> IO () 26 | 27 | foreign import javascript unsafe "$($1).html($2);" 28 | js_setHtmlForId :: JSString -> JSString -> IO () 29 | 30 | foreign import javascript unsafe "$($1).show();" 31 | js_show :: JSString -> IO () 32 | 33 | foreign import javascript unsafe "$($1).hide();" 34 | js_hide :: JSString -> IO () 35 | 36 | foreign import javascript unsafe "$($1).effect('shake');" 37 | js_shake :: JSString -> IO () 38 | 39 | -- go through script tags, loading each one in order 40 | -- the deferred object and $.when make sure scripts are executed 41 | -- sequentially 42 | foreign import javascript unsafe "setTimeout(function() { \ 43 | var scripts = []; \ 44 | $($1).find('script').each(function() { \ 45 | var $e = $(this); \ 46 | $.when.apply($, scripts).then(function() { \ 47 | if ($e.attr('src')) { \ 48 | var d = $.Deferred(); \ 49 | $.getScript($e.attr('src'), function() { d.resolve() }); \ 50 | scripts.push(d); \ 51 | } else { \ 52 | eval($e.html()); \ 53 | } \ 54 | }) \ 55 | }) \ 56 | }, 0);" 57 | js_activateScriptTags :: JSString -> IO () 58 | 59 | foreign import javascript unsafe "setTimeout(function() { $($1).height($($2).height()) }, 0);" 60 | js_setHeightFromElement :: JSString -> JSString -> IO () 61 | 62 | getValueFromId :: String -> IO String 63 | getValueFromId s = do 64 | r <- js_getValueFromId $ pack s 65 | return $ unpack r 66 | 67 | setValueForId :: String -> String -> IO () 68 | setValueForId id' s = js_setValueForId (pack id') (pack s) 69 | 70 | setHtmlForId :: String -> String -> IO () 71 | setHtmlForId id' s = js_setHtmlForId (pack id') (pack s) 72 | 73 | activateScriptTags :: String -> IO () 74 | activateScriptTags id' = js_activateScriptTags (pack id') 75 | 76 | setHeightFromElement :: String -> String -> IO () 77 | setHeightFromElement id' id'' = js_setHeightFromElement (pack id') (pack id'') 78 | 79 | show :: String -> IO () 80 | show = js_show . pack 81 | 82 | hide :: String -> IO () 83 | hide = js_hide . pack 84 | 85 | shake :: String -> IO () 86 | shake = js_shake . pack 87 | -------------------------------------------------------------------------------- /src/ghcjs-specific/Foreign/Materialize.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - Copyright (c) 2017 The Agile Monkeys S.L. 3 | - 4 | - Licensed under the Apache License, Version 2.0 (the "License"); 5 | - you may not use this file except in compliance with the License. 6 | - You may obtain a copy of the License at 7 | - 8 | - http://www.apache.org/licenses/LICENSE-2.0 9 | - 10 | - Unless required by applicable law or agreed to in writing, software 11 | - distributed under the License is distributed on an "AS IS" BASIS, 12 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13 | - See the License for the specific language governing permissions and 14 | - limitations under the License. 15 | -} 16 | module Foreign.Materialize where 17 | 18 | import GHCJS.Types 19 | import Data.JSString 20 | 21 | openModal :: String -> IO () 22 | openModal s = do 23 | makeModals 24 | js_openModal . pack $ s 25 | 26 | closeModal :: String -> IO () 27 | closeModal = js_closeModal . pack 28 | 29 | foreign import javascript unsafe "$($1).modal('open')" 30 | js_openModal :: JSString -> IO () 31 | 32 | foreign import javascript unsafe "$($1).modal('close')" 33 | js_closeModal :: JSString -> IO () 34 | 35 | foreign import javascript unsafe "$('.modal').modal({dismissible: true, opacity: 0.7});" 36 | makeModals :: IO () 37 | 38 | foreign import javascript unsafe "$('.tooltipped').tooltip({delay: 50});" 39 | initTooltips :: IO () 40 | 41 | foreign import javascript unsafe "$('#editor').is('visible')" 42 | isEditorVisible :: IO Bool 43 | 44 | foreign import javascript unsafe "toggleEditor()" 45 | toggleEditor :: IO () 46 | 47 | foreign import javascript unsafe "$('#errorDisplay').toggle()" 48 | toggleError :: IO () 49 | -------------------------------------------------------------------------------- /src/ghcjs-specific/Foreign/MathJax.hs: -------------------------------------------------------------------------------- 1 | module Foreign.MathJax where 2 | 3 | import GHCJS.Types 4 | import Data.JSString 5 | 6 | foreign import javascript unsafe "MathJax.Hub.Queue(['Typeset', MathJax.Hub, $1]);" 7 | js_typeset :: JSString -> IO () 8 | 9 | typeset :: String -> IO () 10 | typeset = js_typeset . pack 11 | 12 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.3 2 | packages: 3 | - location: '.' 4 | - extra-dep: true 5 | location: 6 | git: https://github.com/transient-haskell/transient 7 | commit: f38fd2869b045564445edcc0fa3274490a750219 8 | - extra-dep: true 9 | location: 10 | git: https://github.com/transient-haskell/transient-universe 11 | commit: f5ce492ff31808e05dca85957f9ce6a1a48c7a62 12 | - extra-dep: true 13 | location: 14 | git: https://github.com/geraldus/ghcjs-perch 15 | commit: 6c238f6ab9624eb1e950059d602aaff35446476b 16 | - extra-dep: true 17 | location: 18 | git: https://github.com/transient-haskell/axiom 19 | commit: ee39119817ff05ed7385ced4c8c0e7ee0ed7f682 20 | 21 | extra-deps: 22 | - datetime-0.3.1 23 | 24 | flags: {} 25 | 26 | extra-package-dbs: [] 27 | -------------------------------------------------------------------------------- /static/out.jsexe/banner.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/theam/haskell-do/f339e57859d308437a72800bda08f96d0de12982/static/out.jsexe/banner.png -------------------------------------------------------------------------------- /static/out.jsexe/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/theam/haskell-do/f339e57859d308437a72800bda08f96d0de12982/static/out.jsexe/favicon.ico -------------------------------------------------------------------------------- /static/out.jsexe/index.html: -------------------------------------------------------------------------------- 1 | 16 | 17 | 18 | 19 | 20 | haskell.do 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 55 | 56 | 57 | 58 | 88 | 89 | 90 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {- 2 | - test\Spec.hs 3 | - Copyright (c) 2017 The Agile Monkeys S.L. 4 | - 5 | - Licensed under the Apache License, Version 2.0 (the "License"); 6 | - you may not use this file except in compliance with the License. 7 | - You may obtain a copy of the License at 8 | - 9 | - http://www.apache.org/licenses/LICENSE-2.0 10 | - 11 | - Unless required by applicable law or agreed to in writing, software 12 | - distributed under the License is distributed on an "AS IS" BASIS, 13 | - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14 | - See the License for the specific language governing permissions and 15 | - limitations under the License. 16 | -} 17 | module Main where 18 | 19 | main :: IO () 20 | main = putStrLn "TODO: Write tests" 21 | --------------------------------------------------------------------------------