├── backend
├── .gitignore
├── Setup.hs
├── app
│ └── Main.hs
├── test
│ ├── Spec.hs
│ └── Backend
│ │ ├── Test
│ │ └── Prelude.hs
│ │ └── ApiSpec.hs
├── .dockerignore
├── .env.test
├── hie.yaml
├── db
│ ├── migrations
│ │ ├── 2021-10-21_15-13-41_add_unique_snapshot_index.txt
│ │ └── 2021-10-18_07-40-31_add-snapshots-table.txt
│ ├── boot
│ ├── check
│ ├── draft
│ └── upgrade
├── src
│ └── Backend
│ │ ├── Signature.hs
│ │ ├── Api.hs
│ │ ├── Main.hs
│ │ ├── Envelope.hs
│ │ ├── Name.hs
│ │ ├── Env.hs
│ │ ├── Random.hs
│ │ ├── Wai.hs
│ │ ├── Prelude.hs
│ │ ├── Middleware.hs
│ │ ├── Database.hs
│ │ ├── Settings.hs
│ │ ├── Snapshot.hs
│ │ ├── Code.hs
│ │ └── Micro.hs
├── stack.yaml
├── Dockerfile
├── stack.yaml.lock
├── brittany.yaml
├── package.yaml
└── backend.cabal
├── frontend
├── static
│ ├── CNAME
│ ├── images
│ │ ├── favicon.ico
│ │ ├── favicon-16x16.png
│ │ ├── favicon-32x32.png
│ │ ├── lambda-machine.png
│ │ ├── apple-touch-icon.png
│ │ ├── android-chrome-192x192.png
│ │ ├── android-chrome-512x512.png
│ │ └── about.txt
│ ├── fonts
│ │ ├── glyphicons-halflings-regular.eot
│ │ ├── glyphicons-halflings-regular.ttf
│ │ ├── glyphicons-halflings-regular.woff
│ │ └── glyphicons-halflings-regular.woff2
│ └── css
│ │ └── styles.css
├── index.js
├── .env
├── .env.production
├── src
│ ├── Lambda
│ │ ├── Env.js
│ │ ├── Env.purs
│ │ ├── Language
│ │ │ ├── Program.purs
│ │ │ ├── Snapshot
│ │ │ │ ├── Code.purs
│ │ │ │ ├── Signature.purs
│ │ │ │ ├── Tag.purs
│ │ │ │ ├── Error.purs
│ │ │ │ └── RPN.purs
│ │ │ ├── Statement.purs
│ │ │ ├── History.purs
│ │ │ ├── Prelude.purs
│ │ │ ├── Definition.purs
│ │ │ ├── Pretty.purs
│ │ │ ├── Parser.purs
│ │ │ ├── Nameless.purs
│ │ │ ├── Name.purs
│ │ │ ├── World.purs
│ │ │ └── Snapshot.purs
│ │ ├── Machine
│ │ │ ├── Address.purs
│ │ │ ├── Globals.purs
│ │ │ ├── Stash.purs
│ │ │ ├── Stack.purs
│ │ │ ├── Heap.purs
│ │ │ └── Node.purs
│ │ ├── Flags.purs
│ │ ├── Api.purs
│ │ └── Prelude.purs
│ ├── React
│ │ ├── Portal.js
│ │ └── Portal.purs
│ ├── Components
│ │ ├── App
│ │ │ ├── Request.purs
│ │ │ ├── Response.purs
│ │ │ ├── Action.purs
│ │ │ └── Alert.purs
│ │ ├── Footer.purs
│ │ ├── Level.purs
│ │ ├── ParseError.purs
│ │ ├── Spinner.purs
│ │ ├── Alert.purs
│ │ ├── Overlay.purs
│ │ ├── Expressions.purs
│ │ ├── Definitions.purs
│ │ ├── ConsistencyError.purs
│ │ ├── Modal.purs
│ │ ├── Input.purs
│ │ ├── ApiError.purs
│ │ ├── Controls.purs
│ │ ├── Markup.purs
│ │ ├── Copy.purs
│ │ └── App.purs
│ ├── Effect
│ │ ├── DOM.purs
│ │ ├── Copy.purs
│ │ ├── QueryParams.js
│ │ ├── Save.js
│ │ ├── Copy.js
│ │ ├── QueryParams.purs
│ │ ├── Save.purs
│ │ └── DOM.js
│ ├── Main.purs
│ └── Data
│ │ ├── Grammar.purs
│ │ └── Queue.purs
├── test
│ ├── Main.purs
│ ├── Data
│ │ ├── QueueSpec.purs
│ │ └── GrammarSpec.purs
│ ├── Lambda
│ │ ├── Language
│ │ │ ├── Snapshot
│ │ │ │ └── RPNSpec.purs
│ │ │ ├── ExpressionSpec.purs
│ │ │ ├── NamelessSpec.purs
│ │ │ ├── SnapshotSpec.purs
│ │ │ └── WorldSpec.purs
│ │ └── MachineSpec.purs
│ └── Prelude.purs
├── site.webmanifest
├── index.html
├── .deploy.sh
├── spago.dhall
├── package.json
└── packages.dhall
├── .gitignore
├── LICENSE
├── CODE_OF_CONDUCT.md
├── .github
└── workflows
│ └── ci.yml
└── README.md
/backend/.gitignore:
--------------------------------------------------------------------------------
1 | .stack-work/
2 | *~
--------------------------------------------------------------------------------
/frontend/static/CNAME:
--------------------------------------------------------------------------------
1 | lambda-machine.com
2 |
--------------------------------------------------------------------------------
/frontend/index.js:
--------------------------------------------------------------------------------
1 | require('./output/Main').main();
2 |
--------------------------------------------------------------------------------
/backend/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/backend/app/Main.hs:
--------------------------------------------------------------------------------
1 | module Main (main) where
2 |
3 | import Backend.Main (main)
4 |
--------------------------------------------------------------------------------
/frontend/.env:
--------------------------------------------------------------------------------
1 | API=http://api.localhost.com:3000
2 | HOST=http://localhost.com:1234
3 |
--------------------------------------------------------------------------------
/frontend/.env.production:
--------------------------------------------------------------------------------
1 | API=https://api.lambda-machine.com
2 | HOST=https://lambda-machine.com
3 |
--------------------------------------------------------------------------------
/backend/test/Spec.hs:
--------------------------------------------------------------------------------
1 | {-# OPTIONS_GHC -Wno-missing-export-lists #-}
2 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-}
3 |
--------------------------------------------------------------------------------
/backend/.dockerignore:
--------------------------------------------------------------------------------
1 | *.cabal
2 | .dockerignore
3 | .env*
4 | .gitignore
5 | .stack-work
6 | Dockerfile
7 | db
8 | test
9 |
--------------------------------------------------------------------------------
/frontend/static/images/favicon.ico:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/cdparks/lambda-machine/HEAD/frontend/static/images/favicon.ico
--------------------------------------------------------------------------------
/frontend/static/images/favicon-16x16.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/cdparks/lambda-machine/HEAD/frontend/static/images/favicon-16x16.png
--------------------------------------------------------------------------------
/frontend/static/images/favicon-32x32.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/cdparks/lambda-machine/HEAD/frontend/static/images/favicon-32x32.png
--------------------------------------------------------------------------------
/frontend/static/images/lambda-machine.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/cdparks/lambda-machine/HEAD/frontend/static/images/lambda-machine.png
--------------------------------------------------------------------------------
/backend/.env.test:
--------------------------------------------------------------------------------
1 | ROOT=x
2 | ORIGIN=x
3 | PORT=3000
4 | LOG_LEVEL=LevelInfo
5 | DATABASE_URL=postgres://postgres:password@localhost/lambda_test
6 |
--------------------------------------------------------------------------------
/frontend/static/images/apple-touch-icon.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/cdparks/lambda-machine/HEAD/frontend/static/images/apple-touch-icon.png
--------------------------------------------------------------------------------
/frontend/static/images/android-chrome-192x192.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/cdparks/lambda-machine/HEAD/frontend/static/images/android-chrome-192x192.png
--------------------------------------------------------------------------------
/frontend/static/images/android-chrome-512x512.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/cdparks/lambda-machine/HEAD/frontend/static/images/android-chrome-512x512.png
--------------------------------------------------------------------------------
/frontend/static/fonts/glyphicons-halflings-regular.eot:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/cdparks/lambda-machine/HEAD/frontend/static/fonts/glyphicons-halflings-regular.eot
--------------------------------------------------------------------------------
/frontend/static/fonts/glyphicons-halflings-regular.ttf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/cdparks/lambda-machine/HEAD/frontend/static/fonts/glyphicons-halflings-regular.ttf
--------------------------------------------------------------------------------
/frontend/static/fonts/glyphicons-halflings-regular.woff:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/cdparks/lambda-machine/HEAD/frontend/static/fonts/glyphicons-halflings-regular.woff
--------------------------------------------------------------------------------
/frontend/static/fonts/glyphicons-halflings-regular.woff2:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/cdparks/lambda-machine/HEAD/frontend/static/fonts/glyphicons-halflings-regular.woff2
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | .cache
2 | .parcel-cache
3 | .psa-stash
4 | .psci_modules
5 | .psc-package
6 | .purs-repl
7 | .spago
8 | dist
9 | node_modules
10 | output
11 | yarn-error.log
12 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Env.js:
--------------------------------------------------------------------------------
1 | // module Lambda.Env
2 | "use strict"
3 |
4 | exports.api = process.env.API || "https://api.lambda-machine.com"
5 | exports.host = process.env.HOST || "https://lambda-machine.com"
6 |
--------------------------------------------------------------------------------
/frontend/src/React/Portal.js:
--------------------------------------------------------------------------------
1 | // module React.Portal
2 | "use strict"
3 |
4 | exports.createPortal = function(jsx) {
5 | return function(element) {
6 | return require('react-dom').createPortal(jsx, element)
7 | }
8 | }
9 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Env.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Env
2 | ( api
3 | , host
4 | ) where
5 |
6 | -- | Get api url from environment or default to the real thing
7 | foreign import api :: String
8 |
9 | -- | Get app host from environment or default to the real thing
10 | foreign import host :: String
11 |
--------------------------------------------------------------------------------
/backend/hie.yaml:
--------------------------------------------------------------------------------
1 | cradle:
2 | stack:
3 | - path: "./src"
4 | component: "backend:lib"
5 |
6 | - path: "./app/Main.hs"
7 | component: "backend:exe:serve"
8 |
9 | - path: "./app/Paths_backend.hs"
10 | component: "backend:exe:serve"
11 |
12 | - path: "./test"
13 | component: "backend:test:spec"
14 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Program.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Program
2 | ( Program
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Lambda.Language.Definition (Definition)
8 | import Lambda.Language.Expression (Expression)
9 |
10 | type Program =
11 | { defs :: Array Definition
12 | , expr :: Maybe Expression
13 | }
14 |
--------------------------------------------------------------------------------
/frontend/src/Components/App/Request.purs:
--------------------------------------------------------------------------------
1 | module Components.App.Request
2 | ( Request(..)
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Lambda.Language.Snapshot.Code (Code)
8 |
9 | -- | Actions that must be performed asynchronously
10 | data Request
11 | = Fetch Code
12 | | Store
13 | | Save
14 |
15 | derive instance eqRequest :: Eq Request
16 |
--------------------------------------------------------------------------------
/frontend/static/images/about.txt:
--------------------------------------------------------------------------------
1 | This favicon was generated using the following font:
2 |
3 | - Font Title: Source Code Pro
4 | - Font Author: Copyright 2010, 2012 Adobe Systems Incorporated. All Rights Reserved.
5 | - Font Source: http://fonts.gstatic.com/s/sourcecodepro/v14/HI_SiYsKILxRpg3hIP6sJ7fM7PqVOuHXvMY3xw.ttf
6 | - Font License: SIL Open Font License, 1.1 (http://scripts.sil.org/OFL)
7 |
--------------------------------------------------------------------------------
/frontend/test/Main.purs:
--------------------------------------------------------------------------------
1 | module Test.Main
2 | ( main
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Effect.Aff (launchAff_)
8 | import Test.Spec.Discovery (discover)
9 | import Test.Spec.Reporter.Console (consoleReporter)
10 | import Test.Spec.Runner (runSpec)
11 |
12 | main :: Effect Unit
13 | main = launchAff_ do
14 | specs <- discover "\\..*Spec"
15 | runSpec [consoleReporter] specs
16 |
--------------------------------------------------------------------------------
/backend/db/migrations/2021-10-21_15-13-41_add_unique_snapshot_index.txt:
--------------------------------------------------------------------------------
1 | # vim: ft=yaml
2 | Description: |
3 | Add unique index to hopefully avoid some duplication. We only ever
4 | need equality, so default btree indexes should be fine, even on jsonb
5 | Created: 2021-10-21 15:13:41.083509 UTC
6 | Depends: 2021-10-18_07-40-31_add-snapshots-table
7 | Apply: |
8 | CREATE UNIQUE INDEX ON snapshots (signature, names, state);
9 |
--------------------------------------------------------------------------------
/frontend/src/Components/Footer.purs:
--------------------------------------------------------------------------------
1 | module Components.Footer
2 | ( component
3 | ) where
4 |
5 | import React.Basic (JSX, fragment)
6 | import React.Basic.DOM as R
7 |
8 | component :: {} -> JSX
9 | component _ = fragment
10 | [ R.hr {}
11 | , R.a
12 | { className: "pull-right"
13 | , href: "https://github.com/cdparks/lambda-machine"
14 | , children: [R.text "Source on GitHub"]
15 | }
16 | ]
17 |
--------------------------------------------------------------------------------
/frontend/src/Components/App/Response.purs:
--------------------------------------------------------------------------------
1 | module Components.App.Response
2 | ( Response(..)
3 | ) where
4 |
5 | import Lambda.Api as Api
6 | import Lambda.Language.Program (Program)
7 | import Lambda.Language.Snapshot.Code (Code)
8 |
9 | -- | Result of handling an asynchronous request
10 | data Response
11 | = Fetched Program
12 | | Stored Code
13 | | Saved
14 | | ApiError Api.Error
15 | | SaveError String
16 |
--------------------------------------------------------------------------------
/frontend/src/Effect/DOM.purs:
--------------------------------------------------------------------------------
1 | module Effect.DOM
2 | ( getBody
3 | , getRoot
4 | , getPortal
5 | ) where
6 |
7 | import Lambda.Prelude
8 |
9 | import Web.DOM.Element (Element)
10 |
11 | -- | Get document.body or throw
12 | foreign import getBody :: Effect Element
13 |
14 | -- | Get element with id "app" or throw
15 | foreign import getRoot :: Effect Element
16 |
17 | -- | Get element with id "portal" or throw
18 | foreign import getPortal :: Effect Element
19 |
--------------------------------------------------------------------------------
/frontend/src/Components/App/Action.purs:
--------------------------------------------------------------------------------
1 | module Components.App.Action
2 | ( Action(..)
3 | ) where
4 |
5 | import Components.App.Request (Request)
6 | import Components.App.Response (Response)
7 | import Lambda.Language.Name (Name)
8 |
9 | -- | Set of user-driven events
10 | data Action
11 | = Help
12 | | Dismiss
13 | | Update String
14 | | Parse
15 | | Delete Name
16 | | Step
17 | | Clear
18 | | Toggle
19 | | Enqueue Request
20 | | Examine Response
21 |
--------------------------------------------------------------------------------
/backend/db/boot:
--------------------------------------------------------------------------------
1 | #!/bin/sh
2 | # Create local DB if it doesn't already exist
3 |
4 | if [ -z "$1" ]; then
5 | echo 'usage: db/boot name'
6 | exit 2
7 | fi
8 |
9 | tmp=$(mktemp)
10 | trap 'rm -f -- "$tmp"' EXIT
11 | createdb -O postgres --encoding UTF8 "$1" > "$tmp" 2>&1
12 | result=$?
13 |
14 | if [ "$result" -ne 0 ] && grep -Fq 'already exists' "$tmp"; then
15 | echo "Skipping, database $1 already exists"
16 | exit 0
17 | fi
18 |
19 | cat "$tmp"
20 | exit "$result"
21 |
--------------------------------------------------------------------------------
/frontend/src/Effect/Copy.purs:
--------------------------------------------------------------------------------
1 | module Effect.Copy
2 | ( copy
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Effect.Aff.Compat (fromEffectFnAff, EffectFnAff)
8 |
9 | copy :: String -> Aff (Either String Unit)
10 | copy = fromEffectFnAff <<< copyImpl Left Right
11 |
12 | -- | Async navigator.clipboard.writeText
13 | foreign import copyImpl
14 | :: (String -> Either String Unit)
15 | -> (Unit -> Either String Unit)
16 | -> String
17 | -> EffectFnAff (Either String Unit)
18 |
--------------------------------------------------------------------------------
/frontend/src/Components/Level.purs:
--------------------------------------------------------------------------------
1 | module Components.Level
2 | ( Level(..)
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | -- | Bootstrap theme color suffixes
8 | data Level
9 | = Default
10 | | Primary
11 | | Success
12 | | Info
13 | | Warning
14 | | Danger
15 |
16 | instance showLevel :: Show Level where
17 | show Default = "default"
18 | show Primary = "primary"
19 | show Success = "success"
20 | show Info = "info"
21 | show Warning = "warning"
22 | show Danger = "danger"
23 |
--------------------------------------------------------------------------------
/frontend/src/Main.purs:
--------------------------------------------------------------------------------
1 | module Main
2 | ( main
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Components.App as App
8 | import Effect.DOM as DOM
9 | import Effect.QueryParams as QueryParams
10 | import Lambda.Flags as Flags
11 | import React.Basic.DOM (render)
12 |
13 | main :: Effect Unit
14 | main = do
15 | app <- App.new
16 | code <- QueryParams.get "code"
17 | flags <- fromMaybe Flags.none <$> QueryParams.getWith Flags.parse "f"
18 | let node = app { code, flags }
19 | render node =<< DOM.getRoot
20 |
--------------------------------------------------------------------------------
/backend/db/migrations/2021-10-18_07-40-31_add-snapshots-table.txt:
--------------------------------------------------------------------------------
1 | # vim: ft=yaml
2 | Description: add snapshots table
3 | Created: 2021-10-18 07:40:32.791827 UTC
4 | Depends:
5 | Apply: |
6 | CREATE TABLE snapshots (
7 | id text not null primary key,
8 | created_at timestamptz not null default now(),
9 | signature integer not null default 0,
10 | names jsonb not null default '[]',
11 | state jsonb not null default '[]'
12 | );
13 | CREATE INDEX ON snapshots (created_at);
14 | Revert: |
15 | DROP TABLE snapshots;
16 |
--------------------------------------------------------------------------------
/frontend/site.webmanifest:
--------------------------------------------------------------------------------
1 | {
2 | "name": "",
3 | "short_name": "",
4 | "icons": [
5 | {
6 | "src": "/static/images/android-chrome-192x192.png",
7 | "sizes": "192x192",
8 | "type": "image/png"
9 | },
10 | {
11 | "src": "/static/images/android-chrome-512x512.png",
12 | "sizes": "512x512",
13 | "type": "image/png"
14 | }
15 | ],
16 | "theme_color": "#ffffff",
17 | "background_color": "#ffffff",
18 | "display": "standalone",
19 | "permissions": [
20 | "clipboardWrite"
21 | ]
22 | }
23 |
--------------------------------------------------------------------------------
/frontend/src/Effect/QueryParams.js:
--------------------------------------------------------------------------------
1 | // module Effect.QueryParams
2 | "use strict"
3 |
4 | require('url-search-params-polyfill');
5 |
6 | exports.getParamImpl = function(Nothing) {
7 | return function(parse) {
8 | return function(name) {
9 | return function() {
10 | var params = new URLSearchParams(window.location.search)
11 | var value = params.get(name)
12 | if (value === null || value === undefined) {
13 | return Nothing
14 | }
15 | return parse(value)
16 | }
17 | }
18 | }
19 | }
20 |
--------------------------------------------------------------------------------
/backend/src/Backend/Signature.hs:
--------------------------------------------------------------------------------
1 | module Backend.Signature
2 | ( Signature(..)
3 | ) where
4 |
5 | import Backend.Prelude
6 |
7 | -- | Bitset indiciating which Prelude definitions are used in a session
8 | --
9 | -- For example, 3 => 0x3 => 0b11 means that the first two Prelude
10 | -- definitions are used. Prelude currently only has 22 definitions,
11 | -- so we can use an 'Int32' here and integer in Postgres.
12 | --
13 | newtype Signature = Signature Int32
14 | deriving newtype (Eq, Show, Ord, Hashable, FromJSON, ToJSON, PersistField, PersistFieldSql, Default)
15 |
--------------------------------------------------------------------------------
/frontend/src/Effect/Save.js:
--------------------------------------------------------------------------------
1 | // module Effect.Save
2 | "use strict"
3 |
4 | exports.saveImpl = function(Left) {
5 | return function(Right) {
6 | return function(text) {
7 | return function(filename) {
8 | return function() {
9 | var blob = new Blob([text], {type: 'text/plain;charset=utf-8'})
10 | try {
11 | require('file-saver').saveAs(blob, filename)
12 | return Right({})
13 | } catch (e) {
14 | return Left(e.toString())
15 | }
16 | }
17 | }
18 | }
19 | }
20 | }
21 |
--------------------------------------------------------------------------------
/frontend/src/Components/App/Alert.purs:
--------------------------------------------------------------------------------
1 | module Components.App.Alert
2 | ( Alert(..)
3 | , Error(..)
4 | ) where
5 |
6 | import Lambda.Api as Api
7 | import Lambda.Language.Parser (ParseError)
8 | import Lambda.Language.Snapshot.Code (Code)
9 | import Lambda.Language.World (ConsistencyError)
10 |
11 | -- | Interrupt the main view
12 | data Alert
13 | = Help
14 | | Link Code
15 | | Error Error
16 |
17 | -- | Error messages
18 | data Error
19 | = ApiError Api.Error
20 | | SaveError String
21 | | ParseError String ParseError
22 | | Inconsistent ConsistencyError
23 |
--------------------------------------------------------------------------------
/backend/db/check:
--------------------------------------------------------------------------------
1 | #!/bin/sh
2 | # Fail if there are any migrations that haven't been run in prod yet
3 | set -e
4 |
5 | DBM_DATABASE=$(heroku config:get DATABASE_URL --app lambda-machine)
6 | DBM_MIGRATION_STORE=$(cd "$(dirname "$0")" && pwd)/migrations
7 |
8 | export DBM_DATABASE
9 | export DBM_MIGRATION_STORE
10 | export DBM_LINEAR_MIGRATIONS=on
11 | export DBM_TIMESTAMP_FILENAMES=on
12 |
13 | tmp=$(mktemp)
14 | trap 'rm -f -- "$tmp"' EXIT
15 | exec stack exec -- moo-postgresql upgrade-list 2>&1 | tee "$tmp"
16 |
17 | if ! grep -Fqx 'Database is up to date.' "$tmp"; then
18 | exit 1
19 | fi
20 |
--------------------------------------------------------------------------------
/backend/src/Backend/Api.hs:
--------------------------------------------------------------------------------
1 | module Backend.Api
2 | ( api
3 | ) where
4 |
5 | import Backend.Prelude
6 |
7 | import Backend.Database (HasSqlPool, runDB)
8 | import Backend.Envelope (Envelope(..))
9 | import Backend.Micro ((//), get, param, post, root, run)
10 | import Backend.Random (HasRandom)
11 | import qualified Backend.Snapshot as Snapshot
12 |
13 | -- | Generate WAI 'Application'
14 | api :: (HasSqlPool env, HasRandom env) => RIO env Application
15 | api = run $ do
16 | get root $ pure $ object []
17 | post "snapshots" $ fmap (Envelope @"code") . Snapshot.store
18 | get ("snapshots" // param) $ runDB . Snapshot.fetch
19 |
--------------------------------------------------------------------------------
/frontend/src/Effect/Copy.js:
--------------------------------------------------------------------------------
1 | // module Effect.Copy
2 | "use strict"
3 |
4 | var clipboard = require("clipboard-polyfill/text")
5 |
6 | exports.copyImpl = function(Left) {
7 | return function(Right) {
8 | return function(text) {
9 | return function(error, success) {
10 | clipboard.writeText(text).then(function() {
11 | success(Right({}))
12 | }, function(err) {
13 | error(Left('clipboard.writeText failed: ' + err.toString()))
14 | })
15 |
16 | return function(_cancel, _cancelError, cancelSuccess) {
17 | cancelSuccess()
18 | }
19 | }
20 | }
21 | }
22 | }
23 |
--------------------------------------------------------------------------------
/backend/src/Backend/Main.hs:
--------------------------------------------------------------------------------
1 | module Backend.Main
2 | ( main
3 | ) where
4 |
5 | import Backend.Prelude
6 |
7 | import Backend.Api (api)
8 | import Backend.Env (Env(..))
9 | import qualified Backend.Env as Env
10 | import Backend.Middleware (middleware)
11 | import Backend.Settings (Settings(..))
12 | import qualified Backend.Settings as Settings
13 | import qualified Network.Wai.Handler.Warp as Warp
14 |
15 | main :: IO ()
16 | main = do
17 | settings <- Settings.load
18 | env <- Env.new settings
19 | app <- runRIO env $ do
20 | logDebug $ "running with " <> display settings
21 | middleware settings <$> api
22 | Warp.run (port settings) app `finally` shutdown env
23 |
--------------------------------------------------------------------------------
/frontend/src/Effect/QueryParams.purs:
--------------------------------------------------------------------------------
1 | module Effect.QueryParams
2 | ( get
3 | , getWith
4 | ) where
5 |
6 | import Lambda.Prelude
7 |
8 | import Lambda.Language.Parser (class Parse, parse, run)
9 |
10 | -- | Attempt to parse value from query string
11 | get :: forall a. Parse a => String -> Effect (Maybe a)
12 | get = getWith $ hush <<< run parse
13 |
14 | -- | Attempt to parse value from query string given a parser
15 | getWith :: forall a. (String -> Maybe a) -> String -> Effect (Maybe a)
16 | getWith = getParamImpl Nothing
17 |
18 | foreign import getParamImpl
19 | :: forall a
20 | . Maybe a
21 | -> (String -> Maybe a)
22 | -> String
23 | -> Effect (Maybe a)
24 |
--------------------------------------------------------------------------------
/frontend/src/Components/ParseError.purs:
--------------------------------------------------------------------------------
1 | module Components.ParseError
2 | ( component
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Lambda.Language.Parser (ParseError, formatParseError)
8 | import React.Basic (JSX, fragment)
9 | import React.Basic.DOM as R
10 |
11 | type Props =
12 | { input :: String
13 | , error :: ParseError
14 | }
15 |
16 | component :: Props -> JSX
17 | component { input, error } = fragment
18 | [ R.p_ [R.text message]
19 | , R.p
20 | { className: "preformatted"
21 | , children:
22 | [ R.text $ source <> "\n" <> caret
23 | ]
24 | }
25 | ]
26 | where
27 | {message, source, caret} = formatParseError input error
28 |
--------------------------------------------------------------------------------
/frontend/src/Effect/Save.purs:
--------------------------------------------------------------------------------
1 | module Effect.Save
2 | ( save
3 | , Filename(..)
4 | ) where
5 |
6 | import Lambda.Prelude
7 |
8 | newtype Filename = Filename String
9 |
10 | derive instance newtypeFilename :: Newtype Filename _
11 | derive newtype instance eqFilename :: Eq Filename
12 | derive newtype instance showFilename :: Show Filename
13 |
14 | save :: { text :: String, to :: Filename } -> Effect (Either String Unit)
15 | save { text, to: Filename filename } = saveImpl Left Right text filename
16 |
17 | -- | Save text to file
18 | foreign import saveImpl
19 | :: (String -> Either String Unit)
20 | -> (Unit -> Either String Unit)
21 | -> String
22 | -> String
23 | -> Effect (Either String Unit)
24 |
--------------------------------------------------------------------------------
/frontend/src/Components/Spinner.purs:
--------------------------------------------------------------------------------
1 | module Components.Spinner
2 | ( new
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Components.Overlay as Overlay
8 | import React.Basic.DOM as R
9 | import React.Basic.Hooks (Component, component)
10 |
11 | new :: Component {}
12 | new = do
13 | overlay <- Overlay.new
14 | component "Spinner" \_ ->
15 | pure $ overlay
16 | { dismiss: Nothing
17 | , children:
18 | [ R.div
19 | { className: "spinner"
20 | , children:
21 | [ R.span
22 | { className: "glyphicon glyphicon-refresh spin"
23 | , children: []
24 | }
25 | ]
26 | }
27 | ]
28 | }
29 |
--------------------------------------------------------------------------------
/frontend/src/Effect/DOM.js:
--------------------------------------------------------------------------------
1 | // module Effect.DOM
2 | "use strict"
3 |
4 | exports.getBody = function() {
5 | return assertDefined(
6 | window.document.body,
7 | 'window.document.body'
8 | )
9 | }
10 |
11 | exports.getRoot = function() {
12 | return assertDefined(
13 | window.document.getElementById('root'),
14 | 'root container element'
15 | )
16 | }
17 |
18 | exports.getPortal = function() {
19 | return assertDefined(
20 | window.document.getElementById('portal'),
21 | 'portal container element'
22 | )
23 | }
24 |
25 | function assertDefined(value, name) {
26 | if (value === null || value === undefined) {
27 | throw new Error(name + ' not defined')
28 | }
29 | return value
30 | }
31 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Machine/Address.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Machine.Address
2 | ( Address
3 | , offset
4 | , baseptr
5 | , nullptr
6 | ) where
7 |
8 | import Lambda.Prelude
9 |
10 | -- | Heap address for nodes in a graph
11 | newtype Address = Address Int
12 |
13 | derive newtype instance eqAddress :: Eq Address
14 | derive newtype instance hashableAddress :: Hashable Address
15 | derive newtype instance ordAddress :: Ord Address
16 |
17 | instance showAddress :: Show Address where
18 | show (Address i) = "#" <> show i
19 |
20 | offset :: Int -> Address -> Address
21 | offset i address = Address $ coerce address + i
22 |
23 | baseptr :: Address
24 | baseptr = coerce 1
25 |
26 | nullptr :: Address
27 | nullptr = coerce 0
28 |
--------------------------------------------------------------------------------
/backend/db/draft:
--------------------------------------------------------------------------------
1 | #!/bin/sh
2 | # Create and open new migration in editor
3 | set -e
4 |
5 | if [ -z "$1" ]; then
6 | echo 'usage: db/draft name'
7 | exit 2
8 | fi
9 |
10 | DBM_MIGRATION_STORE=$(cd "$(dirname "$0")" && pwd)/migrations
11 | DBM_DATABASE=postgres://postgres:password@localhost:5432/lambda
12 |
13 | export DBM_MIGRATION_STORE
14 | export DBM_DATABASE
15 | export DBM_LINEAR_MIGRATIONS=on
16 | export DBM_TIMESTAMP_FILENAMES=on
17 |
18 | path=$(yes | stack exec -- moo-postgresql new "$1" | grep -o '".*"' | sed 's/"//g')
19 |
20 | # Break up modeline so this script doesn't confuse vim
21 | tmp=$(mktemp)
22 | trap 'rm -f -- "$tmp"' EXIT
23 | printf '# %s: ft=yaml\n' vim | cat - "$path" > "$tmp" && mv "$tmp" "$path"
24 |
25 | "$EDITOR" "$path"
26 |
--------------------------------------------------------------------------------
/backend/db/upgrade:
--------------------------------------------------------------------------------
1 | #!/bin/sh
2 | # Run migrations in specified environment, defaulting to dev and test
3 | set -e
4 |
5 | case "$1" in
6 | dev)
7 | DBM_DATABASE=postgres://postgres:password@localhost/lambda
8 | ;;
9 | test)
10 | DBM_DATABASE=postgres://postgres:password@localhost/lambda_test
11 | ;;
12 | prod)
13 | DBM_DATABASE=$(heroku config:get DATABASE_URL --app lambda-machine)
14 | ;;
15 | *)
16 | echo "usage: db/upgrade [dev | test | prod]"
17 | exit 2
18 | ;;
19 | esac
20 | shift
21 |
22 | DBM_MIGRATION_STORE=$(cd "$(dirname "$0")" && pwd)/migrations
23 | export DBM_DATABASE
24 | export DBM_MIGRATION_STORE
25 | export DBM_LINEAR_MIGRATIONS=on
26 | export DBM_TIMESTAMP_FILENAMES=on
27 |
28 | exec stack exec -- moo-postgresql upgrade
29 |
--------------------------------------------------------------------------------
/frontend/index.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 |
10 |
11 | Lambda Machine
12 |
13 |
14 |
15 |
16 |
17 |
18 |
19 |
20 |
21 |
22 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Flags.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Flags
2 | ( Flags
3 | , none
4 | , parse
5 | , param
6 | ) where
7 |
8 | import Lambda.Prelude
9 |
10 | import Data.Array as Array
11 | import Data.Foldable (elem)
12 | import Data.String.CodeUnits (toCharArray)
13 |
14 | type Flags =
15 | { sharing :: Boolean
16 | , loading :: Boolean
17 | }
18 |
19 | none :: Flags
20 | none =
21 | { sharing: false
22 | , loading: false
23 | }
24 |
25 | parse :: String -> Maybe Flags
26 | parse = Just <<< set <<< toCharArray
27 | where
28 | set cs =
29 | { sharing: 's' `elem` cs
30 | , loading: 'l' `elem` cs
31 | }
32 |
33 | param :: Flags -> String
34 | param { sharing, loading} = fold $ Array.catMaybes
35 | [ "&f=" <$ guard (sharing || loading)
36 | , "s" <$ guard sharing
37 | , "l" <$ guard loading
38 | ]
39 |
--------------------------------------------------------------------------------
/frontend/src/Components/Alert.purs:
--------------------------------------------------------------------------------
1 | module Components.Alert
2 | ( component
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Components.Level (Level)
8 | import React.Basic (JSX)
9 | import React.Basic.DOM as R
10 | import React.Basic.Events (handler_)
11 |
12 | type Props =
13 | { level :: Level
14 | , dismiss :: Effect Unit
15 | , child :: JSX
16 | }
17 |
18 | component :: Props -> JSX
19 | component { level, dismiss, child } = R.div
20 | { className: "alert alert-dismissable alert-" <> show level
21 | , children:
22 | [ R.button
23 | { "type": "button"
24 | , onClick: handler_ dismiss
25 | , className: "close"
26 | , children:
27 | [ R.span
28 | { className: "cursor-pointer glyphicon glyphicon-remove pull-right"
29 | }
30 | ]
31 | }
32 | , child
33 | ]
34 | }
35 |
--------------------------------------------------------------------------------
/frontend/.deploy.sh:
--------------------------------------------------------------------------------
1 | #!/bin/bash
2 |
3 | set -eu
4 |
5 | branch=$(git rev-parse --abbrev-ref HEAD)
6 |
7 | if [ "$branch" != "main" ]; then
8 | echo "Cannot deploy from branch $branch; switch to main first"
9 | exit 2
10 | fi
11 |
12 | if [ ! -d "./dist" ]; then
13 | echo "./dist directory doesn't exist; run yarn deploy or yarn bundle"
14 | exit 2
15 | fi
16 |
17 | git_root=$(git rev-parse --show-toplevel)
18 | pushd "$git_root" > /dev/null
19 | trap "popd > /dev/null" EXIT
20 |
21 | now=$(date)
22 |
23 | git branch -D gh-pages 2>/dev/null || true
24 | git branch -D draft 2>/dev/null || true
25 | git checkout -b draft
26 | cp -r ./frontend/dist ./dist
27 | cp ./frontend/static/CNAME ./dist/CNAME
28 | echo "$now" > ./dist/deployed.txt
29 | git add -f ./dist
30 | git commit -am "Deploy to gh-pages on $now"
31 | git subtree split --prefix dist -b gh-pages
32 | git push --force origin gh-pages:gh-pages
33 | git checkout main
34 |
--------------------------------------------------------------------------------
/frontend/src/Components/Overlay.purs:
--------------------------------------------------------------------------------
1 | module Components.Overlay
2 | ( new
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import React.Basic (JSX)
8 | import React.Basic.DOM as R
9 | import React.Basic.DOM.Events (stopPropagation)
10 | import React.Basic.Events (handler)
11 | import React.Basic.Hooks (Component, component)
12 | import React.Portal as Portal
13 |
14 | type Props =
15 | { dismiss :: Maybe (Effect Unit)
16 | , children :: Array JSX
17 | }
18 |
19 | new :: Component Props
20 | new = do
21 | portal <- Portal.new
22 | component "Overlay" \{ dismiss, children } ->
23 | pure $ portal
24 | { children:
25 | [ R.div
26 | { className: "overlay"
27 | , children:
28 | [ R.div
29 | { className: "overlay-item"
30 | , children
31 | }
32 | ]
33 | , onClick: handler stopPropagation $ const $ sequence_ dismiss
34 | }
35 | ]
36 | }
37 |
--------------------------------------------------------------------------------
/frontend/spago.dhall:
--------------------------------------------------------------------------------
1 | {-
2 | Welcome to a Spago project!
3 | You can edit this file as you like.
4 | -}
5 | { name = "lambda-machine"
6 | , dependencies =
7 | [ "aff"
8 | , "argonaut-codecs"
9 | , "argonaut-core"
10 | , "arrays"
11 | , "bifunctors"
12 | , "control"
13 | , "debug"
14 | , "effect"
15 | , "either"
16 | , "foldable-traversable"
17 | , "identity"
18 | , "integers"
19 | , "lists"
20 | , "maybe"
21 | , "newtype"
22 | , "ordered-collections"
23 | , "parsing"
24 | , "partial"
25 | , "prelude"
26 | , "psci-support"
27 | , "quickcheck"
28 | , "react-basic"
29 | , "react-basic-dom"
30 | , "react-basic-hooks"
31 | , "safe-coerce"
32 | , "simple-ajax"
33 | , "spec"
34 | , "spec-discovery"
35 | , "spec-quickcheck"
36 | , "strings"
37 | , "tailrec"
38 | , "transformers"
39 | , "tuples"
40 | , "unfoldable"
41 | , "unordered-collections"
42 | , "variant"
43 | , "web-dom"
44 | ]
45 | , packages = ./packages.dhall
46 | , sources = [ "src/**/*.purs", "test/**/*.purs" ]
47 | }
48 |
--------------------------------------------------------------------------------
/frontend/src/Components/Expressions.purs:
--------------------------------------------------------------------------------
1 | module Components.Expressions
2 | ( component
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Data.Array as Array
8 | import Lambda.Language.History (History)
9 | import Lambda.Language.History as History
10 | import Lambda.Language.Pretty (Rep)
11 | import React.Basic (JSX)
12 | import React.Basic.DOM as R
13 |
14 | type Props =
15 | { history :: History
16 | , rep :: Rep
17 | }
18 |
19 | component :: Props -> JSX
20 | component {history, rep} = R.ul
21 | { className: "unstyled scroll-overflow"
22 | , children: truncate $ History.toJSX rep history
23 | }
24 |
25 | truncate :: List JSX -> Array JSX
26 | truncate = Array.fromFoldable <<< loop 20
27 | where
28 | loop :: Int -> List JSX -> List JSX
29 | loop n = case _ of
30 | Nil -> Nil
31 | Cons e es
32 | | n <= 0 -> item (R.text "…") : Nil
33 | | otherwise -> item e : loop (n - 1) es
34 |
35 | item :: JSX -> JSX
36 | item body = R.li
37 | { className: "expression"
38 | , children: [body]
39 | }
40 |
--------------------------------------------------------------------------------
/backend/src/Backend/Envelope.hs:
--------------------------------------------------------------------------------
1 | module Backend.Envelope
2 | ( Envelope(..)
3 | ) where
4 |
5 | import Backend.Prelude hiding (fromString)
6 | import Data.Aeson.Key (fromString)
7 |
8 | -- | Wrap a value in an object with one field
9 | --
10 | -- e.g.
11 | --
12 | -- >>> encode (Envelope @"count" @Int 3)
13 | -- "{\"count\":3}"
14 | --
15 | newtype Envelope (field :: Symbol) a = Envelope
16 | { unEnvelope :: a
17 | }
18 | deriving stock (Eq, Show)
19 |
20 | instance (KnownSymbol field, ToJSON a) => ToJSON (Envelope field a) where
21 | toEncoding = pairs . mconcat . toPairs
22 | toJSON = object . toPairs
23 |
24 | instance (KnownSymbol field, FromJSON a) => FromJSON (Envelope field a) where
25 | parseJSON = withObject "Envelope" $ fmap Envelope . (.: key)
26 | where key = fromString $ symbolVal $ Proxy @field
27 |
28 | toPairs
29 | :: forall field a kv e
30 | . (KeyValue e kv, KnownSymbol field, ToJSON a)
31 | => Envelope field a
32 | -> [kv]
33 | toPairs (Envelope value) = [key .= value]
34 | where key = fromString $ symbolVal $ Proxy @field
35 |
--------------------------------------------------------------------------------
/frontend/src/Components/Definitions.purs:
--------------------------------------------------------------------------------
1 | module Components.Definitions
2 | ( component
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Lambda.Language.Definition (Definition(..))
8 | import Lambda.Language.Name (Name)
9 | import Lambda.Language.Pretty (pretty, Rep, toJSX)
10 | import React.Basic (JSX)
11 | import React.Basic.DOM as R
12 | import React.Basic.Events (handler_)
13 |
14 | type Props =
15 | { defs :: Array Definition
16 | , onDelete :: Name -> Effect Unit
17 | , rep :: Rep
18 | }
19 |
20 | component :: Props -> JSX
21 | component {defs, rep, onDelete} =
22 | R.ul
23 | { className: "unstyled"
24 | , children: map renderDef defs
25 | }
26 | where
27 | renderDef def@(Definition { name }) =
28 | R.li
29 | { className: "definition"
30 | , children:
31 | [ R.span
32 | { className: "cursor-pointer glyphicon glyphicon-remove"
33 | , onClick: handler_ $ onDelete name
34 | , children: []
35 | }
36 | , R.text " "
37 | , toJSX $ pretty rep def
38 | ]
39 | }
40 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Snapshot/Code.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Snapshot.Code
2 | ( Code(..)
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Data.String.Pattern (Pattern(..))
8 | import Data.String.CodeUnits (contains, singleton, fromCharArray)
9 | import Lambda.Language.Parser (liftJson, satisfy, class Parse, parse)
10 |
11 | -- | Identifies a snapshot
12 | newtype Code = Code String
13 |
14 | derive instance newtypeCode :: Newtype Code _
15 | derive newtype instance eqCode :: Eq Code
16 | derive newtype instance showCode :: Show Code
17 | derive newtype instance encodeJsonCode :: EncodeJson Code
18 |
19 | instance decodeJsonCode :: DecodeJson Code where
20 | decodeJson = liftJson parse <=< decodeJson
21 |
22 | instance parseCode :: Parse Code where
23 | parse = (Code <<< fromCharArray) <$> replicateA 8 (satisfy isCodeChar)
24 |
25 | isCodeChar :: Char -> Boolean
26 | isCodeChar c = isDigit || (isUpper && not ambiguous)
27 | where
28 | isDigit = '0' <= c && c <= '9'
29 | isUpper = 'A' <= c && c <= 'Z'
30 | ambiguous = contains pat "ILOU"
31 | pat = Pattern $ singleton c
32 |
--------------------------------------------------------------------------------
/backend/stack.yaml:
--------------------------------------------------------------------------------
1 | resolver: nightly-2024-03-28
2 |
3 | packages:
4 | - .
5 |
6 | ghc-options:
7 | "$locals": >-
8 | -fignore-optim-changes
9 | -Weverything
10 | -Wno-all-missed-specialisations
11 | -Wno-implicit-prelude
12 | -Wno-missed-specialisations
13 | -Wno-missing-import-lists
14 | -Wno-missing-kind-signatures
15 | -Wno-missing-local-signatures
16 | -Wno-missing-poly-kind-signatures
17 | -Wno-missing-role-annotations
18 | -Wno-missing-safe-haskell-mode
19 | -Wno-monomorphism-restriction
20 | -Wno-prepositive-qualified-module
21 | -Wno-safe
22 | -Wno-unsafe
23 | -Wno-unused-packages
24 |
25 |
26 | # for dbmigrations-postgresql
27 | extra-deps:
28 | - HDBC-postgresql-2.5.0.0@sha256:10ceb4f456bbd4768a3f0ab425d9b4d40cb0e17992083b881b37fe5d91b58aba,3050
29 | - dbmigrations-2.0.0@sha256:1e3bd62ca980659d27b6bc7b00e58ae0e2bf7781e3859f440b7c005c46037075,5270
30 | - yaml-light-0.1.4@sha256:838b509c3a895339eea42b6524f46ba4e59c33e9f43537123cdaedfea09ca58d,1887
31 | - HsSyck-0.53@sha256:a987ae2163811bdebfd4f2e2dcb7c75e9d2d68afd97d196f969d6a74786e43da,1818
32 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Statement.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Statement
2 | ( Statement(..)
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Lambda.Language.Definition (Definition)
8 | import Lambda.Language.Expression (Expression)
9 | import Lambda.Language.Parser (class Parse, parse, try)
10 | import Lambda.Language.Pretty (class Pretty, pretty)
11 |
12 | -- | A `Statement` is either a top-level `Definition` or an
13 | -- | `Expression` to be evaluated
14 | data Statement
15 | = Define Definition
16 | | Eval Expression
17 |
18 | -- | Warning - not alpha-equivalence; names matter here
19 | derive instance eqStatement :: Eq Statement
20 | derive instance genericStatement :: Generic Statement _
21 |
22 | instance showStatement :: Show Statement where
23 | show x = genericShow x
24 |
25 | instance prettyStatement :: Pretty Statement where
26 | pretty rep = case _ of
27 | Define def -> pretty rep def
28 | Eval expr -> pretty rep expr
29 |
30 | -- | Parse a `Definition` or an `Expression`
31 | instance parseStatement :: Parse Statement where
32 | parse = try (Define <$> parse) <|> (Eval <$> parse)
33 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | The MIT License (MIT)
2 |
3 | Copyright (c) 2015 Christopher D. Parks
4 |
5 | Permission is hereby granted, free of charge, to any person obtaining a copy
6 | of this software and associated documentation files (the "Software"), to deal
7 | in the Software without restriction, including without limitation the rights
8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 |
12 | The above copyright notice and this permission notice shall be included in
13 | all copies or substantial portions of the Software.
14 |
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
21 | THE SOFTWARE.
22 |
23 |
--------------------------------------------------------------------------------
/backend/src/Backend/Name.hs:
--------------------------------------------------------------------------------
1 | module Backend.Name
2 | ( Name
3 | ) where
4 |
5 | import Backend.Prelude hiding (takeWhile)
6 |
7 | import Data.Attoparsec.Text (Parser, endOfInput, parseOnly, satisfy, takeWhile)
8 | import Data.Text (singleton)
9 | import qualified RIO.Char as Char
10 |
11 | newtype Name = Name Text
12 | deriving newtype (Eq, Show, Ord, ToJSON, PersistField, PersistFieldSql)
13 |
14 | instance FromJSON Name where
15 | parseJSON =
16 | withText "Name" $ either fail pure . parseOnly (parseName <* endOfInput)
17 |
18 | parseName :: Parser Name
19 | parseName =
20 | toName
21 | <$> satisfy isStart
22 | <*> takeWhile isBody
23 | <*> optional (satisfy (== '?'))
24 | <*> takeWhile isDigit
25 | where
26 | toName start body question digits =
27 | Name $ mconcat [singleton start, body, maybe "" singleton question, digits]
28 |
29 | isStart :: Char -> Bool
30 | isStart c = Char.isAsciiLower c || c == '_'
31 |
32 | isBody :: Char -> Bool
33 | isBody c = Char.isAsciiLower c || c == '-'
34 |
35 | isDigit :: Char -> Bool
36 | isDigit c = Char.isDigit c || c `elem` subscripts
37 |
38 | subscripts :: String
39 | subscripts = "₀₁₂₃₄₅₆₇₈₉"
40 |
--------------------------------------------------------------------------------
/frontend/package.json:
--------------------------------------------------------------------------------
1 | {
2 | "name": "lambda-machine",
3 | "version": "2.0.0",
4 | "author": "Chris Parks",
5 | "repository": "https://github.com/cdparks/lambda-machine",
6 | "license": "MIT",
7 | "dependencies": {
8 | "clipboard-polyfill": "^3.0.3",
9 | "file-saver": "^2.0.5",
10 | "react": "^17.0.2",
11 | "react-dom": "^17.0.2",
12 | "url-search-params-polyfill": "^8.1.1",
13 | "xhr2": "^0.2.1"
14 | },
15 | "devDependencies": {
16 | "@parcel/packager-raw-url": "2.0.0",
17 | "@parcel/transformer-webmanifest": "2.0.0",
18 | "parcel": "^2.0.0",
19 | "purescript": "^0.14.4",
20 | "purescript-psa": "^0.8.2",
21 | "spago": "^0.20.3"
22 | },
23 | "scripts": {
24 | "setup": "yarn install && spago install",
25 | "start": "yarn build && parcel index.html",
26 | "bundle": "NODE_ENV=production yarn build && parcel build --public-url='./' index.html",
27 | "build": "spago build --purs-args '--stash --censor-lib --strict'",
28 | "test": "spago test",
29 | "repl": "spago repl",
30 | "clean": "rm -rf .cache .spago .psci_modules output dist",
31 | "reset": "yarn clean && rm -rf node_modules",
32 | "deploy": "yarn bundle && ./.deploy.sh"
33 | }
34 | }
35 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Snapshot/Signature.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Snapshot.Signature
2 | ( Signature
3 | , deflate
4 | , inflate
5 | , nil
6 | ) where
7 |
8 | import Lambda.Prelude
9 |
10 | import Data.Array as Array
11 | import Data.Int.Bits ((.&.), (.|.))
12 | import Lambda.Language.Definition (Definition(..))
13 | import Lambda.Language.Prelude as Prelude
14 |
15 | -- | Bit field indicating which prelude definitions are used
16 | newtype Signature = Signature Int
17 |
18 | derive newtype instance eqSignature :: Eq Signature
19 | derive newtype instance showSignature :: Show Signature
20 | derive newtype instance encodeJsonSignature :: EncodeJson Signature
21 | derive newtype instance decodeJsonSignature :: DecodeJson Signature
22 |
23 | -- | Empty Signature uses no prelude definitions
24 | nil :: Signature
25 | nil = Signature 0
26 |
27 | -- | Generate prelude signature by OR'ing together ids
28 | deflate :: Array Definition -> Signature
29 | deflate = Signature <<< flip foldl 0 \acc (Definition {id}) -> acc .|. id
30 |
31 | -- | Convert signature back into prelude definitions
32 | inflate :: Signature -> Array Definition
33 | inflate (Signature sig) = Array.filter used Prelude.defs
34 | where
35 | used (Definition {id}) = (id .&. sig) /= 0
36 |
--------------------------------------------------------------------------------
/backend/Dockerfile:
--------------------------------------------------------------------------------
1 | # Builder image
2 | FROM fpco/stack-build-small:lts-18.8 AS builder
3 | LABEL maintainer="Chris Parks "
4 | ENV DEBIAN_FRONTEND=noninteractive LANG=C.UTF-8 LC_ALL=C.UTF-8
5 | RUN \
6 | apt-get update && \
7 | apt-get install -y --no-install-recommends \
8 | ca-certificates \
9 | curl \
10 | gcc \
11 | libpq-dev \
12 | locales \
13 | netbase && \
14 | locale-gen en_US.UTF-8 && \
15 | rm -rf /var/lib/apt/lists/*
16 |
17 | # Build dependencies
18 | RUN mkdir -p /src
19 | WORKDIR /src
20 | COPY stack.yaml package.yaml /src/
21 | RUN stack install --dependencies-only
22 |
23 | # Build app
24 | COPY src /src/src
25 | COPY app /src/app
26 | RUN stack install
27 |
28 | # Actual image
29 | FROM ubuntu:18.04
30 | LABEL maintainer="Chris Parks "
31 | ENV DEBIAN_FRONTEND=noninteractive LANG=C.UTF-8 LC_ALL=C.UTF-8
32 | RUN \
33 | apt-get update && \
34 | apt-get install -y --no-install-recommends \
35 | ca-certificates \
36 | gcc \
37 | libpq-dev \
38 | locales \
39 | netbase && \
40 | locale-gen en_US.UTF-8 && \
41 | rm -rf /var/lib/apt/lists/*
42 |
43 | # Copy build artifact
44 | RUN mkdir -p /app
45 | WORKDIR /app
46 | COPY --from=builder /root/.local/bin/serve /app/serve
47 |
--------------------------------------------------------------------------------
/frontend/test/Data/QueueSpec.purs:
--------------------------------------------------------------------------------
1 | module Data.QueueSpec
2 | ( spec
3 | ) where
4 |
5 | import Test.Prelude
6 |
7 | import Data.Queue (Queue)
8 | import Data.Queue as Queue
9 |
10 | spec :: Spec Unit
11 | spec = describe "Data.Queue" do
12 | describe "Queue.fromFoldable" do
13 | it "round-trips with Queue.toUnfoldable" do
14 | quickCheck \(xs :: Array Int) ->
15 | Queue.toUnfoldable (Queue.fromFoldable xs) === xs
16 |
17 | it "maintains the invariant" do
18 | quickCheck \(xs :: Array Int) ->
19 | Queue.valid $ Queue.fromFoldable xs
20 |
21 | describe "Queue.toUnfoldable" do
22 | it "round-trips with Queue.fromFoldable" do
23 | quickCheck \q ->
24 | Queue.fromFoldable (Queue.toUnfoldable q :: Array Int) === q
25 |
26 | describe "Queue.push" do
27 | it "maintains the invariant" do
28 | quickCheck \(x :: Int) q ->
29 | Queue.valid q && Queue.valid (Queue.push q x)
30 |
31 | describe "Queue.pop" do
32 | it "maintains the invariant" do
33 | quickCheck \(q :: Queue Int) ->
34 | Queue.valid q && maybe true (Queue.valid <<< snd) (Queue.pop q)
35 |
36 | describe "Queue.extend" do
37 | it "maintains the invariant" do
38 | quickCheck \(xs :: Array Int) q ->
39 | Queue.valid q && Queue.valid (Queue.extend q xs)
40 |
--------------------------------------------------------------------------------
/frontend/test/Data/GrammarSpec.purs:
--------------------------------------------------------------------------------
1 | module Data.GrammarSpec
2 | ( spec
3 | ) where
4 |
5 | import Test.Prelude hiding (join)
6 |
7 | import Data.Grammar (pluralizeWith, joinWith)
8 |
9 | spec :: Spec Unit
10 | spec = describe "Data.Grammar" do
11 | describe "pluralizeWith" do
12 | it "pluralizes 0 items" do
13 | pluralizeWith "s" 0 "item" `shouldEqual` "items"
14 |
15 | it "does not pluralize 1 item" do
16 | pluralizeWith "s" 1 "item" `shouldEqual` "item"
17 |
18 | it "pluralizes > 1 items" $ quickCheck \(Positive n) ->
19 | pluralizeWith "s" n "item" === "items"
20 |
21 | describe "joinWith" do
22 | let join = joinWith {inject: identity, conjunction: "and"}
23 | it "produces an empty string given an empty foldable" do
24 | join [] `shouldEqual` ""
25 |
26 | it "returns the only element of a singleton foldable" do
27 | join ["x"] `shouldEqual` "x"
28 |
29 | it "joins 2 elements with the conjunction" $ do
30 | join ["x", "y"] `shouldEqual` "x and y"
31 |
32 | it "joins > 2 elements with commas and the conjunction" $ do
33 | join ["x", "y", "z"] `shouldEqual` "x, y, and z"
34 |
35 | -- | Generate positive integers only
36 | newtype Positive = Positive Int
37 |
38 | instance arbitraryPositive :: Arbitrary Positive where
39 | arbitrary = Positive <$> chooseInt 1 top
40 |
--------------------------------------------------------------------------------
/backend/src/Backend/Env.hs:
--------------------------------------------------------------------------------
1 | module Backend.Env
2 | ( new
3 | , Env(..)
4 | ) where
5 |
6 | import Backend.Prelude
7 |
8 | import Backend.Database (HasSqlPool(..), SqlPool, newSqlPool)
9 | import Backend.Random (HasRandom(..), Random)
10 | import qualified Backend.Random as Random
11 | import Backend.Settings (HasSettings(..), Settings(..))
12 |
13 | new :: Settings -> IO Env
14 | new settings@Settings {..} = do
15 | sqlPool <- runNoLoggingT $ newSqlPool postgresConf
16 | random <- Random.new
17 | options <- setLogMinLevel logLevel <$> logOptionsHandle stdout False
18 | (logger, shutdown) <- newLogFunc options
19 | pure Env{..}
20 |
21 | data Env = Env
22 | { random :: Random
23 | , sqlPool :: SqlPool
24 | , settings :: Settings
25 | , logger :: LogFunc
26 | , shutdown :: IO ()
27 | }
28 |
29 | instance HasRandom Env where
30 | randomLens = lens random $ \env r -> env { random = r }
31 | {-# INLINE randomLens #-}
32 |
33 | instance HasSqlPool Env where
34 | sqlPoolLens = lens sqlPool $ \env x -> env { sqlPool = x }
35 | {-# INLINE sqlPoolLens #-}
36 |
37 | instance HasSettings Env where
38 | settingsLens = lens settings $ \env x -> env { settings = x }
39 | {-# INLINE settingsLens #-}
40 |
41 | instance HasLogFunc Env where
42 | logFuncL = lens logger $ \env x -> env { logger = x }
43 | {-# INLINE logFuncL #-}
44 |
--------------------------------------------------------------------------------
/frontend/test/Lambda/Language/Snapshot/RPNSpec.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Snapshot.RPNSpec
2 | ( spec
3 | ) where
4 |
5 | import Test.Prelude
6 |
7 | import Lambda.Language.Snapshot.RPN (RPN(..), encode, decode)
8 | import Lambda.Language.Snapshot.Error (Error(..))
9 | import Lambda.Language.Snapshot.Tag (Tag(..), _VAR)
10 |
11 | spec :: Spec Unit
12 | spec = describe "Lambda.Language.Snapshot.RPN" do
13 | describe "RPN.encode/decode" do
14 | it "roundtrips" do
15 | let
16 | ops = [Var 0, Nat 0, Take 0, Lambda 0, Define 0, AppVar 0, Apply]
17 | result = decode =<< encode ops
18 | result `shouldEqual` Right ops
19 |
20 | describe "RPN.encode" do
21 | it "throws on payloads larger than 0x1FFFFFFF" do
22 | let
23 | ops = [Var 0x20000000]
24 | result = runIdentity $ runExceptT $ encode ops
25 | result `shouldEqual` Left (PayloadOutOfRange _VAR 0x20000000)
26 |
27 | it "throws on payloads smaller than 0" do
28 | let
29 | ops = [Var (-1)]
30 | result = runIdentity $ runExceptT $ encode ops
31 | result `shouldEqual` Left (PayloadOutOfRange _VAR (-1))
32 |
33 | describe "RPN.decode" do
34 | -- We're using all 3-bit tags except 0b000
35 | it "throws on unrecognized tags" $ do
36 | let result = runIdentity $ runExceptT $ decode [0]
37 | result `shouldEqual` Left (UnrecognizedTag $ Tag 0)
38 |
--------------------------------------------------------------------------------
/backend/src/Backend/Random.hs:
--------------------------------------------------------------------------------
1 | module Backend.Random
2 | ( HasRandom(..)
3 | , Random
4 | , new
5 | , uniform
6 | , range
7 | ) where
8 |
9 | import Backend.Prelude
10 |
11 | import System.Random.MWC
12 | (GenIO, Uniform(..), UniformRange(..), createSystemRandom)
13 | import System.Random.Stateful (StatefulGen(..))
14 |
15 | -- | Environment has access to a random generator
16 | class HasRandom env where
17 | randomLens :: Lens' env Random
18 |
19 | instance HasRandom Random where
20 | randomLens = id
21 | {-# INLINE randomLens #-}
22 |
23 | -- | Fix source of randomness to use 'IO'
24 | newtype Random = Random GenIO
25 |
26 | instance StatefulGen Random IO where
27 | uniformWord32 = coerce @(GenIO -> IO Word32) uniformWord32
28 | {-# INLINE uniformWord32 #-}
29 | uniformWord64 = coerce @(GenIO -> IO Word64) uniformWord64
30 | {-# INLINE uniformWord64 #-}
31 |
32 | -- | Create new generator
33 | new :: MonadIO m => m Random
34 | new = coerce <$> liftIO createSystemRandom
35 |
36 | -- | Generate a random value
37 | uniform :: forall a env . (HasRandom env, Uniform a) => RIO env a
38 | uniform = do
39 | gen <- view randomLens
40 | liftIO $ uniformM gen
41 |
42 | -- | Generate a random value from within an inclusive range
43 | range :: forall a env . (HasRandom env, UniformRange a) => (a, a) -> RIO env a
44 | range x = do
45 | gen <- view randomLens
46 | liftIO $ uniformRM x gen
47 |
--------------------------------------------------------------------------------
/frontend/src/Data/Grammar.purs:
--------------------------------------------------------------------------------
1 | module Data.Grammar
2 | ( pluralizeWith
3 | , joinWith
4 | ) where
5 |
6 | import Lambda.Prelude hiding (join)
7 |
8 | import Data.Array as Array
9 | import Data.Maybe (fromJust)
10 | import Partial.Unsafe (unsafePartial)
11 |
12 | -- | Append suffix if `Int` argument is zero or greater than one.
13 | pluralizeWith :: String -> Int -> String -> String
14 | pluralizeWith suffix n text
15 | | n == 1 = text
16 | | otherwise = text <> suffix
17 |
18 | -- | Join `Foldable` of `String`s with commas and a conjunction,
19 | -- | if necessary.
20 | joinWith
21 | :: forall m f
22 | . Monoid m
23 | => Foldable f
24 | => { inject :: String -> m, conjunction :: m }
25 | -> f m
26 | -> m
27 | joinWith options = joinInternal options <<< Array.fromFoldable
28 |
29 | -- | Implementation of `joinWith` that operates on `Array`.
30 | joinInternal
31 | :: forall m
32 | . Monoid m
33 | => { inject :: String -> m, conjunction :: m }
34 | -> Array m
35 | -> m
36 | joinInternal {inject, conjunction} xs = case Array.length xs of
37 | 0 -> mempty
38 | 1 -> Array.intercalate mempty xs
39 | 2 -> Array.intercalate space $ conjOnLast 1
40 | n -> Array.intercalate comma $ conjOnLast $ n - 1
41 | where
42 | space = inject " "
43 | comma = inject ", "
44 | conjOnLast i = unsafePartial $ fromJust $ Array.modifyAt i prepend xs
45 | prepend x = conjunction <> space <> x
46 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Snapshot/Tag.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Snapshot.Tag
2 | ( Tag(..)
3 | , _VAR
4 | , _NAT
5 | , _TAK
6 | , _LAM
7 | , _DEF
8 | , _APV
9 | , _AP0
10 | ) where
11 |
12 | import Lambda.Prelude
13 |
14 | import Lambda.Language.Pretty (class Pretty, text)
15 |
16 | -- | 3-bit tag used to encode RPN instructions as Ints
17 | newtype Tag = Tag Int
18 |
19 | derive instance newtypeTag :: Newtype Tag _
20 | derive newtype instance eqTag :: Eq Tag
21 |
22 | instance showTag :: Show Tag where
23 | show tag
24 | | tag == _VAR = "_VAR"
25 | | tag == _NAT = "_NAT"
26 | | tag == _TAK = "_TAK"
27 | | tag == _LAM = "_LAM"
28 | | tag == _DEF = "_DEF"
29 | | tag == _APV = "_APV"
30 | | tag == _APV = "_AP0"
31 | | otherwise = "?" <> show (un Tag tag)
32 |
33 | instance prettyTag :: Pretty Tag where
34 | pretty _ = text <<< show
35 |
36 | -- | Fetch name at index
37 | _VAR :: Tag
38 | _VAR = Tag 1
39 |
40 | -- | Push literal natural number
41 | _NAT :: Tag
42 | _NAT = Tag 2
43 |
44 | -- | Take N items from stack as literal list
45 | _TAK :: Tag
46 | _TAK = Tag 3
47 |
48 | -- | Create lambda from name and expression on stack
49 | _LAM :: Tag
50 | _LAM = Tag 4
51 |
52 | -- | Create definition from name and expression on stack
53 | _DEF :: Tag
54 | _DEF = Tag 5
55 |
56 | -- | Apply name using variable index to top of stack
57 | _APV :: Tag
58 | _APV = Tag 6
59 |
60 | -- | Apply top of stack to element beneath it
61 | _AP0 :: Tag
62 | _AP0 = Tag 7
63 |
--------------------------------------------------------------------------------
/frontend/test/Prelude.purs:
--------------------------------------------------------------------------------
1 | module Test.Prelude
2 | ( mkAst
3 | , mkAnon
4 | , mkDef
5 | , mkBind
6 | , module Lambda.Prelude
7 | , module X
8 | ) where
9 |
10 | import Lambda.Prelude
11 |
12 | -- Re-exports
13 | import Lambda.Language.Definition (Definition) as X
14 | import Lambda.Language.Name (Name) as X
15 | import Lambda.Language.Statement (Statement) as X
16 | import Test.QuickCheck (class Arbitrary, (===)) as X
17 | import Test.QuickCheck.Gen (chooseInt) as X
18 | import Test.Spec (Spec, describe, describeOnly, it, itOnly, focus, pending, pending') as X
19 | import Test.Spec.Assertions (shouldEqual) as X
20 | import Test.Spec.QuickCheck (quickCheck) as X
21 |
22 | -- Imports for test helpers below
23 |
24 | import Lambda.Language.Definition (Definition)
25 | import Lambda.Language.Definition as Definition
26 | import Lambda.Language.Expression (Expression)
27 | import Lambda.Language.Name (Name)
28 | import Lambda.Language.Nameless (Nameless)
29 | import Lambda.Language.Nameless as Nameless
30 | import Lambda.Language.Parser (parse, unsafeRun)
31 | -- Crashy test helpers for constructing terms
32 |
33 | mkAst :: String -> Expression
34 | mkAst = unsafeRun parse
35 |
36 | mkAnon :: String -> Nameless
37 | mkAnon = Nameless.from <<< mkAst
38 |
39 | mkDef :: String -> Definition
40 | mkDef = unsafeRun parse
41 |
42 | mkBind :: String -> Tuple Name Nameless
43 | mkBind text = Tuple name nameless
44 | where
45 | {name, expr} = Definition.split $ mkDef text
46 | nameless = Nameless.from expr
47 |
--------------------------------------------------------------------------------
/frontend/src/Components/ConsistencyError.purs:
--------------------------------------------------------------------------------
1 | module Components.ConsistencyError
2 | ( component
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Data.Array as Array
8 | import Data.Grammar as Grammar
9 | import Data.Set as Set
10 | import Lambda.Language.World (ConsistencyError(..))
11 | import React.Basic (JSX)
12 | import React.Basic.DOM as R
13 |
14 | type Props =
15 | { error :: ConsistencyError
16 | }
17 |
18 | component :: Props -> JSX
19 | component { error } = R.p { children }
20 | where
21 | children = case error of
22 | Undefined missing ->
23 | [ R.text "No top-level "
24 | , R.text $ Grammar.pluralizeWith "s" (Set.size missing) "definition"
25 | , R.text " for "
26 | , R.span_ $ join missing
27 | ]
28 | CannotDelete name entities ->
29 | [ R.text "Cannot delete "
30 | , code $ show name
31 | , R.text " because it's still referenced by "
32 | , R.span_ $ join entities
33 | ]
34 | CannotRedefine name entities ->
35 | [ R.text "Cannot redefine "
36 | , code $ show name
37 | , R.text " because it's still referenced by "
38 | , R.span_ $ join entities
39 | ]
40 |
41 | join :: forall a f. Show a => Foldable f => f a -> Array JSX
42 | join = Grammar.joinWith {inject, conjunction: [R.text "and"]}
43 | <<< map (pure <<< code <<< show)
44 | <<< Array.fromFoldable
45 |
46 | inject :: String -> Array JSX
47 | inject = pure <<< R.text
48 |
49 | code :: String -> JSX
50 | code = R.code_ <<< pure <<< R.text
51 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Machine/Globals.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Machine.Globals
2 | ( Globals
3 | , empty
4 | , add
5 | , get
6 | ) where
7 |
8 | import Lambda.Prelude hiding (add, get)
9 |
10 | import Data.HashMap as HashMap
11 | import Lambda.Language.Name (Name)
12 | import Lambda.Machine.Address (Address)
13 | import Lambda.Machine.Heap (Heap)
14 | import Lambda.Machine.Heap as Heap
15 | import Partial.Unsafe (unsafeCrashWith)
16 |
17 | -- | Top-level names
18 | type Globals = HashMap Name Address
19 |
20 | -- | Empty `Globals`
21 | empty :: Globals
22 | empty = HashMap.empty
23 |
24 | -- | Add a new top-level definition. Note that the way we reserve
25 | -- | memory for a global before defining it means we can support
26 | -- | direct recursion, but currently this is disallowed by the
27 | -- | consistency-checking in `World`. May relax that once we have
28 | -- | concrete syntax for let-rec/fix beyond what can be defined with
29 | -- | plain lambda calculus.
30 | add
31 | :: forall a s m. MonadState { heap :: Heap a , globals :: Globals | s} m
32 | => Name
33 | -> (Unit -> m a)
34 | -> m Unit
35 | add name gen = do
36 | globals <- gets _.globals
37 | p <- Heap.reserve
38 | modify_ _ { globals = HashMap.insert name p globals }
39 | node <- gen unit
40 | Heap.update p node
41 |
42 | -- | Fetch a top-level definition or crash.
43 | get
44 | :: forall s m
45 | . MonadState { globals :: Globals | s } m
46 | => Name
47 | -> m Address
48 | get name = do
49 | globals <- gets _.globals
50 | case HashMap.lookup name globals of
51 | Just addr -> pure addr
52 | Nothing -> unsafeCrashWith $ "No global binding for " <> show name
53 |
--------------------------------------------------------------------------------
/frontend/src/React/Portal.purs:
--------------------------------------------------------------------------------
1 | module React.Portal
2 | ( new
3 | ) where
4 |
5 | import Lambda.Prelude hiding (State)
6 |
7 | import Effect.DOM (getPortal, getBody)
8 | import React.Basic (JSX, fragment, empty)
9 | import React.Basic.Hooks (Component, component, useState, useEffect)
10 | import React.Basic.Hooks as Hooks
11 | import Web.DOM.Element (Element, setAttribute, getAttribute)
12 |
13 | type Props =
14 | { children :: Array JSX
15 | }
16 |
17 | -- | Maybe, but all Justs (DisableScrolling) are equal
18 | -- | Makes useEffect work even though we can't compare elements
19 | data State
20 | = GetPortal
21 | | DisableScrolling Element
22 |
23 | instance eqState :: Eq State where
24 | eq GetPortal GetPortal = true
25 | eq (DisableScrolling _) (DisableScrolling _) = true
26 | eq _ _ = false
27 |
28 | new :: Component Props
29 | new = component "Portal" \{ children } -> Hooks.do
30 | state /\ setState <- useState GetPortal
31 | useEffect state $ case state of
32 | -- Find portal element, stash it for rendering, and move onto next state
33 | GetPortal -> do
34 | portal <- getPortal
35 | setState $ const $ DisableScrolling portal
36 | pure mempty
37 | -- Disable scrolling on body and set up clean-up handler
38 | DisableScrolling _ -> do
39 | body <- getBody
40 | style <- fromMaybe "" <$> getAttribute "style" body
41 | setAttribute "style" "overflow: hidden;" body
42 | pure $ setAttribute "style" style body
43 | pure $ case state of
44 | GetPortal -> empty
45 | DisableScrolling portal -> createPortal (fragment children) portal
46 |
47 | foreign import createPortal :: JSX -> Element -> JSX
48 |
--------------------------------------------------------------------------------
/backend/test/Backend/Test/Prelude.hs:
--------------------------------------------------------------------------------
1 | module Backend.Test.Prelude
2 | ( module X
3 | , shouldBeJust
4 | , liftEnv
5 | , get
6 | , post
7 | , SResponse(..)
8 | ) where
9 |
10 | import Backend.Prelude as X
11 | import Data.Aeson.Lens as X
12 | import Network.Wai.Test (SResponse(..))
13 | import Test.Hspec as X hiding
14 | ( expectationFailure
15 | , shouldBe
16 | , shouldContain
17 | , shouldEndWith
18 | , shouldMatchList
19 | , shouldNotBe
20 | , shouldNotContain
21 | , shouldNotReturn
22 | , shouldNotSatisfy
23 | , shouldReturn
24 | , shouldSatisfy
25 | , shouldStartWith
26 | , shouldThrow
27 | )
28 | import Test.Hspec.Expectations.Lifted as X
29 | import Test.Hspec.Wai as X hiding (get, pending, pendingWith, post)
30 | import Test.Hspec.Wai.JSON as X
31 | import Test.HUnit.Lang (assertFailure)
32 |
33 | -- | Unwrap 'Maybe' to 'Just' or fail the test
34 | shouldBeJust :: (HasCallStack, MonadIO m) => Maybe a -> m a
35 | shouldBeJust = maybe (liftIO $ assertFailure "Found Nothing instead of Just") pure
36 |
37 | -- | Lift an action on the application environment to 'WaiSession'
38 | liftEnv :: RIO env a -> WaiSession env a
39 | liftEnv act = do
40 | env <- getState
41 | liftIO $ runRIO env act
42 |
43 | -- | 'get' with correct CORS and Accept headers
44 | get :: ByteString -> WaiSession st SResponse
45 | get path = X.request methodGet path headers ""
46 |
47 | -- | 'post' with correct CORS, Accept, and Content-Type headers
48 | post :: ByteString -> LByteString -> WaiSession st SResponse
49 | post path = X.request methodPost path $ contentType : headers
50 | where contentType = (hContentType, "application/json")
51 |
52 | -- | Shared headers
53 | headers :: [Header]
54 | headers = [(hOrigin, "x"), (hAccept, "application/json")]
55 |
--------------------------------------------------------------------------------
/frontend/src/Components/Modal.purs:
--------------------------------------------------------------------------------
1 | module Components.Modal
2 | ( new
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Components.Level (Level)
8 | import Components.Overlay as Overlay
9 | import React.Basic (JSX)
10 | import React.Basic.DOM as R
11 | import React.Basic.DOM.Events (stopPropagation)
12 | import React.Basic.Events (handler_, handler)
13 | import React.Basic.Hooks (Component, component)
14 |
15 | type Props =
16 | { level :: Level
17 | , title :: String
18 | , dismiss :: Effect Unit
19 | , children :: Array JSX
20 | }
21 |
22 | new :: Component Props
23 | new = do
24 | overlay <- Overlay.new
25 | component "Modal" \{ level, title, dismiss, children } ->
26 | pure $ overlay
27 | { dismiss: Just dismiss
28 | , children:
29 | [ R.div
30 | { className: fold
31 | [ "panel panel-"
32 | , show level
33 | , " overlay-modal"
34 | ]
35 | , onClick: handler stopPropagation $ const $ pure unit
36 | , children:
37 | [ R.div
38 | { className: "panel-heading"
39 | , children:
40 | [ R.h3
41 | { className: "panel-title"
42 | , children:
43 | [ R.span
44 | { className: "cursor-pointer glyphicon glyphicon-remove pull-right"
45 | , onClick: handler_ dismiss
46 | }
47 | , R.text title
48 | ]
49 | }
50 | ]
51 | }
52 | , R.div
53 | { className: "panel-body"
54 | , children
55 | }
56 | ]
57 | }
58 | ]
59 | }
60 |
--------------------------------------------------------------------------------
/backend/src/Backend/Wai.hs:
--------------------------------------------------------------------------------
1 | module Backend.Wai
2 | ( Error(..)
3 | , jsonResponse
4 | , jsonResponseWith
5 | , errorResponse
6 | , exceptionResponse
7 | ) where
8 |
9 | import Backend.Prelude
10 | import Network.Wai (mapResponseHeaders)
11 |
12 | -- | Return JSON bytestring
13 | jsonResponse :: ToJSON a => a -> Response
14 | jsonResponse = jsonResponseWith ok200
15 |
16 | -- | Return JSON bytestring with 'Status'
17 | jsonResponseWith :: ToJSON a => Status -> a -> Response
18 | jsonResponseWith status = responseLBS status headers . encode
19 | where headers = [(hContentType, "application/json")]
20 |
21 | -- | Return 'Error' as JSON
22 | errorResponse :: Error -> Response
23 | errorResponse err@Error {..} =
24 | mapResponseHeaders (<> errHeaders) $ jsonResponseWith errStatus err
25 |
26 | -- | Try to convert 'SomeException' to 'Error' or generate a 500
27 | exceptionResponse :: SomeException -> Response
28 | exceptionResponse e@SomeException{}
29 | | Just err <- fromException e = errorResponse err
30 | | otherwise = errorResponse $ Error [] status500 $ pure $ tshow e
31 |
32 | -- | Generic server error
33 | data Error = Error
34 | { errHeaders :: [Header]
35 | -- ^ Headers to add to response
36 | , errStatus :: Status
37 | -- ^ Status to return
38 | , errDetail :: Maybe Text
39 | -- ^ Optional error detail, e.g. a parse failure
40 | }
41 | deriving stock Show
42 |
43 | instance Exception Error
44 |
45 | instance ToJSON Error where
46 | toEncoding = pairs . mconcat . toPairs
47 | toJSON = object . toPairs
48 |
49 | toPairs :: forall kv e. KeyValue e kv => Error -> [kv]
50 | toPairs (Error _ Status {..} mDetail) = mconcat
51 | [ ["status" .= statusCode, "error" .= decodeUtf8 statusMessage]
52 | , [ "detail" .= detail | detail <- maybeToList mDetail ]
53 | ]
54 |
--------------------------------------------------------------------------------
/frontend/src/Components/Input.purs:
--------------------------------------------------------------------------------
1 | module Components.Input
2 | ( component
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import React.Basic (JSX)
8 | import React.Basic.DOM as R
9 | import React.Basic.DOM.Events (targetValue, preventDefault)
10 | import React.Basic.Events (handler, handler_)
11 |
12 | type Props =
13 | { text :: String
14 | , onChange :: String -> Effect Unit
15 | , onSubmit :: Effect Unit
16 | , onHelp :: Effect Unit
17 | }
18 |
19 | component :: Props -> JSX
20 | component {text, onChange, onSubmit, onHelp} =
21 | R.form
22 | { onSubmit: handler preventDefault $ const onSubmit
23 | , children:
24 | [ inputGroup
25 | [ inputGroupBtn $ R.button
26 | { className: "btn btn-info"
27 | , "type": "button"
28 | , onClick: handler_ onHelp
29 | , children: [R.text "Help"]
30 | }
31 | , R.input
32 | { className: "form-control monospace-font"
33 | , autoComplete: "off"
34 | , autoCorrect: "off"
35 | , autoCapitalize: "off"
36 | , spellCheck: false
37 | , placeholder: "expression or definition"
38 | , onChange: handler targetValue $ traverse_ onChange
39 | , value: text
40 | }
41 | , inputGroupBtn $ R.button
42 | { className: "btn btn-default"
43 | , "type": "submit"
44 | , onClick: handler_ onSubmit
45 | , children: [R.text "Parse"]
46 | }
47 | ]
48 | ]
49 | }
50 |
51 | inputGroup :: Array JSX -> JSX
52 | inputGroup children =
53 | R.div
54 | { className: "input-group"
55 | , children
56 | }
57 |
58 | inputGroupBtn :: JSX -> JSX
59 | inputGroupBtn child =
60 | R.div
61 | { className: "input-group-btn"
62 | , children: [child]
63 | }
64 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Machine/Stash.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Machine.Stash
2 | ( Stash
3 | , empty
4 | , suspend
5 | , restore
6 | , roots
7 | ) where
8 |
9 | import Lambda.Prelude
10 |
11 | import Data.Array as Array
12 | import Lambda.Machine.Address (Address)
13 | import Lambda.Machine.Stack (Stack, fromList)
14 | import Lambda.Machine.Stack as Stack
15 |
16 | -- | A `Stash` is a possibly empty stack of `Stack`s on which we
17 | -- | intend to resume evaluation later.
18 | newtype Stash = Stash (List Stack)
19 |
20 | -- | Empty `Stash`
21 | empty :: Stash
22 | empty = Stash Nil
23 |
24 | -- | Suspend the current computation by moving the top of the `Stack`
25 | -- | to its own `Stack`, and everything else to the `Stash`.
26 | suspend :: forall s m. MonadState { stack :: Stack, stash :: Stash | s } m => m Unit
27 | suspend = do
28 | {top, rest} <- gets _.stack
29 | Stash stacks <- gets _.stash
30 | modify_ $ _
31 | { stack = {top, rest: Nil}
32 | , stash = Stash $ extend stacks rest
33 | }
34 | where
35 | extend stash = maybe stash (_ : stash) <<< fromList
36 |
37 | -- | Resume a suspended computation by replacing the `Stack` with
38 | -- | the `Stack` on top of the `Stash` if the `Stash` is non-empty.
39 | restore :: forall s m. MonadState { stack :: Stack, stash :: Stash | s } m => m (Maybe Address)
40 | restore = do
41 | Stash stash <- gets _.stash
42 | case stash of
43 | Cons stack stacks -> do
44 | modify_ $ _
45 | { stack = stack
46 | , stash = Stash stacks
47 | }
48 | pure $ Just stack.top
49 | _ -> pure Nothing
50 |
51 | -- | Return all addresses from the `Stash` for garbage collection.
52 | roots :: Stash -> Array Address
53 | roots = fold <<< Array.fromFoldable <<< map Stack.roots <<< unStash
54 | where
55 | unStash :: Stash -> List Stack
56 | unStash = coerce
57 |
--------------------------------------------------------------------------------
/frontend/test/Lambda/Language/ExpressionSpec.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.ExpressionSpec
2 | ( spec
3 | ) where
4 |
5 | import Test.Prelude
6 |
7 | import Lambda.Language.Name as Name
8 | import Lambda.Language.Expression (Expression(..))
9 | import Lambda.Language.Pretty (Rep(..), pretty, toString)
10 |
11 | spec :: Spec Unit
12 | spec = describe "Lambda.Language.Expression" do
13 | describe "Expression.encodeNat" do
14 | it "converts Church naturals using s and z to literals" do
15 | let one = oneWith (Name.from "s") (Name.from "z")
16 | toString (pretty Sugar one) `shouldEqual` "1"
17 |
18 | it "ignores Church naturals with different base names" do
19 | let one = oneWith (Name.from "f") (Name.from "z")
20 | toString (pretty Sugar one) `shouldEqual` "λf. λz. f z"
21 |
22 | describe "Expression.encodeList" do
23 | it "converts Church lists using cons and nil to literals" do
24 | let ones = listWith (Name.from "cons") (Name.from "nil") (Nat 1)
25 | toString (pretty Sugar ones) `shouldEqual` "[1, 1, 1]"
26 |
27 | it "converts Church lists using f and z to literals" do
28 | let ones = listWith (Name.from "f") (Name.from "z") (Nat 1)
29 | toString (pretty Sugar ones) `shouldEqual` "[1, 1, 1]"
30 |
31 | it "ignores Church lists with different base names" do
32 | let ones = listWith (Name.from "g") (Name.from "z") (Nat 1)
33 | toString (pretty Sugar ones) `shouldEqual` "λg. λz. g 1 (g 1 (g 1 z))"
34 |
35 | oneWith :: Name -> Name -> Expression
36 | oneWith s z = Lambda s
37 | $ Lambda z
38 | $ Apply (Var s)
39 | $ Var z
40 |
41 | listWith :: Name -> Name -> Expression -> Expression
42 | listWith cons nil x = Lambda cons
43 | $ Lambda nil
44 | $ Apply (Apply (Var cons) x)
45 | $ Apply (Apply (Var cons) x)
46 | $ Apply (Apply (Var cons) x)
47 | $ Var nil
48 |
--------------------------------------------------------------------------------
/backend/src/Backend/Prelude.hs:
--------------------------------------------------------------------------------
1 | module Backend.Prelude
2 | ( module X
3 | , (<$$>)
4 | ) where
5 |
6 | import RIO as X hiding (Handler, timeout)
7 |
8 | import Data.Type.Equality as X (type (~))
9 | import Control.Error.Util as X (hush, note)
10 | import Control.Monad as X (replicateM)
11 | import Control.Monad.Logger as X
12 | ( MonadLogger
13 | , MonadLoggerIO
14 | , runNoLoggingT
15 | , runStderrLoggingT
16 | , runStdoutLoggingT
17 | )
18 | import Control.Monad.State as X
19 | (MonadState, State, evalState, execState, modify, runState)
20 | import Data.Aeson as X
21 | ( (.:)
22 | , (.=)
23 | , FromJSON(..)
24 | , KeyValue
25 | , ToJSON(..)
26 | , decode
27 | , eitherDecode
28 | , encode
29 | , object
30 | , pairs
31 | , withObject
32 | , withText
33 | )
34 | import Data.Coerce as X (Coercible, coerce)
35 | import Data.Default as X
36 | import Data.Kind as X (Constraint, Type)
37 | import Data.Text as X (pack, unpack)
38 | import Data.Text.Encoding as X (decodeUtf8)
39 | import Database.Esqueleto.PostgreSQL.JSON as X (JSONB(..))
40 | import Database.Persist as X
41 | (Entity(..), Key, PersistEntity(..), PersistEntityBackend, PersistField)
42 | import Database.Persist.Sql as X
43 | (ConnectionPool, PersistFieldSql, SqlBackend, SqlPersistT)
44 | import GHC.TypeLits as X (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal)
45 | import Network.HTTP.Types.Header as X
46 | import Network.HTTP.Types.Method as X
47 | import Network.HTTP.Types.Status as X
48 | import Network.Wai as X
49 | (Application, Middleware, Request, Response, responseLBS)
50 | import RIO.Orphans as X ()
51 | import RIO.Seq as X ((<|), (|>))
52 | import Web.HttpApiData as X (FromHttpApiData(..), ToHttpApiData(..))
53 | import Web.PathPieces as X (PathPiece(..))
54 |
55 | (<$$>) :: (Functor m, Functor n) => (a -> b) -> m (n a) -> m (n b)
56 | f <$$> m = fmap f <$> m
57 | {-# INLINE (<$$>) #-}
58 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/History.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.History
2 | ( History
3 | , empty
4 | , new
5 | , add
6 | , toStrings
7 | , toJSX
8 | ) where
9 |
10 | import Lambda.Prelude hiding (add)
11 |
12 | import Lambda.Language.Pretty (class Pretty, pretty, select, Rep(..))
13 | import Lambda.Language.Pretty as P
14 | import React.Basic (JSX)
15 |
16 | -- | Cache pretty-printed JSX and text with and without syntactic sugar
17 | -- |
18 | -- | Then we can incrementally build each list and switch between them without
19 | -- | redoing a bunch of work.
20 | -- |
21 | newtype History = History
22 | { sugar :: List Bundle
23 | , raw :: List Bundle
24 | }
25 |
26 | -- | No history
27 | empty :: History
28 | empty = History {sugar: Nil, raw: Nil}
29 |
30 | -- | Single expression
31 | new :: forall a. Pretty a => a -> History
32 | new a = add a empty
33 |
34 | -- | Add expression
35 | add :: forall a. Pretty a => a -> History -> History
36 | add a (History {sugar, raw}) = History
37 | { sugar: Cons (bundle Sugar a) sugar
38 | , raw: Cons (bundle Raw a) raw
39 | }
40 |
41 | -- | Pretty-printed text format, most-recently evaluated first
42 | toStrings :: Rep -> History -> List String
43 | toStrings = toListWith $ _.text
44 |
45 | -- | Pretty-printed JSX format, most-recently evaluated first
46 | toJSX :: Rep -> History -> List JSX
47 | toJSX = toListWith $ _.jsx
48 |
49 | -- | Extract one list of pretty-printed elments from the history
50 | toListWith :: forall r. (Bundle -> r) -> Rep -> History -> List r
51 | toListWith f rep = map f <<< select rep <<< coerce
52 |
53 | -- | Pretty print and bundle JSX and text representations
54 | bundle :: forall a. Pretty a => Rep -> a -> Bundle
55 | bundle rep a =
56 | { jsx: P.toJSX node
57 | , text: P.toString node
58 | }
59 | where
60 | node = pretty rep a
61 |
62 | type Bundle =
63 | { jsx :: JSX
64 | , text :: String
65 | }
66 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Api.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Api
2 | ( Error(..)
3 | , fetch
4 | , store
5 | ) where
6 |
7 | import Lambda.Prelude
8 |
9 | import Data.Variant (match)
10 | import Lambda.Env as Env
11 | import Lambda.Language.Program (Program)
12 | import Lambda.Language.Snapshot as Snapshot
13 | import Lambda.Language.Snapshot.Code (Code)
14 | import Simple.Ajax as Ajax
15 | import Simple.Ajax (AjaxError)
16 |
17 | -- | Store `Program` and generate `Code`
18 | store :: Program -> Aff (Either Error Code)
19 | store program = case Snapshot.new program of
20 | Left err -> pure $ Left $ BadSnapshot err
21 | Right snapshot -> convert <$> Ajax.post url (Just snapshot)
22 | where
23 | url = Env.api <> "/snapshots"
24 | convert = bimap
25 | (fromAjaxError Nothing)
26 | (_.code :: { code :: Code } -> Code)
27 |
28 | -- | Fetch `Program` by `Code`
29 | fetch :: Code -> Aff (Either Error Program)
30 | fetch code = convert <$> Ajax.get url
31 | where
32 | url = Env.api <> "/snapshots/" <> unwrap code
33 | convert = either
34 | (Left <<< fromAjaxError (Just code))
35 | (lmap BadSnapshot <<< Snapshot.load)
36 |
37 | -- | Logic and simplified Ajax errors
38 | data Error
39 | = BadSnapshot Snapshot.Error
40 | | ParseError String
41 | | Missing Code
42 | | HttpError (Maybe String)
43 |
44 | derive instance genericError :: Generic Error _
45 | instance showError :: Show Error where
46 | show x = genericShow x
47 |
48 | -- | Convert `Ajax.Error` to application-specific `Error`
49 | fromAjaxError :: Maybe Code -> AjaxError -> Error
50 | fromAjaxError code = match
51 | { parseError: ParseError <<< printJsonDecodeError
52 | , badRequest: HttpError <<< Just
53 | , unAuthorized: const ignore
54 | , forbidden: const ignore
55 | , notFound: const $ maybe ignore Missing code
56 | , methodNotAllowed: const ignore
57 | , serverError: const ignore
58 | , affjaxError: const ignore
59 | }
60 | where
61 | ignore = HttpError Nothing
62 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Machine/Stack.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Machine.Stack
2 | ( Stack
3 | , singleton
4 | , push
5 | , discard
6 | , replace
7 | , peek
8 | , fromList
9 | , roots
10 | ) where
11 |
12 | import Lambda.Prelude
13 |
14 | import Data.Array as Array
15 | import Data.List (index)
16 | import Lambda.Machine.Address (Address)
17 |
18 | -- | Non-empty stack.
19 | type Stack =
20 | { top :: Address
21 | , rest :: List Address
22 | }
23 |
24 | -- | Stack with one element.
25 | singleton :: Address -> Stack
26 | singleton top = { top, rest: Nil }
27 |
28 | -- | Push an element on top of the stack
29 | push :: forall s m. MonadState { stack :: Stack | s } m => Address -> m Unit
30 | push address = do
31 | {top, rest} <- gets _.stack
32 | modify_ $ _ { stack = {top: address, rest: Cons top rest} }
33 |
34 | -- | Discard the top element unless doing so would produce an empty stack.
35 | discard :: forall s m. MonadState { stack :: Stack | s } m => m Unit
36 | discard = do
37 | {rest} <- gets _.stack
38 | case rest of
39 | Cons y ys -> modify_ $ _ { stack = {top: y, rest: ys} }
40 | Nil -> pure unit
41 |
42 | -- | Replace the top element of the stack.
43 | replace :: forall s m. MonadState { stack :: Stack | s } m => Address -> m Unit
44 | replace address = do
45 | {rest} <- gets _.stack
46 | modify_ $ _ { stack = {top: address, rest} }
47 |
48 | -- | Attempt to return the address on the stack offset from the top.
49 | peek :: forall s m. MonadState { stack :: Stack | s } m => Int -> m (Maybe Address)
50 | peek i = do
51 | {top, rest} <- gets _.stack
52 | pure $ index (Cons top rest) i
53 |
54 | -- | Attempt to convert a `List` of `Address`'s to a `Stack`
55 | fromList :: List Address -> Maybe Stack
56 | fromList = case _ of
57 | Nil -> Nothing
58 | Cons top rest -> Just {top, rest}
59 |
60 | -- | Return all addresses from the `Stack` for garbage collection.
61 | roots :: Stack -> Array Address
62 | roots {top, rest} = [top] <> Array.fromFoldable rest
63 |
--------------------------------------------------------------------------------
/frontend/test/Lambda/MachineSpec.purs:
--------------------------------------------------------------------------------
1 | module Lambda.MachineSpec
2 | ( spec
3 | ) where
4 |
5 | import Test.Prelude
6 |
7 | import Data.Function (applyN)
8 | import Lambda.Language.Expression (Expression, encodeNat)
9 | import Lambda.Language.Expression as Expression
10 | import Lambda.Language.Nameless (Nameless)
11 | import Lambda.Machine as Machine
12 |
13 | spec :: Spec Unit
14 | spec = describe "Lambda.Machine" do
15 | describe "Lambda.Machine.step" do
16 | it "is stack-safe with programs that loop" do
17 | let result = stepN 100_000 [mkBind "f x = x x"] $ mkAnon "f f"
18 | Expression.unHighlight result `shouldEqual` mkAst "f f"
19 |
20 | it "evaluates addition of church numerals" do
21 | let result = normalize [mkBind "add m n s z = m s (n s z)"] $ mkAnon "add 2 3"
22 | result `shouldEqual` encodeNat 5
23 |
24 | it "lazily consumes an infinite list" do
25 | let
26 | globals =
27 | [ mkBind "fix f = (λx. f (x x)) (λy. f (y y))"
28 | , mkBind "true t _ = t"
29 | , mkBind "false _ f = f"
30 | , mkBind "or x y = x true y"
31 | , mkBind "any l = l or false"
32 | , mkBind "cons x xs c n = c x (xs c n)"
33 | , mkBind "repeat x = fix (λnext. cons x next)"
34 | ]
35 | result = normalize globals $ mkAnon "any (repeat true)"
36 | result `shouldEqual` mkAst "λt. λ_. t"
37 |
38 | -- | Create a new `Machine` and step it N times.
39 | stepN
40 | :: Int
41 | -> Array (Tuple Name Nameless)
42 | -> Nameless
43 | -> Expression
44 | stepN n globals =
45 | Machine.snapshot
46 | <<< applyN Machine.step n
47 | <<< Machine.new globals
48 |
49 | -- | Create a new `Machine` and step it until it halts.
50 | normalize
51 | :: Array (Tuple Name Nameless)
52 | -> Nameless
53 | -> Expression
54 | normalize globals =
55 | loop <<< Machine.new globals
56 | where
57 | loop m
58 | | m.halted = Machine.snapshot m
59 | | otherwise = loop $ Machine.step m
60 |
--------------------------------------------------------------------------------
/frontend/test/Lambda/Language/NamelessSpec.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.NamelessSpec
2 | ( spec
3 | ) where
4 |
5 | import Test.Prelude
6 |
7 | import Data.Set as Set
8 | import Lambda.Language.Name as Name
9 | import Lambda.Language.Nameless (Nameless(..))
10 | import Lambda.Language.Nameless as Nameless
11 |
12 | spec :: Spec Unit
13 | spec = describe "Lambda.Language.Nameless" do
14 | describe "Nameless.from" do
15 | it "creates a locally-nameless Expression from an AST" do
16 | let
17 | expr = Nameless.from $ mkAst "λx y. f y x"
18 | expected = Lambda x (Set.singleton f)
19 | $ Lambda y (Set.singleton f)
20 | $ Apply (Apply (Free f) (Bound 0))
21 | $ Bound 1
22 | expr `shouldEqual` expected
23 |
24 | it "renames names that would otherwise shadow" do
25 | let
26 | expr = Nameless.from $ mkAst "λx x. x"
27 | expected = Lambda x Set.empty
28 | $ Lambda (Name.withSubscript 0 "x") Set.empty
29 | $ Bound 0
30 | expr `shouldEqual` expected
31 |
32 | it "eliminates literal natural numbers" do
33 | let
34 | s = Name.from "s"
35 | z = Name.from "z"
36 | expr = Nameless.from $ mkAst "3"
37 | expected = Lambda s Set.empty
38 | $ Lambda z Set.empty
39 | $ Apply (Bound 1)
40 | $ Apply (Bound 1)
41 | $ Apply (Bound 1) (Bound 0)
42 | expr `shouldEqual` expected
43 |
44 | it "eliminates literal lists" do
45 | let
46 | cons = Name.from "cons"
47 | nil = Name.from "nil"
48 | expr = Nameless.from $ mkAst "[x, y]"
49 | expected = Lambda cons Set.empty
50 | $ Lambda nil Set.empty
51 | $ Apply (Apply (Bound 1) (Free x))
52 | $ Apply (Apply (Bound 1) (Free y))
53 | $ Bound 0
54 | expr `shouldEqual` expected
55 |
56 | x :: Name
57 | x = Name.from "x"
58 |
59 | y :: Name
60 | y = Name.from "y"
61 |
62 | f :: Name
63 | f = Name.from "f"
64 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Prelude.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Prelude
2 | ( defs
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Data.Array (mapWithIndex, length)
8 | import Data.Int.Bits (shl)
9 | import Lambda.Language.Definition (Definition(..))
10 | import Lambda.Language.Parser (parse)
11 | import Lambda.Language.Parser as Parser
12 | import Partial.Unsafe (unsafeCrashWith)
13 |
14 | -- | Default set of global definitions
15 | --
16 | -- Don't reorder these; only add new definitions at the end. This will
17 | -- eventually allow us to store the set of prelude definitions used in
18 | -- a session with a bitset. For example, 0x3 or 0b011 would mean only
19 | -- const and identity are used:
20 | --
21 | -- position | mask | definition | used
22 | -- 0 | 0b001 | id | ✓
23 | -- 1 | 0b010 | const | ✓
24 | -- 2 | 0b100 | compose | ✗
25 | -- …
26 | --
27 | defs :: Array Definition
28 | defs = addPreludeIds $ Parser.unsafeRun parse <$>
29 | [ "identity x = x"
30 | , "const x y = x"
31 | , "compose f g x = f (g x)"
32 | , "fix f = f (fix f)"
33 | , "true t f = t"
34 | , "false t f = f"
35 | , "and x y = x y false"
36 | , "or x y = x true y"
37 | , "not x = x false true"
38 | , "succ n s z = s (n s z)"
39 | , "pred n s z = n (λg. λh. h (g s)) (λu. z) (λu. u)"
40 | , "add m n s z = m s (n s z)"
41 | , "mul m n s z = m (n s) z"
42 | , "zero? n = n (λx. false) true"
43 | , "cons x xs f z = f x (xs f z)"
44 | , "nil f z = z"
45 | , "foldr f z l = l f z"
46 | , "map f = foldr (compose cons f) nil"
47 | , "any = foldr or false"
48 | , "all = foldr and true"
49 | , "iterate f x = cons x (iterate f (f x))"
50 | , "repeat x = cons x (repeat x)"
51 | ]
52 |
53 | addPreludeIds :: Array Definition -> Array Definition
54 | addPreludeIds ds
55 | | length ds > 32 = unsafeCrashWith "too many prelude defs"
56 | | otherwise = mapWithIndex setPreludeId ds
57 | where
58 | setPreludeId i (Definition def) = Definition $ def { id = 1 `shl` i }
59 |
--------------------------------------------------------------------------------
/backend/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/topics/lock_files
5 |
6 | packages:
7 | - completed:
8 | hackage: HDBC-postgresql-2.5.0.0@sha256:10ceb4f456bbd4768a3f0ab425d9b4d40cb0e17992083b881b37fe5d91b58aba,3050
9 | pantry-tree:
10 | sha256: 9db472e5f433c07d097b6cdc6af354d0a40c0fd3c7205510973380ced739c764
11 | size: 1611
12 | original:
13 | hackage: HDBC-postgresql-2.5.0.0@sha256:10ceb4f456bbd4768a3f0ab425d9b4d40cb0e17992083b881b37fe5d91b58aba,3050
14 | - completed:
15 | hackage: dbmigrations-2.0.0@sha256:1e3bd62ca980659d27b6bc7b00e58ae0e2bf7781e3859f440b7c005c46037075,5270
16 | pantry-tree:
17 | sha256: c0ed60caea8b8aace63e40628c753ba8b007edcea17ccc270317b533d07c8e28
18 | size: 3935
19 | original:
20 | hackage: dbmigrations-2.0.0@sha256:1e3bd62ca980659d27b6bc7b00e58ae0e2bf7781e3859f440b7c005c46037075,5270
21 | - completed:
22 | hackage: yaml-light-0.1.4@sha256:838b509c3a895339eea42b6524f46ba4e59c33e9f43537123cdaedfea09ca58d,1887
23 | pantry-tree:
24 | sha256: ed05f839d189a312392f35d41888602b5929a8c0bcd54ee50bffe013552526ba
25 | size: 217
26 | original:
27 | hackage: yaml-light-0.1.4@sha256:838b509c3a895339eea42b6524f46ba4e59c33e9f43537123cdaedfea09ca58d,1887
28 | - completed:
29 | hackage: HsSyck-0.53@sha256:a987ae2163811bdebfd4f2e2dcb7c75e9d2d68afd97d196f969d6a74786e43da,1818
30 | pantry-tree:
31 | sha256: d0465b8296fc621a76c7362eadf1364489781ca09d79441ec22b7a18b12eed46
32 | size: 1024
33 | original:
34 | hackage: HsSyck-0.53@sha256:a987ae2163811bdebfd4f2e2dcb7c75e9d2d68afd97d196f969d6a74786e43da,1818
35 | snapshots:
36 | - completed:
37 | sha256: 6460bf705effd837fad0bd231abc26263e7fcd7266a6341f47c52d20c571f341
38 | size: 621458
39 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2024/3/28.yaml
40 | original: nightly-2024-03-28
41 |
--------------------------------------------------------------------------------
/frontend/src/Components/ApiError.purs:
--------------------------------------------------------------------------------
1 | module Components.ApiError
2 | ( component
3 | ) where
4 |
5 | import Components.Markup
6 |
7 | import Lambda.Api (Error(..))
8 | import Lambda.Prelude (Maybe(..), (<>), show, ($), (<<<))
9 | import Lambda.Language.Pretty (pretty, Rep(..), toString)
10 |
11 | component :: { error :: Error } -> JSX
12 | component = markup <<< explain <<< _.error
13 |
14 | explain :: Error -> Array Markup
15 | explain = case _ of
16 | BadSnapshot error ->
17 | [ para
18 | [ text "Something went wrong while processing a snapshot:"
19 | ]
20 | , code [toString $ pretty Raw error]
21 | , para $ bug Definitely
22 | ]
23 | ParseError error ->
24 | [ para
25 | [ text "A response from the API failed to parse:"
26 | ]
27 | , code [error]
28 | , para $ bug Probably
29 | ]
30 | Missing code ->
31 | [ para $
32 | [ text "The snapshot identified by "
33 | , text $ show code
34 | , text " doesn't appear to exist anymore. "
35 | ] <> bug Maybe
36 | ]
37 | HttpError (Just error) ->
38 | [ para
39 | [ text "Something went wrong while communicating with the API:"
40 | ]
41 | , code [error]
42 | , para $ bug Probably
43 | ]
44 | HttpError Nothing ->
45 | [ para $
46 | [ text "Something went wrong while communicating with the API. "
47 | ] <> bug Probably
48 | ]
49 |
50 | bug :: Likelihood -> Array Leaf
51 | bug = case _ of
52 | Definitely ->
53 | [ text "This is definitely a bug. If you have time to "
54 | , fileAnIssue
55 | , text ", I'd really appreciate it!"
56 | ]
57 | Probably ->
58 | [ text "This is probably a bug. If you have time to "
59 | , fileAnIssue
60 | , text ", I'd really appreciate it!"
61 | ]
62 | Maybe ->
63 | [ text "If you think this looks like a bug, feel free to "
64 | , fileAnIssue
65 | , text ". Thanks!"
66 | ]
67 | where
68 | fileAnIssue = link
69 | { this: "file an issue"
70 | , to: "github.com/cdparks/lambda-machine/issues"
71 | }
72 |
73 | data Likelihood
74 | = Definitely
75 | | Probably
76 | | Maybe
77 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Definition.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Definition
2 | ( Definition(..)
3 | , split
4 | , join
5 | ) where
6 |
7 | import Lambda.Prelude
8 |
9 | import Data.Array as Array
10 | import Data.Foldable (intercalate)
11 | import Lambda.Language.Expression (Expression(..))
12 | import Lambda.Language.Name (Name)
13 | import Lambda.Language.Parser (class Parse, parse, token, string)
14 | import Lambda.Language.Pretty (class Pretty, pretty, text)
15 |
16 | -- | A top-level definition
17 | newtype Definition = Definition
18 | { id :: Int
19 | , name :: Name
20 | , args :: Array Name
21 | , expr :: Expression
22 | }
23 |
24 | -- | Warning - not alpha-equivalence; names matter here
25 | derive newtype instance eqDefinition :: Eq Definition
26 | derive newtype instance showDefinition :: Show Definition
27 | derive instance newtypeDefinition :: Newtype Definition _
28 |
29 | instance prettyDefinition :: Pretty Definition where
30 | pretty rep (Definition {name, args, expr}) =
31 | text prefix <> pretty rep expr
32 | where
33 | prefix = fold
34 | [ show name
35 | , " "
36 | , intercalate " " $ fold
37 | [ show <$> args
38 | , ["= "]
39 | ]
40 | ]
41 |
42 | -- | Convert a `Definition` to an `Expression` returning the `Name`
43 | split :: Definition -> {id :: Int, name :: Name, expr :: Expression}
44 | split (Definition {id, name, args, expr}) =
45 | { id
46 | , name
47 | , expr: foldr Lambda expr args
48 | }
49 |
50 | -- | Covert a `Name` and an `Expression` to a `Definition`
51 | join :: Name -> Expression -> Definition
52 | join name = Definition <<< go []
53 | where
54 | go args = case _ of
55 | Lambda arg body-> go (args <> [arg]) body
56 | expr-> { id: 0, name, args, expr }
57 |
58 | -- | Parse a `Definition`
59 | -- |
60 | -- | ```ebnf
61 | -- | definition = name, {name}, "=", expression ;
62 | -- | ```
63 | -- |
64 | instance parseDefinition :: Parse Definition where
65 | parse = do
66 | name <- parse
67 | args <- Array.many parse
68 | expr <- token (string "=") *> parse
69 | pure $ Definition {id: 0, name, args, expr}
70 |
--------------------------------------------------------------------------------
/frontend/src/Components/Controls.purs:
--------------------------------------------------------------------------------
1 | module Components.Controls
2 | ( component
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Lambda.Flags (Flags)
8 | import Lambda.Language.Pretty (Rep, select)
9 | import React.Basic (JSX, empty)
10 | import React.Basic.DOM as R
11 | import React.Basic.Events (handler_)
12 |
13 | type Props =
14 | { flags :: Flags
15 | , onStep :: Maybe (Effect Unit)
16 | , onClear :: Maybe (Effect Unit)
17 | , onShare :: Maybe (Effect Unit)
18 | , onSave :: Maybe (Effect Unit)
19 | , onSugar :: Maybe (Effect Unit)
20 | , rep :: Rep
21 | }
22 |
23 | component :: Props -> JSX
24 | component { flags, onStep, onClear, onShare, onSave, onSugar, rep } =
25 | R.div
26 | { className: "add-margin-medium btn-group pull-right"
27 | , children:
28 | [ button
29 | { label: "Step"
30 | , className: "btn btn-default"
31 | , onClick: onStep
32 | }
33 | , button
34 | { label: "Clear"
35 | , className: "btn btn-default"
36 | , onClick: onClear
37 | }
38 | , if flags.sharing
39 | then button
40 | { label: "Share"
41 | , className: "btn btn-default"
42 | , onClick: onShare
43 | }
44 | else empty
45 | , button
46 | { label: "Save"
47 | , className: "btn btn-default"
48 | , onClick: onSave
49 | }
50 | , button
51 | { label: select rep
52 | { sugar: "Raw"
53 | , raw: "Sugar"
54 | }
55 | , className: select rep
56 | { sugar: "btn btn-danger"
57 | , raw: "btn btn-success"
58 | }
59 | , onClick: onSugar
60 | }
61 | ]
62 | }
63 |
64 | -- | Disable button if `onClick` is `Nothing`
65 | button
66 | ::
67 | { label :: String
68 | , className :: String
69 | , onClick :: Maybe (Effect Unit)
70 | }
71 | -> JSX
72 | button { label, className, onClick } =
73 | R.button
74 | { className
75 | , onClick: handler_ $ fromMaybe (pure unit) $ onClick
76 | , children: [R.text label]
77 | , disabled: isNothing onClick
78 | }
79 |
--------------------------------------------------------------------------------
/frontend/test/Lambda/Language/SnapshotSpec.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.SnapshotSpec
2 | ( spec
3 | ) where
4 |
5 | import Test.Prelude
6 |
7 | import Lambda.Language.Name as Name
8 | import Lambda.Language.Snapshot (Snapshot(..))
9 | import Lambda.Language.Snapshot as Snapshot
10 | import Lambda.Language.Snapshot.Error (Error(..))
11 | import Lambda.Language.Snapshot.RPN (unsafeTag)
12 | import Lambda.Language.Snapshot.Signature as Signature
13 | import Lambda.Language.Snapshot.Tag (_VAR, _AP0, _TAK)
14 |
15 | spec :: Spec Unit
16 | spec = describe "Lambda.Language.Snapshot" do
17 | describe "Snapshot.new/load" do
18 | it "roundtrips" do
19 | let
20 | program =
21 | { defs: [mkDef "id x = x", mkDef "const x y = x"]
22 | , expr: pure $ mkAst "const id id"
23 | }
24 | result = Snapshot.load =<< Snapshot.new program
25 | result `shouldEqual` Right program
26 |
27 | describe "Snapshot.load" do
28 | it "throws on unprocessed stack values" do
29 | let
30 | state = [unsafeTag _VAR 0, unsafeTag _VAR 1]
31 | result = Snapshot.load $ snapshot state
32 | result `shouldEqual` Left (ExtraStackValues 2)
33 |
34 | it "throws on stack underflow with empty stack" do
35 | let
36 | state = [unsafeTag _AP0 0]
37 | result = Snapshot.load $ snapshot state
38 | result `shouldEqual` Left (StackUnderflow { op: "pop", wanted: 1, saw: 0 })
39 |
40 | it "throws on stack underflow with not enough values for Take" do
41 | let
42 | state = [unsafeTag _VAR 0, unsafeTag _VAR 1, unsafeTag _TAK 4]
43 | result = Snapshot.load $ snapshot state
44 | result `shouldEqual` Left (StackUnderflow { op: "take", wanted: 4, saw: 2 })
45 |
46 | it "throws name index out of range" do
47 | let
48 | state = [unsafeTag _VAR 0, unsafeTag _VAR 2]
49 | result = Snapshot.load $ snapshot state
50 | result `shouldEqual` Left (IndexOutOfRange 2 names)
51 |
52 | snapshot :: Array Int -> Snapshot
53 | snapshot state = Snapshot { sig: Signature.nil, names, state }
54 |
55 | names :: Array Name
56 | names = [Name.from "x", Name.from "y"]
57 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Snapshot/Error.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Snapshot.Error
2 | ( Error(..)
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Data.Array as Array
8 | import Data.Grammar (pluralizeWith)
9 | import Lambda.Language.Name (Name)
10 | import Lambda.Language.Pretty (class Pretty, text, pretty)
11 | import Lambda.Language.Snapshot.Tag (Tag)
12 |
13 | -- | Errors that can occur while creating or loading a `Snapshot`
14 | data Error
15 | -- | Payload would use more than 29 bits
16 | = PayloadOutOfRange Tag Int
17 | -- | Unrecognized 3-bit tag (only 0b000 now)
18 | | UnrecognizedTag Tag
19 | -- | Unprocessed values on the stack after running out of instructions
20 | | ExtraStackValues Int
21 | -- | Not enough values on the stack
22 | | StackUnderflow { op :: String, wanted :: Int, saw :: Int }
23 | -- | Bad index into the name store
24 | | IndexOutOfRange Int (Array Name)
25 |
26 | derive instance eqError :: Eq Error
27 | derive instance genericError :: Generic Error _
28 |
29 | instance showError :: Show Error where
30 | show x = genericShow x
31 |
32 | instance Pretty Error where
33 | pretty rep = case _ of
34 | PayloadOutOfRange tag p -> fold
35 | [ text "payload "
36 | , text $ show p
37 | , text " for tag "
38 | , pretty rep tag
39 | , text " out of range for 29 bits"
40 | ]
41 | UnrecognizedTag tag -> fold
42 | [ text "unrecognized tag "
43 | , pretty rep tag
44 | ]
45 | ExtraStackValues n -> fold
46 | [ text "malformed snapshot; "
47 | , text $ show n
48 | , text " extra expressions left on stack"
49 | ]
50 | StackUnderflow { op, wanted, saw } -> fold
51 | [ text "stack underflow for "
52 | , text op
53 | , text "; wanted "
54 | , text $ show wanted
55 | , text $ pluralizeWith "s" wanted "item"
56 | , text ", saw "
57 | , text $ show saw
58 | ]
59 | IndexOutOfRange i names -> fold
60 | [ text "index "
61 | , text $ show i
62 | , text " out of range for symbol table ["
63 | , Array.intercalate (text ", ") (pretty rep <$> names)
64 | , text "]"
65 | ]
66 |
--------------------------------------------------------------------------------
/backend/src/Backend/Middleware.hs:
--------------------------------------------------------------------------------
1 | module Backend.Middleware
2 | ( middleware
3 | ) where
4 |
5 | import Backend.Prelude
6 |
7 | import Backend.Settings (Settings(..))
8 | import Backend.Wai (Error(..), errorResponse)
9 | import Network.Wai.Middleware.Autohead (autohead)
10 | import Network.Wai.Middleware.Cors (CorsResourcePolicy(..), cors, simpleMethods)
11 | import Network.Wai.Middleware.Gzip (gzip)
12 | import Network.Wai.Middleware.RequestLogger (logStdoutDev)
13 | import Network.Wai.Middleware.RequestSizeLimit
14 | ( defaultRequestSizeLimitSettings
15 | , requestSizeLimitMiddleware
16 | , setOnLengthExceeded
17 | )
18 | import Network.Wai.Middleware.Timeout (timeoutAs)
19 |
20 | -- | Enable CORS, logging, compression, and limits
21 | middleware :: Settings -> Middleware
22 | middleware Settings {..} =
23 | cors (corsPolicy origin)
24 | . autohead
25 | . logRequests
26 | . gzip def
27 | . limitRequestSize
28 | . timeoutRequest timeout
29 | where
30 | logRequests
31 | | logLevel == LevelDebug = logStdoutDev
32 | | otherwise = id
33 |
34 | -- | Limit request size to default 2MB and respond with JSON
35 | limitRequestSize :: Middleware
36 | limitRequestSize = requestSizeLimitMiddleware
37 | $ setOnLengthExceeded handler defaultRequestSizeLimitSettings
38 | where
39 | handler bytes _ _ respond = respond $ errorResponse Error
40 | { errHeaders = []
41 | , errStatus = status413
42 | , errDetail =
43 | Just $ "request entity larger than " <> tshow bytes <> " bytes"
44 | }
45 |
46 | -- | Limit request time and respond with JSON
47 | timeoutRequest :: Int -> Middleware
48 | timeoutRequest = timeoutAs $ errorResponse Error
49 | { errHeaders = []
50 | , errStatus = status503
51 | , errDetail = Nothing
52 | }
53 |
54 | -- | Allow GET and JSON POST from specified origin
55 | corsPolicy :: Text -> Request -> Maybe CorsResourcePolicy
56 | corsPolicy origin _ = pure CorsResourcePolicy
57 | { corsOrigins = Just ([encodeUtf8 origin], True)
58 | , corsMethods = simpleMethods
59 | , corsRequestHeaders = [hContentType]
60 | , corsExposedHeaders = Nothing
61 | , corsMaxAge = Nothing
62 | , corsVaryOrigin = True
63 | , corsRequireOrigin = True
64 | , corsIgnoreFailures = False
65 | }
66 |
--------------------------------------------------------------------------------
/backend/src/Backend/Database.hs:
--------------------------------------------------------------------------------
1 | module Backend.Database
2 | ( module X
3 | , HasSqlPool(..)
4 | , SqlPool
5 | , PostgresConf(..)
6 | , ConnectionString
7 | , newSqlPool
8 | , runDB
9 | , tryInsertKey
10 | , get404
11 | ) where
12 |
13 | import Backend.Prelude
14 |
15 | import Backend.Micro (notFound)
16 | import Database.Persist as X
17 | import Database.Persist.Postgresql
18 | (ConnectionString, PostgresConf(..), createPostgresqlPool)
19 | import Database.Persist.Sql (runSqlPool)
20 | import Database.PostgreSQL.Simple (SqlError(..))
21 |
22 | -- | 'SqlPool' == 'Pool' 'SqlBackend' == 'ConnectionPool'
23 | type SqlPool = ConnectionPool
24 |
25 | class HasSqlPool env where
26 | sqlPoolLens :: Lens' env SqlPool
27 |
28 | instance HasSqlPool SqlPool where
29 | sqlPoolLens = id
30 | {-# INLINE sqlPoolLens #-}
31 |
32 | -- | Execute a query using the sql pool from the ambient environment
33 | runDB
34 | :: forall env a m
35 | . (MonadUnliftIO m, MonadReader env m, HasSqlPool env)
36 | => SqlPersistT m a
37 | -> m a
38 | runDB act = runSqlPool act =<< view sqlPoolLens
39 |
40 | -- | Create a new connection pool
41 | newSqlPool
42 | :: forall m . (MonadUnliftIO m, MonadLoggerIO m) => PostgresConf -> m SqlPool
43 | newSqlPool PostgresConf {..} = createPostgresqlPool pgConnStr pgPoolSize
44 |
45 | -- | Attempt to insert an entity whose key may not be unique
46 | --
47 | -- Used for entities that use randomly generated keys that are likely
48 | -- but not guaranteed to be unique. Returns 'Nothing' if the insertion
49 | -- failed.
50 | --
51 | tryInsertKey
52 | :: ( MonadUnliftIO m
53 | , PersistEntity record
54 | , PersistEntityBackend record ~ SqlBackend
55 | )
56 | => Key record
57 | -> record
58 | -> SqlPersistT m (Maybe (Key record))
59 | tryInsertKey key record = do
60 | result <- try $ insertKey key record
61 | case result of
62 | Right{} -> pure $ Just key
63 | Left SqlError { sqlState = "23505" } -> pure Nothing
64 | Left e -> throwIO e
65 |
66 | -- | Fetch an entity or throw a 404
67 | get404
68 | :: ( MonadUnliftIO m
69 | , PersistEntity record
70 | , PersistEntityBackend record ~ SqlBackend
71 | )
72 | => Key record
73 | -> SqlPersistT m record
74 | get404 = maybe notFound pure <=< get
75 |
--------------------------------------------------------------------------------
/frontend/static/css/styles.css:
--------------------------------------------------------------------------------
1 | .add-margin-medium {
2 | margin-top: 15px;
3 | }
4 |
5 | .cursor-pointer {
6 | cursor: pointer;
7 | }
8 |
9 | .scroll-overflow {
10 | max-height: 600px;
11 | overflow-y: scroll;
12 | }
13 |
14 | .monospace-font,
15 | .preformatted,
16 | li.definition,
17 | li.expression {
18 | font-family: Menlo, Monaco, Consolas, "Courier New", monospace;
19 | }
20 |
21 | ul.unstyled {
22 | list-style: none;
23 | padding: 0;
24 | }
25 |
26 | li.definition,
27 | li.expression {
28 | font-size: 18px;
29 | margin-top: 10px;
30 | margin-bottom: 10px;
31 | }
32 |
33 | li.expression {
34 | color: #777;
35 | }
36 |
37 | li.expression:first-child {
38 | color: inherit;
39 | }
40 |
41 | .preformatted {
42 | white-space: pre;
43 | display: block;
44 | line-height: 1.43;
45 | page-break-inside: avoid;
46 | word-break: break-all;
47 | word-wrap: break-word;
48 | }
49 |
50 | .comment {
51 | font-style: italic;
52 | padding-left: 30px;
53 | }
54 |
55 | .highlight-function {
56 | text-decoration: underline 2px blue;
57 | -webkit-text-decoration: underline 2px blue;
58 | }
59 |
60 | .highlight-argument {
61 | text-decoration: underline 2px red;
62 | -webkit-text-decoration: underline 2px red;
63 | }
64 |
65 | .highlight-global {
66 | text-decoration: underline 2px lightgreen;
67 | -webkit-text-decoration: underline 2px lightgreen;
68 | }
69 |
70 | .overlay {
71 | display: flex;
72 | align-items: center;
73 | justify-content: center;
74 | background: rgba(0, 0, 0, 0.5);
75 | z-index: 100; /* Weirdly, bootstrap inputs have like z-index 3? */
76 | position : fixed;
77 | top: 0;
78 | left: 0;
79 | right: 0;
80 | bottom: 0;
81 | overflow-y: scroll;
82 | }
83 |
84 | .overlay-item {
85 | display: flex;
86 | flex-direction: column;
87 | position: relative;
88 | }
89 |
90 | .overlay-modal {
91 | min-width: 600px;
92 | }
93 |
94 | .spinner {
95 | position: relative;
96 | display: flex;
97 | justify-content: center;
98 | font-size: 20vh;
99 | color: rgba(127, 127, 127, 0.9);
100 | background: #4db3d7;
101 | border: 1px solid transparent;
102 | border-radius: 32px;
103 | padding: 24px;
104 | }
105 |
106 | .spin {
107 | animation: spin-right 2.2s infinite linear;
108 | }
109 |
110 | @keyframes spin-right {
111 | 0% {
112 | transform: rotate(0deg);
113 | }
114 |
115 | 100% {
116 | transform: rotate(359deg);
117 | }
118 | }
119 |
--------------------------------------------------------------------------------
/backend/src/Backend/Settings.hs:
--------------------------------------------------------------------------------
1 | module Backend.Settings
2 | ( Settings(..)
3 | , HasSettings(..)
4 | , load
5 | , parseSettings
6 | , parsePostgresConf
7 | ) where
8 |
9 | import Backend.Prelude
10 |
11 | import Backend.Database (ConnectionString, PostgresConf(..))
12 | import Env (Error, Parser, header, parse)
13 | import Network.URI (parseURI)
14 | import qualified Env
15 |
16 | data Settings = Settings
17 | { port :: Int
18 | , root :: Text
19 | , origin :: Text
20 | , logLevel :: LogLevel
21 | , timeout :: Int
22 | , postgresConf :: PostgresConf
23 | }
24 |
25 | instance Display Settings where
26 | display Settings{..} = mconcat
27 | [ "Settings {"
28 | , "\n PORT="
29 | , display port
30 | , ",\n ROOT="
31 | , display root
32 | , ",\n ORIGIN="
33 | , display origin
34 | , ",\n LOG_LEVEL="
35 | , displayShow logLevel
36 | , ",\n TIMEOUT="
37 | , display timeout
38 | , ",\n DATABASE_URL="
39 | --- Show instance for URI automatically redacts passwords
40 | , maybe "…" displayShow uri
41 | , ",\n PGPOOLSTRIPES="
42 | , display pgPoolStripes
43 | , ",\n PGPOOLIDLETIMEOUT="
44 | , display pgPoolIdleTimeout
45 | , ",\n PGPOOLSIZE="
46 | , display pgPoolSize
47 | , "\n}"
48 | ]
49 | where
50 | PostgresConf{..} = postgresConf
51 | uri = parseURI $ unpack $ decodeUtf8 pgConnStr
52 |
53 | class HasSettings env where
54 | settingsLens :: Lens' env Settings
55 |
56 | instance HasSettings Settings where
57 | settingsLens = id
58 | {-# INLINE settingsLens #-}
59 |
60 | load :: IO Settings
61 | load = parse (header "backend") parseSettings
62 |
63 | parseSettings :: Parser Error Settings
64 | parseSettings =
65 | Settings
66 | <$> Env.var Env.auto "PORT" (Env.def 3000)
67 | <*> Env.var Env.str "ROOT" (Env.def "http://api.localhost.com:3000")
68 | <*> Env.var Env.str "ORIGIN" (Env.def "http://localhost.com:1234")
69 | <*> Env.var Env.auto "LOG_LEVEL" (Env.def LevelInfo)
70 | <*> Env.var Env.auto "TIMEOUT" (Env.def 20)
71 | <*> parsePostgresConf
72 |
73 | parsePostgresConf :: Parser Error PostgresConf
74 | parsePostgresConf =
75 | PostgresConf
76 | <$> Env.var Env.str "DATABASE_URL" (Env.def defaultUrl)
77 | <*> Env.var Env.auto "PGPOOLSTRIPES" (Env.def 1)
78 | <*> Env.var Env.auto "PGPOOLIDLETIMEOUT" (Env.def 20)
79 | <*> Env.var Env.auto "PGPOOLSIZE" (Env.def 10)
80 |
81 | defaultUrl :: ConnectionString
82 | defaultUrl = "postgres://postgres:password@localhost:5432/lambda"
83 |
--------------------------------------------------------------------------------
/frontend/src/Components/Markup.purs:
--------------------------------------------------------------------------------
1 | -- | Simplified, fixed-depth markup for tutorial and errors
2 | module Components.Markup
3 | ( module X
4 | , Markup
5 | , Note
6 | , Leaf
7 | , markup
8 | , title
9 | , para
10 | , code
11 | , notes
12 | , note
13 | , (?~)
14 | , text
15 | , bold
16 | , mono
17 | , link
18 | ) where
19 |
20 | import Lambda.Prelude hiding (note)
21 |
22 | import React.Basic (JSX) as X
23 | import React.Basic (JSX, fragment)
24 | import React.Basic.DOM as R
25 |
26 | -- | Nodes that can have children
27 | newtype Markup = Markup JSX
28 |
29 | -- | Nodes without children
30 | newtype Leaf = Leaf JSX
31 |
32 | -- | Nodes with a focus and a sequence of annotations
33 | newtype Note = Note JSX
34 |
35 | -- | Coerce `Markup` to `JSX
36 | markup :: Array Markup -> JSX
37 | markup = fragment <<< coerce
38 |
39 | -- | Title fixed to h3
40 | title :: String -> Markup
41 | title = coerce <<< R.h3_ <<< pure <<< R.text
42 |
43 | -- | Paragraph containing only leaf nodes
44 | para :: Array Leaf -> Markup
45 | para = coerce <<< R.p_ <<< coerce
46 |
47 | -- | Preformatted block of text lines
48 | code :: Array String -> Markup
49 | code xs = coerce $ R.p
50 | { className: "preformatted"
51 | , children: formatPre <$> xs
52 | }
53 |
54 | -- | Preformatted block of text lines each with zero or more annotations
55 | notes :: Array Note -> Markup
56 | notes xs = coerce $ R.table_
57 | [ R.tbody_ $ coerce xs
58 | ]
59 |
60 | -- | Preformatted text line with zero or more annotations
61 | note :: String -> Array Leaf -> Note
62 | note x xs = coerce $ R.tr_
63 | [ R.td_
64 | [ R.span
65 | { className: "preformatted"
66 | , children: [formatPre x]
67 | }
68 | ]
69 | , R.td
70 | { className: "comment"
71 | , children: coerce xs
72 | }
73 | ]
74 |
75 | infix 1 note as ?~
76 |
77 | -- | Body text
78 | text :: String -> Leaf
79 | text = coerce <<< R.text
80 |
81 | -- | Bold text
82 | bold :: String -> Leaf
83 | bold = coerce <<< R.strong_ <<< pure <<< R.text
84 |
85 | -- | Monospaced text
86 | mono :: String -> Leaf
87 | mono x = coerce $ R.span
88 | { className: "monospace-font"
89 | , children: [R.text x]
90 | }
91 |
92 | -- | Anchor
93 | link :: { this :: String, to :: String } -> Leaf
94 | link { this, to: url } = coerce $ R.a
95 | { href: "https://" <> url
96 | , target: "_blank"
97 | , rel: "noopener"
98 | , children: [R.text this]
99 | }
100 |
101 | formatPre :: String -> JSX
102 | formatPre x = R.text $ " " <> x <> "\n"
103 |
--------------------------------------------------------------------------------
/backend/src/Backend/Snapshot.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE QuasiQuotes #-}
2 | {-# LANGUAGE TemplateHaskell #-}
3 | {-# LANGUAGE UndecidableInstances #-}
4 |
5 | module Backend.Snapshot
6 | ( ApiSnapshot(..)
7 | , Snapshot(..)
8 | , SnapshotId
9 | , EntityField(..)
10 | , Key(SnapshotKey)
11 | , fetch
12 | , store
13 | ) where
14 |
15 | import Backend.Prelude
16 |
17 | import Backend.Code (Code)
18 | import qualified Backend.Code as Code
19 | import Backend.Database (HasSqlPool, get404, getBy, runDB, tryInsertKey)
20 | import Backend.Micro (internalError)
21 | import Backend.Name (Name)
22 | import Backend.Random (HasRandom)
23 | import Backend.Signature (Signature)
24 | import Control.Monad.Trans.Maybe (MaybeT(..))
25 | import Database.Persist.TH (mkPersist, persistLowerCase, sqlSettings)
26 |
27 | -- | API-level 'Snapshot'
28 | data ApiSnapshot = ApiSnapshot
29 | { sig :: Signature
30 | , names :: [Name]
31 | , state :: [Int32]
32 | }
33 | deriving stock (Eq, Show, Generic)
34 | deriving anyclass (ToJSON, FromJSON, Default)
35 |
36 | mkPersist sqlSettings [persistLowerCase|
37 | Snapshot sql=snapshots
38 | Id Code
39 | signature Signature
40 | names (JSONB [Name])
41 | state (JSONB [Int32])
42 | UniqueSnapshot signature names state
43 | deriving Eq Show
44 | |]
45 |
46 | instance Default Snapshot where
47 | def = Snapshot def (JSONB []) (JSONB [])
48 |
49 | -- | Fetch 'ApiSnapshot' by 'Code'
50 | fetch :: MonadUnliftIO m => Code -> SqlPersistT m ApiSnapshot
51 | fetch key = do
52 | Snapshot {..} <- get404 $ SnapshotKey key
53 | pure ApiSnapshot
54 | { sig = snapshotSignature
55 | , names = unJSONB snapshotNames
56 | , state = unJSONB snapshotState
57 | }
58 |
59 | -- | Store 'ApiSnapshot' returning 'Code'
60 | --
61 | -- Attempts to find an identical 'Snapshot' before storing the new one.
62 | -- Runs in 'RIO' instead of 'SqlPersistT' since 'tryInsertKey' uses
63 | -- exceptions to detect unique violations.
64 | --
65 | store :: (HasSqlPool env, HasRandom env) => ApiSnapshot -> RIO env Code
66 | store ApiSnapshot {..} = unSnapshotKey <$> loop 0
67 | where
68 | loop n
69 | | n >= maxAttempts = internalError message
70 | | otherwise = do
71 | key <- SnapshotKey <$> Code.new
72 | result <- runDB $ runMaybeT $ asum
73 | [ MaybeT $ entityKey <$$> getBy uniqueKey
74 | , MaybeT $ tryInsertKey key snapshot
75 | ]
76 | maybe (loop $ n + 1) pure result
77 |
78 | uniqueKey = UniqueSnapshot sig (JSONB names) (JSONB state)
79 | snapshot = Snapshot sig (JSONB names) (JSONB state)
80 |
81 | maxAttempts = 10 :: Int
82 | message = mconcat
83 | ["Failed to generate unique code in ", tshow maxAttempts, " attempts"]
84 |
--------------------------------------------------------------------------------
/backend/brittany.yaml:
--------------------------------------------------------------------------------
1 | ---
2 | conf_debug:
3 | dconf_roundtrip_exactprint_only: false
4 | dconf_dump_bridoc_simpl_par: false
5 | dconf_dump_ast_unknown: false
6 | dconf_dump_bridoc_simpl_floating: false
7 | dconf_dump_config: false
8 | dconf_dump_bridoc_raw: false
9 | dconf_dump_bridoc_final: false
10 | dconf_dump_bridoc_simpl_alt: false
11 | dconf_dump_bridoc_simpl_indent: false
12 | dconf_dump_annotations: false
13 | dconf_dump_bridoc_simpl_columns: false
14 | dconf_dump_ast_full: false
15 | conf_forward:
16 | options_ghc:
17 | - -XBangPatterns
18 | - -XBinaryLiterals
19 | - -XConstraintKinds
20 | - -XDataKinds
21 | - -XDefaultSignatures
22 | - -XDeriveAnyClass
23 | - -XDeriveDataTypeable
24 | - -XDeriveFoldable
25 | - -XDeriveFunctor
26 | - -XDeriveGeneric
27 | - -XDeriveTraversable
28 | - -XDerivingStrategies
29 | - -XDerivingVia
30 | - -XEmptyDataDecls
31 | - -XExistentialQuantification
32 | - -XFlexibleContexts
33 | - -XFlexibleInstances
34 | - -XFunctionalDependencies
35 | - -XGADTs
36 | - -XGeneralizedNewtypeDeriving
37 | - -XInstanceSigs
38 | - -XKindSignatures
39 | - -XLambdaCase
40 | - -XMultiParamTypeClasses
41 | - -XMultiWayIf
42 | - -XNamedFieldPuns
43 | - -XNoImplicitPrelude
44 | - -XNoMonomorphismRestriction
45 | - -XOverloadedStrings
46 | - -XPartialTypeSignatures
47 | - -XPatternGuards
48 | - -XPolyKinds
49 | - -XRankNTypes
50 | - -XRecordWildCards
51 | - -XScopedTypeVariables
52 | - -XStandaloneDeriving
53 | - -XTupleSections
54 | - -XTypeApplications
55 | - -XTypeFamilies
56 | - -XTypeFamilyDependencies
57 | - -XTypeOperators
58 | - -XTypeSynonymInstances
59 | conf_errorHandling:
60 | econf_ExactPrintFallback: ExactPrintFallbackModeInline
61 | econf_Werror: false
62 | econf_omit_output_valid_check: false
63 | econf_produceOutputOnErrors: false
64 | conf_preprocessor:
65 | ppconf_CPPMode: CPPModeAbort
66 | ppconf_hackAroundIncludes: false
67 | conf_obfuscate: false
68 | conf_roundtrip_exactprint_only: false
69 | conf_version: 1
70 | conf_layout:
71 | lconfig_reformatModulePreamble: true
72 | lconfig_altChooser:
73 | tag: AltChooserBoundedSearch
74 | contents: 3
75 | lconfig_allowSingleLineExportList: false
76 | lconfig_importColumn: 60
77 | lconfig_hangingTypeSignature: false
78 | lconfig_importAsColumn: 60
79 | lconfig_alignmentLimit: 1
80 | lconfig_indentListSpecial: true
81 | lconfig_indentAmount: 2
82 | lconfig_alignmentBreakOnMultiline: true
83 | lconfig_cols: 80
84 | lconfig_indentPolicy: IndentPolicyLeft
85 | lconfig_indentWhereSpecial: true
86 | lconfig_columnAlignMode:
87 | tag: ColumnAlignModeDisabled
88 | contents: 0.7
89 |
--------------------------------------------------------------------------------
/backend/package.yaml:
--------------------------------------------------------------------------------
1 | name: backend
2 | version: 0.1.0.0
3 | license: MIT
4 | author: "Christopher D. Parks"
5 | maintainer: "christopher.daniel.parks@gmail.com"
6 | copyright: "2021 Christopher D. Parks"
7 |
8 | # To avoid duplicated efforts in documentation and dealing with the
9 | # complications of embedding Haddock markup inside cabal files, it is
10 | # common to point users to the README.md file.
11 | description: Please see the README on GitHub at
12 |
13 | default-extensions:
14 | - BangPatterns
15 | - BinaryLiterals
16 | - ConstraintKinds
17 | - DataKinds
18 | - DefaultSignatures
19 | - DeriveAnyClass
20 | - DeriveDataTypeable
21 | - DeriveFoldable
22 | - DeriveFunctor
23 | - DeriveGeneric
24 | - DeriveTraversable
25 | - DerivingStrategies
26 | - DerivingVia
27 | - EmptyDataDecls
28 | - ExistentialQuantification
29 | - FlexibleContexts
30 | - FlexibleInstances
31 | - FunctionalDependencies
32 | - GADTs
33 | - GeneralizedNewtypeDeriving
34 | - InstanceSigs
35 | - KindSignatures
36 | - LambdaCase
37 | - MultiParamTypeClasses
38 | - MultiWayIf
39 | - NamedFieldPuns
40 | - NoImplicitPrelude
41 | - NoMonomorphismRestriction
42 | - OverloadedStrings
43 | - PartialTypeSignatures
44 | - PatternGuards
45 | - PolyKinds
46 | - RankNTypes
47 | - RecordWildCards
48 | - RoleAnnotations
49 | - ScopedTypeVariables
50 | - StandaloneDeriving
51 | - StandaloneKindSignatures
52 | - TupleSections
53 | - TypeApplications
54 | - TypeFamilies
55 | - TypeFamilyDependencies
56 | - TypeOperators
57 | - TypeSynonymInstances
58 |
59 | library:
60 | source-dirs: src
61 | dependencies:
62 | - aeson
63 | - attoparsec
64 | - base >= 4.7 && < 5
65 | - data-default
66 | - envparse
67 | - errors
68 | - esqueleto
69 | - http-api-data
70 | - http-types
71 | - monad-logger
72 | - mtl
73 | - mwc-random
74 | - network-uri
75 | - path-pieces
76 | - persistent
77 | - persistent-postgresql
78 | - postgresql-simple
79 | - random
80 | - rio
81 | - rio-orphans
82 | - text
83 | - transformers
84 | - vector
85 | - wai
86 | - wai-cors
87 | - wai-extra
88 | - warp
89 |
90 | executables:
91 | serve:
92 | main: Main.hs
93 | source-dirs: app
94 | ghc-options:
95 | - -threaded
96 | - -rtsopts
97 | - -with-rtsopts=-N
98 | dependencies:
99 | - backend
100 | - base
101 |
102 | tests:
103 | spec:
104 | main: Spec.hs
105 | source-dirs: test
106 | ghc-options:
107 | - -threaded
108 | - -rtsopts
109 | - -with-rtsopts=-N
110 | dependencies:
111 | - aeson
112 | - backend
113 | - base
114 | - hspec
115 | - hspec-expectations-lifted
116 | - hspec-wai
117 | - hspec-wai-json
118 | - HUnit
119 | - lens-aeson
120 | - load-env
121 | - wai-extra
122 |
--------------------------------------------------------------------------------
/backend/src/Backend/Code.hs:
--------------------------------------------------------------------------------
1 | module Backend.Code
2 | ( Code
3 | , new
4 | , parse
5 | , ParseError(..)
6 | ) where
7 |
8 | import Backend.Prelude
9 |
10 | import Backend.Random (HasRandom)
11 | import qualified Backend.Random as Random
12 | import qualified Data.Text as Text
13 | import Data.Vector ((!))
14 | import qualified Data.Vector as V
15 | import Text.Read (Read(..))
16 |
17 | -- | Random 8-character code using 32 unambiguous characters
18 | --
19 | -- See http://www.crockford.com/base32.html. We're not encoding
20 | -- anything, just trying to make semi-readable non-numeric ids.
21 | --
22 | newtype Code = Code Text
23 | deriving newtype (Eq, Show, Ord, Hashable, ToJSON, ToHttpApiData, PersistField, PersistFieldSql)
24 |
25 | -- | Throws on invalid 'Code's; used only for testing
26 | instance IsString Code where
27 | fromString = either (error . unpack . textDisplay) id . parse . fromString
28 |
29 | -- | Errors encountered during parsing
30 | data ParseError
31 | = -- | Code must be 8 characters long
32 | WrongLength Text
33 | | -- | Code must only consist of characters from 'alphabet'
34 | UnrecognizedCharacters Text
35 | deriving stock (Eq, Show)
36 |
37 | instance Display ParseError where
38 | display = \case
39 | WrongLength text -> "wrong length for code: " <> display text
40 | UnrecognizedCharacters text ->
41 | "unrecognized characters in code: " <> display text
42 |
43 | instance PathPiece Code where
44 | toPathPiece = coerce
45 | fromPathPiece = hush . parse
46 |
47 | instance FromHttpApiData Code where
48 | parseUrlPiece = first textDisplay . parse
49 |
50 | instance FromJSON Code where
51 | parseJSON =
52 | withText "Code" $ either (fail . unpack . textDisplay) pure . parse
53 |
54 | instance Read Code where
55 | readsPrec _ = either mempty ok . parse . pack where ok code = [(code, "")]
56 |
57 | -- | Generate a new random 'Code'
58 | new :: forall env . HasRandom env => RIO env Code
59 | new = Code . pack <$> replicateM size char
60 | where char = (alphabet !) <$> Random.range (0, lastIndex)
61 |
62 | -- | Parse 'Code' from 'Text'
63 | parse :: Text -> Either ParseError Code
64 | parse raw
65 | | Text.length upper /= size = Left $ WrongLength raw
66 | | Text.any (`notElem` alphabet) upper = Left $ UnrecognizedCharacters raw
67 | | otherwise = pure $ Code upper
68 | where upper = Text.toUpper raw
69 |
70 | -- | Set of allowed characters
71 | --
72 | -- NOINLINE - compute once and store as a CAF.
73 | alphabet :: Vector Char
74 | alphabet = V.fromList $ ['0' .. '9'] <> filter unambiguous ['A' .. 'Z']
75 | where unambiguous = (`notElem` ("ILOU" :: String))
76 | {-# NOINLINE alphabet #-}
77 |
78 | -- | Last valid index into 'alphabet'
79 | --
80 | -- NOINLINE - compute once and store as a CAF.
81 | lastIndex :: Int
82 | lastIndex = V.length alphabet - 1
83 | {-# NOINLINE lastIndex #-}
84 |
85 | -- | 'Code' is always 8 characters long
86 | size :: Int
87 | size = 8
88 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Prelude.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Prelude
2 | ( module Prelude
3 | , module X
4 | , withReader
5 | , withState
6 | , runIdentity
7 | , map2
8 | , (<$$>)
9 | ) where
10 |
11 | import Prelude
12 |
13 | import Control.Alt ((<|>)) as X
14 | import Control.Monad.Error.Class (class MonadThrow, class MonadError, throwError, catchError) as X
15 | import Control.Monad.Except.Trans (ExceptT, runExceptT) as X
16 | import Control.Monad.Reader (Reader, runReader) as X
17 | import Control.Monad.Reader.Class (class MonadAsk, class MonadReader, ask, asks, local) as X
18 | import Control.Monad.Reader.Trans (ReaderT, runReaderT) as X
19 | import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM) as X
20 | import Control.Monad.State (State, evalState, execState, runState) as X
21 | import Control.Monad.State.Class (class MonadState, gets, get, modify_, put) as X
22 | import Control.Monad.State.Trans (StateT, evalStateT, execStateT, runStateT) as X
23 | import Control.MonadZero (guard) as X
24 | import Data.Argonaut.Core (stringify) as X
25 | import Data.Argonaut.Decode (class DecodeJson, decodeJson, JsonDecodeError(..), printJsonDecodeError) as X
26 | import Data.Argonaut.Encode (class EncodeJson, encodeJson) as X
27 | import Data.Bifunctor (class Bifunctor, bimap, lmap, rmap) as X
28 | import Data.Either (Either(..), either, hush, note) as X
29 | import Data.Foldable (class Foldable, fold, foldr, foldl, foldM, foldMap, for_, traverse_, sequence_) as X
30 | import Data.Generic.Rep (class Generic) as X
31 | import Data.HashMap (HashMap) as X
32 | import Data.HashSet (HashSet) as X
33 | import Data.Hashable (class Hashable, hash) as X
34 | import Data.Identity (Identity(..)) as X
35 | import Data.List (List(..), (:)) as X
36 | import Data.Map (Map) as X
37 | import Data.Maybe (Maybe(..), fromMaybe', fromMaybe, maybe, maybe', isJust, isNothing) as X
38 | import Data.Monoid (class Monoid, mempty) as X
39 | import Data.Newtype (class Newtype, un, wrap, unwrap) as X
40 | import Data.Semigroup (class Semigroup, append, (<>)) as X
41 | import Data.Set (Set) as X
42 | import Data.Show.Generic (genericShow) as X
43 | import Data.Traversable (class Traversable, traverse, for) as X
44 | import Data.Tuple (Tuple(..), uncurry, fst, snd) as X
45 | import Data.Tuple.Nested ((/\)) as X
46 | import Data.Unfoldable (class Unfoldable, replicate, replicateA) as X
47 | import Debug (trace, traceM, spy, debugger) as X
48 | import Effect (Effect) as X
49 | import Effect.Aff (Aff) as X
50 | import Effect.Class (liftEffect) as X
51 | import Safe.Coerce (class Coercible, coerce) as X
52 |
53 | --- | Flipped runReader
54 | withReader :: forall a r. r -> X.Reader r a -> a
55 | withReader = flip X.runReader
56 |
57 | --- | Flipped evalState
58 | withState :: forall a s. s -> X.State s a -> a
59 | withState = flip X.evalState
60 |
61 | -- | Not included in Data.Identity anymore
62 | runIdentity :: forall a. X.Identity a -> a
63 | runIdentity = X.unwrap
64 |
65 | map2 :: forall a b f g. Functor f => Functor g => (a -> b) -> f (g a) -> f (g b)
66 | map2 f = map (map f)
67 | infixl 4 map2 as <$$>
68 |
--------------------------------------------------------------------------------
/frontend/src/Data/Queue.purs:
--------------------------------------------------------------------------------
1 | module Data.Queue
2 | ( Queue
3 | , fromFoldable
4 | , toUnfoldable
5 | , empty
6 | , singleton
7 | , pop
8 | , push
9 | , extend
10 | , valid
11 | ) where
12 |
13 | import Lambda.Prelude
14 |
15 | import Data.Array as Array
16 | import Data.List as List
17 | import Data.Traversable (sequenceDefault)
18 | import Test.QuickCheck (class Arbitrary, arbitrary)
19 |
20 | -- | Okasaki-style queue with amortized constant push and pop
21 | newtype Queue a = Queue
22 | { front :: List a
23 | , back :: List a
24 | }
25 |
26 | instance showQueue :: Show a => Show (Queue a) where
27 | show q = "fromFoldable " <> show (Array.fromFoldable q)
28 |
29 | instance eqQueue :: Eq a => Eq (Queue a) where
30 | eq lhs rhs = eq (toList lhs) (toList rhs)
31 |
32 | instance functorQueue :: Functor Queue where
33 | map f (Queue {front, back}) = queue (f <$> front) (f <$> back)
34 |
35 | instance foldableQueue :: Foldable Queue where
36 | foldr f z = foldr f z <<< toList
37 | foldl f z = foldl f z <<< toList
38 | foldMap f = foldMap f <<< toList
39 |
40 | instance traversableQueue :: Traversable Queue where
41 | traverse f =
42 | map (flip queue Nil)
43 | <<< traverse f
44 | <<< toList
45 | sequence = sequenceDefault
46 |
47 | instance arbitraryQueue :: Arbitrary a => Arbitrary (Queue a) where
48 | arbitrary = queue <$> arbitrary <*> arbitrary
49 |
50 | -- | Convert any `Foldable` to a `Queue`, O(n)
51 | fromFoldable :: forall a f. Foldable f => f a -> Queue a
52 | fromFoldable = flip queue Nil <<< List.fromFoldable
53 |
54 | -- | Convert a `Queue` to any `Unfoldable`, O(n)
55 | toUnfoldable :: forall a f. Unfoldable f => Queue a -> f a
56 | toUnfoldable = List.toUnfoldable <<< toList
57 |
58 | -- | The empty `Queue`, O(1)
59 | empty :: forall a. Queue a
60 | empty = queue Nil Nil
61 |
62 | -- | A `Queue` with only one element, O(1)
63 | singleton :: forall a. a -> Queue a
64 | singleton a = queue (a:Nil) Nil
65 |
66 | -- | Convert a `Queue` into a `List`, O(n)
67 | toList :: forall a. Queue a -> List a
68 | toList (Queue { front, back }) = front <> List.reverse back
69 |
70 | -- | Push an element onto the back of the `Queue`, amortized O(1)
71 | push :: forall a. Queue a -> a -> Queue a
72 | push (Queue {front, back}) x = queue front $ x : back
73 |
74 | -- | Pop an element off of the front of the `Queue`, amortized O(1)
75 | pop :: forall a. Queue a -> Maybe (Tuple a (Queue a))
76 | pop (Queue {front, back}) = case front of
77 | Nil -> Nothing
78 | Cons x xs -> Just $ Tuple x $ queue xs back
79 |
80 | -- | Push each element of a `Foldable` value onto the back of the `Queue`, amortized O(n)
81 | extend :: forall a f. Foldable f => Queue a -> f a -> Queue a
82 | extend = foldl push
83 |
84 | -- | Maintain the invariant that a non-empty `Queue` has a non-empty front list
85 | queue :: forall a. List a -> List a -> Queue a
86 | queue front back = case front of
87 | Nil -> Queue {front: List.reverse back, back: Nil}
88 | _ -> Queue {front, back}
89 |
90 | -- | Validate that the invariant is maintained
91 | valid :: forall a. Queue a -> Boolean
92 | valid (Queue {front, back}) = not (List.null front) || List.null back
93 |
--------------------------------------------------------------------------------
/frontend/src/Components/Copy.purs:
--------------------------------------------------------------------------------
1 | module Components.Copy
2 | ( new
3 | ) where
4 |
5 | import Lambda.Prelude
6 |
7 | import Effect.Aff (delay, Milliseconds(..))
8 | import Effect.Copy as Copy
9 | import React.Basic.DOM as R
10 | import React.Basic.DOM.Events (preventDefault)
11 | import React.Basic.Events (handler, handler_)
12 | import React.Basic.Hooks (Component, component, useState)
13 | import React.Basic.Hooks as Hooks
14 | import React.Basic.Hooks.Aff (useAff)
15 |
16 | type Props =
17 | { text :: String
18 | }
19 |
20 | data Copying
21 | = Ready
22 | | Copying
23 | | DidCopy
24 | | NoCopy
25 |
26 | derive instance eqCopying :: Eq Copying
27 |
28 | new :: Component Props
29 | new = component "Copy" \{ text } -> Hooks.do
30 | copying /\ setCopying <- useState Ready
31 | _ <- useAff (Tuple text copying) do
32 | case copying of
33 | Ready -> pure unit
34 | NoCopy -> pure unit
35 | Copying -> do
36 | result <- Copy.copy text
37 | -- Artificial delay to avoid flash
38 | delay $ Milliseconds 300.0
39 | liftEffect $ setCopying $ const $ case result of
40 | Left _ -> NoCopy
41 | Right _ -> DidCopy
42 | DidCopy -> do
43 | delay $ Milliseconds 1000.0
44 | liftEffect $ setCopying $ const Ready
45 |
46 | let
47 | startCopying = setCopying $ const Copying
48 | copyButton = case copying of
49 | Ready -> R.button
50 | { className
51 | , style
52 | , "type": "submit"
53 | , onClick: handler_ startCopying
54 | , children: copyIcon "Copy to Clipboard"
55 | }
56 | Copying -> R.button
57 | { className
58 | , style
59 | , disabled: true
60 | , "type": "submit"
61 | , children: copyIcon "Copying…"
62 | }
63 | DidCopy -> R.button
64 | { className
65 | , style
66 | , "type": "submit"
67 | , onClick: handler_ startCopying
68 | , children: copyIcon "Copied!"
69 | }
70 | NoCopy -> R.button
71 | { className
72 | , style
73 | , disabled: true
74 | , "type": "submit"
75 | , children: copyIcon "Copy Manually"
76 | }
77 |
78 | pure $ R.form
79 | { onSubmit: handler preventDefault $ const $ pure unit
80 | , children:
81 | [ R.div
82 | { className: "input-group"
83 | , children:
84 | [ R.input
85 | { className: "form-control"
86 | , readOnly: true
87 | , autoComplete: "off"
88 | , autoCorrect: "off"
89 | , autoCapitalize: "off"
90 | , spellCheck: false
91 | , value: text
92 | }
93 | , R.div
94 | { className: "input-group-btn"
95 | , children: [copyButton]
96 | }
97 | ]
98 | }
99 | ]
100 | }
101 | where
102 | className = "btn btn-default"
103 | style = R.css { width: "160px" }
104 | copyIcon label =
105 | [ R.span
106 | { className: "glyphicon glyphicon-copy"
107 | , children: []
108 | }
109 | , R.text $ " " <> label
110 | ]
111 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Pretty.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Pretty
2 | ( class Pretty
3 | , pretty
4 | , Rep(..)
5 | , parensIf
6 | , select
7 | , toggle
8 | , Builder
9 | , text
10 | , style
11 | , toJSX
12 | , toString
13 | )
14 | where
15 |
16 | import Lambda.Prelude
17 |
18 | import React.Basic (JSX)
19 | import React.Basic.DOM as R
20 |
21 | data Rep = Raw | Sugar
22 |
23 | derive instance eqRep :: Eq Rep
24 |
25 | -- | Pretty-print some structure to a Builder
26 | class Pretty a where
27 | pretty :: Rep -> a -> Builder
28 |
29 | -- | Wrap with parentheses if condition is true
30 | parensIf :: Boolean -> Builder -> Builder
31 | parensIf cond body
32 | | cond = text "(" <> body <> text ")"
33 | | otherwise = body
34 |
35 | -- | Select from object based on 'Rep'
36 | select :: forall a. Rep -> { sugar :: a, raw :: a } -> a
37 | select rep {sugar, raw} = case rep of
38 | Sugar -> sugar
39 | Raw -> raw
40 |
41 | -- | Toggle 'Rep'
42 | toggle :: Rep -> Rep
43 | toggle = case _ of
44 | Sugar -> Raw
45 | Raw -> Sugar
46 |
47 | -- | (<>) for JSX is really slow if you have lots of text fragments.
48 | -- | By combining adjacent text, and _then_ going to JSX, we create
49 | -- | way fewer DOM nodes.
50 | newtype Builder = Builder (Node -> Node)
51 |
52 | instance semigroupBuilder :: Semigroup Builder where
53 | append (Builder lhs) (Builder rhs) = Builder $ lhs <<< rhs
54 |
55 | instance monoidBuilder :: Monoid Builder where
56 | mempty = Builder identity
57 |
58 | -- | Appends are right-associated by construction since
59 | -- | Nodes cannot appear as their left operand
60 | data Node
61 | = Leaf Leaf
62 | | Append Leaf Node
63 |
64 | -- | Technically Style is a "node", but it acts like a leaf for Append
65 | data Leaf
66 | = Empty
67 | | Text String
68 | | Style String Node
69 |
70 | -- | Text node automatically coalesces adjacent text
71 | text :: String -> Builder
72 | text s = Builder $ case _ of
73 | Leaf Empty -> Leaf $ Text s
74 | Leaf (Text t) -> Leaf $ Text $ s <> t
75 | Append (Text t) rhs -> Append (Text $ s <> t) rhs
76 | node -> Append (Text s) node
77 |
78 | -- | Style node using CSS classname
79 | style :: String -> Builder -> Builder
80 | style cls (Builder f) = Builder $ Append $ Style cls $ f $ Leaf Empty
81 |
82 | -- | Render builder to JSX
83 | toJSX :: Builder -> JSX
84 | toJSX = buildWith R.text \className node -> R.span
85 | { className
86 | , children: [node]
87 | }
88 |
89 | -- | Render builder to text
90 | toString :: Builder -> String
91 | toString = buildWith identity \_ -> identity
92 |
93 | -- | Convert Builder to actual representation
94 | buildWith
95 | :: forall r
96 | . Monoid r
97 | => (String -> r)
98 | -- ^ Generate text representation
99 | -> (String -> r -> r)
100 | -- ^ Generate styled representation
101 | -> Builder
102 | -> r
103 | buildWith onText onStyle (Builder f) = onNode $ f $ Leaf Empty
104 | where
105 | onNode = case _ of
106 | Leaf leaf -> onLeaf leaf
107 | Append leaf node -> onLeaf leaf <> onNode node
108 |
109 | onLeaf = case _ of
110 | Empty -> mempty
111 | Text t -> onText t
112 | Style className node -> onStyle className $ onNode node
113 |
--------------------------------------------------------------------------------
/frontend/test/Lambda/Language/WorldSpec.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.WorldSpec
2 | ( spec
3 | ) where
4 |
5 | import Test.Prelude
6 |
7 | import Data.Map as Map
8 | import Data.Set as Set
9 | import Lambda.Language.Name as Name
10 | import Lambda.Language.World (World(..), ConsistencyError(..), Entity(..))
11 | import Lambda.Language.World as World
12 |
13 | spec :: Spec Unit
14 | spec = describe "Lambda.Language.World" do
15 | describe "World.define" do
16 | it "disallows definitions that depend on non-extant names" do
17 | let
18 | world = World.new []
19 | result = uncurry World.define (mkBind "x = y") world
20 | result `shouldEqual` Left (Undefined $ Set.singleton y)
21 |
22 | it "allows definitions that depend on extant names" do
23 | let
24 | world = World.new [mkBind "y = λa. a"]
25 | result = uncurry World.define (mkBind "x = y") world
26 | expected = Right $ mkWorld
27 | [ Tuple (Global y) [Global x]
28 | , Tuple (Global x) []
29 | ]
30 | result `shouldEqual` expected
31 |
32 | it "disallows redefining names that depend on extant names" do
33 | let
34 | world = World.new [mkBind "y x = x", mkBind "x = y y"]
35 | result = uncurry World.define (mkBind "y = 1") world
36 | result `shouldEqual` Left (CannotRedefine y $ Set.singleton $ Global x)
37 |
38 | describe "World.undefine" do
39 | it "disallows deleting definitions that have dependencies" do
40 | let
41 | world = World.new [mkBind "y a = a", mkBind "x = y"]
42 | result = World.undefine y world
43 | result `shouldEqual` Left (CannotDelete y $ Set.singleton $ Global x)
44 |
45 | it "allows deleting definitions that have no dependencies" do
46 | let
47 | world = World.new [mkBind "y = λa. a", mkBind "x = y"]
48 | result = World.undefine x world
49 | result `shouldEqual` Right (mkWorld [Tuple (Global y) []])
50 |
51 | describe "World.focus" do
52 | it "disallows root expressions that depend on non-extant names" do
53 | let
54 | world = World.new []
55 | result = World.focus (mkAnon "y") world
56 | result `shouldEqual` Left (Undefined $ Set.singleton y)
57 |
58 | it "allows root expressions that depend on extant names" do
59 | let
60 | world = World.new [mkBind "y = λa. a"]
61 | result = World.focus (mkAnon "y") world
62 | expected = Right $ mkWorld
63 | [ Tuple (Global y) [Root]
64 | , Tuple Root []
65 | ]
66 | result `shouldEqual` expected
67 |
68 | describe "World.unfocus" do
69 | it "removes root as a dependency" do
70 | let
71 | world = World.focus (mkAnon "y") $ World.new [mkBind "y = λa. a"]
72 | result = World.unfocus <$> world
73 | result `shouldEqual` Right (mkWorld [Tuple (Global y) []])
74 |
75 | it "has no effect if world has no focus" do
76 | let
77 | world = World.new [mkBind "y = λa. a"]
78 | result = World.unfocus world
79 | result `shouldEqual` world
80 |
81 | x :: Name
82 | x = Name.from "x"
83 |
84 | y :: Name
85 | y = Name.from "y"
86 |
87 | mkWorld :: Array (Tuple Entity (Array Entity)) -> World
88 | mkWorld = World <<< Map.fromFoldable <<< map (map Set.fromFoldable)
89 |
--------------------------------------------------------------------------------
/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 christopher.daniel.parks@gmail.com. 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 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Parser.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Parser
2 | ( class Parse
3 | , parse
4 | , Parser
5 | , run
6 | , liftJson
7 | , unsafeRun
8 | , formatParseError
9 | , token
10 | , balance
11 | , parens
12 | , brackets
13 | , module X
14 | ) where
15 |
16 | import Lambda.Prelude hiding (between)
17 |
18 | import Data.Array as Array
19 | import Data.String.CodeUnits (fromCharArray)
20 | import Partial.Unsafe (unsafeCrashWith)
21 | import Text.Parsing.Parser (ParseError, parseErrorMessage, parseErrorPosition, runParser)
22 | import Text.Parsing.Parser (fail, ParseError) as X
23 | import Text.Parsing.Parser as Parser
24 | import Text.Parsing.Parser.Combinators (between)
25 | import Text.Parsing.Parser.Combinators (between, option, optionMaybe, optional, sepBy, sepBy1, try) as X
26 | import Text.Parsing.Parser.Pos (Position(..))
27 | import Text.Parsing.Parser.String (char, eof, skipSpaces)
28 | import Text.Parsing.Parser.String (char, satisfy, skipSpaces, string) as X
29 |
30 | -- | All of our parsers work over strings
31 | type Parser r = Parser.Parser String r
32 |
33 | -- | Parse some structure from a string
34 | class Parse a where
35 | parse :: Parser a
36 |
37 | -- | Run a parser and then consume all trailing space
38 | run :: forall a. Parser a -> String -> Either ParseError a
39 | run p s = runParser s (skipSpaces *> p <* eof)
40 |
41 | -- | Parse structured data from a JSON string in Either
42 | liftJson :: forall a. Parser a -> String -> Either JsonDecodeError a
43 | liftJson p = lmap TypeMismatch <<< simpleRun p
44 |
45 | -- | Run a parser, formatting the parse error as a String
46 | simpleRun :: forall a. Parser a -> String -> Either String a
47 | simpleRun p s = lmap (toString <<< formatParseError s) $ run p s
48 | where
49 | toString { message, source, caret } = Array.intercalate "\n"
50 | [ message
51 | , source
52 | , caret
53 | ]
54 |
55 | -- | Run a parser, crashing if it fails to parse the input. Use this
56 | -- | only for trusted input, e.g. in tests or default definitions.
57 | unsafeRun :: forall a. Parser a -> String -> a
58 | unsafeRun p = either unsafeCrashWith identity <<< simpleRun p
59 |
60 | -- | Format a parse error to highlight the position where the malformed
61 | -- | input was encountered.
62 | formatParseError :: String -> ParseError -> { message :: String, source :: String, caret :: String }
63 | formatParseError text err =
64 | { message: "Parse error: " <> message <> " at column " <> show column
65 | , source: text
66 | , caret: caret
67 | }
68 | where
69 | message = parseErrorMessage err
70 | column = positionColumn $ parseErrorPosition err
71 | caret = fromCharArray (Array.replicate (column - 1) ' ') <> "^"
72 |
73 | -- | Project column from `Position`
74 | positionColumn :: Position -> Int
75 | positionColumn (Position {column}) = column
76 |
77 | -- | Extend a parser to consume trailing whitespace
78 | token :: forall a. Parser a -> Parser a
79 | token p = p <* skipSpaces
80 |
81 | -- | Apply a parser between two grouping characters.
82 | balance :: forall a. Char -> Char -> Parser a -> Parser a
83 | balance lhs rhs = between (token (char lhs)) (token (char rhs))
84 |
85 | -- | Apply a parser between parens.
86 | parens :: forall a. Parser a -> Parser a
87 | parens = balance '(' ')'
88 |
89 | -- | Apply a parser between brackets.
90 | brackets :: forall a. Parser a -> Parser a
91 | brackets = balance '[' ']'
92 |
--------------------------------------------------------------------------------
/frontend/packages.dhall:
--------------------------------------------------------------------------------
1 | {-
2 | Welcome to your new Dhall package-set!
3 |
4 | Below are instructions for how to edit this file for most use
5 | cases, so that you don't need to know Dhall to use it.
6 |
7 | ## Warning: Don't Move This Top-Level Comment!
8 |
9 | Due to how `dhall format` currently works, this comment's
10 | instructions cannot appear near corresponding sections below
11 | because `dhall format` will delete the comment. However,
12 | it will not delete a top-level comment like this one.
13 |
14 | ## Use Cases
15 |
16 | Most will want to do one or both of these options:
17 | 1. Override/Patch a package's dependency
18 | 2. Add a package not already in the default package set
19 |
20 | This file will continue to work whether you use one or both options.
21 | Instructions for each option are explained below.
22 |
23 | ### Overriding/Patching a package
24 |
25 | Purpose:
26 | - Change a package's dependency to a newer/older release than the
27 | default package set's release
28 | - Use your own modified version of some dependency that may
29 | include new API, changed API, removed API by
30 | using your custom git repo of the library rather than
31 | the package set's repo
32 |
33 | Syntax:
34 | where `entityName` is one of the following:
35 | - dependencies
36 | - repo
37 | - version
38 | -------------------------------
39 | let upstream = --
40 | in upstream
41 | with packageName.entityName = "new value"
42 | -------------------------------
43 |
44 | Example:
45 | -------------------------------
46 | let upstream = --
47 | in upstream
48 | with halogen.version = "master"
49 | with halogen.repo = "https://example.com/path/to/git/repo.git"
50 |
51 | with halogen-vdom.version = "v4.0.0"
52 | -------------------------------
53 |
54 | ### Additions
55 |
56 | Purpose:
57 | - Add packages that aren't already included in the default package set
58 |
59 | Syntax:
60 | where `` is:
61 | - a tag (i.e. "v4.0.0")
62 | - a branch (i.e. "master")
63 | - commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977")
64 | -------------------------------
65 | let upstream = --
66 | in upstream
67 | with new-package-name =
68 | { dependencies =
69 | [ "dependency1"
70 | , "dependency2"
71 | ]
72 | , repo =
73 | "https://example.com/path/to/git/repo.git"
74 | , version =
75 | ""
76 | }
77 | -------------------------------
78 |
79 | Example:
80 | -------------------------------
81 | let upstream = --
82 | in upstream
83 | with benchotron =
84 | { dependencies =
85 | [ "arrays"
86 | , "exists"
87 | , "profunctor"
88 | , "strings"
89 | , "quickcheck"
90 | , "lcg"
91 | , "transformers"
92 | , "foldable-traversable"
93 | , "exceptions"
94 | , "node-fs"
95 | , "node-buffer"
96 | , "node-readline"
97 | , "datetime"
98 | , "now"
99 | ]
100 | , repo =
101 | "https://github.com/hdgarrood/purescript-benchotron.git"
102 | , version =
103 | "v7.0.0"
104 | }
105 | -------------------------------
106 | -}
107 | let upstream =
108 | https://github.com/purescript/package-sets/releases/download/psc-0.14.4-20211005/packages.dhall sha256:2ec351f17be14b3f6421fbba36f4f01d1681e5c7f46e0c981465c4cf222de5be
109 | in upstream
110 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Snapshot/RPN.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Snapshot.RPN
2 | ( RPN(..)
3 | , encode
4 | , decode
5 | , unsafeTag
6 | ) where
7 |
8 | import Lambda.Prelude
9 |
10 | import Data.Int.Bits ((.&.), (.|.), zshr, shl)
11 | import Lambda.Language.Snapshot.Error (Error(..))
12 | import Lambda.Language.Snapshot.Tag
13 | ( Tag(..)
14 | , _VAR
15 | , _NAT
16 | , _TAK
17 | , _LAM
18 | , _DEF
19 | , _APV
20 | , _AP0
21 | )
22 |
23 | -- | Reverse polish notation for constructing ASTs
24 | -- |
25 | -- | Constructor | Tag | Decimal | Binary
26 | -- | ------------+------+---------+-------
27 | -- | Var | _VAR | 1 | 001
28 | -- | Nat | _NAT | 2 | 010
29 | -- | Take | _TAK | 3 | 011
30 | -- | Lambda | _LAM | 4 | 100
31 | -- | Define | _DEF | 5 | 101
32 | -- | AppVar | _APV | 6 | 110
33 | -- | Apply | _AP0 | 7 | 111
34 | data RPN
35 | -- | Push name at index
36 | = Var Int
37 | -- | Push literal natural number
38 | | Nat Int
39 | -- | Take n elements from the stack and build a list
40 | | Take Int
41 | -- | Build lambda with name at index and body from stack
42 | | Lambda Int
43 | -- | Build definition with name at index and body from stack
44 | | Define Int
45 | -- | Apply name at index to top of stack
46 | | AppVar Int
47 | -- | Apply top of stack to element beneath it
48 | | Apply
49 |
50 | derive instance eqRPN :: Eq RPN
51 |
52 | instance Show RPN where
53 | show = case _ of
54 | Var i -> "var " <> show i
55 | Nat i -> show i
56 | Take i -> "take " <> show i
57 | Lambda i -> "lam " <> show i
58 | Define i -> "def " <> show i
59 | AppVar i -> "app " <> show i
60 | Apply -> "app"
61 |
62 | -- | Encode RPN as a sequence of 32-bit ints
63 | encode :: forall m. MonadThrow Error m => Array RPN -> m (Array Int)
64 | encode = traverse case _ of
65 | Var i -> setTag _VAR i
66 | Nat i -> setTag _NAT i
67 | Take i -> setTag _TAK i
68 | Lambda i -> setTag _LAM i
69 | Define i -> setTag _DEF i
70 | AppVar i -> setTag _APV i
71 | Apply -> setTag _AP0 1
72 |
73 | -- | Attempt to decode sequence of 32-bit ints back to RPN
74 | decode :: forall m. MonadThrow Error m => Array Int -> m (Array RPN)
75 | decode = traverse (step <<< untag)
76 | where
77 | step { tag, payload }
78 | | tag == _VAR = pure $ Var payload
79 | | tag == _NAT = pure $ Nat payload
80 | | tag == _TAK = pure $ Take payload
81 | | tag == _LAM = pure $ Lambda payload
82 | | tag == _DEF = pure $ Define payload
83 | | tag == _APV = pure $ AppVar payload
84 | | tag == _AP0 = pure $ Apply
85 | | otherwise = throwError $ UnrecognizedTag tag
86 |
87 | -- | Attempt to tag payload if it fits in 29 bits
88 | setTag :: forall m. MonadThrow Error m => Tag -> Int -> m Int
89 | setTag tag payload = unsafeTag tag <$> check payload
90 | where
91 | check x
92 | | x < 0x00000000 = throwError $ PayloadOutOfRange tag payload
93 | | x > 0x1FFFFFFF = throwError $ PayloadOutOfRange tag payload
94 | | otherwise = pure x
95 |
96 | -- | Split tagged value into tag and payload
97 | untag :: Int -> { tag :: Tag, payload :: Int }
98 | untag tagged = { tag, payload }
99 | where
100 | tag = Tag $ tagged .&. 0x7
101 | payload = tagged `zshr` 3
102 |
103 | -- | Exported for testing only
104 | unsafeTag :: Tag -> Int -> Int
105 | unsafeTag tag x = (x `shl` 3) .|. un Tag tag
106 |
--------------------------------------------------------------------------------
/.github/workflows/ci.yml:
--------------------------------------------------------------------------------
1 | name: CI
2 |
3 | on:
4 | pull_request:
5 | paths:
6 | - .github/workflows/ci.yml
7 | - backend/**
8 |
9 | push:
10 | branches:
11 | - main
12 | paths:
13 | - .github/workflows/ci.yml
14 | - backend/**
15 |
16 | jobs:
17 | build:
18 | runs-on: ubuntu-latest
19 |
20 | services:
21 | postgres:
22 | image: postgres
23 | env:
24 | POSTGRES_USER: postgres
25 | POSTGRES_PASSWORD: password
26 | POSTGRES_DB: lambda_test
27 | ports:
28 | - 5432:5432
29 | options: >-
30 | --health-cmd pg_isready
31 | --health-interval 10s
32 | --health-timeout 5s
33 | --health-retries 5
34 |
35 | steps:
36 | - uses: actions/checkout@v2
37 |
38 | - uses: freckle/stack-cache-action@main
39 | with:
40 | working-directory: backend
41 |
42 | - run: stack install --no-terminal --copy-compiler-tool dbmigrations-postgresql
43 | working-directory: backend
44 |
45 | - run: db/upgrade test
46 | working-directory: backend
47 |
48 | - uses: freckle/stack-action@main
49 | with:
50 | fast: ${{ github.ref != 'refs/heads/main' }}
51 | hlint: false
52 | weeder: false
53 | working-directory: backend
54 |
55 | - run: db/check
56 | working-directory: backend
57 | env:
58 | HEROKU_API_KEY: ${{ secrets.HEROKU_API_KEY }}
59 |
60 | image:
61 | runs-on: ubuntu-latest
62 |
63 | outputs:
64 | image: ${{ steps.prep.outputs.image }}
65 |
66 | steps:
67 | - id: prep
68 | run: |
69 | image=cdparks7/lambda-machine:$(echo "${{ github.sha }}" | head -c7)
70 | echo "::set-output name=image::${image}"
71 |
72 | - id: buildx
73 | uses: docker/setup-buildx-action@v1
74 |
75 | - uses: actions/cache@v2
76 | with:
77 | path: /tmp/.buildx-cache
78 | key: ${{ runner.os }}-image-${{ github.sha }}
79 | restore-keys: |
80 | ${{ runner.os }}-image-
81 |
82 | - uses: docker/login-action@v1
83 | with:
84 | username: cdparks7
85 | password: ${{ secrets.DOCKER_HUB_ACCESS_TOKEN }}
86 |
87 | - uses: docker/build-push-action@v2
88 | with:
89 | context: "https://github.com/${{ github.repository }}.git#${{ github.sha }}:backend"
90 | builder: ${{ steps.buildx.outputs.name }}
91 | cache-from: type=local,src=/tmp/.buildx-cache
92 | cache-to: type=local,mode=max,dest=/tmp/.buildx-cache-new
93 | push: true
94 | tags: ${{ steps.prep.outputs.image }}
95 |
96 | - run: |
97 | rm -rf /tmp/.buildx-cache
98 | mv /tmp/.buildx-cache-new /tmp/.buildx-cache
99 |
100 | deploy:
101 | if: ${{ github.ref == 'refs/heads/main' }}
102 | runs-on: ubuntu-latest
103 |
104 | needs: [build, image]
105 |
106 | steps:
107 | - uses: docker/login-action@v1
108 | with:
109 | username: cdparks7
110 | password: ${{ secrets.DOCKER_HUB_ACCESS_TOKEN }}
111 |
112 | - run: |
113 | cat >Dockerfile.web <<'EOM'
114 | FROM ${{ needs.image.outputs.image }}
115 | ENV ORIGIN=https://lambda-machine.com
116 | CMD ["/app/serve"]
117 | EOM
118 |
119 | - uses: gonuit/heroku-docker-deploy@v1.3.3
120 | with:
121 | email: ${{ secrets.HEROKU_EMAIL }}
122 | heroku_api_key: ${{ secrets.HEROKU_API_KEY }}
123 | heroku_app_name: lambda-machine
124 | dockerfile_name: Dockerfile.web
125 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Machine/Heap.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Machine.Heap
2 | ( Heap
3 | , empty
4 | , alloc
5 | , reserve
6 | , fetch
7 | , update
8 | , free
9 | , gc
10 | ) where
11 |
12 | import Lambda.Prelude
13 |
14 | import Data.Foldable (maximum)
15 | import Data.HashMap as HashMap
16 | import Data.Queue as Queue
17 | import Lambda.Machine.Address (Address, baseptr, nullptr, offset)
18 | import Partial.Unsafe (unsafeCrashWith)
19 |
20 | -- | Heap memory represented by a map from addresses to nodes.
21 | type Heap a =
22 | { memory :: HashMap Address a
23 | , next :: Address
24 | }
25 |
26 | -- | Empty heap
27 | empty :: forall a. Heap a
28 | empty = { memory: HashMap.empty, next: baseptr }
29 |
30 | -- | Allocate memory for a node and return the `Address`.
31 | alloc :: forall a s m. MonadState { heap :: Heap a | s } m => a -> m Address
32 | alloc node = modifyHeap \{ memory, next } -> Tuple next
33 | { memory: HashMap.insert next node memory
34 | , next: offset 1 next
35 | }
36 |
37 | -- | Reserve an `Address` for a node without actually writing it.
38 | reserve :: forall a s m. MonadState { heap :: Heap a | s } m => m Address
39 | reserve = modifyHeap \{ memory, next } -> Tuple next
40 | { memory
41 | , next: offset 1 next
42 | }
43 |
44 | -- | Dereference an `Address` or crash.
45 | fetch :: forall a s m. MonadState { heap :: Heap a | s } m => Address -> m a
46 | fetch address = withHeap \{ memory } ->
47 | case HashMap.lookup address memory of
48 | Just node -> node
49 | Nothing -> unsafeCrashWith $ "Invalid address " <> show address
50 |
51 | -- | Overwrite the value at an `Address`.
52 | update :: forall a s m. MonadState { heap :: Heap a | s } m => Address -> a -> m Unit
53 | update address node = modifyHeap \heap -> Tuple unit $ heap
54 | { memory = HashMap.insert address node heap.memory
55 | }
56 |
57 | -- | Free the memory associated with an `Address`.
58 | free :: forall a s m. MonadState { heap :: Heap a | s } m => Address -> m Unit
59 | free address = modifyHeap \heap -> Tuple unit $ heap
60 | { memory = HashMap.delete address heap.memory
61 | }
62 |
63 | -- | Eliminate unused nodes from the `Heap`. The first argument is a
64 | -- | sequence of root addresses, and the second argument specifies how
65 | -- | to find child addresses of a node. Uses stack-safe breadth-first-
66 | -- | search to move all used addresses to a new heap.
67 | gc
68 | :: forall a s m f
69 | . MonadState { heap :: Heap a | s } m
70 | => MonadRec m
71 | => Foldable f
72 | => f Address
73 | -> (a -> Array Address)
74 | -> m Unit
75 | gc roots children = do
76 | toSpace <- tailRecM go
77 | { queue: Queue.fromFoldable roots
78 | , toSpace: HashMap.empty
79 | }
80 | modify_ _
81 | { heap =
82 | { memory: toSpace
83 | , next: offset 1 $ fromMaybe nullptr $ maximum $ HashMap.keys toSpace
84 | }
85 | }
86 | where
87 | go {queue, toSpace} =
88 | case Queue.pop queue of
89 | Nothing -> pure $ Done toSpace
90 | Just (Tuple root rest)
91 | | root `HashMap.member` toSpace ->
92 | pure $ Loop
93 | { queue: rest
94 | , toSpace
95 | }
96 | | otherwise -> do
97 | node <- fetch root
98 | pure $ Loop
99 | { queue: Queue.extend rest $ children node
100 | , toSpace: HashMap.insert root node toSpace
101 | }
102 |
103 | -- | Helper to modify the `Heap` and return a value.
104 | modifyHeap :: forall a s m r. MonadState { heap :: Heap a | s } m => (Heap a -> Tuple r (Heap a)) -> m r
105 | modifyHeap f = do
106 | heap0 <- gets _.heap
107 | case f heap0 of
108 | Tuple r heap1 -> do
109 | modify_ $ _ { heap = heap1 }
110 | pure r
111 |
112 | -- | Helper to use data from the `Heap` without modifying it.
113 | withHeap :: forall a s m r. MonadState { heap :: Heap a | s } m => (Heap a -> r) -> m r
114 | withHeap f = modifyHeap $ \heap -> Tuple (f heap) heap
115 |
--------------------------------------------------------------------------------
/backend/test/Backend/ApiSpec.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE QuasiQuotes #-}
2 |
3 | module Backend.ApiSpec
4 | ( spec
5 | ) where
6 |
7 | import Backend.Test.Prelude
8 |
9 | import Backend.Api (api)
10 | import qualified Backend.Env as Env
11 | import Backend.Env (Env)
12 | import Backend.Database (deleteWhere, insertKey, runDB)
13 | import qualified Backend.Database as DB
14 | import Backend.Middleware (middleware)
15 | import qualified Backend.Settings as Settings
16 | import Backend.Snapshot (Key(SnapshotKey), Snapshot(..))
17 | import Backend.Signature (Signature(..))
18 | import LoadEnv (loadEnvFrom)
19 |
20 | spec :: Spec
21 | spec = withState testApp $ do
22 | describe "GET /snapshots/:code" $ do
23 | it "rejects a code that's too short" $ do
24 | get "/snapshots/ABCDEFG" `shouldRespondWith` status
25 | 400
26 | [json|
27 | { status: 400
28 | , error: "Bad Request"
29 | , detail: "wrong length for code: ABCDEFG"
30 | }
31 | |]
32 |
33 | it "rejects a code that's too long" $ do
34 | get "/snapshots/ABCDEFGHJ" `shouldRespondWith` status
35 | 400
36 | [json|
37 | { status: 400
38 | , error: "Bad Request"
39 | , detail: "wrong length for code: ABCDEFGHJ"
40 | }
41 | |]
42 |
43 | it "rejects a code with illegal characters" $ do
44 | get "/snapshots/ABCDEFGI" `shouldRespondWith` status
45 | 400
46 | [json|
47 | { status: 400
48 | , error: "Bad Request"
49 | , detail: "unrecognized characters in code: ABCDEFGI"
50 | }
51 | |]
52 |
53 | it "404s on a nonexistent snapshot" $ do
54 | get "/snapshots/N0TTHERE" `shouldRespondWith` status
55 | 404
56 | [json|
57 | { status: 404
58 | , error: "Not Found"
59 | }
60 | |]
61 |
62 | it "returns an extant snapshot" $ do
63 | get "/snapshots/SNAPSH0T" `shouldRespondWith` [json|
64 | { sig: 0
65 | , names: []
66 | , state: []
67 | }
68 | |]
69 |
70 | describe "POST /snapshots" $ do
71 | it "requires a JSON body" $ do
72 | post "/snapshots" "" `shouldRespondWith` status
73 | 400
74 | [json|
75 | { status: 400
76 | , error: "Bad Request"
77 | , detail: "Unexpected end-of-input, expecting JSON value"
78 | }
79 | |]
80 |
81 | it "rejects a malformed JSON body" $ do
82 | let body = [json|{sig: 0, names: []}|]
83 | post "/snapshots" body `shouldRespondWith` status
84 | 400
85 | [json|
86 | { status: 400
87 | , error: "Bad Request"
88 | , detail: "Error in $: parsing Backend.Snapshot.ApiSnapshot(ApiSnapshot) failed, key \"state\" not found"
89 | }
90 | |]
91 |
92 | it "accepts and returns an extant snapshot" $ do
93 | SResponse {..} <- post "/snapshots" [json|
94 | { sig: 0
95 | , state: []
96 | , names: []
97 | }
98 | |]
99 | code <- shouldBeJust $ simpleBody ^? key "code" . _JSON
100 | code `shouldBe` SnapshotKey "SNAPSH0T"
101 | snapshot <- liftEnv $ runDB $ DB.get code
102 | liftIO $ snapshot `shouldBe` Just def
103 |
104 | it "accepts and stores a valid snapshot" $ do
105 | SResponse {..} <- post "/snapshots" [json|
106 | { sig: 1
107 | , state: []
108 | , names: []
109 | }
110 | |]
111 | code <- shouldBeJust $ simpleBody ^? key "code" . _JSON
112 | code `shouldNotBe` SnapshotKey "SNAPSH0T"
113 | snapshot <- liftEnv $ runDB $ DB.get code
114 | liftIO $ snapshot `shouldBe` Just def { snapshotSignature = Signature 1 }
115 |
116 | testApp :: IO (Env, Application)
117 | testApp = do
118 | loadEnvFrom ".env.test"
119 | settings <- Settings.load
120 | env <- Env.new settings
121 | runRIO env $ do
122 | runDB $ do
123 | deleteWhere @_ @_ @Snapshot []
124 | insertKey (SnapshotKey "SNAPSH0T") def
125 | app <- middleware settings <$> api
126 | pure (env, app)
127 |
128 | status :: Int -> ResponseMatcher -> ResponseMatcher
129 | status n m = m { matchStatus = n }
130 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Nameless.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Nameless
2 | ( Nameless(..)
3 | , from
4 | , freeVars
5 | , alpha
6 | ) where
7 |
8 | import Lambda.Prelude
9 |
10 | import Data.Map as Map
11 | import Data.Set as Set
12 | import Lambda.Language.Expression (Expression, encodeNat, encodeList)
13 | import Lambda.Language.Expression as Expression
14 | import Lambda.Language.Name (Name, next)
15 | import Lambda.Language.Name as Name
16 | import Lambda.Language.Pretty (class Pretty, parensIf, text)
17 | import Partial.Unsafe (unsafeCrashWith)
18 |
19 | -- | Locally nameless expression tree using zero-based De-Bruijn
20 | -- | indexes. That is, `λx. x` is represented by `λx. 0`, and
21 | -- | `λx. λy. x` is represented by `λx. λy. 1`. Binders are annotated
22 | -- | with their source-level name for quoting back to an `Expression`
23 | -- | as well as the set of free-variables they reference. The latter
24 | -- | is used to avoid garbage-collecting global definitions.
25 | data Nameless
26 | = Bound Int
27 | | Free Name
28 | | Lambda Name (Set Name) Nameless
29 | | Apply Nameless Nameless
30 |
31 | derive instance genericNameless :: Generic Nameless _
32 |
33 | instance showNameless :: Show Nameless where
34 | show x = genericShow x
35 |
36 | -- | Alpha-equivalence
37 | instance eqNameless :: Eq Nameless where
38 | eq lhs rhs = case lhs, rhs of
39 | Bound i, Bound j -> i == j
40 | Free n, Free m -> n == m
41 | Lambda _ _ x, Lambda _ _ y -> x == y
42 | Apply f a, Apply g b -> f == g && a == b
43 | _, _ -> false
44 |
45 | -- | Alph-equivalent expressions should have the same hash
46 | instance hashableNameless :: Hashable Nameless where
47 | hash = case _ of
48 | Bound i -> hash i
49 | Free n -> hash n
50 | Lambda _ _ b -> hash b
51 | Apply f a -> hash $ Tuple f a
52 |
53 | -- | Create a locally-nameless expression from an AST
54 | -- | Also eliminates literals
55 | from :: Expression -> Nameless
56 | from = alphaInternal <<< go Map.empty
57 | where
58 | go env = case _ of
59 | Expression.Var n ->
60 | case Map.lookup n env of
61 | Nothing -> {expr: Free n, fvs: Set.singleton n}
62 | Just i -> {expr: Bound i, fvs: Set.empty}
63 | Expression.Nat i -> go env $ encodeNat i
64 | Expression.List xs -> go env $ do
65 | let names = Map.keys env
66 | let {new: cons} = fresh names $ Name.from "cons"
67 | let {new: nil} = fresh names $ Name.from "nil"
68 | encodeList cons nil xs
69 | Expression.Lambda n body ->
70 | let
71 | shifted = Map.insert n 0 $ (_ + 1) <$> env
72 | {expr, fvs} = go shifted body
73 | in {expr: Lambda n fvs expr, fvs}
74 | Expression.Apply f0 a0 ->
75 | let
76 | f = go env f0
77 | a = go env a0
78 | in {expr: Apply f.expr a.expr, fvs: f.fvs <> a.fvs}
79 | Expression.Highlight x -> go env x
80 | Expression.Cycle -> unsafeCrashWith "Parser should never produce a cycle"
81 |
82 | -- | Alpha-convert an nameless expression such that no names are shadowed.
83 | alpha :: Nameless -> Nameless
84 | alpha expr = alphaInternal { expr, fvs: freeVars expr }
85 |
86 | -- | Alpha-conversion when we already have an nameless expression's free variables
87 | alphaInternal :: {expr :: Nameless, fvs :: Set Name} -> Nameless
88 | alphaInternal x =
89 | loop x.fvs x.expr
90 | where
91 | loop env = case _ of
92 | Bound i ->
93 | Bound i
94 | Free n ->
95 | Free n
96 | Lambda n fvs b ->
97 | let {used, new} = fresh env n
98 | in Lambda new fvs $ loop used b
99 | Apply f a ->
100 | Apply (loop env f) (loop env a)
101 |
102 | -- | Conjure a fresh name by appending a subscript
103 | fresh :: Set Name -> Name -> {used :: Set Name, new :: Name}
104 | fresh env n
105 | | n `Set.member` env = fresh env (next n)
106 | | otherwise = {used: Set.insert n env, new: n}
107 |
108 | -- | Access a nameless expression's precomputed free variables.
109 | freeVars :: Nameless -> Set Name
110 | freeVars = case _ of
111 | Bound _ -> Set.empty
112 | Free n -> Set.singleton n
113 | Lambda _ fvs _ -> fvs
114 | Apply f a -> freeVars f <> freeVars a
115 |
116 | instance prettyNameless :: Pretty Nameless where
117 | pretty _ =
118 | walk false
119 | where
120 | walk inApp = case _ of
121 | Bound i ->
122 | text $ show i
123 | Free n ->
124 | text $ show n
125 | Lambda _ _ b ->
126 | parensIf inApp $ text "λ. " <> walk false b
127 | Apply f a ->
128 | walk true f <> text " " <> walk true a
129 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Name.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Name
2 | ( Name
3 | , from
4 | , withSubscript
5 | , base
6 | , next
7 | ) where
8 |
9 | import Lambda.Prelude
10 |
11 | import Data.Array (unsafeIndex)
12 | import Data.Array as Array
13 | import Data.Char (toCharCode)
14 | import Data.String.CodeUnits (fromCharArray)
15 | import Lambda.Language.Parser (class Parse, Parser, parse, liftJson, satisfy, string, token)
16 | import Lambda.Language.Pretty (class Pretty, text)
17 | import Partial.Unsafe (unsafePartial)
18 |
19 | -- | Source-level name with an optional subscript.
20 | data Name = Name String (Maybe Int)
21 |
22 | derive instance eqName :: Eq Name
23 | derive instance ordName :: Ord Name
24 |
25 | instance showName :: Show Name where
26 | show (Name n ms) = n <> maybe "" intToSubscript ms
27 |
28 | instance hashableName :: Hashable Name where
29 | hash (Name n ms) = hash $ Tuple n ms
30 |
31 | instance decodeJsonName :: DecodeJson Name where
32 | decodeJson = liftJson parse <=< decodeJson
33 |
34 | instance encodeJsonName :: EncodeJson Name where
35 | encodeJson = encodeJson <<< show
36 |
37 | instance prettyName :: Pretty Name where
38 | pretty _ = text <<< show
39 |
40 | -- | Construct a `Name` with no subscript.
41 | from :: String -> Name
42 | from s = Name s Nothing
43 |
44 | -- | Construct a `Name` with a subscript.
45 | withSubscript :: Int -> String -> Name
46 | withSubscript n s = Name s $ Just n
47 |
48 | -- | Append or increment a `Name`'s subscript.
49 | next :: Name -> Name
50 | next (Name n ms) = Name n $ (_ + 1) <$> ms <|> pure 0
51 |
52 | -- | Extract a `Name`'s textual component
53 | base :: Name -> String
54 | base (Name s _) = s
55 |
56 | -- | Parse a `Name`
57 | -- |
58 | -- | ```ebnf
59 | -- | name
60 | -- | = (letter | "_") (* Initial letter or underscore *)
61 | -- | , {letter | "-"} (* Zero or more letters or hyphens *)
62 | -- | , ["?"] (* Optional question mark *)
63 | -- | , {subscript | digit} (* Zero or more subscripts or digits *)
64 | -- | ;
65 | -- |
66 | -- | letter (* Lowercase latin letters *)
67 | -- | = "a" | "b" | "c" | "d" | "e" | "f" | "g"
68 | -- | | "h" | "i" | "j" | "k" | "l" | "m" | "n"
69 | -- | | "o" | "p" | "q" | "r" | "s" | "t" | "u"
70 | -- | | "v" | "w" | "x" | "y" | "z" ;
71 | -- |
72 | -- | subscript (* Subscripts *)
73 | -- | = "₀" | "₁" | "₂" | "₃" | "₄" | "₅" | "₆"
74 | -- | | "₇" | "₈" | "₉" ;
75 | -- |
76 | -- | digit (* Decimal digits *)
77 | -- | = "0" | "1" | "2" | "3" | "4" | "5" | "6"
78 | -- | | "7" | "8" | "9" ;
79 | -- | ```
80 | -- |
81 | instance parseName :: Parse Name where
82 | parse = token do
83 | first <- satisfy firstChar
84 | body <- Array.many $ satisfy bodyChar
85 | question <- string "?" <|> pure ""
86 | subscript <- Just <$> parseSubscript <|> pure Nothing
87 | let var = fromCharArray ([first] <> body) <> question
88 | pure $ Name var subscript
89 |
90 | -- | Parse subscripts for a `Name`
91 | parseSubscript :: Parser Int
92 | parseSubscript = subscriptToInt <$> Array.some anyDigit
93 |
94 | -- | Parse the first character of a `Name`
95 | firstChar :: Char -> Boolean
96 | firstChar c = isLower c || c == '_'
97 |
98 | -- | Parse the remaining (non-question-mark, non-subscript-y)
99 | -- | characters of a `Name`.
100 | bodyChar :: Char -> Boolean
101 | bodyChar c = isLower c || c == '-'
102 |
103 | -- | Is a character a lowercase letter?
104 | isLower :: Char -> Boolean
105 | isLower c = 'a' <= c && c <= 'z'
106 |
107 | -- | Convert `Int` subscript to textual subscript.
108 | intToSubscript :: Int -> String
109 | intToSubscript = fromCharArray <<< map (unsafePartial (subscriptTable `unsafeIndex` _)) <<< toDigits
110 |
111 | -- | Convert textual subscript to `Int` subscript.
112 | subscriptToInt :: Array Int -> Int
113 | subscriptToInt = foldl step 0
114 | where
115 | step acc d = 10 * acc + d
116 |
117 | -- | Parse a digit as its numeric value
118 | anyDigit :: Parser Int
119 | anyDigit = offsetFrom '0' '9' <|> offsetFrom '₀' '₉'
120 |
121 | -- | Find charcter's offset from the lo end of the range
122 | offsetFrom :: Char -> Char -> Parser Int
123 | offsetFrom lo hi = do
124 | c <- satisfy inRange
125 | pure $ toCharCode c - toCharCode lo
126 | where
127 | inRange c = lo <= c && c <= hi
128 |
129 | -- | Fixed array of actual subscript characters.
130 | subscriptTable :: Array Char
131 | subscriptTable = ['₀', '₁', '₂', '₃', '₄', '₅', '₆', '₇', '₈', '₉']
132 |
133 | -- | Split decimal integer into its constituent digits.
134 | toDigits :: Int -> Array Int
135 | toDigits n
136 | | n < 10 = [n]
137 | | otherwise = toDigits (n `div` 10) <> [n `mod` 10]
138 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Machine/Node.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Machine.Node
2 | ( Node(..)
3 | , Stuck(..)
4 | , Closure
5 | , Env
6 | , deref
7 | , define
8 | , compile
9 | , instantiate
10 | , instantiateAt
11 | , children
12 | ) where
13 |
14 | import Lambda.Prelude
15 |
16 | import Data.Array as Array
17 | import Data.List as List
18 | import Lambda.Language.Name (Name)
19 | import Lambda.Language.Nameless (Nameless)
20 | import Lambda.Language.Nameless as Nameless
21 | import Lambda.Machine.Address (Address)
22 | import Lambda.Machine.Globals (Globals)
23 | import Lambda.Machine.Globals as Globals
24 | import Lambda.Machine.Heap (Heap)
25 | import Lambda.Machine.Heap as Heap
26 | import Partial.Unsafe (unsafeCrashWith)
27 |
28 | -- | Nodes in the graph. Closures contain references to the global
29 | -- | addresses they use as well as their local environment. `Stuck`
30 | -- | nodes cannot be evaluated any further. Pointers are used in
31 | -- | updates.
32 | data Node
33 | = Apply Address Address
34 | | Closure Closure
35 | | Global Name Address
36 | | Pointer Address
37 | | Stuck Stuck
38 |
39 | type Closure =
40 | { fvs :: Array Address
41 | , env :: Env Address
42 | , name :: Name
43 | , body :: Nameless
44 | }
45 |
46 | derive instance eqNode :: Eq Node
47 | derive instance genericNode :: Generic Node _
48 |
49 | instance showNode :: Show Node where
50 | show x = genericShow x
51 |
52 | -- | Stuck nodes cannot be evaluated any further.
53 | data Stuck
54 | = StuckVar Name
55 | | StuckLambda Name Address
56 | | StuckApply Address Address
57 |
58 | derive instance eqStuck :: Eq Stuck
59 | derive instance genericStuck :: Generic Stuck _
60 |
61 | instance showStuck :: Show Stuck where
62 | show x = genericShow x
63 |
64 | -- | Closure environments are lists. Construction is fast; indexing is
65 | -- | slow. Environments should be small enough that it doesn't matter.
66 | type Env = List
67 |
68 | -- | Index a closure's environment with the De-Bruijn index in a bound
69 | -- | variable.
70 | deref :: forall a. Show a => Int -> Env a -> a
71 | deref i env = case List.index env i of
72 | Just a -> a
73 | Nothing -> unsafeCrashWith $ fold
74 | [ "Invalid De Bruijn index "
75 | , show i
76 | , " in environment "
77 | , show env
78 | ]
79 |
80 | -- | Add a top-level definition to the `Globals`.
81 | define
82 | :: forall s m
83 | . MonadState { heap :: Heap Node, globals :: Globals | s } m
84 | => Name
85 | -> Nameless
86 | -> m Unit
87 | define name expr = Globals.add name \_ ->
88 | Global name <$> compile expr
89 |
90 | -- | Instantiate a closed expression.
91 | compile
92 | :: forall s m
93 | . MonadState { heap :: Heap Node, globals :: Globals | s } m
94 | => Nameless
95 | -> m Address
96 | compile = instantiate Nil
97 |
98 | -- | Instantiate an expression in an environment. This builds a shallow
99 | -- | graph of an expression - shallow because we don't go under lambdas
100 | -- | until they're applied.
101 | instantiate
102 | :: forall s m
103 | . MonadState { heap :: Heap Node, globals :: Globals | s } m
104 | => Env Address
105 | -> Nameless
106 | -> m Address
107 | instantiate env = case _ of
108 | Nameless.Lambda name fvs0 body -> do
109 | fvs <- traverse Globals.get $ Array.fromFoldable fvs0
110 | Heap.alloc $ Closure { fvs, env, name, body }
111 | Nameless.Apply f0 a0 -> do
112 | a <- instantiate env a0
113 | f <- instantiate env f0
114 | Heap.alloc $ Apply f a
115 | Nameless.Bound i ->
116 | pure $ deref i env
117 | Nameless.Free name -> Globals.get name
118 |
119 | -- | Instantiate an expression in an environment and overwrite the
120 | -- | given address. Generates fewer pointer chains since we don't
121 | -- | need an indirection.
122 | instantiateAt
123 | :: forall s m
124 | . MonadState { heap :: Heap Node, globals :: Globals | s } m
125 | => Address
126 | -> Env Address
127 | -> Nameless
128 | -> m Unit
129 | instantiateAt target env = case _ of
130 | Nameless.Lambda name fvs0 body -> do
131 | fvs <- traverse Globals.get $ Array.fromFoldable fvs0
132 | Heap.update target $ Closure {fvs, env, name, body}
133 | Nameless.Apply f0 a0 -> do
134 | a <- instantiate env a0
135 | f <- instantiate env f0
136 | Heap.update target $ Apply f a
137 | Nameless.Bound i ->
138 | Heap.update target $ Pointer $ deref i env
139 | Nameless.Free name -> do
140 | addr <- Globals.get name
141 | Heap.update target $ Pointer addr
142 |
143 | -- | Find all addresses embedded in a `Node`. Used for pointer-chasing
144 | -- | in garbage collection.
145 | children :: Node -> Array Address
146 | children = case _ of
147 | Apply lhs rhs -> [lhs, rhs]
148 | Closure {fvs, env} -> fvs <> Array.fromFoldable env
149 | Global _ addr -> [addr]
150 | Stuck (StuckVar _) -> []
151 | Stuck (StuckLambda _ addr) -> [addr]
152 | Stuck (StuckApply lhs rhs) -> [lhs, rhs]
153 | Pointer addr -> [addr]
154 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/World.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.World
2 | ( World(..)
3 | , Graph
4 | , ConsistencyError(..)
5 | , new
6 | , empty
7 | , define
8 | , undefine
9 | , focus
10 | , unfocus
11 | -- Exposed only for testing
12 | , Entity(..)
13 | ) where
14 |
15 | import Lambda.Prelude hiding (add)
16 |
17 | import Data.Array as Array
18 | import Data.Grammar as Grammar
19 | import Data.Map as Map
20 | import Data.Set as Set
21 | import Lambda.Language.Name (Name)
22 | import Lambda.Language.Nameless (Nameless, freeVars)
23 | import Partial.Unsafe (unsafeCrashWith)
24 |
25 | -- | Representation of dependencies between global definitions and the
26 | -- | main expression.
27 | newtype World = World Graph
28 |
29 | derive instance newtypeWorld :: Newtype World _
30 | derive newtype instance eqWorld :: Eq World
31 | derive newtype instance showWorld :: Show World
32 |
33 | -- | Map an entity to the set of other entities that depend on it
34 | type Graph = Map Entity (Set Entity)
35 |
36 | -- | A `Entity` is either a global `Name`, or the root expression
37 | -- | under evaluation.
38 | data Entity
39 | = Global Name
40 | | Root
41 |
42 | derive instance eqEntity :: Eq Entity
43 | derive instance ordEntity :: Ord Entity
44 |
45 | instance showEntity :: Show Entity where
46 | show = case _ of
47 | Global name -> show name
48 | Root -> "the input"
49 |
50 | -- | The `World` is inconsistent if anything depends on an undefined `Name`, or
51 | -- | if we attempt to delete a `Name` that is depended on by anything else.
52 | data ConsistencyError
53 | = Undefined (Set Name)
54 | | CannotDelete Name (Set Entity)
55 | | CannotRedefine Name (Set Entity)
56 |
57 | derive instance eqConsistencyError :: Eq ConsistencyError
58 | derive instance ordConsistencyError :: Ord ConsistencyError
59 |
60 | instance showConsistencyError :: Show ConsistencyError where
61 | show = case _ of
62 | Undefined missing -> fold
63 | [ "No top-level "
64 | , Grammar.pluralizeWith "s" (Set.size missing) "definition"
65 | , " for "
66 | , join missing
67 | ]
68 | CannotDelete name deps -> fold
69 | [ "Cannot delete "
70 | , show name
71 | , " because it's still referenced by "
72 | , join deps
73 | ]
74 | CannotRedefine name deps -> fold
75 | [ "Cannot redefine "
76 | , show name
77 | , " because it's still referenced by "
78 | , join deps
79 | ]
80 | where
81 | join :: forall a f. Show a => Foldable f => f a -> String
82 | join = Grammar.joinWith {inject: identity, conjunction: "and" }
83 | <<< map (show <<< show)
84 | <<< Array.fromFoldable
85 |
86 | -- | An empty `World` has no definitions
87 | empty :: World
88 | empty = World Map.empty
89 |
90 | -- | Create a new `World` given a list of top-level definitions. Crashes
91 | -- | if any definition depends on `Name`s that did not appear before it.
92 | new :: Array (Tuple Name Nameless) -> World
93 | new prelude = case foldM (flip addGlobal) empty prelude of
94 | Left err -> unsafeCrashWith $ "Malformed prelude: " <> show err
95 | Right world -> world
96 | where
97 | addGlobal (Tuple name expr) = add (Global name) expr
98 |
99 | -- | Attempt to define a new top-level definition. Fails if the
100 | -- | definition mentions other undefined `Name`s.
101 | define :: Name -> Nameless -> World -> Either ConsistencyError World
102 | define name x world = do
103 | let refs = referencing name world
104 | if Set.size refs == 0
105 | then add (Global name) x world
106 | else Left $ CannotRedefine name refs
107 |
108 | -- | Attempt to delete an existing top-level definition. Fails if any
109 | -- | other definition still depends on it.
110 | undefine :: Name -> World -> Either ConsistencyError World
111 | undefine name world = do
112 | let refs = referencing name world
113 | if Set.size refs == 0
114 | then pure $ remove (Global name) world
115 | else Left $ CannotDelete name refs
116 |
117 | -- | Set of `Entity`s that refer to this name
118 | referencing :: Name -> World -> Set Entity
119 | referencing name = fromMaybe Set.empty <<< Map.lookup (Global name) <<< un World
120 |
121 | -- | Attempt to focus the `World` on a new root expression. Fails if
122 | -- | the expression mentions any undefined `Name`s.
123 | focus :: Nameless -> World -> Either ConsistencyError World
124 | focus = add Root
125 |
126 | -- | Remove root expression.
127 | unfocus :: World -> World
128 | unfocus = remove Root
129 |
130 | -- | Internal operation for adding a new element to the `World`.
131 | add :: Entity -> Nameless -> World -> Either ConsistencyError World
132 | add entity expr world = do
133 | let
134 | fvs = freeVars expr
135 | missing = fvs `Set.difference` globals world
136 | isClosed = case entity of
137 | Global name -> Set.size missing == 0 || missing == Set.singleton name
138 | Root -> Set.size missing == 0
139 | if isClosed
140 | then pure $ combine world $ fromFreeVars entity fvs
141 | else Left $ Undefined missing
142 |
143 | -- | Internal operation for removing an element from the `World`.
144 | remove :: Entity -> World -> World
145 | remove entity = World <<< map (Set.delete entity) <<< Map.delete entity <<< un World
146 |
147 | -- | Set of top-level `Name`s.
148 | globals :: World -> Set Name
149 | globals = Set.mapMaybe name <<< Map.keys <<< un World
150 | where
151 | name = case _ of
152 | Root -> Nothing
153 | Global n -> pure n
154 |
155 | -- | Create a minimal `World` based on an item's free variables
156 | -- | assuming nothing else can depend on this item yet.
157 | fromFreeVars :: Entity -> Set Name -> World
158 | fromFreeVars entity fvs = World graph
159 | where
160 | graph = Map.fromFoldable $ Array.snoc others $ Tuple entity Set.empty
161 | others = do
162 | name <- Array.fromFoldable fvs
163 | pure $ Tuple (Global name) $ Set.singleton entity
164 |
165 | -- | Monoidally combine `World`s by unioning `Map`s point-wise.
166 | combine :: World -> World -> World
167 | combine (World lhs) (World rhs) = World $ Map.unionWith Set.union lhs rhs
168 |
--------------------------------------------------------------------------------
/frontend/src/Components/App.purs:
--------------------------------------------------------------------------------
1 | module Components.App
2 | ( new
3 | ) where
4 |
5 | import Lambda.Prelude hiding (State)
6 |
7 | import Components.Alert (component) as Alert
8 | import Components.ApiError as ApiError
9 | import Components.App.Action as Action
10 | import Components.App.Alert (Alert(..), Error(..)) as Alert
11 | import Components.App.Request as Request
12 | import Components.App.State as State
13 | import Components.ConsistencyError as ConsistencyError
14 | import Components.Controls as Controls
15 | import Components.Copy as Copy
16 | import Components.Definitions as Definitions
17 | import Components.Expressions as Expressions
18 | import Components.Footer as Footer
19 | import Components.Help as Help
20 | import Components.Input as Input
21 | import Components.Level as Level
22 | import Components.Modal as Modal
23 | import Components.ParseError as ParseError
24 | import Components.Spinner as Spinner
25 | import Data.Grammar (pluralizeWith)
26 | import Lambda.Env as Env
27 | import Lambda.Flags as Flags
28 | import Lambda.Flags (Flags)
29 | import Lambda.Language.Snapshot.Code (Code)
30 | import React.Basic (fragment, JSX)
31 | import React.Basic as React
32 | import React.Basic.DOM as R
33 | import React.Basic.Hooks (Component, component, mkReducer, useReducer)
34 | import React.Basic.Hooks as Hooks
35 | import React.Basic.Hooks.Aff (useAff)
36 |
37 | type Props =
38 | { code :: Maybe Code
39 | , flags :: Flags
40 | }
41 |
42 | new :: Component Props
43 | new = do
44 | reducer <- mkReducer State.reduce
45 | spinner <- Spinner.new
46 | modal <- linkModal
47 | component "App" \{ code: mCode, flags } -> Hooks.do
48 | state /\ dispatch <- useReducer (State.new flags mCode) reducer
49 | _ <- useAff state.request $ traverse_ (State.handle dispatch state) state.request
50 |
51 | let
52 | dismiss = dispatch Action.Dismiss
53 | alert = case state.alert of
54 | Just Alert.Help ->
55 | row $ helpAlert dismiss
56 | Just (Alert.Error error) ->
57 | row $ errorAlert dismiss error
58 | Just (Alert.Link code) ->
59 | row $ modal { dismiss, code, flags: state.flags }
60 | Nothing ->
61 | React.empty
62 |
63 | { isHalted, hasProgram, hasMachine } = State.status state
64 | dispatchIf cond = (_ <$ guard cond) <<< dispatch
65 |
66 | pure $ fragment
67 | [ R.div
68 | { className: "container"
69 | , children:
70 | [ row $ R.h2
71 | { className: "page-header"
72 | , children: [R.text "Lambda Machine"]
73 | }
74 | , alert
75 | , row $ Input.component
76 | { text: state.text
77 | , onChange: dispatch <<< Action.Update
78 | , onSubmit: dispatch Action.Parse
79 | , onHelp: dispatch Action.Help
80 | }
81 | , row $ R.h3_ [R.text "Definitions"]
82 | , row $ Definitions.component
83 | { defs: state.defs
84 | , rep: state.rep
85 | , onDelete: dispatch <<< Action.Delete
86 | }
87 | , split
88 | (stepsHeader state.steps)
89 | (Controls.component
90 | { flags
91 | , onStep: dispatchIf (not isHalted) Action.Step
92 | , onClear: dispatchIf hasMachine Action.Clear
93 | , onShare: dispatchIf hasProgram $ Action.Enqueue Request.Store
94 | , onSave: dispatchIf hasProgram $ Action.Enqueue Request.Save
95 | , onSugar: pure $ dispatch $ Action.Toggle
96 | , rep: state.rep
97 | }
98 | )
99 | , row $ Expressions.component
100 | { history: state.history
101 | , rep: state.rep
102 | }
103 | , row $ Footer.component {}
104 | ]
105 | }
106 | , maybe React.empty (\_ -> spinner {}) state.request
107 | ]
108 |
109 | errorAlert :: Effect Unit -> Alert.Error -> JSX
110 | errorAlert dismiss = case _ of
111 | Alert.ApiError error -> Alert.component
112 | { dismiss
113 | , level: Level.Danger
114 | , child: ApiError.component { error }
115 | }
116 | Alert.SaveError error -> Alert.component
117 | { dismiss
118 | , level: Level.Danger
119 | , child: R.text error
120 | }
121 | Alert.ParseError input error -> Alert.component
122 | { dismiss
123 | , level: Level.Danger
124 | , child: ParseError.component
125 | { input
126 | , error
127 | }
128 | }
129 | Alert.Inconsistent error -> Alert.component
130 | { dismiss
131 | , level: Level.Danger
132 | , child: ConsistencyError.component { error }
133 | }
134 |
135 | helpAlert :: Effect Unit -> JSX
136 | helpAlert dismiss = Alert.component
137 | { dismiss
138 | , level: Level.Info
139 | , child: Help.component {}
140 | }
141 |
142 | linkModal :: Component { dismiss :: Effect Unit, code :: Code, flags :: Flags }
143 | linkModal = do
144 | copy <- Copy.new
145 | modal <- Modal.new
146 | pure \{ dismiss, code, flags } -> modal
147 | { dismiss
148 | , level: Level.Info
149 | , title: "Copy Link To This Machine"
150 | , children:
151 | [ copy
152 | { text: Env.host <> "/?code=" <> unwrap code <> Flags.param flags
153 | }
154 | ]
155 | }
156 |
157 | -- | Row containing a single full-width element
158 | row :: JSX -> JSX
159 | row child =
160 | R.div
161 | { className: "row"
162 | , children: [R.div {className: "col-sm-12", children: [child]}]
163 | }
164 |
165 | -- | Row containing two equal-width elements
166 | split :: JSX -> JSX -> JSX
167 | split lhs rhs =
168 | R.div
169 | { className: "row"
170 | , children:
171 | [ R.div {className: "col-sm-6", children: [lhs]}
172 | , R.div {className: "col-sm-6", children: [rhs]}
173 | ]
174 | }
175 |
176 | stepsHeader :: Maybe Int -> JSX
177 | stepsHeader = case _ of
178 | Nothing -> R.h3
179 | { className: "text-muted"
180 | , children: [R.text "Steps"]
181 | }
182 | Just n -> R.h3_
183 | [ R.text $ fold
184 | [ show n
185 | , " "
186 | , pluralizeWith "s" n "Step"
187 | ]
188 | ]
189 |
--------------------------------------------------------------------------------
/backend/backend.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 1.12
2 |
3 | -- This file has been generated from package.yaml by hpack version 0.37.0.
4 | --
5 | -- see: https://github.com/sol/hpack
6 |
7 | name: backend
8 | version: 0.1.0.0
9 | description: Please see the README on GitHub at
10 | author: Christopher D. Parks
11 | maintainer: christopher.daniel.parks@gmail.com
12 | copyright: 2021 Christopher D. Parks
13 | license: MIT
14 | build-type: Simple
15 |
16 | library
17 | exposed-modules:
18 | Backend.Api
19 | Backend.Code
20 | Backend.Database
21 | Backend.Env
22 | Backend.Envelope
23 | Backend.Main
24 | Backend.Micro
25 | Backend.Middleware
26 | Backend.Name
27 | Backend.Prelude
28 | Backend.Random
29 | Backend.Settings
30 | Backend.Signature
31 | Backend.Snapshot
32 | Backend.Wai
33 | other-modules:
34 | Paths_backend
35 | hs-source-dirs:
36 | src
37 | default-extensions:
38 | BangPatterns
39 | BinaryLiterals
40 | ConstraintKinds
41 | DataKinds
42 | DefaultSignatures
43 | DeriveAnyClass
44 | DeriveDataTypeable
45 | DeriveFoldable
46 | DeriveFunctor
47 | DeriveGeneric
48 | DeriveTraversable
49 | DerivingStrategies
50 | DerivingVia
51 | EmptyDataDecls
52 | ExistentialQuantification
53 | FlexibleContexts
54 | FlexibleInstances
55 | FunctionalDependencies
56 | GADTs
57 | GeneralizedNewtypeDeriving
58 | InstanceSigs
59 | KindSignatures
60 | LambdaCase
61 | MultiParamTypeClasses
62 | MultiWayIf
63 | NamedFieldPuns
64 | NoImplicitPrelude
65 | NoMonomorphismRestriction
66 | OverloadedStrings
67 | PartialTypeSignatures
68 | PatternGuards
69 | PolyKinds
70 | RankNTypes
71 | RecordWildCards
72 | RoleAnnotations
73 | ScopedTypeVariables
74 | StandaloneDeriving
75 | StandaloneKindSignatures
76 | TupleSections
77 | TypeApplications
78 | TypeFamilies
79 | TypeFamilyDependencies
80 | TypeOperators
81 | TypeSynonymInstances
82 | build-depends:
83 | aeson
84 | , attoparsec
85 | , base >=4.7 && <5
86 | , data-default
87 | , envparse
88 | , errors
89 | , esqueleto
90 | , http-api-data
91 | , http-types
92 | , monad-logger
93 | , mtl
94 | , mwc-random
95 | , network-uri
96 | , path-pieces
97 | , persistent
98 | , persistent-postgresql
99 | , postgresql-simple
100 | , random
101 | , rio
102 | , rio-orphans
103 | , text
104 | , transformers
105 | , vector
106 | , wai
107 | , wai-cors
108 | , wai-extra
109 | , warp
110 | default-language: Haskell2010
111 |
112 | executable serve
113 | main-is: Main.hs
114 | other-modules:
115 | Paths_backend
116 | hs-source-dirs:
117 | app
118 | default-extensions:
119 | BangPatterns
120 | BinaryLiterals
121 | ConstraintKinds
122 | DataKinds
123 | DefaultSignatures
124 | DeriveAnyClass
125 | DeriveDataTypeable
126 | DeriveFoldable
127 | DeriveFunctor
128 | DeriveGeneric
129 | DeriveTraversable
130 | DerivingStrategies
131 | DerivingVia
132 | EmptyDataDecls
133 | ExistentialQuantification
134 | FlexibleContexts
135 | FlexibleInstances
136 | FunctionalDependencies
137 | GADTs
138 | GeneralizedNewtypeDeriving
139 | InstanceSigs
140 | KindSignatures
141 | LambdaCase
142 | MultiParamTypeClasses
143 | MultiWayIf
144 | NamedFieldPuns
145 | NoImplicitPrelude
146 | NoMonomorphismRestriction
147 | OverloadedStrings
148 | PartialTypeSignatures
149 | PatternGuards
150 | PolyKinds
151 | RankNTypes
152 | RecordWildCards
153 | RoleAnnotations
154 | ScopedTypeVariables
155 | StandaloneDeriving
156 | StandaloneKindSignatures
157 | TupleSections
158 | TypeApplications
159 | TypeFamilies
160 | TypeFamilyDependencies
161 | TypeOperators
162 | TypeSynonymInstances
163 | ghc-options: -threaded -rtsopts -with-rtsopts=-N
164 | build-depends:
165 | backend
166 | , base
167 | default-language: Haskell2010
168 |
169 | test-suite spec
170 | type: exitcode-stdio-1.0
171 | main-is: Spec.hs
172 | other-modules:
173 | Backend.ApiSpec
174 | Backend.Test.Prelude
175 | Paths_backend
176 | hs-source-dirs:
177 | test
178 | default-extensions:
179 | BangPatterns
180 | BinaryLiterals
181 | ConstraintKinds
182 | DataKinds
183 | DefaultSignatures
184 | DeriveAnyClass
185 | DeriveDataTypeable
186 | DeriveFoldable
187 | DeriveFunctor
188 | DeriveGeneric
189 | DeriveTraversable
190 | DerivingStrategies
191 | DerivingVia
192 | EmptyDataDecls
193 | ExistentialQuantification
194 | FlexibleContexts
195 | FlexibleInstances
196 | FunctionalDependencies
197 | GADTs
198 | GeneralizedNewtypeDeriving
199 | InstanceSigs
200 | KindSignatures
201 | LambdaCase
202 | MultiParamTypeClasses
203 | MultiWayIf
204 | NamedFieldPuns
205 | NoImplicitPrelude
206 | NoMonomorphismRestriction
207 | OverloadedStrings
208 | PartialTypeSignatures
209 | PatternGuards
210 | PolyKinds
211 | RankNTypes
212 | RecordWildCards
213 | RoleAnnotations
214 | ScopedTypeVariables
215 | StandaloneDeriving
216 | StandaloneKindSignatures
217 | TupleSections
218 | TypeApplications
219 | TypeFamilies
220 | TypeFamilyDependencies
221 | TypeOperators
222 | TypeSynonymInstances
223 | ghc-options: -threaded -rtsopts -with-rtsopts=-N
224 | build-depends:
225 | HUnit
226 | , aeson
227 | , backend
228 | , base
229 | , hspec
230 | , hspec-expectations-lifted
231 | , hspec-wai
232 | , hspec-wai-json
233 | , lens-aeson
234 | , load-env
235 | , wai-extra
236 | default-language: Haskell2010
237 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | ![Lambda Machine Screenshot][screenshot]
2 |
3 | ## What?
4 |
5 | [Try it here][lambda-machine]! It's a machine for evaluating
6 | expressions in the untyped lambda calculus. This machine has everything:
7 | * Lambdas
8 | * Variables
9 | * Applications
10 | * **Recursive** top-level definitions (_I finally caved_)
11 | * Uh, that's it
12 |
13 | ## Really?
14 |
15 | Yep. Here's a grammar, if you like that kind of thing. I know I do.
16 |
17 | ```ebnf
18 | definition
19 | = name, {name}, "=", expression ; (* Definition *)
20 |
21 | expression
22 | = lambda, name, {name}, ".", expression (* Lambda abstraction *)
23 | | name (* Variable *)
24 | | expression, expression (* Application *)
25 | | "(", expression, ")" (* Parentheses *)
26 | | {digit} (* Natural number *)
27 | | "[", [expressions], "]" (* List *)
28 | ;
29 |
30 | expressions
31 | = expression, [",", expressions] ; (* One or more comma-separated expressions *)
32 |
33 | lambda
34 | = "\" (* Backslash *)
35 | | "λ" (* Greek letter lambda *)
36 | ;
37 |
38 | name
39 | = (letter | "_") (* Initial letter or underscore *)
40 | , {letter | "-"} (* Zero or more letters or hyphens *)
41 | , ["?"] (* Optional question mark *)
42 | , {subscript | digit} (* Zero or more subscripts or digits *)
43 | ;
44 |
45 | letter (* Lowercase latin letters *)
46 | = "a" | "b" | "c" | "d" | "e" | "f" | "g"
47 | | "h" | "i" | "j" | "k" | "l" | "m" | "n"
48 | | "o" | "p" | "q" | "r" | "s" | "t" | "u"
49 | | "v" | "w" | "x" | "y" | "z" ;
50 |
51 | subscript (* Subscripts *)
52 | = "₀" | "₁" | "₂" | "₃" | "₄" | "₅" | "₆"
53 | | "₇" | "₈" | "₉" ;
54 |
55 | digit (* Decimal digits *)
56 | = "0" | "1" | "2" | "3" | "4" | "5" | "6"
57 | | "7" | "8" | "9" ;
58 | ```
59 |
60 | Natural numbers and lists are desugared to plain lambda calculus during
61 | parsing. A natural number **n** is parsed as a function that applies
62 | **s** to **z** **n** times.
63 |
64 | ```plaingtext
65 | 0 -> \s. \z. z
66 | 1 -> \s. \z. s z
67 | 2 -> \s. \z. s (s z)
68 | 3 -> \s. \z. s (s (s z))
69 | 4 -> \s. \z. s (s (s (s z)))
70 | ```
71 |
72 | A list is parsed as a right fold over its elements using **cons** and
73 | **nil**.
74 |
75 | ```plaintext
76 | [a] -> \cons. \nil. cons a nil
77 | [a, b] -> \cons. \nil. cons a (cons b nil)
78 | [a, b, c] -> \cons. \nil. cons a (cons b (cons c nil))
79 | ```
80 |
81 | These work together too:
82 |
83 | ```plaintext
84 | [0, 1, 2] -> \cons. \nil. cons (\s. \z. z) (cons (\s. \z. s z) (cons (\s. \z. s (s z)) nil))
85 | ```
86 |
87 | ## Why?
88 |
89 | ~~I've been working through the exercises in
90 | [_Introduction to Functional Programming Through Lambda Calculus_][book]
91 | by [Greg Michaelson][greg], and some of these expressions are tedious
92 | to reduce by hand. I build this to do it for me.~~
93 |
94 | Lol, I'm not doing that anymore. At this point, it's mostly just a fun
95 | way for me to fiddle around with PureScript. Hopefully, it's also
96 | useful to someone learning the lambda calculus for the first time.
97 | Let [me][me] know if you're using it and how I can make it better.
98 |
99 | ## How?
100 |
101 | Lambda Machine is written in [PureScript][purescript] and [React][react]
102 | using the [purescript-react-basic][react-basic] bindings. Expressions
103 | are converted to a locally nameless representation before being
104 | evaluated in normal order using call-by-need. Specifically, I use a
105 | tweaked version of the Template Instantiation Machine described in
106 | Simon Peyton Jones' and David Lester's [_Implementing Functional Languages: A Tutorial_][ifl].
107 |
108 | The Template Instantiation Machine is a graph reduction interpreter
109 | that is typically considered too slow and inflexible for "real"
110 | language implementations. However, for Lambda Machine, I only care
111 | about retaining or reconstructing enough syntactic information to
112 | easily visualize incremental lazy evaluation for humans. Speed is not
113 | the goal, so the Template Instantiation Machine works just fine.
114 |
115 | Tweaks:
116 | 1. The Template Instantiation Machine operates on lambda-lifted
117 | supercombinators. Lambda Machine creates closures at runtime.
118 | 2. The Template Instantiation Machine applies functions to as many
119 | arguments as are available on the stack. Lambda Machine applies
120 | functions one argument at a time, like a person working with pen and
121 | paper might.
122 | 3. The Template Instantiation Machine does not evaluate under lambdas.
123 | Lambda Machine does. This makes certain functions (e.g. the predecessor
124 | function on Church numerals) work that would otherwise get stuck too
125 | early.
126 | 4. The Template Instantiation calls its stack-of-suspended-stacks the
127 | "dump". Lambda Machine calls its stack-of-suspended-stacks the "stash".
128 | I don't remember why I did this. Maybe I thought "stash" looked nicer
129 | next to "stack". Maybe I thought "dump" was too ugly of a word to be
130 | typing so much. Truly, it is a mystery lost to time.
131 |
132 | Anyway, build and run it like this:
133 |
134 | ```bash
135 | cd frontend
136 | yarn setup
137 | yarn build
138 | yarn start
139 | ```
140 |
141 | (Or, again, just go [here][lambda-machine].)
142 |
143 | ## Who?
144 |
145 | Me, [Chris Parks][me], hi, hello, how are you? Let me know if you have
146 | questions, comments, or, like, really good sandwich recipes.
147 |
148 | [screenshot]: https://raw.githubusercontent.com/cdparks/lambda-machine/main/frontend/static/images/lambda-machine.png
149 | [lambda-machine]: https://lambda-machine.com
150 | [book]: https://www.amazon.com/dp/0486478831
151 | [greg]: https://www.macs.hw.ac.uk/~greg
152 | [purescript]: https://www.purescript.org
153 | [react]: https://reactjs.org/
154 | [react-basic]: https://github.com/lumihq/purescript-react-basic
155 | [ifl]: https://www.microsoft.com/en-us/research/publication/implementing-functional-languages-a-tutorial
156 | [me]: mailto:christopher.daniel.parks@gmail.com
157 |
--------------------------------------------------------------------------------
/backend/src/Backend/Micro.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE AllowAmbiguousTypes #-}
2 | {-# LANGUAGE UndecidableInstances #-}
3 |
4 | module Backend.Micro
5 | ( run
6 | , root
7 | , segment
8 | , param
9 | , (//)
10 | , get
11 | , post
12 | , notFound
13 | , badRequest
14 | , badMethod
15 | , internalError
16 | , Path
17 | , Handler
18 | ) where
19 |
20 | import Backend.Prelude hiding (handle)
21 |
22 | import Backend.Wai (Error(..), exceptionResponse, jsonResponse)
23 | import qualified Data.Text as T
24 | import Network.Wai
25 | import qualified RIO.ByteString as BS
26 |
27 | -- | Root path /
28 | root :: Path '[]
29 | root = End
30 |
31 | -- | Capture variable in path
32 | param :: FromHttpApiData v => Path '[v]
33 | param = Param End
34 |
35 | -- | Literal path text. Prefer using the 'IsString' instance instead.
36 | segment :: Text -> Path '[]
37 | segment = foldr Segment End . pieces
38 | where pieces = filter (not . T.null) . T.split (== '/')
39 |
40 | -- | Join paths
41 | (//) :: Path xs -> Path ys -> Path (Append xs ys)
42 | lhs // rhs = case lhs of
43 | End -> rhs
44 | Segment s ps -> Segment s $ ps // rhs
45 | Param ps -> Param $ ps // rhs
46 | infixl 1 //
47 |
48 | -- | Handle GET request
49 | --
50 | -- Handler receives capture variables as typed, parsed arguments.
51 | --
52 | get
53 | :: forall m f vs r
54 | . (MonadIO m, Apply m f vs, Result m f vs ~ m r, ToJSON r)
55 | => Path vs
56 | -> f
57 | -> Handler m ()
58 | get path f = handle methodGet path $ const . apply @m f
59 |
60 | -- | Handle POST request
61 | --
62 | -- Handler receives request body and capture variables as typed, parsed
63 | -- arguments.
64 | --
65 | post
66 | :: forall m f vs body r
67 | . ( FromJSON body
68 | , MonadIO m
69 | , Apply m f (body ': vs)
70 | , Result m f (body ': vs) ~ m r
71 | , ToJSON r
72 | )
73 | => Path vs
74 | -> f
75 | -> Handler m ()
76 | post path f = handle methodPost path $ \args req -> do
77 | body :: body <- liftIO $ jsonBody req
78 | apply @m f $ body :- args
79 |
80 | -- | throw 404 Not Found
81 | notFound :: MonadIO m => m a
82 | notFound = throwIO $ Error [] status404 Nothing
83 |
84 | -- | throw 400 Bad Request
85 | badRequest :: MonadIO m => Text -> m a
86 | badRequest = throwIO . Error [] status400 . Just
87 |
88 | -- | Throw 405 Method Not Allowed
89 | badMethod :: MonadIO m => [Method] -> m a
90 | badMethod allowed = throwIO $ Error headers status405 Nothing
91 | where headers = [("Allow", BS.intercalate ", " allowed)]
92 |
93 | -- | Throw 500 Internal Server Error
94 | internalError :: MonadIO m => Text -> m a
95 | internalError = throwIO . Error [] status500 . Just
96 |
97 | -- | Build handlers for specific methods
98 | handle
99 | :: forall m vs r
100 | . (MonadIO m, ToJSON r)
101 | => Method
102 | -> Path vs
103 | -> (Args vs -> Request -> m r)
104 | -> Handler m ()
105 | handle method path f = modify (|> match)
106 | where
107 | match m ts = case parse path ts of
108 | Just (Right args)
109 | | m == method -> Match $ fmap jsonResponse . f args
110 | | otherwise -> WrongMethod [method]
111 | Just (Left err) -> BadParse err
112 | Nothing -> NoMatch
113 |
114 | -- | Convert 'Handler' to Wai 'Application'
115 | run :: MonadUnliftIO m => Handler m () -> m Application
116 | run routes = do
117 | io <- askRunInIO
118 | pure $ \req respond -> do
119 | let match = findMatch (requestMethod req) (pathInfo req) routes
120 | result <- try $ case match of
121 | NoMatch -> notFound
122 | WrongMethod allowed -> badMethod allowed
123 | BadParse err -> badRequest err
124 | Match act -> io $ act req
125 | respond $ case result of
126 | Left e -> exceptionResponse e
127 | Right response -> response
128 |
129 | -- | Parse JSON from request body
130 | jsonBody :: forall a m . (MonadIO m, FromJSON a) => Request -> m a
131 | jsonBody req = do
132 | let contentType = lookup "content-type" $ requestHeaders req
133 | unless (contentType == Just "application/json")
134 | $ badRequest "content type not JSON"
135 | bytes <- liftIO $ lazyRequestBody req
136 | either (badRequest . pack) pure $ eitherDecode bytes
137 |
138 | -- | Attempt to find a match given 'Handler'
139 | findMatch :: Method -> [Text] -> Handler m () -> Match m
140 | findMatch method ts = foldMap step . flip execState mempty . runHandler
141 | where step matcher = matcher method ts
142 |
143 | -- | Path indexed by capture variable types
144 | data Path (vs :: [Type]) where
145 | End ::Path '[]
146 | Segment ::Text -> Path vs -> Path vs
147 | Param ::FromHttpApiData v => Path vs -> Path (v ': vs)
148 |
149 | instance vs ~ '[] => IsString (Path vs) where
150 | fromString = segment . fromString
151 |
152 | -- | Type-level list append
153 | type family Append xs ys where
154 | Append '[] ys = ys
155 | Append (x ': xs) ys = x ': Append xs ys
156 |
157 | -- | Heterogenous list of function arguments
158 | data Args vs where
159 | Nil ::Args '[]
160 | (:-) ::v -> Args vs -> Args (v ': vs)
161 | infixr 5 :-
162 |
163 | -- | Parse path segments into 'Args' if they match 'Path'
164 | --
165 | -- Returns 'Nothing' if segments don't match. Returns 'Left' if
166 | -- segments did match but some variable failed to parse.
167 | --
168 | parse :: Path vs -> [Text] -> Maybe (Either Text (Args vs))
169 | parse End [] = Just $ Right Nil
170 | parse _ [] = Nothing
171 | parse path (t : ts) = case path of
172 | End -> Nothing
173 | Segment s ps
174 | | s == t -> parse ps ts
175 | | otherwise -> Nothing
176 | Param ps -> case parseUrlPiece t of
177 | Left err -> Just $ Left err
178 | Right arg -> fmap (arg :-) <$> parse ps ts
179 |
180 | -- | Class for applying functions to 'Args' in some monad
181 | class Apply m f vs where
182 | type Result m f vs
183 | apply :: f -> Args vs -> Result m f vs
184 |
185 | instance (m ~ n) => Apply m (n r) '[] where
186 | type Result m (n r) '[] = n r
187 | apply f Nil = f
188 |
189 | instance (Apply m r vs, v ~ a) => Apply m (a -> r) (v ': vs) where
190 | type Result m (a -> r) (v ': vs) = Result m r vs
191 | apply f (v :- vs) = apply @m (f v :: r) vs
192 |
193 | -- | Result of running 'findMatch'
194 | data Match m
195 | = Match (Request -> m Response)
196 | -- ^ Matched path - run the embedded handler
197 | | WrongMethod [Method]
198 | -- ^ Path matched but can only handle these methods
199 | | BadParse Text
200 | -- ^ Path matched but a param failed to parse
201 | | NoMatch
202 | -- ^ No match at all
203 |
204 | instance Semigroup (Match m) where
205 | -- Bad parses take highest priority
206 | BadParse lhs <> _ = BadParse lhs
207 | _ <> BadParse rhs = BadParse rhs
208 |
209 | -- Followed by successful matches
210 | Match lhs <> _ = Match lhs
211 | _ <> Match rhs = Match rhs
212 |
213 | -- Followed by wrong method (which collects allowed methods)
214 | WrongMethod lhs <> WrongMethod rhs = WrongMethod $ lhs <> rhs
215 |
216 | -- No match is the identity
217 | NoMatch <> rhs = rhs
218 | lhs <> NoMatch = lhs
219 |
220 | instance Monoid (Match m) where
221 | mempty = NoMatch
222 |
223 | -- | Generate a 'Match' based on method and path pieces
224 | type Matcher m = Method -> [Text] -> Match m
225 |
226 | -- | State-based writer for collecting 'Matcher's
227 | newtype Handler m a = Handler { runHandler :: State (Seq (Matcher m)) a }
228 | deriving newtype (Functor, Applicative, Monad, MonadState (Seq (Matcher m)))
229 |
--------------------------------------------------------------------------------
/frontend/src/Lambda/Language/Snapshot.purs:
--------------------------------------------------------------------------------
1 | module Lambda.Language.Snapshot
2 | ( Snapshot(..)
3 | , module Error
4 | , new
5 | , load
6 | ) where
7 |
8 | import Lambda.Prelude
9 |
10 | import Data.Array as Array
11 | import Data.Map as Map
12 | import Lambda.Language.Definition (Definition)
13 | import Lambda.Language.Definition as Definition
14 | import Lambda.Language.Expression (Expression)
15 | import Lambda.Language.Expression as Expression
16 | import Lambda.Language.Name (Name)
17 | import Lambda.Language.Program (Program)
18 | import Lambda.Language.Snapshot.Error (Error(..))
19 | import Lambda.Language.Snapshot.Error (Error(..)) as Error
20 | import Lambda.Language.Snapshot.RPN (RPN(..))
21 | import Lambda.Language.Snapshot.RPN as RPN
22 | import Lambda.Language.Snapshot.Signature (Signature)
23 | import Lambda.Language.Snapshot.Signature as Signature
24 |
25 | -- | Compact representation of a machine state
26 | newtype Snapshot = Snapshot
27 | { sig :: Signature
28 | , names :: Array Name
29 | , state :: Array Int
30 | }
31 |
32 | derive instance newtypeSnapshot :: Newtype Snapshot _
33 | derive newtype instance eqSnapshot :: Eq Snapshot
34 | derive newtype instance showSnapshot :: Show Snapshot
35 | derive newtype instance decodeJsonSnapshot :: DecodeJson Snapshot
36 | derive newtype instance encodeJsonSnapshot :: EncodeJson Snapshot
37 |
38 | -- | Convert definitions and input to `Snapshot`
39 | new :: Program -> Either Error Snapshot
40 | new {defs, expr} = runIdentity $ runExceptT $ do
41 | state <- RPN.encode rpn
42 | pure $ Snapshot { sig, names, state }
43 | where
44 | sig = Signature.deflate defs
45 | Tuple names rpn = flatten defs expr
46 |
47 | -- | Attempt to load definitions and input from `Snapshot`
48 | load :: Snapshot -> Either Error Program
49 | load (Snapshot { sig, names, state }) =
50 | withPrelude <$> runIdentity (runExceptT $ evalStateT act start)
51 | where
52 | start = { stack: Nil, defs: [], names }
53 | act = replay =<< RPN.decode state
54 | withPrelude program = program
55 | { defs = Signature.inflate sig <> program.defs
56 | }
57 |
58 | -- | Collect names and program to a sequence of RPN instructions
59 | flatten :: Array Definition -> Maybe Expression -> Tuple (Array Name) (Array RPN)
60 | flatten defs expr = collect do
61 | flatDefs <- traverse flattenDef defs
62 | flatExpr <- traverse flattenExpr expr
63 | pure $ Array.concat flatDefs <> fromMaybe [] flatExpr
64 |
65 | -- | Flatten definition to a sequence of RPN instructions
66 | flattenDef :: forall m. MonadState Dictionary m => Definition -> m (Array RPN)
67 | flattenDef def = case Definition.split def of
68 | {id, name, expr}
69 | | id /= 0 -> pure []
70 | | otherwise -> do
71 | i <- save name
72 | ops <- flattenExpr expr
73 | pure $ ops <> [Define i]
74 |
75 | -- | Flatten expression to a sequence of RPN instructions
76 | flattenExpr :: forall m. MonadState Dictionary m => Expression -> m (Array RPN)
77 | flattenExpr = case _ of
78 | Expression.Var n -> do
79 | i <- save n
80 | pure [Var i]
81 | Expression.Nat i ->
82 | pure [Nat i]
83 | Expression.List xs -> do
84 | let arr = Array.fromFoldable xs
85 | ys <- traverse flattenExpr arr
86 | pure $ Array.concat ys <> [Take $ Array.length arr]
87 | Expression.Apply (Expression.Var n) arg -> do
88 | i <- save n
89 | flatArg <- flattenExpr arg
90 | pure $ flatArg <> [AppVar i]
91 | Expression.Apply fun arg -> do
92 | flatArg <- flattenExpr arg
93 | flatFun <- flattenExpr fun
94 | pure $ flatArg <> flatFun <> [Apply]
95 | Expression.Lambda n body -> do
96 | i <- save n
97 | flatBody <- flattenExpr body
98 | pure $ flatBody <> [Lambda i]
99 | Expression.Highlight e -> flattenExpr e
100 | Expression.Cycle -> pure []
101 |
102 | -- | Store names and cache their position
103 | type Dictionary =
104 | { names :: Array Name
105 | , cache :: Map Name Int
106 | }
107 |
108 | -- | Collect names
109 | collect :: forall a. State Dictionary a -> Tuple (Array Name) a
110 | collect act = Tuple names result
111 | where
112 | dict = { names: [], cache: Map.empty}
113 | Tuple result { names } = runState act dict
114 |
115 | -- | Save or fetch a `Name` in the dictionary returning its index
116 | save :: forall m. MonadState Dictionary m => Name -> m Int
117 | save name = do
118 | { names, cache } <- get
119 | case Map.lookup name cache of
120 | Just i -> pure i
121 | Nothing -> do
122 | let i = Array.length names
123 | modify_ \s -> s
124 | { names = names <> [name]
125 | , cache = Map.insert name i cache
126 | }
127 | pure i
128 |
129 | -- | Create definitions and input from sequence of encoded RPN instructions
130 | replay :: forall m. MonadThrow Error m => MonadState Store m => Array RPN -> m Program
131 | replay ops = do
132 | traverse_ step ops
133 | { defs, stack } <- get
134 | case stack of
135 | Nil -> pure { defs, expr: Nothing }
136 | Cons expr Nil -> pure { defs, expr: Just expr }
137 | _ -> throwError $ ExtraStackValues $ Array.length $ Array.fromFoldable stack
138 | where
139 | step = case _ of
140 | Var i -> do
141 | name <- fetch i
142 | push $ Expression.Var name
143 | Nat i -> do
144 | push $ Expression.Nat i
145 | Take i -> do
146 | xs <- take i
147 | push $ Expression.List xs
148 | Lambda i -> do
149 | body <- pop
150 | name <- fetch i
151 | push $ Expression.Lambda name body
152 | Define i -> do
153 | body <- pop
154 | name <- fetch i
155 | define $ Definition.join name body
156 | AppVar i -> do
157 | arg <- pop
158 | name <- fetch i
159 | push $ Expression.Apply (Expression.Var name) arg
160 | Apply -> do
161 | f <- pop
162 | arg <- pop
163 | push $ Expression.Apply f arg
164 |
165 | -- | Stack of expressions, new definitions, name store
166 | type Store =
167 | { stack :: List Expression
168 | , defs :: Array Definition
169 | , names :: Array Name
170 | }
171 |
172 | -- | Pop top of stack or throw
173 | pop :: forall m. MonadThrow Error m => MonadState Store m => m Expression
174 | pop = do
175 | { stack } <- get
176 | case stack of
177 | Nil -> throwError $ StackUnderflow { op: "pop", wanted: 1, saw: 0 }
178 | Cons x xs -> do
179 | modify_ \s -> s { stack = xs }
180 | pure x
181 |
182 | -- | Push expression on top of stack
183 | push :: forall m. MonadState Store m => Expression -> m Unit
184 | push e = modify_ $ \s -> s { stack = e : s.stack }
185 |
186 | -- | Add definition to defs
187 | define :: forall m. MonadState Store m => Definition -> m Unit
188 | define def = do
189 | { defs } <- get
190 | modify_ \s -> s { defs = defs <> [def] }
191 |
192 | -- | Take exactly n items from the stack or throw
193 | take :: forall m. MonadThrow Error m => MonadState Store m => Int -> m (List Expression)
194 | take n = do
195 | { stack } <- get
196 | { acc, stack: newStack } <- go { acc: Nil, stack } n
197 | modify_ \s -> s { stack = newStack }
198 | pure acc
199 | where
200 | go { acc, stack } i
201 | | i <= 0 = pure { acc, stack }
202 | | otherwise = case stack of
203 | Nil -> throwError $ StackUnderflow { op: "take", wanted: n, saw: n - i }
204 | Cons x xs -> go { acc: Cons x acc, stack: xs } $ i - 1
205 |
206 | -- | Fetch name by index or throw
207 | fetch :: forall m. MonadThrow Error m => MonadState Store m => Int -> m Name
208 | fetch i = do
209 | { names } <- get
210 | case Array.index names i of
211 | Just x -> pure x
212 | Nothing -> throwError $ IndexOutOfRange i names
213 |
--------------------------------------------------------------------------------