git.iko.soy/project-m36
on master help sign in
swap
44feeff35 ahead, 0 behind
36 files changed+1248−512
since splitsnapshots
unifiedsplit
.github/workflows/ci.yaml+61−21 .gitignore+1 .travis.yml−60 .travis/attach-binary.sh−25 .travis/install-dependencies.sh−22 .travis/install-ghc.sh−16 .travis/install-ghr.sh−21 .travis/install-stack.sh−27 Changelog.markdown+4 README.markdown+1−2 docker.nix+16−11 docs/introduction_to_the_relational_algebra.markdown+1−1 docs/tutd_cheatsheet.markdown+2 docs/tutd_tutorial.markdown+18 examples/Plantfarm.hs+446 nix/sources.json+50 nix/sources.nix+171 pkgs.nix−7 project-m36.cabal+40−31 release.nix+16−140 src/bin/ProjectM36/Server/WebSocket/websocket-server.hs+42−9 src/bin/TutorialD/Interpreter/Base.hs+1−1 src/bin/TutorialD/Interpreter/Import/TutorialD.hs+5−6 src/bin/TutorialD/Interpreter/RelationalExpr.hs+2−2 src/lib/ProjectM36/Server/Config.hs+6 src/lib/ProjectM36/Server/ParseArgs.hs+31−14 src/lib/ProjectM36/Shortcuts.hs+247 src/lib/ProjectM36/WithNameExpr.hs+4−2 stack.ghc8.0.yaml−48 stack.ghc8.10.yaml+19 stack.ghc8.6.yaml+24−20 stack.ghc8.8.yaml+24−22 test/TutorialD/Interpreter/Import/TutorialD.hs → test/TutorialD/Interpreter/Import/ImportTest.hs+10−4 test/TutorialD/Interpreter/Import/httpimporttest.tutd+2 test/TutorialD/Interpreter.hs → test/TutorialD/InterpreterTest.hs+4 test/TutorialD/Printer.hs → test/TutorialD/PrinterTest.hs
.github/workflows/ci.yaml+61−21
@@ -6,24 +6,64 @@ jobs:
66 dockerimage:
77 runs-on: ubuntu-latest
88 steps:
9− - uses: actions/checkout@v2.3.1
10− - uses: cachix/install-nix-action@v12
11− with:
12− nix_path: nixpkgs=channel:nixos-unstable
13− - uses: cachix/cachix-action@v8
14− with:
15− name: project-m36
16− signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}'
17− - run: cachix use iohk
18− - name: docker load
19− run: docker load < $(nix-build docker.nix)
20− - name: docker login
21− run: echo ${{secrets.DOCKERHUB_PASSWORD}} | docker login --username ${{secrets.DOCKERHUB_USER}} --password-stdin
22− - name: docker tag with version
23− run: docker tag project-m36:latest projectm36/project-m36:$(awk '/^Version:/ {print $2}' project-m36.cabal)
24− if: ${{ github.ref == 'refs/heads/master' }}
25− - name: docker tag latest
26− run: docker tag project-m36:latest projectm36/project-m36:latest
27− if: ${{ github.ref == 'refs/heads/master' }}
28− - run: docker push projectm36/project-m36
29− if: ${{ github.ref == 'refs/heads/master' }}
9+ - uses: actions/checkout@v2.3.1
10+ - uses: cachix/install-nix-action@v12
11+ with:
12+ nix_path: nixpkgs=channel:nixos-unstable
13+ - uses: cachix/cachix-action@v8
14+ with:
15+ name: project-m36
16+ signingKey: "${{ secrets.CACHIX_SIGNING_KEY }}"
17+ - run: cachix use iohk
18+ - name: docker load
19+ run: docker load < $(nix-build docker.nix)
20+ - name: docker login
21+ if: ${{ github.ref == 'refs/heads/master' }}
22+ run: echo ${{secrets.DOCKERHUB_PASSWORD}} | docker login --username ${{secrets.DOCKERHUB_USER}} --password-stdin
23+ - name: docker tag with version
24+ run: docker tag project-m36:latest projectm36/project-m36:$(awk '/^Version:/ {print $2}' project-m36.cabal)
25+ if: ${{ github.ref == 'refs/heads/master' }}
26+ - name: docker tag latest
27+ run: docker tag project-m36:latest projectm36/project-m36:latest
28+ if: ${{ github.ref == 'refs/heads/master' }}
29+ - run: docker push projectm36/project-m36
30+ if: ${{ github.ref == 'refs/heads/master' }}
31+
32+ stack-build:
33+ runs-on: ${{ matrix.os }}
34+ strategy:
35+ matrix:
36+ os: [ubuntu-latest]
37+ ghc:
38+ - ghc8.10
39+ - ghc8.8
40+ - ghc8.6
41+ include:
42+ - os: macos-latest
43+ ghc: ghc8.10
44+ env:
45+ STACK_YAML: stack.${{ matrix.ghc }}.yaml
46+ steps:
47+ - uses: actions/checkout@v2
48+ - name: Cache
49+ uses: actions/cache@v1
50+ with:
51+ path: ~/.stack
52+ key: ${{ runner.os }}-build-stack-${{ matrix.ghc }}-${{ hashFiles(env.STACK_YAML) }}-${{ hashFiles('**/*.cabal') }}
53+ restore-keys: |
54+ ${{ runner.os }}-build-stack-${{ matrix.ghc }}-${{ hashFiles(env.STACK_YAML) }}
55+ ${{ runner.os }}-build-stack-${{ matrix.ghc }}
56+ - name: Fix macOS cache bug
57+ run: rm -rf ~/.stack/setup-exe-cache
58+ - name: Build
59+ run: stack build --ghc-options -O2 --local-bin-path out --copy-bins
60+ - name: Test
61+ run: stack test --stack-yaml=${{ env.STACK_YAML }}
62+ - name: HLint
63+ run: curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s .
64+ - name: Haddock
65+ run: stack --no-install-ghc --system-ghc --no-haddock-deps haddock
66+ - uses: actions/upload-artifact@v2
67+ with:
68+ name: project-m36-${{ matrix.os }}-${{ matrix.ghc }}
69+ path: out/
.gitignore+1
@@ -20,3 +20,4 @@ jupyter/build
2020juyter/dist
2121.ipynb_checkpoints
2222project-m36.nix
23+stack.yaml
.travis.ymldeleted−60
@@ -1,60 +0,0 @@
1−# For more information, see https://github.com/ChrisPenner/haskell-stack-travis-ci
2−language: c
3−sudo: false
4−
5−git:
6− submodules: false # whether to recursively clone submodules
7−
8−cache:
9− directories:
10− - $HOME/.ghc
11− - $HOME/.cabal
12− - $HOME/.stack
13− - .stack-work
14− timeout: 1000
15−
16−matrix:
17− fast_finish: true
18− include:
19− - env: CACHE_NAME=8.8.4 STACK_YAML=stack.ghc8.8.yaml
20− compiler: ": #stack 8.8.4"
21−
22− - env: CACHE_NAME=8.6.5 STACK_YAML=stack.ghc8.6.yaml
23− compiler: ": #stack 8.6.5"
24−
25− - env: CACHE_NAME=osx-8.6.5 STACK_YAML=stack.ghc8.6.yaml
26− os: osx
27− osx_image: xcode11
28− compiler: ": #stack 8.6.5"
29−
30−before_script:
31− - unset CC
32− - export PATH=$HOME/.local/bin:/opt/ghc/$GHC_VERSION/bin:$PATH
33− - ./.travis/install-ghr.sh
34− - ./.travis/install-stack.sh
35−
36−# Here starts the actual work to be performed for the package under test;
37−# any command which exits with a non-zero exit code causes the build to fail.
38−script:
39− - |
40− # Run tests
41− set -e
42− ./.travis/install-dependencies.sh
43− stack --no-terminal --jobs=2 --system-ghc test
44− - |
45− #Run HLint
46− if [[ "$(uname)" = "Linux" ]]; then
47− curl -sL https://raw.github.com/ndmitchell/hlint/master/misc/travis.sh | sh -s lint src test examples --cpp-define VERSION_project_m36=HLINT
48− fi
49− - |
50− #Run Haddock
51− if [[ "$(uname)" = "Linux" ]]; then
52− stack --no-install-ghc --system-ghc --no-haddock-deps haddock
53− fi
54−
55−after_success:
56− - |
57− # Build and ship binary
58− #./.travis/attach-binary.sh
59−
60−# EOF
.travis/attach-binary.shdeleted−25
@@ -1,25 +0,0 @@
1−#!/bin/sh
2−set -o errexit -o verbose
3−
4−if test ! "$BUILD_BINARY" || test ! "$TRAVIS_TAG"
5−then
6− echo 'This is not a release build.'
7−elif test ! "$GITHUB_TOKEN"
8−then
9− echo 'The GITHUB_TOKEN environment variable is not set!'
10− exit 1
11−else
12− echo "Building binary for $TRAVIS_OS_NAME to $TRAVIS_TAG..."
13− stack build --ghc-options -O2 --pedantic
14− echo "Attaching binary for $TRAVIS_OS_NAME to $TRAVIS_TAG..."
15− OWNER="$(echo "$TRAVIS_REPO_SLUG" | cut -f1 -d/)"
16− REPO="$(echo "$TRAVIS_REPO_SLUG" | cut -f2 -d/)"
17− BIN="$(stack path --local-install-root)/bin/$REPO"
18− BUNDLE_NAME="$REPO-$TRAVIS_TAG-$TRAVIS_OS_NAME.tar.gz"
19− cp "$BIN" "./$REPO"
20− chmod +x "./$REPO"
21− tar -czf "$BUNDLE_NAME" "$REPO"
22− echo "SHA256:"
23− shasum -a 256 "$BUNDLE_NAME"
24− ghr -t "$GITHUB_TOKEN" -u "$OWNER" -r "$REPO" --replace "$(git describe --tags)" "$BUNDLE_NAME"
25−fi
.travis/install-dependencies.shdeleted−22
@@ -1,22 +0,0 @@
1−# Run tests
2−if [[ "$(uname)" = "Darwin" ]]; then
3− timeout_cmd="gtimeout"
4−else
5− timeout_cmd="timeout"
6−fi
7−$timeout_cmd 40m stack --no-terminal --jobs=2 --install-ghc --system-ghc build --only-dependencies --fast
8−ret=$?
9−case "$ret" in
10− 0)
11− # continue
12− ;;
13− 124)
14− echo "Timed out while installing dependencies."
15− echo "Try building again by pushing a new commit."
16− exit 1
17− ;;
18− *)
19− echo "Failed to install dependencies; stack exited with $ret"
20− exit "$ret"
21− ;;
22−esac
.travis/install-ghc.shdeleted−16
@@ -1,16 +0,0 @@
1−#!/bin/sh
2−set -eux
3−#assume stack is installed
4−STACK=~/.local/bin/stack
5−
6−fetch_ghc_osx() {
7− echo "Using stack to install GHC $GHC_VERSION"
8− $STACK setup $GHC_VERSION
9−}
10−
11−if [ "$(uname)" = "Darwin" ]; then
12− fetch_ghc_osx
13−else
14− #installed by apt
15− echo "Linux GHC $GHC_VERSION via APT already installed."
16−fi
.travis/install-ghr.shdeleted−21
@@ -1,21 +0,0 @@
1−#!/bin/sh
2−set -o errexit -o verbose
3−
4−if test ! "$BUILD_BINARY" || test ! "$TRAVIS_TAG"
5−then
6− echo 'This is not a release build.'
7−else
8− if [ "$TRAVIS_OS_NAME" = "linux" ]
9− then
10− ARCH="linux"
11− else
12− ARCH="darwin"
13− fi
14− echo "Installing ghr"
15− URL="https://github.com/tcnksm/ghr/releases/download/v0.5.4/ghr_v0.5.4_${ARCH}_386.zip"
16− curl -L ${URL} > ghr.zip
17− mkdir -p "$HOME/bin"
18− export PATH="$HOME/bin:$PATH"
19− unzip ghr.zip -d "$HOME/bin"
20− rm ghr.zip
21−fi
.travis/install-stack.shdeleted−27
@@ -1,27 +0,0 @@
1−#!/bin/sh
2−
3−# Adapted from https://github.com/commercialhaskell/stack
4−
5−set -eux
6−
7−travis_retry() {
8− cmd=$*
9− $cmd || (sleep 2 && $cmd) || (sleep 10 && $cmd)
10−}
11−
12−fetch_stack_osx() {
13− curl -skL https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin;
14−}
15−
16−fetch_stack_linux() {
17− curl -sL https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack';
18−}
19−
20−# We need stack to generate cabal files with precise bounds, even for cabal
21−# builds.
22−mkdir -p ~/.local/bin;
23−if [ "$(uname)" = "Darwin" ]; then
24− travis_retry fetch_stack_osx
25−else
26− travis_retry fetch_stack_linux
27−fi
Changelog.markdown+4
@@ -1,3 +1,7 @@
1+# 2021-04-01 (v0.9.3)
2+
3+* add new ":importtutd <URI> <SHA256 hash>" feature to import TutorialD from a local file or a HTTP/HTTPS URI
4+
15# 2020-12-27 (v0.9.0)
26
37* replace unmaintained distributed-process-client-server RPC package with new curryer RPC package
README.markdown+1−2
@@ -4,7 +4,6 @@
44[![Public Domain](https://img.shields.io/badge/license-Public%20Domain-brightgreen.svg)](http://unlicense.org)
55[![Hackage](https://img.shields.io/hackage/v/project-m36.svg)](http://hackage.haskell.org/package/project-m36)
66[![Hackage dependency status](https://img.shields.io/hackage-deps/v/project-m36.svg)](http://packdeps.haskellers.com/feed?needle=project-m36)
7−[![Build status](https://travis-ci.org/agentm/project-m36.svg?branch=master)](https://travis-ci.org/agentm/project-m36)
87[![Windows Build status](https://ci.appveyor.com/api/projects/status/q7jyddd6dy1ibqdo/branch/master?svg=true)](https://ci.appveyor.com/project/agentm/project-m36)
98[![Github Workflow status](https://github.com/agentm/project-m36/workflows/CI/badge.svg)](https://github.com/agentm/project-m36/actions?query=workflow%3ACI)
109
@@ -45,7 +44,7 @@ Project:M36 supports multiple frontends which target different audiences.
4544
4645* [Developer's Blog](https://agentm.github.io/project-m36/)
4746* [Mailing List/Discussion Group](https://groups.google.com/d/forum/project-m36)
48−* IRC Channel: chat.freenode.net #project-m36
47+* IRC Channel: irc.libera.chat #project-m36 -- [Chat via Web Client](http://kiwiirc.com/nextclient/irc.libera.chat:+6697/#project-m36)
4948* [Hackage](https://hackage.haskell.org/package/project-m36)
5049* [Diogo Biazus' Project:M36 Video Tutorial](https://www.youtube.com/watch?v=_GC_lxlVEnE)
5150
docker.nix+16−11
@@ -1,13 +1,18 @@
1−{ pkgs ? import ./pkgs.nix }:
1+{ compiler ? "ghc8104"
2+, sources ? import ./nix/sources.nix
3+, pkgs ? import sources.nixpkgs { }
4+}:
25let
3− release = import ./release.nix { inherit pkgs; };
4− static-project-m36 = pkgs.haskell.lib.justStaticExecutables release.project;
6+ release = import ./release.nix { inherit pkgs compiler sources; };
7+ static-project-m36 = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.justStaticExecutables release.project);
58in
6− pkgs.dockerTools.buildImage {
7− name = "project-m36";
8− tag = "latest";
9− contents = [static-project-m36];
10− #expose default project-m36 and websocket server ports
11− config = { Env = ["LC_ALL=en_US.UTF-8"];
12− ExposedPorts = { "6543/tcp" = {}; "8000/tcp" = {}; }; };
13− }
9+pkgs.dockerTools.buildImage {
10+ name = "project-m36";
11+ tag = "latest";
12+ contents = [ static-project-m36 ];
13+ # expose default project-m36 and websocket server ports
14+ config = {
15+ Env = [ "LC_ALL=en_US.UTF-8" ];
16+ ExposedPorts = { "6543/tcp" = { }; "8000/tcp" = { }; };
17+ };
18+}
docs/introduction_to_the_relational_algebra.markdown+1−1
@@ -202,7 +202,7 @@ Join (Instructor relation)
202202
203203(Course Relation)
204204
205−|(Course Name, Course Name Type)|(Instructor, Instructor Name Type)|(Course Room Number, Room Number Type)|
205+|(Course Name, Course Name Type)|(Instructor Name, Instructor Name Type)|(Course Room Number, Room Number Type)|
206206|-------------------------------|----------------------------------|--------------------------------------|
207207|English 1|Steve|Room 104|
208208|French 2|Bob|Room 103|
docs/tutd_cheatsheet.markdown+2
@@ -48,6 +48,8 @@ Database context expressions take the current database context as input and alte
4848|Database Context Expression |Description |
4949|------------------------------------------------------|---------------------------------------|
5050|`:importexample cjdate`|Imports a precooked schema from Chris Date's books resulting in relvars `s`, `sp`, and `p`|
51+|`:importtutd "file:///home/agentm/project-m36/scripts/emp.tutd"`|Imports TutorialD from file URI|
52+|`:importtutd "https://raw.githubusercontent.com/agentm/project-m36/master/scripts/emp.tutd" "effe32b247586dc3ac0079fc241b9618d41d189afcaeb7907edbe5a8b45992a4"`| Imports TutorialD from HTTP or HTTPS URI|
5153|`newrelvar:=relation{tuple{age 3}}`|Assign a new relation variable named `newrelvar`|
5254|`undefine s`|Remove a relation variable|
5355|`insert s relation{tuple{city "Boston",s# "S10",sname "Gonzalez",status 10}}`| Append to an existing relation variable with another relational expression|
docs/tutd_tutorial.markdown+18
@@ -30,6 +30,24 @@ Each section assumes a fresh instance of the Date examples. The relation variabl
3030|p|parts|
3131|sp|contains mapping of which suppliers supply which parts|
3232
33+### Importing TutorialD from Other Sources
34+
35+The `tutd` console can also run TutorialD from a local file or from a web server.
36+
37+To import TutorialD from a file:
38+
39+```
40+:importtutd "file:///home/agentm/project-m36/scripts/emp.tutd"
41+```
42+
43+or from a web server:
44+
45+```
46+:importtutd "https://raw.githubusercontent.com/agentm/project-m36/master/scripts/DateExamples.tutd" "db9f3d9fe06d0a29b8355e045b89ec94d6428e3a3de93def7ca77bf0298b7010"
47+```
48+
49+The second argument is an optional SHA256 hash in hexadecimal form. This can be used to validate that the script has not changed since the last import. Importing TutorialD from the web is in general safe because it is effectively sandboxed with "Safe Haskell" for functions, so the script is contained security-wise, however, nothing prevents the script from running forever. Downloading a schema from the web is a great way to share schemas and to kick start your project without starting from scratch.
50+
3351### Types
3452
3553TutorialD is strongly-typed. The basic built-in types are:
examples/Plantfarm.hsnew file+446
@@ -0,0 +1,446 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+{-# LANGUAGE DeriveAnyClass #-}
6+
7+{-# LANGUAGE DerivingVia #-}
8+
9+
10+import Codec.Winery (Serialise, WineryVariant(WineryVariant))
11+import Control.DeepSeq (NFData)
12+import Data.Aeson (FromJSON, ToJSON(toEncoding, toJSON))
13+import Data.Data (Proxy(Proxy))
14+import Data.Either (lefts, rights)
15+import Data.Functor (($>))
16+import Data.Text as T (Text)
17+import qualified Data.Text.Lazy as TL (pack)
18+import GHC.Generics (Generic)
19+import qualified ProjectM36.Base as Base
20+import ProjectM36.Client
21+ ( AtomExprBase(NakedAtomExpr)
22+ , Atomable(toAddTypeExpr, toAtom)
23+ , AttributeName
24+ , Connection
25+ , ConnectionInfo(InProcessConnectionInfo)
26+ , DatabaseContextExpr
27+ , DatabaseContextExprBase(Delete)
28+ , PersistenceStrategy(NoPersistence)
29+ , RelationalError
30+ , RelationalExprBase(RelationVariable, Restrict)
31+ , RestrictionPredicateExprBase(AttributeEqualityPredicate)
32+ , SessionId
33+ , close
34+ , commit
35+ , connectProjectM36
36+ , createSessionAtHead
37+ , databaseContextExprForUniqueKey
38+ , defaultHeadName
39+ , emptyNotificationCallback
40+ , executeDatabaseContextExpr
41+ , executeRelationalExpr
42+ , withTransaction
43+ )
44+import qualified ProjectM36.Relation as Relation
45+import ProjectM36.Tupleable
46+ ( Tupleable(fromTuple)
47+ , toDefineExpr
48+ , toDeleteExpr
49+ , toInsertExpr
50+ , toUpdateExpr
51+ )
52+import qualified System.Random as R
53+
54+
55+import Control.Monad.IO.Class (MonadIO(liftIO))
56+import qualified Web.Scotty as S
57+
58+-- | This is an example showcasing the updating of data
59+-- with the help of plants. \\
60+-- This is a very simple example and of course not how
61+-- plants grow in nature. \\
62+-- The main goal of this example is to showcase the updating
63+-- of data and the different options of persistence.
64+-- You can just pipe the output from curl into jq:
65+--
66+-- curl -X POST -H 'Accept: application/json' http://localhost:8001/plant/water/angu | jq -r '.stage'
67+
68+
69+data Stage = Seed | Sprout | Seedling | Adult | Dead
70+ deriving (Show, Eq, Ord, Generic, NFData, Atomable)
71+ deriving Serialise via WineryVariant Stage
72+
73+
74+instance ToJSON Stage where -- The where can be removed and the implementation commented out
75+ -- if the ascii values are not wanted
76+ toJSON s = toJSON $ show s <> "\nascii only provided for visualisation:\n" <> stagetoAscii s
77+
78+ toEncoding s = toEncoding $ show s <> "\nascii only provided for visualisation:\n" <> stagetoAscii s
79+
80+instance FromJSON Stage
81+
82+instance S.Parsable Stage where
83+ parseParam t
84+ | t == "seed" || t == "Seed" = Right Seed
85+ | t == "sprout" || t == "Sprout" = Right Sprout
86+ | t == "seedling" || t == "Seedling" = Right Seedling
87+ | t == "adult" || t == "Adult" = Right Adult
88+ | t == "dead" || t == "Dead" = Right Dead
89+ | otherwise = Left t
90+
91+
92+-- Just for ToJSON for ilustration of stage
93+type ASCIIStage = String
94+
95+seedStr :: ASCIIStage
96+seedStr = "<>\n\
97+ \'''\n"
98+sproutStr :: ASCIIStage
99+sproutStr = " ..\n\
100+ \<|>\n\
101+ \''''\n"
102+seedlingStr :: ASCIIStage
103+seedlingStr = " `\\⁄o \n\
104+ \ v|/\n\
105+ \'´;'''\n"
106+adultStr :: ASCIIStage
107+adultStr = "*~(#)~\n\
108+ \ \\,Y,e\n\
109+ \ \\|/\n\
110+ \''+'\\''\n"
111+deadStr :: ASCIIStage
112+deadStr = " ,__:<\n\
113+ \'/'''''\n"
114+
115+-- Just used for ToJSON illustration of stages
116+stagetoAscii :: Stage -> ASCIIStage
117+stagetoAscii Seed = seedStr
118+stagetoAscii Sprout = sproutStr
119+stagetoAscii Seedling = seedlingStr
120+stagetoAscii Adult = adultStr
121+stagetoAscii Dead = deadStr
122+
123+-- used for update stage
124+next :: Stage -> Stage
125+next Seed = Sprout
126+next Sprout = Seedling
127+next Seedling = Adult
128+next s = s
129+
130+data Plant = Plant { name :: Text, species :: Text, stage :: Stage, waterings:: Integer } deriving (Show, Generic)
131+instance Tupleable Plant
132+instance ToJSON Plant
133+instance FromJSON Plant
134+
135+
136+main :: IO ()
137+main = do
138+ putStrLn "Connecting to plant farm"
139+ c <- dbConnection
140+ _ <- createSchema c
141+ putStrLn "Planting some plants"
142+ _ <- insertSampleData c
143+ let port = 8001
144+ putStrLn $ "Started Plant farm at " <> show port
145+ S.scotty port $ do
146+
147+ -- retrieve a plant by name
148+ S.get "/plant/:name" $ do
149+ n <- S.param "name"
150+ e <- liftIO $ getPlant c n
151+ p <- handleWebError e
152+ S.json p
153+
154+
155+ -- save a plant providing it as json data
156+ S.post "/plant" $ do
157+ pl <- S.jsonData :: S.ActionM Plant
158+ e <- liftIO $ savePlant c [pl]
159+ p <- handleWebError e
160+ S.json p
161+
162+ -- updating a plant providing it as json data
163+ S.put "/plant" $ do
164+ pl <- S.jsonData :: S.ActionM Plant
165+ e <- liftIO $ updatePlantFst c pl
166+ p <- handleWebError e
167+ S.json p
168+
169+ -- watering the plant having the provided name.
170+ -- This will water the plant and might let it progress to the next stage. It might also die.
171+ S.post "/plant/water/:name" $ do
172+ n <- S.param "name"
173+ e <- liftIO $ waterPlant c n
174+ p <- handleWebError e
175+ S.json p
176+
177+ -- retriving all the plants as json data
178+ S.get "/plants" $ do
179+ e <- liftIO $ getAllPlants c
180+ ps <- handleWebErrors e
181+ S.json ps
182+
183+ -- saving many plants at the same time
184+ S.post "/plants" $ do
185+ pl <- S.jsonData :: S.ActionM [Plant]
186+ e <- liftIO $ savePlant c pl
187+ p <- handleWebError e
188+ S.json p
189+
190+ -- deleting all plants at a specific stage
191+ S.delete "/plants?stage=:stage" $ do
192+ s <- S.param "stage"
193+ e <- liftIO $ deletePlantsByStage c s
194+ p <- handleWebError e
195+ S.json p
196+
197+ -- deleting all plants at a specific stage
198+ S.delete "/plants" $ do
199+ s <- S.param "name"
200+ e <- liftIO $ deletePlantByName c s
201+ p <- handleWebError e
202+ S.json p
203+
204+ -- deleting all dead plants
205+ S.delete "/plants/clear" $ do
206+ e <- liftIO $ clearDeadPlants c
207+ ps <- handleWebErrors e
208+ S.json ps
209+
210+handleWebError :: Either Err b -> S.ActionM b
211+handleWebError (Left e) = S.raise (TL.pack $ "An error occurred:\n" <> show e)
212+handleWebError (Right v) = pure v
213+
214+handleWebErrors :: [Either Err b] -> S.ActionM [b]
215+handleWebErrors e = do
216+ case lefts e of
217+ [] -> pure (rights e)
218+ l -> S.raise (TL.pack $ "Errors occurred:\n" <> concatMap ((<>"\n") . show) l)
219+
220+
221+-- | watering a plant and thereby possibly updating its stage
222+waterPlant :: DBConnection -> Text -> IO (Either Err Plant)
223+waterPlant db n = do
224+ p <- getPlant db n
225+ case p of
226+ Left e -> pure $ Left e
227+ Right v -> updateStage db $ v { waterings = waterings v + 1 }
228+
229+-- | used by 'waterPlant' updates the stage depending on random numbers
230+updateStage :: DBConnection -> Plant -> IO (Either Err Plant)
231+updateStage db p@(Plant _ _ Dead _ ) = do
232+ tmp <- updatePlantFst db p
233+ case tmp of
234+ Left e -> pure $ Left e
235+ Right _ -> pure $ Right p
236+updateStage db p = do
237+ res <- calculateStage p
238+ tmp <- updatePlantFst db res
239+ case tmp of
240+ Left e -> pure $ Left e
241+ Right _ -> pure $ Right res
242+ where calculateStage p' = do
243+ r1 <- R.randomRIO (1, 10) :: IO Integer
244+ let np = if r1 < waterings p' then p' { stage = next $ stage p', waterings = 0 } else p'
245+ r2 <- R.randomRIO (1, 20)
246+ pure $ if r2 < waterings np then np { stage = Dead, waterings = 0 } else np
247+
248+-- | deletes all plants with Stage = Dead
249+clearDeadPlants :: DBConnection -> IO [Either Err Plant]
250+clearDeadPlants db = do
251+ _ <- deletePlantsByStage db Dead
252+ getAllPlants db
253+
254+
255+-- ****************************
256+-- | *Database functions* :
257+-- ****************************
258+
259+
260+-- | Error type for passing. It is not very specific.
261+-- Just minimal and non optimal for this example.
262+data Err = NotSpecified | NotFound deriving (Show ,Generic)
263+
264+instance ToJSON Err
265+
266+-- | Just for convinience for passing around the SessionId
267+-- and the Connection
268+data DBConnection = DB SessionId Connection
269+
270+
271+-- | Getting plants by their name.\
272+-- Because plant has name as primary key \
273+-- we can assume will get at most one result. \
274+-- Alternatively we could return a list.
275+getPlant :: DBConnection -> Text -> IO (Either Err Plant)
276+getPlant db n = defaultHead (Left NotFound) <$> (
277+ get db
278+ ( Restrict -- Restrict can be thought of as similar to "WITH" in SQL
279+ (AttributeEqualityPredicate "name" (NakedAtomExpr (toAtom n))) -- This is the Predicate we are "restricting" our RelationalExprBase with
280+ (RelationVariable "plants" ())
281+ )
282+ :: IO [Either Err Plant] -- this is needed because our 'get' function is
283+ )
284+
285+defaultHead :: a -> [a] -> a
286+defaultHead d [] = d
287+defaultHead _ (x:_) = x
288+
289+-- | Getting all the plants
290+getAllPlants :: DBConnection -> IO [Either Err Plant]
291+getAllPlants db = get db (RelationVariable "plants" ())
292+
293+-- | Getting all the plants that satisfy the restrictions
294+getAllPlantsWith :: DBConnection -> Base.RestrictionPredicateExpr -> IO [Either Err Plant]
295+getAllPlantsWith db ex = get db (Restrict ex (RelationVariable "plants" ()))
296+
297+
298+-- | Saving a plant
299+savePlant :: (Traversable t) => DBConnection -> t Plant -> IO (Either Err ())
300+savePlant db sps = insert db sps "plants"
301+
302+-- | An alternative to update alone because due to updates
303+-- not being cached yet \
304+-- they have to be calculated every update. \
305+-- This seems like an alternative until caching is implemented.
306+updatePlantFst :: DBConnection -> Plant -> IO (Either Err ())
307+updatePlantFst db pln = do
308+ _ <- delete db pln ["name"] "plants"
309+ savePlant db [pln]
310+
311+-- | Updating a plant. Due to the way project 36 works, \
312+-- updates have to be executed every time.\
313+-- This is slow but won't be an issue soon because they will
314+-- be cached.\
315+-- But because of this project 36 can provide O(1) commits.
316+updatePlant :: DBConnection -> Plant -> IO (Either Err ())
317+updatePlant db sps = update
318+ db -- db connection
319+ sps -- plant value
320+ ["name"] -- the attributes to be updated by (in case of unique key)
321+ "plants" -- the relation we want to update on
322+
323+
324+-- | deleting all plants that have given name.
325+deletePlantByName :: DBConnection -> Text -> IO (Either Err ())
326+deletePlantByName db s = executeWithTransaction db $ Right $ Delete "plants" $ AttributeEqualityPredicate "name" (NakedAtomExpr (toAtom s))
327+
328+-- | deleting all plants that have given stage.
329+deletePlantsByStage :: DBConnection -> Stage -> IO (Either Err ())
330+deletePlantsByStage db s = executeWithTransaction db $ Right $ Delete "plants" $ AttributeEqualityPredicate "stage" (NakedAtomExpr (toAtom s))
331+
332+
333+-- | Inserting the schema into the DB
334+createSchema :: DBConnection -> IO ()
335+createSchema (DB sessionId conn) = do
336+ _ <- handleIOErrorsAndQuit $ mapM (executeDatabaseContextExpr sessionId conn) [
337+ toAddTypeExpr (Proxy :: Proxy Stage) -- Adds the Type Stage as data to the DB
338+ , toDefineExpr (Proxy :: Proxy Plant) "plants" -- Creates the plants relation
339+ , databaseContextExprForUniqueKey "plants" ["name"] -- Makes name of the plants relation a uniqe Key,
340+ -- Foreign Key restrictions are available too
341+ ]
342+ pure ()
343+
344+
345+-- | inserting some sample data
346+insertSampleData :: DBConnection -> IO (Either Err ())
347+insertSampleData (DB sid conn) = do
348+ insert (DB sid conn) [
349+ Plant "angu" "Caladenia angustata" Seed 0
350+ , Plant "thely" "Thelymitra alcockiae" Seed 0
351+ , Plant "monstera" "Araceae" Seed 0
352+ ] "plants"
353+
354+dbConnection :: IO DBConnection
355+dbConnection = do
356+ -- connect to the database
357+ let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []
358+ -- The code below persists the data in a DB with the name "base". \\
359+-- let connInfo = InProcessConnectionInfo (CrashSafePersistence "base") emptyNotificationCallback [] \\
360+ -- In addition minimal persistance is available. \\
361+-- let connInfo = InProcessConnectionInfo (MinimalPersistence "base") emptyNotificationCallback []
362+ conn <- handleIOErrorAndQuit $ connectProjectM36 connInfo
363+ --create a database session at the default branch of the database
364+ sessionId <- handleIOErrorAndQuit $ createSessionAtHead conn defaultHeadName
365+ pure (DB sessionId conn)
366+
367+
368+-- | A polymorphic function to insert data (a traversable of data) into the DB
369+insert :: (Tupleable a, Traversable t) => DBConnection -> t a -> Base.RelVarName -> IO (Either Err ())
370+insert db rlv rlvName = executeWithTransaction db $ toInsertExpr rlv rlvName
371+
372+-- | A polymorphic function to update data in the DB.
373+-- An update in one funtion would take:
374+--
375+-- - SessionId
376+-- - Connection
377+-- - Tuplable a -- the Tuplable you want to update
378+-- - [AttributeName] -- the Attributes of the Tuplable you want to update those are of StringType
379+-- - RelVarName -- the name of the relation
380+--
381+-- With that you can via 'toUpdateExpr' create a 'DatabaseContextExpr' to be executed. \\
382+-- For inserting its very similarly done with 'toInsertExpr'.
383+update :: (Tupleable a) => DBConnection -> a -> [AttributeName]-> Base.RelVarName -> IO (Either Err ())
384+update db rlv attr rlvName = executeWithTransaction db $ toUpdateExpr rlvName attr rlv
385+
386+-- | A polymorphic function to delete data in the DB
387+delete :: (Tupleable a) => DBConnection -> a -> [AttributeName]-> Base.RelVarName -> IO (Either Err ())
388+delete db rlv attr rlvName = executeWithTransaction db $ toDeleteExpr rlvName attr rlv
389+
390+-- | A convenience function to make executing DBContextExpr with commiting simpler. \\
391+-- In particular for expr that just insert, delete and update.
392+-- Therefor ultimately return Either _ ()
393+executeWithTransaction :: DBConnection -> Either RelationalError DatabaseContextExpr -> IO (Either Err ())
394+executeWithTransaction (DB sid conn) expr = do
395+ iEx <- handleError expr
396+ case iEx of
397+ Left e -> pure $ Left e
398+ Right v -> handleIOError $ withTransaction sid conn (executeDatabaseContextExpr sid conn v) (commit sid conn)
399+
400+-- | A polymorphic function to get data (a list of data and possibly errors) from the DB
401+get :: Tupleable b => DBConnection -> Base.RelationalExpr -> IO [Either Err b]
402+get (DB sessionId conn) q = do
403+ eRel <- executeRelationalExpr sessionId conn q
404+ e <- handleError eRel
405+ case e of
406+ Left err -> pure [Left err]
407+ Right pRel -> do
408+ ws <- Relation.toList pRel
409+ mapM (handleError . fromTuple) ws
410+
411+-- | for closing the DB connection.
412+-- Not really needed when using in-memory DB
413+closeConn :: DBConnection -> IO ()
414+closeConn (DB _ conn) = close conn
415+
416+
417+-- | Error handling is heavily inspired by 'blog.hs' the blog example \\
418+-- by (agentm)[https://github.com/agentm] (https://github.com/agentm/project-m36, commit: f8432522adaafeae7c32bc2b8b6cb09c00396fc6). \\
419+-- As stated there, your application should have proper error handling.
420+handleIOErrorAndQuit :: Show e => IO (Either e a) -> IO a
421+handleIOErrorAndQuit m = do
422+ v <- m
423+ handleErrorAndQuit v
424+
425+handleError :: Show e => Either e a -> IO (Either Err a)
426+handleError eErr = case eErr of
427+ Left err -> print err $> Left NotSpecified
428+ Right v -> pure $ Right v
429+
430+handleIOError :: Show e => IO (Either e a) -> IO (Either Err a)
431+handleIOError m = do
432+ v <- m
433+ handleError v
434+
435+handleErrorAndQuit :: Show e => Either e a -> IO a
436+handleErrorAndQuit eErr = case eErr of
437+ Left err -> print err >> error "Quit."
438+ Right v -> pure v
439+
440+handleIOErrorsAndQuit :: Show e => IO [Either e a] -> IO [a]
441+handleIOErrorsAndQuit m = do
442+ eErrs <- m
443+ case lefts eErrs of
444+ [] -> pure (rights eErrs)
445+ err:_ -> handleErrorAndQuit (Left err)
446+
nix/sources.jsonnew file+50
@@ -0,0 +1,50 @@
1+{
2+ "curryer": {
3+ "branch": "master",
4+ "description": "Fast Haskell RPC",
5+ "homepage": null,
6+ "owner": "agentm",
7+ "repo": "curryer",
8+ "rev": "74ecaac619ad1165a4517d5c0f4e530493bda130",
9+ "sha256": "1izdvzj00k0y76ixm7dfgvq2fzphb8h4nzqgwkl3p0bg0806rsn1",
10+ "type": "tarball",
11+ "url": "https://github.com/agentm/curryer/archive/74ecaac619ad1165a4517d5c0f4e530493bda130.tar.gz",
12+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
13+ },
14+ "niv": {
15+ "branch": "master",
16+ "description": "Easy dependency management for Nix projects",
17+ "homepage": "https://github.com/nmattia/niv",
18+ "owner": "nmattia",
19+ "repo": "niv",
20+ "rev": "1819632b5823e0527da28ad82fecd6be5136c1e9",
21+ "sha256": "08jz17756qchq0zrqmapcm33nr4ms9f630mycc06i6zkfwl5yh5i",
22+ "type": "tarball",
23+ "url": "https://github.com/nmattia/niv/archive/1819632b5823e0527da28ad82fecd6be5136c1e9.tar.gz",
24+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
25+ },
26+ "nixpkgs": {
27+ "branch": "master",
28+ "description": "Nix Packages collection",
29+ "homepage": "",
30+ "owner": "NixOS",
31+ "repo": "nixpkgs",
32+ "rev": "429c23aad0fce9ef38b0e60d55d7459c19d53ddc",
33+ "sha256": "1nj8sh1fnxp07jdlvjkijwfd1pnsi2zj0ivy7a0dhx02g63byhg3",
34+ "type": "tarball",
35+ "url": "https://github.com/NixOS/nixpkgs/archive/429c23aad0fce9ef38b0e60d55d7459c19d53ddc.tar.gz",
36+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
37+ },
38+ "streamly": {
39+ "branch": "ac3af8749194f1788704dda8667d0b3807075cc2",
40+ "description": "Beautiful Streaming, Concurrent and Reactive Composition (Haskell)",
41+ "homepage": "https://hackage.haskell.org/package/streamly",
42+ "owner": "composewell",
43+ "repo": "streamly",
44+ "rev": "ac3af8749194f1788704dda8667d0b3807075cc2",
45+ "sha256": "04d8fk654vawdfs0dfidmq2awwgwi8x44iv8r7vqz70zkcsd5fij",
46+ "type": "tarball",
47+ "url": "https://github.com/composewell/streamly/archive/ac3af8749194f1788704dda8667d0b3807075cc2.tar.gz",
48+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
49+ }
50+}
nix/sources.nixnew file+171
@@ -0,0 +1,171 @@
1+# This file has been generated by Niv.
2+
3+let
4+
5+ #
6+ # The fetchers. fetch_<type> fetches specs of type <type>.
7+ #
8+
9+ fetch_file = pkgs: name: spec:
10+ let
11+ name' = sanitizeName name + "-src";
12+ in
13+ if spec.builtin or true then
14+ builtins_fetchurl { inherit (spec) url sha256; name = name'; }
15+ else
16+ pkgs.fetchurl { inherit (spec) url sha256; name = name'; };
17+
18+ fetch_tarball = pkgs: name: spec:
19+ let
20+ name' = sanitizeName name + "-src";
21+ in
22+ if spec.builtin or true then
23+ builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
24+ else
25+ pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
26+
27+ fetch_git = name: spec:
28+ let
29+ ref =
30+ if spec ? ref then spec.ref else
31+ if spec ? branch then "refs/heads/${spec.branch}" else
32+ if spec ? tag then "refs/tags/${spec.tag}" else
33+ abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";
34+ in
35+ builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; };
36+
37+ fetch_local = spec: spec.path;
38+
39+ fetch_builtin-tarball = name: throw
40+ ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`.
41+ $ niv modify ${name} -a type=tarball -a builtin=true'';
42+
43+ fetch_builtin-url = name: throw
44+ ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`.
45+ $ niv modify ${name} -a type=file -a builtin=true'';
46+
47+ #
48+ # Various helpers
49+ #
50+
51+ # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695
52+ sanitizeName = name:
53+ (
54+ concatMapStrings (s: if builtins.isList s then "-" else s)
55+ (
56+ builtins.split "[^[:alnum:]+._?=-]+"
57+ ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name)
58+ )
59+ );
60+
61+ # The set of packages used when specs are fetched using non-builtins.
62+ mkPkgs = sources: system:
63+ let
64+ sourcesNixpkgs =
65+ import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
66+ hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
67+ hasThisAsNixpkgsPath = <nixpkgs> == ./.;
68+ in
69+ if builtins.hasAttr "nixpkgs" sources
70+ then sourcesNixpkgs
71+ else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then
72+ import <nixpkgs> {}
73+ else
74+ abort
75+ ''
76+ Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or
77+ add a package called "nixpkgs" to your sources.json.
78+ '';
79+
80+ # The actual fetching function.
81+ fetch = pkgs: name: spec:
82+
83+ if ! builtins.hasAttr "type" spec then
84+ abort "ERROR: niv spec ${name} does not have a 'type' attribute"
85+ else if spec.type == "file" then fetch_file pkgs name spec
86+ else if spec.type == "tarball" then fetch_tarball pkgs name spec
87+ else if spec.type == "git" then fetch_git name spec
88+ else if spec.type == "local" then fetch_local spec
89+ else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
90+ else if spec.type == "builtin-url" then fetch_builtin-url name
91+ else
92+ abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";
93+
94+ # If the environment variable NIV_OVERRIDE_${name} is set, then use
95+ # the path directly as opposed to the fetched source.
96+ replace = name: drv:
97+ let
98+ saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
99+ ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
100+ in
101+ if ersatz == "" then drv else ersatz;
102+
103+ # Ports of functions for older nix versions
104+
105+ # a Nix version of mapAttrs if the built-in doesn't exist
106+ mapAttrs = builtins.mapAttrs or (
107+ f: set: with builtins;
108+ listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))
109+ );
110+
111+ # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295
112+ range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1);
113+
114+ # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257
115+ stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1));
116+
117+ # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
118+ stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
119+ concatMapStrings = f: list: concatStrings (map f list);
120+ concatStrings = builtins.concatStringsSep "";
121+
122+ # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331
123+ optionalAttrs = cond: as: if cond then as else {};
124+
125+ # fetchTarball version that is compatible between all the versions of Nix
126+ builtins_fetchTarball = { url, name ? null, sha256 }@attrs:
127+ let
128+ inherit (builtins) lessThan nixVersion fetchTarball;
129+ in
130+ if lessThan nixVersion "1.12" then
131+ fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
132+ else
133+ fetchTarball attrs;
134+
135+ # fetchurl version that is compatible between all the versions of Nix
136+ builtins_fetchurl = { url, name ? null, sha256 }@attrs:
137+ let
138+ inherit (builtins) lessThan nixVersion fetchurl;
139+ in
140+ if lessThan nixVersion "1.12" then
141+ fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
142+ else
143+ fetchurl attrs;
144+
145+ # Create the final "sources" from the config
146+ mkSources = config:
147+ mapAttrs (
148+ name: spec:
149+ if builtins.hasAttr "outPath" spec
150+ then abort
151+ "The values in sources.json should not have an 'outPath' attribute"
152+ else
153+ spec // { outPath = replace name (fetch config.pkgs name spec); }
154+ ) config.sources;
155+
156+ # The "config" used by the fetchers
157+ mkConfig =
158+ { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
159+ , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
160+ , system ? builtins.currentSystem
161+ , pkgs ? mkPkgs sources system
162+ }: rec {
163+ # The sources, i.e. the attribute set of spec name to spec
164+ inherit sources;
165+
166+ # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers
167+ inherit pkgs;
168+ };
169+
170+in
171+mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }
pkgs.nixdeleted−7
@@ -1,7 +0,0 @@
1−let
2−nixpkgs = builtins.fetchTarball {
3− url = "https://github.com/NixOS/nixpkgs/archive/refs/tags/20.09.tar.gz";
4− sha256 = "1wg61h4gndm3vcprdcg7rc4s1v3jkm5xd7lw8r2f67w502y94gcy";
5−};
6−in
7−import nixpkgs { config.allowBroken = true; }
project-m36.cabal+40−31
@@ -1,8 +1,8 @@
11Cabal-Version: 2.2
22Name: project-m36
3−Version: 0.9.2
3+Version: 0.9.3
44License: MIT
5−--note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain
5+--note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain
66Build-Type: Simple
77Homepage: https://github.com/agentm/project-m36
88Bug-Reports: https://github.com/agentm/project-m36/issues
@@ -35,7 +35,7 @@ Flag haskell-scripting
3535 Default: True
3636
3737Library
38− Build-Depends: base>=4.8 && < 4.15, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery, curryer-rpc, network, async, vector-instances, recursion-schemes
38+ Build-Depends: base>=4.8 && < 4.15, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery, curryer-rpc, network, async, vector-instances, recursion-schemes, streamly >= 0.7.2, convertible
3939 if flag(haskell-scripting)
4040 Build-Depends: ghc >= 8.2 && < 8.11
4141 CPP-Options: -DPM36_HASKELL_SCRIPTING
@@ -63,6 +63,7 @@ Library
6363 ProjectM36.AtomFunction,
6464 ProjectM36.AtomFunctionError,
6565 ProjectM36.ScriptSession,
66+ ProjectM36.Shortcuts,
6667 ProjectM36.DatabaseContextFunction,
6768 ProjectM36.DatabaseContextFunctionError,
6869 ProjectM36.DatabaseContextFunctionUtils,
@@ -142,7 +143,7 @@ Library
142143 Hs-Source-Dirs: ./src/lib
143144 Default-Language: Haskell2010
144145 Default-Extensions: OverloadedStrings, CPP
145− if !flag(stack)
146+ if !flag(stack)
146147 Build-Depends: deferred-folds
147148
148149Executable tutd
@@ -186,7 +187,8 @@ Executable tutd
186187 curryer-rpc,
187188 prettyprinter,
188189 cryptohash-sha256,
189− base16-bytestring,
190+ --due to decode signature change
191+ base16-bytestring >= 1.0.0.0,
190192 http-conduit,
191193 modern-uri,
192194 http-types
@@ -268,11 +270,11 @@ Executable bigrel
268270 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall
269271
270272Common commontest
271− Default-Language: Haskell2010
273+ Default-Language: Haskell2010
272274 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators, winery, curryer-rpc, prettyprinter, base64-bytestring, modern-uri, http-types, http-conduit, base16-bytestring,cryptohash-sha256
273275 Default-Extensions: OverloadedStrings
274276 GHC-Options: -Wall -threaded
275− Hs-Source-Dirs: ./src/bin, ., test/
277+ Hs-Source-Dirs: test, src/bin
276278
277279Benchmark basic-benchmark
278280 Default-Language: Haskell2010
@@ -285,7 +287,7 @@ Benchmark basic-benchmark
285287 if flag(profiler)
286288 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall
287289
288−--benchmark inserts, updates, deletes for a basic use-case to shake out any space leaks
290+--benchmark inserts, updates, deletes for a basic use-case to shake out any space leaks
289291Benchmark update-exprs
290292 Default-Language: Haskell2010
291293 Default-Extensions: OverloadedStrings
@@ -300,7 +302,7 @@ Benchmark update-exprs
300302Test-Suite test-tutoriald
301303 import: commontest
302304 type: exitcode-stdio-1.0
303− main-is: test/TutorialD/Interpreter.hs
305+ main-is: TutorialD/InterpreterTest.hs
304306 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer
305307 Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter
306308
@@ -308,56 +310,56 @@ Test-Suite test-tutoriald-atomfunctionscript
308310 import: commontest
309311 type: exitcode-stdio-1.0
310312 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer
311− main-is: test/TutorialD/Interpreter/AtomFunctionScript.hs
313+ main-is: TutorialD/Interpreter/AtomFunctionScript.hs
312314
313315Test-Suite test-tutoriald-databasecontextfunctionscript
314316 import: commontest
315317 type: exitcode-stdio-1.0
316318 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer
317− main-is: test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs
319+ main-is: TutorialD/Interpreter/DatabaseContextFunctionScript.hs
318320
319321Test-Suite test-relation
320322 import: commontest
321323 type: exitcode-stdio-1.0
322− main-is: test/Relation/Basic.hs
324+ main-is: Relation/Basic.hs
323325
324326Test-Suite test-static-optimizer
325327 import: commontest
326328 type: exitcode-stdio-1.0
327− main-is: test/Relation/StaticOptimizer.hs
329+ main-is: Relation/StaticOptimizer.hs
328330
329331Test-Suite test-transactiongraph-persist
330332 import: commontest
331333 type: exitcode-stdio-1.0
332− main-is: test/TransactionGraph/Persist.hs
334+ main-is: TransactionGraph/Persist.hs
333335 Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer
334336
335337Test-Suite test-relation-import-csv
336338 import: commontest
337339 type: exitcode-stdio-1.0
338− main-is: test/Relation/Import/CSV.hs
340+ main-is: Relation/Import/CSV.hs
339341
340342Test-Suite test-tutoriald-import-tutoriald
341343 import: commontest
342344 type: exitcode-stdio-1.0
343− main-is: test/TutorialD/Interpreter/Import/TutorialD.hs
345+ main-is: TutorialD/Interpreter/Import/ImportTest.hs
344346 Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer
345347
346348Test-Suite test-relation-export-csv
347349 import: commontest
348350 type: exitcode-stdio-1.0
349− main-is: test/Relation/Export/CSV.hs
351+ main-is: Relation/Export/CSV.hs
350352
351353Test-Suite test-transactiongraph-merge
352354 import: commontest
353355 type: exitcode-stdio-1.0
354− main-is: test/TransactionGraph/Merge.hs
356+ main-is: TransactionGraph/Merge.hs
355357
356358
357359Test-Suite test-prettyprinter
358360 import: commontest
359361 type: exitcode-stdio-1.0
360− main-is: test/TutorialD/Printer.hs
362+ main-is: TutorialD/PrinterTest.hs
361363 Other-Modules: TutorialD.Printer, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types
362364
363365benchmark bench
@@ -368,7 +370,7 @@ benchmark bench
368370Test-Suite test-server
369371 import: commontest
370372 type: exitcode-stdio-1.0
371− main-is: test/Server/Main.hs
373+ main-is: Server/Main.hs
372374
373375
374376Executable Example-SimpleClient
@@ -399,6 +401,13 @@ Executable Example-Hair
399401 Main-Is: examples/hair.hs
400402 GHC-Options: -Wall -threaded
401403
404+Executable Example-Plantfarm
405+ Default-Language: Haskell2010
406+ Default-Extensions: OverloadedStrings
407+ Build-Depends: aeson, barbies, base, binary, containers, deepseq, hashable, project-m36, random, scotty, text, winery
408+ Main-Is: examples/Plantfarm.hs
409+ GHC-Options: -Wall -threaded
410+
402411Executable Example-CustomTupleable
403412 Default-Language: Haskell2010
404413 Default-Extensions: OverloadedStrings
@@ -419,12 +428,12 @@ Executable Example-DerivingCustomTupleable
419428Test-Suite test-scripts
420429 import: commontest
421430 type: exitcode-stdio-1.0
422− main-is: test/scripts.hs
431+ main-is: scripts.hs
423432 Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer
424433
425434Executable project-m36-websocket-server
426435 Default-Language: Haskell2010
427− Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256
436+ Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256, wai, wai-websockets, warp, warp-tls
428437 Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs
429438 Other-Modules: ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer
430439 GHC-Options: -Wall -threaded
@@ -434,39 +443,39 @@ Executable project-m36-websocket-server
434443Test-Suite test-websocket-server
435444 import: commontest
436445 type: exitcode-stdio-1.0
437− main-is: test/Server/WebSocket.hs
446+ main-is: Server/WebSocket.hs
438447 Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer
439448
440449Test-Suite test-isomorphic-schemas
441450 import: commontest
442451 type: exitcode-stdio-1.0
443− main-is: test/IsomorphicSchema.hs
452+ main-is: IsomorphicSchema.hs
444453
445454Test-Suite test-atomable
446455 import: commontest
447456 type: exitcode-stdio-1.0
448− main-is: test/Relation/Atomable.hs
457+ main-is: Relation/Atomable.hs
449458 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer
450459
451460Test-Suite test-multiprocess-access
452461 import: commontest
453462 type: exitcode-stdio-1.0
454− main-is: test/MultiProcessDatabaseAccess.hs
463+ main-is: MultiProcessDatabaseAccess.hs
455464
456465Test-Suite test-transactiongraph-automerge
457466 import: commontest
458467 type: exitcode-stdio-1.0
459− main-is: test/TransactionGraph/Automerge.hs
468+ main-is: TransactionGraph/Automerge.hs
460469 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer
461470
462471Test-Suite test-tupleable
463472 import: commontest
464473 type: exitcode-stdio-1.0
465− main-is: test/Relation/Tupleable.hs
474+ main-is: Relation/Tupleable.hs
466475
467476Test-Suite test-client-simple
468477 import: commontest
469− Main-Is: test/Client/Simple.hs
478+ Main-Is: Client/Simple.hs
470479 type: exitcode-stdio-1.0
471480
472481-- test for file handle leaks
@@ -497,9 +506,9 @@ Executable handles
497506 HS-Source-Dirs: ./src/bin
498507 if flag(profiler)
499508 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall
500−
509+
501510Test-Suite test-dataframe
502511 import: commontest
503512 type: exitcode-stdio-1.0
504− Main-Is: test/DataFrame.hs
513+ Main-Is: DataFrame.hs
505514 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer
release.nix+16−140
@@ -1,154 +1,30 @@
1−{ compiler ? "ghc865"
2−, pkgs ? import <nixpkgs> {}
1+{ compiler ? "ghc8104"
2+, sources ? import ./nix/sources.nix
3+, pkgs ? import sources.nixpkgs { }
34}:
4−
55let
6− inherit (pkgs.lib.trivial) flip pipe;
7− inherit (pkgs.haskell.lib) appendPatch appendConfigureFlags;
86 doJailbreak = pkgs.haskell.lib.doJailbreak;
9− dontHaddock = pkgs.haskell.lib.dontHaddock;
10− dontCheck = pkgs.haskell.lib.dontCheck;
11− streamly-master = pkgs.fetchFromGitHub {
12− owner = "composewell";
13− repo = "streamly";
14− rev = "ac3af8749194f1788704dda8667d0b3807075cc2";
15− sha256 = "04d8fk654vawdfs0dfidmq2awwgwi8x44iv8r7vqz70zkcsd5fij";
16− };
7+ needsCocoa = drv:
8+ if pkgs.stdenv.isDarwin
9+ then drv.overrideDerivation (old:
10+ { buildInputs = [ pkgs.darwin.apple_sdk.frameworks.Cocoa ] ++ old.buildInputs; }
11+ )
12+ else drv;
1713
18− distProcessPkg = pkg : dontHaddock (doJailbreak (dontCheck pkg));
19− callHackageDirectWithOptions = {pkg,ver, sha256, options}:
20− let pkgver = "${pkg}-${ver}";
21− in
22− haskellPackages.callCabal2nixWithOptions pkg (pkgs.fetchzip {
23− url = "mirror://hackage/${pkgver}/${pkgver}.tar.gz";
24− inherit sha256;
25− }) options;
26−
2714 haskellPackages = pkgs.haskell.packages.${compiler}.override {
2815 overrides = self: super: {
29− rank1dynamic =
30− distProcessPkg (self.callHackageDirect {
31− pkg = "rank1dynamic";
32− ver = "0.4.0";
33− sha256 = "1x6p9z53s7xwp93jp4n1lq6m5xspcn6w62p461v8vqnp9600328b";
34−}{});
35− stm-hamt =
36− distProcessPkg(self.callHackageDirect {
37− pkg = "stm-hamt";
38− ver = "1.2.0.3";
39− sha256 = "1i8j7q8nhx3l7gydrjlsyhkvllr6bppgrjf0hp38zpm7p6xcv2bb";
40− }{});
41−
42− stm-containers =
43− distProcessPkg(self.callHackageDirect {
44− pkg = "stm-containers";
45− ver = "1.1.0.4";
46− sha256 = "0h9z6lawdm44minx9spvdb7sp645l36ri5cnxvhrcxwzr64s7qb5";
47− }{});
48−
49− data-interval =
50− distProcessPkg(self.callHackageDirect {
51− pkg = "data-interval";
52− ver = "2.0.1";
53− sha256 = "085j4yjr8wimxampxqdrg47p577whwg2mjxgfdl44yfck52fb6an";
54− }{});
55−
56− rset = distProcessPkg super.rset;
57−
58− curryer-rpc =
59− distProcessPkg(self.callHackageDirect {
60− pkg = "curryer-rpc";
61− ver = "0.1";
62− sha256 = "0vb7q68g4zjm20simnqpjdpvcvh4g8cwlc5b6zjdjpg1rargri41";
63− }{});
64−
65− streamly = distProcessPkg(self.callCabal2nix "streamly" streamly-master {});
66−
67− fusion-plugin-types =
68− distProcessPkg(self.callHackageDirect {
69− pkg = "fusion-plugin-types";
70− ver = "0.1.0";
71− sha256 = "17211b80p4zqisghs2j8flm4dj788f9glx2id6nh8f223q4cigc9";
72− }{});
73−
74− winery =
75− distProcessPkg(self.callHackageDirect {
76− pkg = "winery";
77− ver = "1.3.2";
78− sha256 = "1jc7q8m0zd8bziwa3mra44j518ckc566akk7r5hqpf8x5ng0n4vv";
79− }{});
80−
81− barbies-th =
82− distProcessPkg(self.callHackageDirect {
83− pkg = "barbies-th";
84− ver = "0.1.7";
85− sha256 = "0gf39kcn6lwqhz888qm3iypma76yrp3zwmif1niry647qq27xp4j";
86− }{});
87−
88− barbies =
89− distProcessPkg(self.callHackageDirect {
90− pkg = "barbies";
91− ver = "2.0.2.0";
92− sha256 = "0753rd8pw0x1cgasz8a6633kg83jngwzncp9khbimllvcdqzardh";
93− }{});
94−
95− prettyprinter =
96− distProcessPkg(self.callHackageDirect {
97− pkg = "prettyprinter";
98− ver = "1.7.0";
99− sha256 = "17byy08brwcsl5rqdhibq3pcpgx085shizb2ap6s4xy3izdia3cc";
100− }{});
101−
102− prettyprinter-ansi-terminal =
103− distProcessPkg(self.callHackageDirect {
104− pkg = "prettyprinter-ansi-terminal";
105− ver = "1.1.2";
106− sha256 = "0lwcqndppw3jc55rlnn6sp76zmjx2yzl21g9jhg27k2rdnjwd7md";
107− }{});
108−
109− http2 = distProcessPkg super.http2;
110−
111− cryptohash-sha256 =
112− distProcessPkg(self.callHackageDirect {
113− pkg = "cryptohash-sha256";
114− ver = "0.11.101.0";
115− sha256 = "02n4s1fm4kivi5cjzbwkzjs31h5sw8zrv0vv2qyz3413zp3g6010";
116− }{});
117−
118− cryptohash-md5 =
119− distProcessPkg(self.callHackageDirect {
120− pkg = "cryptohash-md5";
121− ver = "0.11.100.1";
122− sha256 = "0sl41rfai346j45475hldzp857s6h28ryxyn6xgrkm8js9yzfkd7";
123− }{});
124−
125− cryptohash-sha1 =
126− distProcessPkg(self.callHackageDirect {
127− pkg = "cryptohash-sha1";
128− ver = "0.11.100.1";
129− sha256 = "0k3q9sraq7s5y8i01p5a2b3cvbdvslz9kv494vh83jrvsamj7dcx";
130− }{});
131−
132− base16-bytestring =
133− distProcessPkg(self.callHackageDirect {
134− pkg = "base16-bytestring";
135− ver = "1.0.1.0";
136− sha256 = "0wvsjhg301qxikarvnvrbhdadrs892z4v8w9bq4na4gwdlf4aw6z";
137− }{});
138−
139− project-m36 = dontCheck (self.callCabal2nixWithOptions "project-m36" ./. "-f-haskell-scripting" { });
140−
16+ curryer-rpc = self.callCabal2nix "curryer-rpc" sources.curryer { };
17+ streamly = doJailbreak (needsCocoa (self.callCabal2nix "streamly" sources.streamly { }));
18+ project-m36 = ((self.callCabal2nixWithOptions "project-m36" ./. "-f-haskell-scripting" { }));
14119 };
14220 };
143−
144− project = haskellPackages.project-m36;
14521in
14622{
147− project = project;
23+ project = haskellPackages.project-m36;
14824
14925 shell = haskellPackages.shellFor {
150− packages = p: with p; [
151− project
26+ packages = p: [
27+ p.project-m36
15228 ];
15329 buildInputs = [
15430 haskellPackages.ghcid
@@ -157,4 +33,4 @@ in
15733 ];
15834 withHoogle = true;
15935 };
160−}
36+}
src/bin/ProjectM36/Server/WebSocket/websocket-server.hs+42−9
@@ -1,23 +1,40 @@
11{-# LANGUAGE CPP #-}
2−import ProjectM36.Server.WebSocket
3−import ProjectM36.Server.Config
4−import ProjectM36.Server.ParseArgs
5−import ProjectM36.Server
2+
63import Control.Concurrent
7−import qualified Network.WebSockets as WS
84import Control.Exception
5+import Control.Monad (when)
6+import Data.Maybe (isJust)
7+import Data.String (fromString)
8+import Network.HTTP.Types (status400)
99import Network.Socket
10+import Network.Wai (Application, responseLBS)
11+import Network.Wai.Handler.Warp
12+import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)
13+import qualified Network.Wai.Handler.WebSockets as WS
14+import Network.WebSockets (defaultConnectionOptions)
15+import ProjectM36.Server
16+import ProjectM36.Server.Config
17+import ProjectM36.Server.ParseArgs
18+import ProjectM36.Server.WebSocket
1019
1120main :: IO ()
1221main = do
1322 -- launch normal project-m36-server
1423 addressMVar <- newEmptyMVar
15− serverConfig <- parseConfigWithDefaults (defaultServerConfig { bindPort = 8000, bindHost = "127.0.0.1" })
24+ wsConfig <- parseWSConfigWithDefaults (defaultServerConfig {bindPort = 8000, bindHost = "127.0.0.1"})
25+
1626 --usurp the serverConfig for our websocket server and make the proxied server run locally
17− let wsHost = bindHost serverConfig
27+ let serverConfig = wsServerConfig wsConfig
28+ wsHost = bindHost serverConfig
1829 wsPort = bindPort serverConfig
1930 serverHost = "127.0.0.1"
2031 serverConfig' = serverConfig {bindPort = 0, bindHost = serverHost}
32+ configCertificateFile = tlsCertificatePath wsConfig
33+ configKeyFile = tlsKeyPath wsConfig
34+
35+ when (isJust configCertificateFile /= isJust configKeyFile) $
36+ throwIO $ ErrorCall "TLS_CERTIFICATE_PATH and TLS_KEY_PATH must be set in tandem"
37+
2138 _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)
2239 --wait for server to be listening
2340 addr <- takeMVar addressMVar
@@ -25,6 +42,22 @@ main = do
2542 case addr of
2643 SockAddrInet port' _ -> fromIntegral port'
2744 _ -> error "unsupported socket address (IPv4 only currently)"
28− --this built-in server is apparently not meant for production use, but it's easier to test than starting up the wai or snap interfaces
29− WS.runServer wsHost (fromIntegral wsPort) (websocketProxyServer port serverHost)
45+ wsApp = websocketProxyServer port serverHost
46+ waiApp = WS.websocketsOr defaultConnectionOptions wsApp backupApp
47+ settings = warpSettings wsHost (fromIntegral wsPort)
48+
49+ case (configCertificateFile, configKeyFile) of
50+ (Just certificate, Just key) -> runTLS (tlsSettings certificate key) settings waiApp
51+ _ -> runSettings settings waiApp
52+
53+backupApp :: Application
54+backupApp _ respond = respond $ responseLBS status400 [] "Not a WebSocket request"
3055
56+warpSettings :: HostName -> Port -> Settings
57+warpSettings host port =
58+ setHost (fromString host)
59+ . setPort port
60+ . setServerName "project-m36"
61+ . setTimeout 3600
62+ . setGracefulShutdownTimeout (Just 5)
63+ $ defaultSettings
src/bin/TutorialD/Interpreter/Base.hs+1−1
@@ -155,7 +155,7 @@ natural = Lex.integer <* spaceConsumer
155155#endif
156156
157157float :: Parser Double
158−float = Lex.float
158+float = Lex.float <* spaceConsumer
159159
160160capitalizedIdentifier :: Parser Text
161161capitalizedIdentifier =
src/bin/TutorialD/Interpreter/Import/TutorialD.hs+5−6
@@ -78,10 +78,9 @@ tutdImportP = do
7878 uri <- quoted URI.parser
7979 spaceConsumer
8080 mhash <- optional (quoted hex)
81− let handler =
82− case URI.unRText <$> URI.uriScheme uri of
83− Nothing -> fail "URI scheme missing"
84− Just "file" -> importTutorialDFromFile
85− Just scheme | scheme `elem` ["http", "https"] -> importTutorialDViaHTTP
86− | otherwise -> fail ("unsupported URI scheme: " <> show scheme)
81+ handler <- case URI.unRText <$> URI.uriScheme uri of
82+ Nothing -> fail "URI scheme missing"
83+ Just "file" -> pure importTutorialDFromFile
84+ Just scheme | scheme `elem` ["http", "https"] -> pure importTutorialDViaHTTP
85+ | otherwise -> fail ( "unsupported URI scheme: " <> show scheme)
8786 pure $ DatabaseContextDataImportOperator uri mhash handler
src/bin/TutorialD/Interpreter/RelationalExpr.hs+2−2
@@ -235,7 +235,7 @@ constructedAtomExprP consume = do
235235-- used only for primitive type parsing ?
236236atomP :: Parser Atom
237237atomP = stringAtomP <|>
238− doubleAtomP <|>
238+ try doubleAtomP <|>
239239 integerAtomP <|>
240240 boolAtomP
241241
@@ -250,7 +250,7 @@ stringAtomP :: Parser Atom
250250stringAtomP = TextAtom <$> quotedString
251251
252252doubleAtomP :: Parser Atom
253−doubleAtomP = DoubleAtom <$> try float
253+doubleAtomP = DoubleAtom <$> float
254254
255255integerAtomP :: Parser Atom
256256integerAtomP = IntegerAtom <$> integer
src/lib/ProjectM36/Server/Config.hs+6
@@ -12,6 +12,12 @@ data ServerConfig = ServerConfig { persistenceStrategy :: PersistenceStrategy,
1212 }
1313 deriving (Show)
1414
15+data WebsocketServerConfig = WebsocketServerConfig { wsServerConfig :: ServerConfig,
16+ tlsCertificatePath :: Maybe String,
17+ tlsKeyPath :: Maybe String
18+ }
19+ deriving (Show)
20+
1521defaultServerConfig :: ServerConfig
1622defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,
1723 checkFS = True,
src/lib/ProjectM36/Server/ParseArgs.hs+31−14
@@ -17,14 +17,14 @@ parseArgsWithDefaults defaults = ServerConfig <$>
1717 many parseGhcPkgPath <*>
1818 parseTimeout (perRequestTimeout defaults) <*>
1919 parseTestMode
20−
20+
2121parsePersistenceStrategy :: Parser PersistenceStrategy
2222parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>
2323 MinimalPersistence <$> dbdirOpt <|>
2424 pure NoPersistence
25− where
26− dbdirOpt = strOption (short 'd' <>
27− long "database-directory" <>
25+ where
26+ dbdirOpt = strOption (short 'd' <>
27+ long "database-directory" <>
2828 metavar "DIRECTORY" <>
2929 showDefaultWith show
3030 )
@@ -34,43 +34,60 @@ parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>
3434
3535parseTestMode :: Parser Bool
3636parseTestMode = flag True False (long "test-mode" <> hidden)
37−
38−parseCheckFS :: Parser Bool
37+
38+parseCheckFS :: Parser Bool
3939parseCheckFS = flag True False (long "disable-fscheck" <>
4040 help "Disable filesystem check for journaling.")
41−
41+
4242parseDatabaseName :: Parser DatabaseName
4343parseDatabaseName = strOption (short 'n' <>
4444 long "database" <>
4545 metavar "DATABASE_NAME")
4646
47−parseHostname :: Hostname -> Parser Hostname
47+parseHostname :: Hostname -> Parser Hostname
4848parseHostname defHostname = strOption (short 'h' <>
4949 long "hostname" <>
5050 metavar "HOST_NAME" <>
5151 value defHostname)
52−
52+
5353parsePort :: Port -> Parser Port
5454parsePort defPort = option auto (short 'p' <>
5555 long "port" <>
5656 metavar "PORT_NUMBER" <>
5757 value defPort)
58−
58+
5959parseGhcPkgPath :: Parser String
6060parseGhcPkgPath = strOption (long "ghc-pkg-dir" <>
6161 metavar "GHC_PACKAGE_DIRECTORY")
62−
63−parseTimeout :: Int -> Parser Int
62+
63+parseTimeout :: Int -> Parser Int
6464parseTimeout defTimeout = option auto (long "timeout" <>
6565 metavar "MICROSECONDS" <>
6666 value defTimeout)
6767
6868parseConfig :: IO ServerConfig
6969parseConfig = parseConfigWithDefaults defaultServerConfig
70−
70+
7171parseConfigWithDefaults :: ServerConfig -> IO ServerConfig
7272parseConfigWithDefaults defaults = execParser (info (parseArgsWithDefaults defaults <**> helpOption) idm)
7373
74+parseWSConfigWithDefaults :: ServerConfig -> IO WebsocketServerConfig
75+parseWSConfigWithDefaults defaults = execParser (info (parseWSArgsWithDefaults defaults <**> helpOption) idm)
76+
77+parseWSArgsWithDefaults :: ServerConfig -> Parser WebsocketServerConfig
78+parseWSArgsWithDefaults defaults = WebsocketServerConfig <$>
79+ parseArgsWithDefaults defaults <*>
80+ parseTlsCertificatePath <*>
81+ parseTlsKeyPath
82+
83+
84+parseTlsCertificatePath :: Parser (Maybe String)
85+parseTlsCertificatePath = optional $ strOption (long "tls-certificate-path" <>
86+ metavar "TLS_CERTIFICATE_PATH")
87+
88+parseTlsKeyPath :: Parser (Maybe String)
89+parseTlsKeyPath = optional $ strOption (long "tls-key-path" <>
90+ metavar "TLS_KEY_PATH")
7491
7592helpOption :: Parser (a -> a)
7693helpOption = abortOption helpText $ mconcat
@@ -80,6 +97,6 @@ helpOption = abortOption helpText $ mconcat
8097 where
8198#if MIN_VERSION_optparse_applicative(0,16,0)
8299 helpText = ShowHelpText Nothing
83−#else
100+#else
84101 helpText = ShowHelpText
85102#endif
src/lib/ProjectM36/Shortcuts.hsnew file+247
@@ -0,0 +1,247 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE TypeApplications #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE TypeFamilies #-}
7+{-# LANGUAGE ExtendedDefaultRules #-}
8+{-# LANGUAGE ExistentialQuantification #-}
9+{-# LANGUAGE FlexibleContexts #-}
10+{-# LANGUAGE GADTs #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+module ProjectM36.Shortcuts where
13+-- users need OverloadedLabels, OverloadedLists, and default(Int,Text) to use these shortcuts.
14+import Data.Text hiding (foldl, map)
15+import ProjectM36.Base
16+import ProjectM36.Relation
17+import ProjectM36.Atomable
18+import Prelude hiding ((!!))
19+import Data.Proxy
20+import GHC.OverloadedLabels
21+import GHC.TypeLits hiding (Text)
22+import qualified Data.Text as T
23+import qualified Data.Map as M
24+import qualified Data.Set as S
25+import GHC.Exts (IsList(..))
26+import Data.Convertible
27+
28+default (Text)
29+
30+instance IsList (AttributeNamesBase ()) where
31+ type Item (AttributeNamesBase ()) = AttributeName
32+ fromList = AttributeNames . S.fromList
33+ toList (AttributeNames ns) = S.toList ns
34+ toList _ = error "needs AttributeNames"
35+
36+instance IsList (TupleExprsBase ()) where
37+ type Item TupleExprs = TupleExpr
38+ fromList ts = TupleExprs () ts
39+ toList (TupleExprs _ ts) = ts
40+
41+instance IsList TupleExpr where
42+ type Item TupleExpr = (AttributeName, AtomExpr)
43+ fromList attributeValues = TupleExpr (M.fromList attributeValues)
44+ toList (TupleExpr attributeValues) = M.toList attributeValues
45+
46+
47+-- #xxx :: Text
48+instance KnownSymbol x => IsLabel x Text where
49+ fromLabel = T.pack $ symbolVal @x Proxy
50+
51+-- #relvarName :: RelationalExpr
52+instance KnownSymbol x => IsLabel x RelationalExpr where
53+ fromLabel = RelationVariable (T.pack $ symbolVal @x Proxy) ()
54+
55+-- *Main> #a Int :: AttributeExpr
56+-- NakedAttributeExpr (Attribute "a" IntAtomType)
57+-- *Main> #a (Attr @[Int]) :: AttributeExpr
58+-- NakedAttributeExpr (Attribute "a" (ConstructedAtomType "List" (fromList [("a",IntAtomType)])))
59+-- can't offer a Relation atomtype -- don't know how to express a Relation type in haskell type. Maybe something a HList of (Text, a) ?
60+--
61+-- ps. I don't understand the usage of "AttributeAndTypeNameExpr AttributeName TypeConstructor a"
62+instance (KnownSymbol x, Atomable a)=> IsLabel x (HaskAtomType a -> AttributeExpr) where
63+ fromLabel = (NakedAttributeExpr . Attribute name) . toAtomType''
64+ where name = T.pack $ symbolVal @x Proxy
65+
66+-- (#a 1) :: ExtendTupleExpr
67+-- no need for :=
68+instance (Convertible a AtomExpr, KnownSymbol x) => IsLabel x (a -> ExtendTupleExpr) where
69+ fromLabel x = AttributeExtendTupleExpr name (convert x)
70+ where name = T.pack $ symbolVal @x Proxy
71+
72+-- #name AtomExpr
73+-- ex. tuple [ #name 3 ]
74+-- default(Text) is needed in client code to avoid `no Atomable Char`
75+instance (Convertible a AtomExpr, KnownSymbol x) => IsLabel x (a -> (AttributeName, AtomExpr)) where
76+ fromLabel = \x -> (name, convert x)
77+ where name = T.pack $ symbolVal @x Proxy
78+
79+-- *Main> #a [1] :: AtomExpr
80+-- FunctionAtomExpr "a" [NakedAtomExpr (IntegerAtom 1)] ()
81+--
82+-- This usage is not working in RestrictionPredicateExpr and AttributeExtendTupleExpr. Use f "a" [1] instead.
83+instance (KnownSymbol x, Convertible a AtomExpr) => IsLabel x ([a] -> AtomExpr) where
84+ fromLabel = \as' -> FunctionAtomExpr name (map convert as') ()
85+ where name = T.pack $ symbolVal @x Proxy
86+
87+instance (KnownSymbol x) => IsLabel x AtomExpr where
88+ fromLabel = AttributeAtomExpr name
89+ where name = T.pack $ symbolVal @x Proxy
90+
91+
92+data HaskAtomType a where
93+ Int :: HaskAtomType Int
94+ Integer :: HaskAtomType Integer
95+ Double :: HaskAtomType Double
96+ Text :: HaskAtomType Text
97+-- Day :: HaskAtomType Day
98+-- DateTime :: HaskAtomType DateTime
99+-- ByteString :: HaskAtomType ByteString
100+ Bool :: HaskAtomType Bool
101+ Attr :: Atomable a => HaskAtomType a -- a Proxy-like value for type application.
102+
103+toAtomType'' :: Atomable a => HaskAtomType a -> AtomType
104+toAtomType'' (_ :: HaskAtomType a) = toAtomType (Proxy @a)
105+
106+-- usage: relation [tuple [#a 1, #b "b"], tuple [#a 2, #b "b"]]
107+relation :: [TupleExpr] -> RelationalExpr
108+relation ts = MakeRelationFromExprs Nothing (TupleExprs () ts)
109+
110+relation' :: [AttributeExprBase ()] -> [TupleExpr] -> RelationalExpr
111+relation' as' ts = MakeRelationFromExprs (Just as') (TupleExprs () ts)
112+
113+-- usage: tuple [#name "Mike",#age 6]
114+tuple :: [(AttributeName, AtomExpr)] -> TupleExprBase ()
115+tuple as' = TupleExpr (M.fromList as')
116+
117+-- #a rename [#b `as` #c]
118+rename :: RelationalExpr -> [(AttributeName,AttributeName)] -> RelationalExpr
119+rename relExpr renameList = case renameList of
120+ [] -> Restrict TruePredicate relExpr
121+ renames ->
122+ foldl (\acc (old,new) -> Rename old new acc) relExpr renames
123+
124+--project !!
125+-- #a !! [#b,#c]
126+infix 9 !!
127+(!!) :: RelationalExpr -> AttributeNames -> RelationalExpr
128+relExpr !! xs = Project xs relExpr
129+
130+--join ><
131+-- #a >< #b
132+(><) :: RelationalExpr -> RelationalExpr -> RelationalExpr
133+a >< b = Join a b
134+
135+allBut :: AttributeNames -> AttributeNames
136+allBut (AttributeNames ns) = InvertedAttributeNames ns
137+allBut _ = error "give allBut something other than attribute names."
138+
139+allFrom :: RelationalExpr -> AttributeNames
140+allFrom = RelationalExprAttributeNames
141+
142+as :: AttributeNames -> AttributeName -> (AttributeNames, AttributeName)
143+as = (,)
144+
145+-- #a `group` ([#b,#c] `as` #d)
146+group :: RelationalExpr -> (AttributeNames, AttributeName) -> RelationalExpr
147+group relExpr (aNames, aName) = Group aNames aName relExpr
148+
149+-- #a `ungroup` #b
150+ungroup :: RelationalExpr -> AttributeName -> RelationalExpr
151+ungroup relExpr aName = Ungroup aName relExpr
152+
153+-- *Main> #a #:= true #: ( #b (f "count" [1,2]))
154+-- Assign "a" (Extend (AttributeExtendTupleExpr "b" (FunctionAtomExpr "count" [NakedAtomExpr (IntegerAtom 1),NakedAtomExpr (IntegerAtom 2)] ())) (ExistingRelation (Relation attributesFromList [] (RelationTupleSet {asList = [RelationTuple attributesFromList [] []]}))))
155+(#:) :: RelationalExpr -> ExtendTupleExpr -> RelationalExpr
156+a #: b = Extend b a
157+infix 8 #:
158+
159+instance Convertible AtomExpr AtomExpr where
160+ safeConvert n = Right n
161+
162+instance Convertible RelVarName AtomExpr where
163+ safeConvert n = Right $ RelationAtomExpr (RelationVariable n ())
164+
165+instance Convertible RelationalExpr AtomExpr where
166+ safeConvert relExpr = Right $ RelationAtomExpr relExpr
167+
168+instance Convertible RelVarName RelationalExpr where
169+ safeConvert n = Right $ RelationVariable n ()
170+
171+-- @ in tutd
172+-- (@@) "aaa"
173+(@@) :: AttributeName -> AtomExpr
174+(@@) = AttributeAtomExpr
175+
176+-- works in RestrictedPredicateExpr and AttributeExtendTupleExpr
177+-- usage: f "gte" [1]
178+f :: Convertible a AtomExpr => AtomFunctionName -> [a] -> AtomExpr
179+f n as' = FunctionAtomExpr n (map convert as') ()
180+
181+-- DatabaseContextExpr
182+-- define
183+(#::) :: RelVarName -> [AttributeExpr] -> DatabaseContextExpr
184+s #:: xs = Define s xs
185+infix 5 #::
186+
187+-- assign
188+(#:=) :: RelVarName -> RelationalExpr -> DatabaseContextExpr
189+s #:= r = Assign s r
190+infix 5 #:=
191+
192+class Boolean a b where
193+ (&&&) :: a -> b -> RestrictionPredicateExpr
194+ infixl 6 &&&
195+ (|||) :: a -> b -> RestrictionPredicateExpr
196+ infixl 5 |||
197+
198+-- where: @~ mimics the restriction symbol in algebra
199+-- usage: true #: (#a 1) @~ #a ?= 1 &&& not' false ||| (f "gte" [1])
200+(@~) :: Convertible a RestrictionPredicateExpr => RelationalExpr -> a -> RelationalExpr
201+(@~) relExpr resPreExpr = Restrict (convert resPreExpr) relExpr
202+infix 4 @~
203+
204+true :: RelationalExpr
205+true = ExistingRelation relationTrue
206+
207+false :: RelationalExpr
208+false = ExistingRelation relationFalse
209+
210+trueP :: RestrictionPredicateExprBase a
211+trueP = TruePredicate
212+
213+falseP :: RestrictionPredicateExprBase a
214+falseP = NotPredicate TruePredicate
215+
216+(?=) :: Convertible a AtomExpr => AttributeName -> a -> RestrictionPredicateExpr
217+(?=) name a = AttributeEqualityPredicate name (convert a)
218+infix 9 ?=
219+
220+not' :: Convertible a RestrictionPredicateExpr => a -> RestrictionPredicateExpr
221+not' = NotPredicate . convert
222+
223+instance (Convertible a RestrictionPredicateExpr, Convertible b RestrictionPredicateExpr) => Boolean a b where
224+ a &&& b = AndPredicate (convert a) (convert b)
225+ a ||| b = OrPredicate (convert a) (convert b)
226+
227+instance {-# Incoherent #-} Atomable a => Convertible a RestrictionPredicateExpr where
228+ safeConvert n = Right $ AtomExprPredicate $ toAtomExpr . toAtom $ n
229+
230+instance {-# Incoherent #-} Convertible RelationalExpr RestrictionPredicateExpr where
231+ safeConvert a = Right $ RelationalExprPredicate a
232+
233+instance {-# Incoherent #-} Convertible AtomExpr RestrictionPredicateExpr where
234+ safeConvert a = Right $ AtomExprPredicate a
235+
236+instance {-# Incoherent #-} Convertible RestrictionPredicateExpr RestrictionPredicateExpr where
237+ safeConvert a = Right a
238+
239+instance {-# Incoherent #-} Atomable a => Convertible a AtomExpr where
240+ safeConvert n = Right $ toAtomExpr . toAtom $ n
241+
242+toAtomExpr :: Atom -> AtomExpr
243+toAtomExpr (ConstructedAtom n _ xs) = ConstructedAtomExpr n (toAtomExpr <$> xs) ()
244+toAtomExpr a = NakedAtomExpr a
245+
246+
247+
src/lib/ProjectM36/WithNameExpr.hs+4−2
@@ -42,9 +42,11 @@ substituteWithNameMacros macros (NotEquals exprA exprB) =
4242substituteWithNameMacros macros (Extend extendTup expr) =
4343 Extend (substituteWitNameMacrosExtendTupleExpr macros extendTup) (substituteWithNameMacros macros expr)
4444substituteWithNameMacros macros (With moreMacros expr) =
45− --collect and override existing macros and recurse
45+ --collect and update nested with exprs
4646 let newMacros = foldr macroFolder macros moreMacros
47− macroFolder (wnexpr, mexpr) acc = filter (\(w,_) -> w /= wnexpr) acc ++ [(wnexpr, mexpr)] in
47+ macroFolder (wnexpr, mexpr) acc =
48+ let subExpr = substituteWithNameMacros macros mexpr in
49+ filter (\(w,_) -> w /= wnexpr) acc ++ [(wnexpr, subExpr)] in
4850 --scan for a match- if it exists, replace it (representing a with clause at a lower level
4951 substituteWithNameMacros newMacros expr
5052
stack.ghc8.0.yamldeleted−48
@@ -1,48 +0,0 @@
1−# This file was automatically generated by stack init
2−# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/
3−
4−# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
5−resolver: lts-8.5
6−
7−# Local packages, usually specified by relative directory name
8−packages:
9−- '.'
10−# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
11−extra-deps:
12−- git: https://github.com/agentm/curryer.git
13− commit: 1e60c0580ca33d6ae1e97aaddc32189fdfe3ef6c
14−- data-accessor-transformers-0.2.1.7
15−- data-interval-1.2.0
16−- extended-reals-0.2.1.0
17−- gnuplot-0.5.4.1
18−- text-1.2.2.1
19−- aeson-1.2.1.00
20−- deferred-folds-0.6.12
21−- rset-1.0.0
22−
23−# Override default flag values for local packages and extra-deps
24−flags: {}
25−
26−# Extra package databases containing global packages
27−extra-package-dbs: []
28−
29−# Control whether we use the GHC we find on the path
30−# system-ghc: true
31−
32−# Require a specific version of stack, using version ranges
33−# require-stack-version: -any # Default
34−# require-stack-version: >= 1.0.0
35−
36−# Override the architecture used by stack, especially useful on Windows
37−# arch: i386
38−# arch: x86_64
39−
40−# Extra directories used by stack for building
41−# extra-include-dirs: [/path/to/dir]
42−# extra-lib-dirs: [/path/to/dir]
43−
44−# Allow a newer minor version of GHC than the snapshot specifies
45−# compiler-check: newer-minor
46−
47−allow-newer: true
48−
stack.ghc8.10.yamlnew file+19
@@ -0,0 +1,19 @@
1+resolver: lts-17.13
2+packages:
3+ - "."
4+
5+extra-deps:
6+ - git: https://github.com/agentm/curryer.git
7+ commit: 74ecaac619ad1165a4517d5c0f4e530493bda130
8+ - git: https://github.com/composewell/streamly.git
9+ commit: ac3af8749194f1788704dda8667d0b3807075cc2
10+ - fast-builder-0.1.2.1
11+ - rset-1.0.0
12+ - winery-1.3.2
13+ - barbies-th-0.1.8
14+ - base16-bytestring-1.0.1.0
15+
16+flags:
17+ project-m36:
18+ stack: true
19+# allow-newer: true
stack.ghc8.6.yaml+24−20
@@ -6,28 +6,32 @@ resolver: lts-14.27
66
77# Local packages, usually specified by relative directory name
88packages:
9−- '.'
9+ - "."
1010# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
1111extra-deps:
12−- git: https://github.com/agentm/curryer.git
13− commit: 28ff1d031078af4a17fa326d43340474571df0c3
14−- git: https://github.com/composewell/streamly.git
15− commit: ac3af8749194f1788704dda8667d0b3807075cc2
16−- fast-builder-0.1.2.1
17−- winery-1.3.2
18−- barbies-2.0.2.0
19−- barbies-th-0.1.7
20−- extended-reals-0.2.3.0
21−- data-interval-2.0.1
22−- stm-containers-1.1.0.4
23−- stm-hamt-1.2.0.4
24−- rset-1.0.0
25−- hashable-time-0.2.0.2
26−- network-transport-tcp-0.6.0
27−- megaparsec-7.0.5
28−- prettyprinter-1.7.0
29−- prettyprinter-ansi-terminal-1.1.2
30−- fusion-plugin-types-0.1.0
12+ - git: https://github.com/agentm/curryer.git
13+ commit: 74ecaac619ad1165a4517d5c0f4e530493bda130
14+ - git: https://github.com/composewell/streamly.git
15+ commit: ac3af8749194f1788704dda8667d0b3807075cc2
16+ - fast-builder-0.1.2.1
17+ - winery-1.3.2
18+ - barbies-2.0.2.0
19+ - barbies-th-0.1.7
20+ - extended-reals-0.2.3.0
21+ - data-interval-2.0.1
22+ - stm-containers-1.1.0.4
23+ - stm-hamt-1.2.0.4
24+ - rset-1.0.0
25+ - hashable-time-0.2.0.2
26+ - network-transport-tcp-0.6.0
27+ - megaparsec-7.0.5
28+ - prettyprinter-1.7.0
29+ - prettyprinter-ansi-terminal-1.1.2
30+ - fusion-plugin-types-0.1.0
31+ - base16-bytestring-1.0.1.0
32+ - modern-uri-0.3.4.0
33+ - cryptohash-sha256-0.11.102.0
34+ - http-types-0.12.3
3135
3236# Override default flag values for local packages and extra-deps
3337flags:
stack.ghc8.8.yaml+24−22
@@ -6,30 +6,32 @@ resolver: lts-16.4
66
77# Local packages, usually specified by relative directory name
88packages:
9−- '.'
9+ - "."
1010# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
1111extra-deps:
12−- git: https://github.com/agentm/curryer.git
13− commit: 28ff1d031078af4a17fa326d43340474571df0c3
14−- git: https://github.com/composewell/streamly.git
15− commit: ac3af8749194f1788704dda8667d0b3807075cc2
16−- fast-builder-0.1.2.1
17−- winery-1.3.2
18−- barbies-2.0.2.0
19−- barbies-th-0.1.7
20−- extended-reals-0.2.3.0
21−- data-interval-2.0.1
22−- stm-containers-1.1.0.4
23−- stm-hamt-1.2.0.4
24−- rset-1.0.0
25−- hashable-time-0.2.0.2
26−- network-transport-tcp-0.7.0
27−- megaparsec-7.0.5
28−- network-2.8.0.1
29−- primitive-extras-0.8
30−- primitive-unlifted-0.1.3.0
31−- prettyprinter-1.7.0
32−- prettyprinter-ansi-terminal-1.1.2
12+ - git: https://github.com/agentm/curryer.git
13+ commit: 74ecaac619ad1165a4517d5c0f4e530493bda130
14+ - git: https://github.com/composewell/streamly.git
15+ commit: ac3af8749194f1788704dda8667d0b3807075cc2
16+ - fast-builder-0.1.2.1
17+ - winery-1.3.2
18+ - barbies-2.0.2.0
19+ - barbies-th-0.1.7
20+ - extended-reals-0.2.3.0
21+ - data-interval-2.0.1
22+ - stm-containers-1.1.0.4
23+ - stm-hamt-1.2.0.4
24+ - rset-1.0.0
25+ - hashable-time-0.2.0.2
26+ - network-transport-tcp-0.7.0
27+ - megaparsec-7.0.5
28+ - network-2.8.0.1
29+ - primitive-extras-0.8
30+ - primitive-unlifted-0.1.3.0
31+ - prettyprinter-1.7.0
32+ - prettyprinter-ansi-terminal-1.1.2
33+ - base16-bytestring-1.0.1.0
34+ - modern-uri-0.3.4.0
3335
3436# Override default flag values for local packages and extra-deps
3537flags:
test/TutorialD/Interpreter/Import/TutorialD.hs → test/TutorialD/Interpreter/Import/ImportTest.hsrenamed+10−4
@@ -4,19 +4,23 @@ import TutorialD.Interpreter.Import.TutorialD
44import System.Exit
55import qualified Data.Text as T
66import System.IO.Temp
7+import System.FilePath
78import qualified Data.Map as M
89import System.IO
10+import System.Directory
911import qualified Data.ByteString as BS
1012import qualified Data.Text.Encoding as TE
11−import Text.URI
13+import Text.URI hiding (makeAbsolute)
1214
1315main :: IO ()
1416main = do
15− tcounts <- runTestTT $ TestList [testTutdFileImport, testTutdHTTPSImport]
17+ tcounts <- runTestTT $ TestList [testTutdFileImport
18+ ,testTutdHTTPSImport
19+ ]
1620 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
1721
1822testTutdFileImport :: Test
19−testTutdFileImport = TestCase $
23+testTutdFileImport = TestCase $
2024 withSystemTempFile "m.tutd" $ \tempPath handle -> do
2125 BS.hPut handle (TE.encodeUtf8 "x:=relation{tuple{a 5,b \"spam\"}}; y:=relation{tuple{b \"漢字\"}}")
2226 hClose handle
@@ -26,7 +30,9 @@ testTutdFileImport = TestCase $
2630 ("b", NakedAtomExpr $ TextAtom "spam")])]),
2731 Assign "y" (MakeRelationFromExprs Nothing
2832 $ TupleExprs () [TupleExpr (M.fromList [("b", NakedAtomExpr (TextAtom "漢字"))])])]
29− fileURI <- mkURI (T.pack ("file://" <> tempPath))
33+ --on Windows, the file URI should not include the drive letter "/c/Users..." -> "/Users"
34+ let uri = "file://" <> map (\c -> if c == '\\' then '/' else c) ( joinDrive "/" (dropDrive tempPath))
35+ fileURI <- mkURI (T.pack uri)
3036 imported <- importTutorialDFromFile fileURI Nothing
3137 assertEqual "import tutd" (Right expectedExpr) imported
3238
test/TutorialD/Interpreter/Import/httpimporttest.tutdnew file+2
@@ -0,0 +1,2 @@
1+x:=true;
2+y:=false;
test/TutorialD/Interpreter.hs → test/TutorialD/InterpreterTest.hsrenamed+4
@@ -665,6 +665,10 @@ testWithClause = TestCase $ do
665665 executeTutorialD sessionId dbconn "x:=with (x as s) x"
666666 eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())
667667 assertEqual "with x as s" (Right suppliersRel) eX
668+
669+ executeTutorialD sessionId dbconn "y:=with(a as true) (with (b as a) b)"
670+ eY <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())
671+ assertEqual "nested with" (Right relationTrue) eY
668672
669673 let err1 = "RelVarAlreadyDefinedError"
670674 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as s) s"
test/TutorialD/Printer.hs → test/TutorialD/PrinterTest.hsrenamed

The content is the same.