├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── fly ├── Dockerfile ├── README.md └── fly.toml ├── package.yaml ├── src └── Lib.hs ├── stack.yaml ├── stack.yaml.lock ├── test └── Spec.hs └── tryhaskell.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | fly/tryhaskell 4 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for `tryhaskell` 2 | 3 | All notable changes to this project will be documented in this file. 4 | 5 | The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), 6 | and this project adheres to the 7 | [Haskell Package Versioning Policy](https://pvp.haskell.org/). 8 | 9 | ## Unreleased 10 | 11 | ## 0.1.0.0 - YYYY-MM-DD 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2023 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # tryhaskell 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Control.Monad 4 | import Network.Wai as Wai 5 | import Control.Exception.Safe 6 | import Network.HTTP.Types 7 | import Network.Wai.Handler.Warp (run) 8 | import Control.Concurrent.Async 9 | import Control.Concurrent 10 | import qualified Data.ByteString.Char8 as S8 11 | import System.IO 12 | import System.Timeout 13 | import Data.IORef 14 | import qualified Data.ByteString.Lazy as L 15 | import qualified Data.ByteString as S 16 | import Lucid hiding (for_) 17 | import Data.Foldable 18 | import Lucid.Base 19 | import Data.Text (Text) 20 | import qualified Data.Text as T 21 | import qualified Data.Text.Encoding as T 22 | 23 | -- Duet dependencies 24 | import qualified Control.Monad.Catch as Exceptions 25 | import Control.Monad.Logger 26 | import Control.Monad.Supply 27 | import Control.Monad.Writer 28 | import qualified Data.Map.Strict as M 29 | import Data.Semigroup ((<>)) 30 | import Duet.Context 31 | import Duet.Errors 32 | import Duet.Infer 33 | import Duet.Parser 34 | import Duet.Printer 35 | import Duet.Renamer 36 | import Duet.Setup 37 | import Duet.Simple 38 | import Duet.Stepper 39 | import Duet.Types 40 | import System.IO 41 | 42 | -------------------------------------------------------------------------------- 43 | -- Types 44 | 45 | data Run = Run 46 | { runInputCode :: Text 47 | , runMainIs :: String 48 | , runConcise :: Bool 49 | , runNumbered :: Bool 50 | , runSteps :: Maybe Integer 51 | , runHideSteps :: Bool 52 | } deriving (Show) 53 | 54 | -------------------------------------------------------------------------------- 55 | -- Main entry point 56 | 57 | main :: IO () 58 | main = do 59 | hSetBuffering stdout NoBuffering 60 | run 3000 app 61 | 62 | -------------------------------------------------------------------------------- 63 | -- Dispatcher 64 | 65 | app :: Application 66 | app request respond = 67 | case parseMethod (requestMethod request) of 68 | Right method -> 69 | case pathInfo request of 70 | [] -> 71 | case method of 72 | GET -> respond rootResponse 73 | _ -> respond invalidMethodResponse 74 | ["evaluator","reply"] -> 75 | case method of 76 | GET -> 77 | case queryString request of 78 | [("code", Just (T.decodeUtf8 -> code))] -> 79 | evaluatorResponse code reply_ >>= respond 80 | _ -> respond invalidArgumentResponse 81 | _ -> respond invalidMethodResponse 82 | ["evaluator","form"] -> 83 | case method of 84 | GET -> 85 | case queryString request of 86 | [("code", Just (T.decodeUtf8 -> code))] -> 87 | evaluatorResponse code evaluator_ >>= respond 88 | _ -> respond invalidArgumentResponse 89 | _ -> respond invalidMethodResponse 90 | _ -> respond pageNotFoundResponse 91 | _ -> respond invalidMethodResponse 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Generic HTTP responses 95 | 96 | invalidMethodResponse :: Response 97 | invalidMethodResponse = responseLBS status405 [("Content-Type","text/html; charset=utf-8")] $ 98 | renderBS $ 99 | doctypehtml_ do 100 | body_ do 101 | p_ "I don't support that method for that path." 102 | 103 | invalidArgumentResponse :: Response 104 | invalidArgumentResponse = responseLBS status400 [("Content-Type","text/html; charset=utf-8")] $ 105 | renderBS $ 106 | doctypehtml_ do 107 | body_ do 108 | p_ "Invalid arguments for this end-point." 109 | 110 | pageNotFoundResponse :: Response 111 | pageNotFoundResponse = responseLBS status404 [("Content-Type","text/html; charset=utf-8")] $ 112 | renderBS $ 113 | doctypehtml_ do 114 | body_ do 115 | p_ "No such path exists." 116 | 117 | -------------------------------------------------------------------------------- 118 | -- Business logic responses 119 | 120 | rootResponse :: Response 121 | rootResponse = responseLBS status200 [("Content-Type", "text/html; charset=utf-8")] $ 122 | renderBS $ 123 | doctypehtml_ do 124 | head_ do 125 | title_ "Try Haskell! An interactive tutorial in your browser" 126 | script_ [src_ "https://unpkg.com/htmx.org@1.9.2" 127 | ,integrity_ "sha384-L6OqL9pRWyyFU3+/bjdSri+iIphTN/bvYyM37tICVyOJkWZLpP2vGn6VUEXgzg6h", crossorigin_ "anonymous"] 128 | (mempty :: Text) 129 | script_ [src_ "https://unpkg.com/htmx.org/dist/ext/preload.js" 130 | ,crossorigin_ "anonymous"] 131 | (mempty :: Text) 132 | style_ ".evaluator-form {border-radius: 3px; border: 2px solid #eee; background: #f5f5f5; margin: 10px; display: inline-block;}" 133 | body_ [makeAttributes "hx-ext" "preload"] do 134 | intro_ 135 | evaluator_ Nothing 136 | 137 | evaluatorResponse :: Text -> (Maybe (Text, String) -> Html ()) -> IO Response 138 | evaluatorResponse input displayer = do 139 | output <- runProgram Run { 140 | runInputCode = input, 141 | runMainIs = "main", 142 | runConcise = True, 143 | runNumbered = False, 144 | runSteps = Just 100, 145 | runHideSteps = False 146 | } 147 | pure $ responseLBS status200 [("Content-Type", "text/html; charset=utf-8")] $ 148 | renderBS do 149 | displayer (Just (input, output)) 150 | 151 | -------------------------------------------------------------------------------- 152 | -- Htmx fragments 153 | 154 | intro_ :: Html () 155 | intro_ = do 156 | h1_ "Try Haskell" 157 | 158 | -- | The evaluator form. 159 | evaluator_ :: Maybe (Text, String) -> Html () 160 | evaluator_ minputOutput = 161 | form_ [class_ "evaluator-form"] do 162 | textarea_ [name_ "code", class_ "code"] (for_ minputOutput $ toHtml . fst) 163 | div_ [class_ "reply"] $ reply_ minputOutput 164 | button_ 165 | [makeAttributes "hx-include" "previous .code" 166 | ,makeAttributes "hx-get" "/evaluator/form" 167 | ,makeAttributes "hx-target" "closest form" 168 | ,makeAttributes "hx-swap" "afterend" 169 | ] 170 | "Clone" 171 | button_ 172 | [makeAttributes "hx-include" "previous .code" 173 | ,makeAttributes "hx-get" "/evaluator/reply" 174 | ,makeAttributes "hx-target" "previous .reply" 175 | ] 176 | "Run" 177 | 178 | -- | The reply from the evaluator. 179 | reply_ :: Maybe (Text, String) -> Html () 180 | reply_ minputOutput = for_ minputOutput $ pre_ . toHtml . snd 181 | 182 | -------------------------------------------------------------------------------- 183 | -- Code evaluation via Duet 184 | 185 | runProgram :: Run -> IO String 186 | runProgram run@Run {..} = do 187 | catchAny 188 | (runNoLoggingT 189 | (evalSupplyT 190 | (do decls <- liftIO (parseText "" runInputCode) 191 | (binds, ctx) <- createContext decls 192 | things <- 193 | execWriterT 194 | (runStepperIO 195 | run 196 | runSteps 197 | ctx 198 | (fmap (fmap typeSignatureA) binds) 199 | runMainIs) 200 | pure (concat things)) 201 | [1 ..])) 202 | (pure . show) 203 | 204 | -- | Run the substitution model on the code. 205 | runStepperIO :: 206 | forall m. (MonadSupply Int m, MonadThrow m, MonadIO m, MonadWriter [String] m) 207 | => Run 208 | -> Maybe Integer 209 | -> Context Type Name Location 210 | -> [BindGroup Type Name Location] 211 | -> String 212 | -> m () 213 | runStepperIO Run {..} maxSteps ctx bindGroups' i = do 214 | e0 <- lookupNameByString i bindGroups' 215 | loop 1 "" e0 216 | where 217 | loop :: Integer -> String -> Expression Type Name Location -> m () 218 | loop count lastString e = do 219 | e' <- expandSeq1 ctx bindGroups' e 220 | let string = printExpression (defaultPrint) e 221 | when 222 | (string /= lastString && not runHideSteps) 223 | (if cleanExpression e || not runConcise 224 | then 225 | (tell [ 226 | ((if runNumbered 227 | then "[" ++ show count ++ "]\n" 228 | else "\n") ++ 229 | printExpression defaultPrint e) ]) 230 | else pure ()) 231 | if (fmap (const ()) e' /= fmap (const ()) e) && 232 | case maxSteps of 233 | Just top -> count < top 234 | Nothing -> True 235 | then do 236 | newE <- 237 | renameExpression 238 | (contextSpecials ctx) 239 | (contextScope ctx) 240 | (contextDataTypes ctx) 241 | e' 242 | loop (count + 1) string newE 243 | else pure () 244 | 245 | -- | Filter out expressions with intermediate case, if and immediately-applied lambdas. 246 | cleanExpression :: Expression Type i l -> Bool 247 | cleanExpression = 248 | \case 249 | CaseExpression {} -> False 250 | IfExpression {} -> False 251 | e0 252 | | (LambdaExpression {}, args) <- fargs e0 -> null args 253 | ApplicationExpression _ f x -> cleanExpression f && cleanExpression x 254 | _ -> True 255 | -------------------------------------------------------------------------------- /fly/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ubuntu:20.04 2 | 3 | RUN apt-get update -y && apt-get install -y libtinfo-dev 4 | 5 | COPY fly/tryhaskell /bin/tryhaskell 6 | 7 | CMD ["/bin/tryhaskell"] 8 | -------------------------------------------------------------------------------- /fly/README.md: -------------------------------------------------------------------------------- 1 | Copy `tryhaskell` binary to `fly/`. 2 | 3 | cp $(stack exec which tryhaskell) fly/ 4 | 5 | From the git root directory, run: 6 | 7 | docker image build -f fly/Dockerfile . -t ghcr.io/chrisdone/tryhaskell 8 | -------------------------------------------------------------------------------- /fly/fly.toml: -------------------------------------------------------------------------------- 1 | # fly.toml app configuration file generated for tryhaskell on 2023-06-04T20:35:36+01:00 2 | # 3 | # See https://fly.io/docs/reference/configuration/ for information about how to use this file. 4 | # 5 | 6 | app = "tryhaskell" 7 | primary_region = "lhr" 8 | 9 | [http_service] 10 | internal_port = 3000 11 | force_https = true 12 | auto_stop_machines = true 13 | auto_start_machines = true 14 | min_machines_running = 0 15 | 16 | [build] 17 | image = "ghcr.io/chrisdone/tryhaskell@sha256:d968d8eb2a0f69099236c3fd9d088d14988b35e4a116f89169ca5296898bf757" 18 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: tryhaskell 2 | version: 0.1.0.0 3 | github: "githubuser/tryhaskell" 4 | license: BSD3 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2023 Author name here" 8 | 9 | default-extensions: 10 | - "OverloadedStrings" 11 | - "MultiWayIf" 12 | - "BlockArguments" 13 | - "ScopedTypeVariables" 14 | - "LambdaCase" 15 | - "RecordWildCards" 16 | - "FlexibleContexts" 17 | - "ViewPatterns" 18 | 19 | extra-source-files: 20 | - README.md 21 | - CHANGELOG.md 22 | 23 | # Metadata used when publishing your package 24 | # synopsis: Short description of your package 25 | # category: Web 26 | 27 | # To avoid duplicated efforts in documentation and dealing with the 28 | # complications of embedding Haddock markup inside cabal files, it is 29 | # common to point users to the README.md file. 30 | description: Please see the README on GitHub at 31 | 32 | dependencies: 33 | - base >= 4.7 && < 5 34 | - duet 35 | - warp 36 | - wai 37 | - mtl 38 | - monad-logger 39 | - exceptions 40 | - bytestring 41 | - text 42 | - lucid2 43 | - http-types 44 | - safe-exceptions 45 | - unliftio 46 | - async 47 | - containers 48 | - unordered-containers 49 | - stm 50 | 51 | ghc-options: 52 | - -Wall 53 | - -Wcompat 54 | - -Widentities 55 | - -Wincomplete-record-updates 56 | - -Wincomplete-uni-patterns 57 | - -Wmissing-export-lists 58 | - -Wmissing-home-modules 59 | - -Wpartial-fields 60 | - -Wredundant-constraints 61 | 62 | library: 63 | source-dirs: src 64 | 65 | executables: 66 | tryhaskell: 67 | main: Main.hs 68 | source-dirs: app 69 | ghc-options: 70 | - -threaded 71 | - -rtsopts 72 | - -with-rtsopts=-N 73 | dependencies: 74 | - tryhaskell 75 | 76 | tests: 77 | tryhaskell-test: 78 | main: Spec.hs 79 | source-dirs: test 80 | ghc-options: 81 | - -threaded 82 | - -rtsopts 83 | - -with-rtsopts=-N 84 | dependencies: 85 | - tryhaskell 86 | -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.20 2 | extra-deps: 3 | - ../duet 4 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 126fa33ceb11f5e85ceb4e86d434756bd9a8439e2e5776d306a15fbc63b01e89 10 | size: 650041 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/20.yaml 12 | original: lts-20.20 13 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /tryhaskell.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: tryhaskell 8 | version: 0.1.0.0 9 | description: Please see the README on GitHub at 10 | homepage: https://github.com/githubuser/tryhaskell#readme 11 | bug-reports: https://github.com/githubuser/tryhaskell/issues 12 | author: Author name here 13 | maintainer: example@example.com 14 | copyright: 2023 Author name here 15 | license: BSD3 16 | license-file: LICENSE 17 | build-type: Simple 18 | extra-source-files: 19 | README.md 20 | CHANGELOG.md 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/githubuser/tryhaskell 25 | 26 | library 27 | exposed-modules: 28 | Lib 29 | other-modules: 30 | Paths_tryhaskell 31 | hs-source-dirs: 32 | src 33 | default-extensions: 34 | OverloadedStrings 35 | MultiWayIf 36 | BlockArguments 37 | ScopedTypeVariables 38 | LambdaCase 39 | RecordWildCards 40 | FlexibleContexts 41 | ViewPatterns 42 | ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints 43 | build-depends: 44 | async 45 | , base >=4.7 && <5 46 | , bytestring 47 | , containers 48 | , duet 49 | , exceptions 50 | , http-types 51 | , lucid2 52 | , monad-logger 53 | , mtl 54 | , safe-exceptions 55 | , stm 56 | , text 57 | , unliftio 58 | , unordered-containers 59 | , wai 60 | , warp 61 | default-language: Haskell2010 62 | 63 | executable tryhaskell 64 | main-is: Main.hs 65 | other-modules: 66 | Paths_tryhaskell 67 | hs-source-dirs: 68 | app 69 | default-extensions: 70 | OverloadedStrings 71 | MultiWayIf 72 | BlockArguments 73 | ScopedTypeVariables 74 | LambdaCase 75 | RecordWildCards 76 | FlexibleContexts 77 | ViewPatterns 78 | ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N 79 | build-depends: 80 | async 81 | , base >=4.7 && <5 82 | , bytestring 83 | , containers 84 | , duet 85 | , exceptions 86 | , http-types 87 | , lucid2 88 | , monad-logger 89 | , mtl 90 | , safe-exceptions 91 | , stm 92 | , text 93 | , tryhaskell 94 | , unliftio 95 | , unordered-containers 96 | , wai 97 | , warp 98 | default-language: Haskell2010 99 | 100 | test-suite tryhaskell-test 101 | type: exitcode-stdio-1.0 102 | main-is: Spec.hs 103 | other-modules: 104 | Paths_tryhaskell 105 | hs-source-dirs: 106 | test 107 | default-extensions: 108 | OverloadedStrings 109 | MultiWayIf 110 | BlockArguments 111 | ScopedTypeVariables 112 | LambdaCase 113 | RecordWildCards 114 | FlexibleContexts 115 | ViewPatterns 116 | ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N 117 | build-depends: 118 | async 119 | , base >=4.7 && <5 120 | , bytestring 121 | , containers 122 | , duet 123 | , exceptions 124 | , http-types 125 | , lucid2 126 | , monad-logger 127 | , mtl 128 | , safe-exceptions 129 | , stm 130 | , text 131 | , tryhaskell 132 | , unliftio 133 | , unordered-containers 134 | , wai 135 | , warp 136 | default-language: Haskell2010 137 | --------------------------------------------------------------------------------