86de73f...master · project-m36

.github/workflows/ci.yaml+61−21

since splitsnapshots

unifiedsplit

@@ -6,24 +6,64 @@ jobs:

6 dockerimage:

7 runs-on: ubuntu-latest

8 steps:

9− - uses: actions/checkout@v2.3.1

9+ - uses: actions/checkout@v2.3.1

10− - uses: cachix/install-nix-action@v12

10+ - uses: cachix/install-nix-action@v12

11− with:

11+ with:

12− nix_path: nixpkgs=channel:nixos-unstable

12+ nix_path: nixpkgs=channel:nixos-unstable

13− - uses: cachix/cachix-action@v8

13+ - uses: cachix/cachix-action@v8

14− with:

14+ with:

15− name: project-m36

15+ name: project-m36

16− signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}'

16+ signingKey: "${{ secrets.CACHIX_SIGNING_KEY }}"

17− - run: cachix use iohk

17+ - run: cachix use iohk

18− - name: docker load

18+ - name: docker load

19− run: docker load < $(nix-build docker.nix)

19+ run: docker load < $(nix-build docker.nix)

20− - name: docker login

20+ - name: docker login

21+ if: ${{ github.ref == 'refs/heads/master' }}

21− run: echo ${{secrets.DOCKERHUB_PASSWORD}} | docker login --username ${{secrets.DOCKERHUB_USER}} --password-stdin

22+ run: echo ${{secrets.DOCKERHUB_PASSWORD}} | docker login --username ${{secrets.DOCKERHUB_USER}} --password-stdin

22− - name: docker tag with version

23+ - name: docker tag with version

23− run: docker tag project-m36:latest projectm36/project-m36:$(awk '/^Version:/ {print $2}' project-m36.cabal)

24+ run: docker tag project-m36:latest projectm36/project-m36:$(awk '/^Version:/ {print $2}' project-m36.cabal)

24− if: ${{ github.ref == 'refs/heads/master' }}

25+ if: ${{ github.ref == 'refs/heads/master' }}

25− - name: docker tag latest

26+ - name: docker tag latest

26− run: docker tag project-m36:latest projectm36/project-m36:latest

27+ run: docker tag project-m36:latest projectm36/project-m36:latest

27− if: ${{ github.ref == 'refs/heads/master' }}

28+ if: ${{ github.ref == 'refs/heads/master' }}

28− - run: docker push projectm36/project-m36

29+ - run: docker push projectm36/project-m36

29− if: ${{ github.ref == 'refs/heads/master' }}

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

20juyter/dist

21.ipynb_checkpoints

22project-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+

1# 2020-12-27 (v0.9.0)

5# 2020-12-27 (v0.9.0)

2

6

3* replace unmaintained distributed-process-client-server RPC package with new curryer RPC package

7* replace unmaintained distributed-process-client-server RPC package with new curryer RPC package

README.markdown+1−2

@@ -4,7 +4,6 @@

4[![Public Domain](https://img.shields.io/badge/license-Public%20Domain-brightgreen.svg)](http://unlicense.org)

5[![Hackage](https://img.shields.io/hackage/v/project-m36.svg)](http://hackage.haskell.org/package/project-m36)

6[![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)

8[![Windows Build status](https://ci.appveyor.com/api/projects/status/q7jyddd6dy1ibqdo/branch/master?svg=true)](https://ci.appveyor.com/project/agentm/project-m36)

7[![Windows Build status](https://ci.appveyor.com/api/projects/status/q7jyddd6dy1ibqdo/branch/master?svg=true)](https://ci.appveyor.com/project/agentm/project-m36)

9[![Github Workflow status](https://github.com/agentm/project-m36/workflows/CI/badge.svg)](https://github.com/agentm/project-m36/actions?query=workflow%3ACI)

8[![Github Workflow status](https://github.com/agentm/project-m36/workflows/CI/badge.svg)](https://github.com/agentm/project-m36/actions?query=workflow%3ACI)

10

9

@@ -45,7 +44,7 @@ Project:M36 supports multiple frontends which target different audiences.

45

44

46* [Developer's Blog](https://agentm.github.io/project-m36/)

45* [Developer's Blog](https://agentm.github.io/project-m36/)

47* [Mailing List/Discussion Group](https://groups.google.com/d/forum/project-m36)

46* [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)

49* [Hackage](https://hackage.haskell.org/package/project-m36)

48* [Hackage](https://hackage.haskell.org/package/project-m36)

50* [Diogo Biazus' Project:M36 Video Tutorial](https://www.youtube.com/watch?v=_GC_lxlVEnE)

49* [Diogo Biazus' Project:M36 Video Tutorial](https://www.youtube.com/watch?v=_GC_lxlVEnE)

51

50

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+}:

2let

5let

3− release = import ./release.nix { inherit pkgs; };

6+ release = import ./release.nix { inherit pkgs compiler sources; };

4− static-project-m36 = pkgs.haskell.lib.justStaticExecutables release.project;

7+ static-project-m36 = pkgs.haskell.lib.dontCheck (pkgs.haskell.lib.justStaticExecutables release.project);

5in

8in

6− pkgs.dockerTools.buildImage {

9+pkgs.dockerTools.buildImage {

7− name = "project-m36";

10+ name = "project-m36";

8− tag = "latest";

11+ tag = "latest";

9− contents = [static-project-m36];

12+ contents = [ static-project-m36 ];

10− #expose default project-m36 and websocket server ports

13+ # expose default project-m36 and websocket server ports

14+ config = {

11− config = { Env = ["LC_ALL=en_US.UTF-8"];

15+ Env = [ "LC_ALL=en_US.UTF-8" ];

12− ExposedPorts = { "6543/tcp" = {}; "8000/tcp" = {}; }; };

16+ ExposedPorts = { "6543/tcp" = { }; "8000/tcp" = { }; };

17+ };

13− }

18+}

docs/15_minute_tutorial.markdown+1−1

@@ -28,7 +28,7 @@ Note that TutorialD is strongly-typed- no type coercions take place automaticall

28### Load the Canonical Chris Date Example

29

30```

31−TutorialD (master/main): :importexample date

31+TutorialD (master/main): :importexample cjdate

32```

33

34```:importexample``` (do not skip typing the preceding colon), loads a built-in example schema and executes it to change the state of the database. In this case, the relations "s" (supplier), "p" (product), and "sp" (suppliers-products) are now loaded.

docs/import_export_csv.markdown+2−2

@@ -9,7 +9,7 @@ If a relation variable cannot be exported due to data types which are not suppor

9### Example Export

10

11```

12−TutorialD (master/main): :importexample date

12+TutorialD (master/main): :importexample cjdate

13TutorialD (master/main): :exportcsv s "/tmp/csv"

14```

15```

@@ -37,7 +37,7 @@ s#,sname,status,city

37S6,Samson,100,New York

38```

39```

40−TutorialD (master/main): :importexample date

40+TutorialD (master/main): :importexample cjdate

41TutorialD (master/main): :showexpr s

42┌──────────┬────────┬───────────┬───────────────┐

43│city::Text│s#::Text│sname::Text│status::Integer│

docs/introduction_to_the_relational_algebra.markdown+1−1

@@ -202,7 +202,7 @@ Join (Instructor relation)

202

203(Course Relation)

204

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)|

206|-------------------------------|----------------------------------|--------------------------------------|

207|English 1|Steve|Room 104|

208|French 2|Bob|Room 103|

docs/reaching_out_of_the_tarpit.markdown+1−1

@@ -57,7 +57,7 @@ Project:M36 implements multiple interfaces:

57To understand how Project:M36 stacks up against the fictional programming language shown in the paper, we have implemented the [example from the paper](/examples/out_of_the_tarpit.tutd). The language used in the script is a dialect of Chris Date's TutorialD language. It can be loaded into an interactive ```tutd``` session like so:

58

59```

60−TutorialD (master/main): :importexample date

60+TutorialD (master/main): :importexample cjdate

61TutorialD (master/main): :showexpr p

62┌───────────────────┬────────────┬───────────────────┬────────────┬────────────┐

63│address::Address │agent::Agent│dateRegistered::Day│photo::Text │price::Price│

docs/tutd_cheatsheet.markdown+3−1

@@ -47,7 +47,9 @@ Database context expressions take the current database context as input and alte

47

48|Database Context Expression |Description |

49|------------------------------------------------------|---------------------------------------|

50−|`:importexample date`|Imports a precooked schema from Chris Date's books resulting in relvars `s`, `sp`, and `p`|

50+|`: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|

51|`newrelvar:=relation{tuple{age 3}}`|Assign a new relation variable named `newrelvar`|

53|`newrelvar:=relation{tuple{age 3}}`|Assign a new relation variable named `newrelvar`|

52|`undefine s`|Remove a relation variable|

54|`undefine s`|Remove a relation variable|

53|`insert s relation{tuple{city "Boston",s# "S10",sname "Gonzalez",status 10}}`| Append to an existing relation variable with another relational expression|

55|`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+19−1

@@ -19,7 +19,7 @@ TutorialD (master/main):

19The examples in this tutorial can be executed after loading Chris Date's sample relations using:

20

21```

22−:importexample date

22+:importexample cjdate

23```

24

25Each section assumes a fresh instance of the Date examples. The relation variables created in the script are:

@@ -30,6 +30,24 @@ Each section assumes a fresh instance of the Date examples. The relation variabl

30|p|parts|

31|sp|contains mapping of which suppliers supply which parts|

32

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+

33### Types

51### Types

34

52

35TutorialD is strongly-typed. The basic built-in types are:

53TutorialD 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+

examples/out_of_the_tarpit.tutd+4−4

@@ -3,9 +3,9 @@

3data Address = Address Text

4data Agent = Agent Text

5data Name = Name Text

6−data Price = Price Double

6+data Price = Price Integer --dollars

7data RoomType = Kitchen | Bathroom | LivingRoom

8−data PriceBand = Low | Medium | High | Premium

8+data PriceBand = Low | Med | High | Premium

9data AreaCode = City | Suburban | Rural

10data SpeedBand = VeryFast | Fast | Medium | Slow

11

@@ -57,9 +57,9 @@ constraint noOffersAfterSale (offer join decision where ^dayEarlierThan(@offerDa

57--1. identify offerPrices > 2000 (arbitrarily-chosen high price band which is not specified in the paper)

58--2. remove the properties which have been sold

59--3. group and count sub-relation and restrict by greater than 50

60−constraint noMoreThan50PremiumProperties ((((property where ^gt(offerPrice,2000.0)) minus ((property join decision){address,agent,dateRegistered,photo,price})) group ({} as x) : {z:=gt(count(@x),50)}) {z}){} equals false

60+constraint noMoreThan50PremiumProperties ((((property where ^gt(@price,Price 2000)) minus ((property join decision){address,agent,dateRegistered,photo,price})) group ({} as x) : {z:=gt(count(@x),50)}) {z}){} equals false

61

62−constraint noBidderCanMakeMoreThan10BidsOnAProperty (((offer group ({all but bidderAddress} as bidder)) : {bidCount:=gt(count(@bidder),10)}) where ^gt(bidCount,10)) {} equals false

62+constraint noBidderCanMakeMoreThan10BidsOnAProperty (((offer group ({all but bidderAddress} as bidder)) : {bidCount:=gt(count(@bidder),10)}) where ^gt(@bidCount,10)) {} equals false

63

64-- sample data

65

jupyter/TutorialD Notebook Walkthrough.ipynb+1−1

@@ -38,7 +38,7 @@

38 }

39 ],

40 "source": [

41− ":importexample date"

41+ ":importexample cjdate"

42 ]

43 },

44 {

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.fetchGit {

3− url = "https://github.com/NixOS/nixpkgs";

4− rev = "f58482658eabf7d695f45904ecbc5f49c19fef98";

5−};

6−in

7−import nixpkgs { config.allowBroken = true; }

project-m36.cabal+47−33

@@ -1,8 +1,8 @@

1Cabal-Version: 2.2

2Name: project-m36

3−Version: 0.9.2

3+Version: 0.9.3

4License: 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

6Build-Type: Simple

7Homepage: https://github.com/agentm/project-m36

8Bug-Reports: https://github.com/agentm/project-m36/issues

@@ -35,7 +35,7 @@ Flag haskell-scripting

35 Default: True

36

37Library

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

39 if flag(haskell-scripting)

40 Build-Depends: ghc >= 8.2 && < 8.11

41 CPP-Options: -DPM36_HASKELL_SCRIPTING

@@ -63,6 +63,7 @@ Library

63 ProjectM36.AtomFunction,

64 ProjectM36.AtomFunctionError,

65 ProjectM36.ScriptSession,

66+ ProjectM36.Shortcuts,

66 ProjectM36.DatabaseContextFunction,

67 ProjectM36.DatabaseContextFunction,

67 ProjectM36.DatabaseContextFunctionError,

68 ProjectM36.DatabaseContextFunctionError,

68 ProjectM36.DatabaseContextFunctionUtils,

69 ProjectM36.DatabaseContextFunctionUtils,

@@ -142,7 +143,7 @@ Library

142 Hs-Source-Dirs: ./src/lib

143 Hs-Source-Dirs: ./src/lib

143 Default-Language: Haskell2010

144 Default-Language: Haskell2010

144 Default-Extensions: OverloadedStrings, CPP

145 Default-Extensions: OverloadedStrings, CPP

145− if !flag(stack)

146+ if !flag(stack)

146 Build-Depends: deferred-folds

147 Build-Depends: deferred-folds

147

148

148Executable tutd

149Executable tutd

@@ -184,7 +185,13 @@ Executable tutd

184 list-t,

185 list-t,

185 parser-combinators,

186 parser-combinators,

186 curryer-rpc,

187 curryer-rpc,

187− prettyprinter

188+ prettyprinter,

189+ cryptohash-sha256,

190+ --due to decode signature change

191+ base16-bytestring >= 1.0.0.0,

192+ http-conduit,

193+ modern-uri,

194+ http-types

188 Other-Modules: TutorialD.Interpreter,

195 Other-Modules: TutorialD.Interpreter,

189 TutorialD.Interpreter.Base,

196 TutorialD.Interpreter.Base,

190 TutorialD.Interpreter.DatabaseContextExpr,

197 TutorialD.Interpreter.DatabaseContextExpr,

@@ -263,11 +270,11 @@ Executable bigrel

263 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

270 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

264

271

265Common commontest

272Common commontest

266− Default-Language: Haskell2010

273+ Default-Language: Haskell2010

267− 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

274+ 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

268 Default-Extensions: OverloadedStrings

275 Default-Extensions: OverloadedStrings

269 GHC-Options: -Wall -threaded

276 GHC-Options: -Wall -threaded

270− Hs-Source-Dirs: ./src/bin, ., test/

277+ Hs-Source-Dirs: test, src/bin

271

278

272Benchmark basic-benchmark

279Benchmark basic-benchmark

273 Default-Language: Haskell2010

280 Default-Language: Haskell2010

@@ -280,7 +287,7 @@ Benchmark basic-benchmark

280 if flag(profiler)

287 if flag(profiler)

281 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

288 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

282

289

283−--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

284Benchmark update-exprs

291Benchmark update-exprs

285 Default-Language: Haskell2010

292 Default-Language: Haskell2010

286 Default-Extensions: OverloadedStrings

293 Default-Extensions: OverloadedStrings

@@ -295,7 +302,7 @@ Benchmark update-exprs

295Test-Suite test-tutoriald

302Test-Suite test-tutoriald

296 import: commontest

303 import: commontest

297 type: exitcode-stdio-1.0

304 type: exitcode-stdio-1.0

298− main-is: test/TutorialD/Interpreter.hs

305+ main-is: TutorialD/InterpreterTest.hs

299 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

306 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

300 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

307 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

301

308

@@ -303,56 +310,56 @@ Test-Suite test-tutoriald-atomfunctionscript

303 import: commontest

310 import: commontest

304 type: exitcode-stdio-1.0

311 type: exitcode-stdio-1.0

305 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

312 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

306− main-is: test/TutorialD/Interpreter/AtomFunctionScript.hs

313+ main-is: TutorialD/Interpreter/AtomFunctionScript.hs

307

314

308Test-Suite test-tutoriald-databasecontextfunctionscript

315Test-Suite test-tutoriald-databasecontextfunctionscript

309 import: commontest

316 import: commontest

310 type: exitcode-stdio-1.0

317 type: exitcode-stdio-1.0

311 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

318 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

312− main-is: test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs

319+ main-is: TutorialD/Interpreter/DatabaseContextFunctionScript.hs

313

320

314Test-Suite test-relation

321Test-Suite test-relation

315 import: commontest

322 import: commontest

316 type: exitcode-stdio-1.0

323 type: exitcode-stdio-1.0

317− main-is: test/Relation/Basic.hs

324+ main-is: Relation/Basic.hs

318

325

319Test-Suite test-static-optimizer

326Test-Suite test-static-optimizer

320 import: commontest

327 import: commontest

321 type: exitcode-stdio-1.0

328 type: exitcode-stdio-1.0

322− main-is: test/Relation/StaticOptimizer.hs

329+ main-is: Relation/StaticOptimizer.hs

323

330

324Test-Suite test-transactiongraph-persist

331Test-Suite test-transactiongraph-persist

325 import: commontest

332 import: commontest

326 type: exitcode-stdio-1.0

333 type: exitcode-stdio-1.0

327− main-is: test/TransactionGraph/Persist.hs

334+ main-is: TransactionGraph/Persist.hs

328 Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer

335 Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer

329

336

330Test-Suite test-relation-import-csv

337Test-Suite test-relation-import-csv

331 import: commontest

338 import: commontest

332 type: exitcode-stdio-1.0

339 type: exitcode-stdio-1.0

333− main-is: test/Relation/Import/CSV.hs

340+ main-is: Relation/Import/CSV.hs

334

341

335Test-Suite test-tutoriald-import-tutoriald

342Test-Suite test-tutoriald-import-tutoriald

336 import: commontest

343 import: commontest

337 type: exitcode-stdio-1.0

344 type: exitcode-stdio-1.0

338− main-is: test/TutorialD/Interpreter/Import/TutorialD.hs

345+ main-is: TutorialD/Interpreter/Import/ImportTest.hs

339 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

346 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

340

347

341Test-Suite test-relation-export-csv

348Test-Suite test-relation-export-csv

342 import: commontest

349 import: commontest

343 type: exitcode-stdio-1.0

350 type: exitcode-stdio-1.0

344− main-is: test/Relation/Export/CSV.hs

351+ main-is: Relation/Export/CSV.hs

345

352

346Test-Suite test-transactiongraph-merge

353Test-Suite test-transactiongraph-merge

347 import: commontest

354 import: commontest

348 type: exitcode-stdio-1.0

355 type: exitcode-stdio-1.0

349− main-is: test/TransactionGraph/Merge.hs

356+ main-is: TransactionGraph/Merge.hs

350

357

351

358

352Test-Suite test-prettyprinter

359Test-Suite test-prettyprinter

353 import: commontest

360 import: commontest

354 type: exitcode-stdio-1.0

361 type: exitcode-stdio-1.0

355− main-is: test/TutorialD/Printer.hs

362+ main-is: TutorialD/PrinterTest.hs

356 Other-Modules: TutorialD.Printer, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types

363 Other-Modules: TutorialD.Printer, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types

357

364

358benchmark bench

365benchmark bench

@@ -363,7 +370,7 @@ benchmark bench

363Test-Suite test-server

370Test-Suite test-server

364 import: commontest

371 import: commontest

365 type: exitcode-stdio-1.0

372 type: exitcode-stdio-1.0

366− main-is: test/Server/Main.hs

373+ main-is: Server/Main.hs

367

374

368

375

369Executable Example-SimpleClient

376Executable Example-SimpleClient

@@ -394,6 +401,13 @@ Executable Example-Hair

394 Main-Is: examples/hair.hs

401 Main-Is: examples/hair.hs

395 GHC-Options: -Wall -threaded

402 GHC-Options: -Wall -threaded

396

403

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+

397Executable Example-CustomTupleable

411Executable Example-CustomTupleable

398 Default-Language: Haskell2010

412 Default-Language: Haskell2010

399 Default-Extensions: OverloadedStrings

413 Default-Extensions: OverloadedStrings

@@ -414,12 +428,12 @@ Executable Example-DerivingCustomTupleable

414Test-Suite test-scripts

428Test-Suite test-scripts

415 import: commontest

429 import: commontest

416 type: exitcode-stdio-1.0

430 type: exitcode-stdio-1.0

417− main-is: test/scripts.hs

431+ main-is: scripts.hs

418 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

432 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

419

433

420Executable project-m36-websocket-server

434Executable project-m36-websocket-server

421 Default-Language: Haskell2010

435 Default-Language: Haskell2010

422− 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

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

423 Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs

437 Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs

424 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

438 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

425 GHC-Options: -Wall -threaded

439 GHC-Options: -Wall -threaded

@@ -429,46 +443,46 @@ Executable project-m36-websocket-server

429Test-Suite test-websocket-server

443Test-Suite test-websocket-server

430 import: commontest

444 import: commontest

431 type: exitcode-stdio-1.0

445 type: exitcode-stdio-1.0

432− main-is: test/Server/WebSocket.hs

446+ main-is: Server/WebSocket.hs

433 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

447 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

434

448

435Test-Suite test-isomorphic-schemas

449Test-Suite test-isomorphic-schemas

436 import: commontest

450 import: commontest

437 type: exitcode-stdio-1.0

451 type: exitcode-stdio-1.0

438− main-is: test/IsomorphicSchema.hs

452+ main-is: IsomorphicSchema.hs

439

453

440Test-Suite test-atomable

454Test-Suite test-atomable

441 import: commontest

455 import: commontest

442 type: exitcode-stdio-1.0

456 type: exitcode-stdio-1.0

443− main-is: test/Relation/Atomable.hs

457+ main-is: Relation/Atomable.hs

444 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

458 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

445

459

446Test-Suite test-multiprocess-access

460Test-Suite test-multiprocess-access

447 import: commontest

461 import: commontest

448 type: exitcode-stdio-1.0

462 type: exitcode-stdio-1.0

449− main-is: test/MultiProcessDatabaseAccess.hs

463+ main-is: MultiProcessDatabaseAccess.hs

450

464

451Test-Suite test-transactiongraph-automerge

465Test-Suite test-transactiongraph-automerge

452 import: commontest

466 import: commontest

453 type: exitcode-stdio-1.0

467 type: exitcode-stdio-1.0

454− main-is: test/TransactionGraph/Automerge.hs

468+ main-is: TransactionGraph/Automerge.hs

455 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

469 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

456

470

457Test-Suite test-tupleable

471Test-Suite test-tupleable

458 import: commontest

472 import: commontest

459 type: exitcode-stdio-1.0

473 type: exitcode-stdio-1.0

460− main-is: test/Relation/Tupleable.hs

474+ main-is: Relation/Tupleable.hs

461

475

462Test-Suite test-client-simple

476Test-Suite test-client-simple

463 import: commontest

477 import: commontest

464− Main-Is: test/Client/Simple.hs

478+ Main-Is: Client/Simple.hs

465 type: exitcode-stdio-1.0

479 type: exitcode-stdio-1.0

466

480

467-- test for file handle leaks

481-- test for file handle leaks

468Executable handles

482Executable handles

469 Default-Language: Haskell2010

483 Default-Language: Haskell2010

470 Default-Extensions: OverloadedStrings

484 Default-Extensions: OverloadedStrings

471− 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, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter

485+ 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, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256

472 main-is: benchmark/Handles.hs

486 main-is: benchmark/Handles.hs

473 Other-Modules: TutorialD.Interpreter,

487 Other-Modules: TutorialD.Interpreter,

474 TutorialD.Interpreter.Base,

488 TutorialD.Interpreter.Base,

@@ -492,9 +506,9 @@ Executable handles

492 HS-Source-Dirs: ./src/bin

506 HS-Source-Dirs: ./src/bin

493 if flag(profiler)

507 if flag(profiler)

494 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

508 GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

495−

509+

496Test-Suite test-dataframe

510Test-Suite test-dataframe

497 import: commontest

511 import: commontest

498 type: exitcode-stdio-1.0

512 type: exitcode-stdio-1.0

499− Main-Is: test/DataFrame.hs

513+ Main-Is: DataFrame.hs

500 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

514 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−108

@@ -1,122 +1,30 @@

1−{ compiler ? "ghc865"

1+{ compiler ? "ghc8104"

2−, pkgs ? import ./pkgs.nix

2+, sources ? import ./nix/sources.nix

3+, pkgs ? import sources.nixpkgs { }

3}:

4}:

4−

5let

6− inherit (pkgs.lib.trivial) flip pipe;

7− inherit (pkgs.haskell.lib) appendPatch appendConfigureFlags;

8 doJailbreak = pkgs.haskell.lib.doJailbreak;

6 doJailbreak = pkgs.haskell.lib.doJailbreak;

9− dontHaddock = pkgs.haskell.lib.dontHaddock;

7+ needsCocoa = drv:

10− dontCheck = pkgs.haskell.lib.dontCheck;

8+ if pkgs.stdenv.isDarwin

11− streamly-master = pkgs.fetchFromGitHub {

9+ then drv.overrideDerivation (old:

12− owner = "composewell";

10+ { buildInputs = [ pkgs.darwin.apple_sdk.frameworks.Cocoa ] ++ old.buildInputs; }

13− repo = "streamly";

11+ )

14− rev = "ac3af8749194f1788704dda8667d0b3807075cc2";

12+ else drv;

15− sha256 = "04d8fk654vawdfs0dfidmq2awwgwi8x44iv8r7vqz70zkcsd5fij";

16− };

17

13

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−

27 haskellPackages = pkgs.haskell.packages.${compiler}.override {

14 haskellPackages = pkgs.haskell.packages.${compiler}.override {

28 overrides = self: super: {

15 overrides = self: super: {

29− rank1dynamic =

16+ curryer-rpc = self.callCabal2nix "curryer-rpc" sources.curryer { };

30− distProcessPkg (self.callHackageDirect {

31− pkg = "rank1dynamic";

32− ver = "0.4.0";

33− sha256 = "1x6p9z53s7xwp93jp4n1lq6m5xspcn6w62p461v8vqnp9600328b";

34−}{});

35− stm-hamt =

36− self.callHackageDirect {

37− pkg = "stm-hamt";

38− ver = "1.2.0.3";

39− sha256 = "1i8j7q8nhx3l7gydrjlsyhkvllr6bppgrjf0hp38zpm7p6xcv2bb";

40− }{};

41−

42− stm-containers =

43− self.callHackageDirect {

44− pkg = "stm-containers";

45− ver = "1.1.0.4";

46− sha256 = "0h9z6lawdm44minx9spvdb7sp645l36ri5cnxvhrcxwzr64s7qb5";

47− }{};

48−

49− data-interval =

50− self.callHackageDirect {

51− pkg = "data-interval";

52− ver = "2.0.1";

53− sha256 = "085j4yjr8wimxampxqdrg47p577whwg2mjxgfdl44yfck52fb6an";

54− }{};

55−

56− curryer-rpc =

57− self.callHackageDirect {

58− pkg = "curryer-rpc";

59− ver = "0.1";

60− sha256 = "0vb7q68g4zjm20simnqpjdpvcvh4g8cwlc5b6zjdjpg1rargri41";

61− }{};

62−

63− streamly = self.callCabal2nix "streamly" streamly-master {};

17+ streamly = doJailbreak (needsCocoa (self.callCabal2nix "streamly" sources.streamly { }));

64−

65− fusion-plugin-types =

66− self.callHackageDirect {

67− pkg = "fusion-plugin-types";

68− ver = "0.1.0";

69− sha256 = "17211b80p4zqisghs2j8flm4dj788f9glx2id6nh8f223q4cigc9";

70− }{};

71−

72− winery =

73− self.callHackageDirect {

74− pkg = "winery";

75− ver = "1.3.2";

76− sha256 = "1jc7q8m0zd8bziwa3mra44j518ckc566akk7r5hqpf8x5ng0n4vv";

77− }{};

78−

79− barbies-th =

80− self.callHackageDirect {

81− pkg = "barbies-th";

82− ver = "0.1.7";

83− sha256 = "0gf39kcn6lwqhz888qm3iypma76yrp3zwmif1niry647qq27xp4j";

84− }{};

85−

86− barbies =

87− self.callHackageDirect {

88− pkg = "barbies";

89− ver = "2.0.2.0";

90− sha256 = "0753rd8pw0x1cgasz8a6633kg83jngwzncp9khbimllvcdqzardh";

91− }{};

92−

93− prettyprinter =

94− self.callHackageDirect {

95− pkg = "prettyprinter";

96− ver = "1.7.0";

97− sha256 = "17byy08brwcsl5rqdhibq3pcpgx085shizb2ap6s4xy3izdia3cc";

98− }{};

99−

100− prettyprinter-ansi-terminal =

101− self.callHackageDirect {

102− pkg = "prettyprinter-ansi-terminal";

103− ver = "1.1.2";

104− sha256 = "0lwcqndppw3jc55rlnn6sp76zmjx2yzl21g9jhg27k2rdnjwd7md";

105− }{};

106−

107− project-m36 = dontCheck (self.callCabal2nixWithOptions "project-m36" ./. "-f-haskell-scripting" { });

18+ project-m36 = ((self.callCabal2nixWithOptions "project-m36" ./. "-f-haskell-scripting" { }));

108−

109 };

19 };

110 };

20 };

111−

112− project = haskellPackages.project-m36;

113in

21in

114{

22{

115− project = project;

23+ project = haskellPackages.project-m36;

116

24

117 shell = haskellPackages.shellFor {

25 shell = haskellPackages.shellFor {

118− packages = p: with p; [

26+ packages = p: [

119− project

27+ p.project-m36

120 ];

28 ];

121 buildInputs = [

29 buildInputs = [

122 haskellPackages.ghcid

30 haskellPackages.ghcid

@@ -125,4 +33,4 @@ in

125 ];

33 ];

126 withHoogle = true;

34 withHoogle = true;

127 };

35 };

128−}

36+}

scripts/DateExamples.tutd+2−2

@@ -20,7 +20,7 @@ sp := relation{tuple{s# "S1",p# "P1",qty 300},

20 tuple{s# "S3",p# "P2",qty 200},

21 tuple{s# "S4",p# "P4",qty 300},

22 tuple{s# "S4",p# "P5",qty 400}};

23−key s_pkey {s#} s

23+key s_pkey {s#} s;

24−key p_key {p#} p

24+key p_key {p#} p;

25foreign key s_sp_fk sp{s#} in s{s#};

26foreign key p_sp_fk sp{p#} in p{p#};

scripts/multiline.tutdnew file+2

@@ -0,0 +1,2 @@

1+x:=relation{

2+tuple{ x 2}} -- nice

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+3

@@ -164,6 +164,9 @@ instance FromJSON SchemaError

164instance ToJSON MergeError

165instance FromJSON MergeError

166

167+instance ToJSON ImportError'

168+instance FromJSON ImportError'

169+

167instance ToJSON DatabaseContextFunctionError

170instance ToJSON DatabaseContextFunctionError

168instance FromJSON DatabaseContextFunctionError

171instance FromJSON DatabaseContextFunctionError

169

172

src/bin/ProjectM36/Server/WebSocket.hs+2−1

@@ -22,6 +22,7 @@ import Data.Attoparsec.Text

22import Control.Applicative

23import Text.Megaparsec.Error

24import Data.Functor

25+import Data.Either (fromRight)

25

26

26#if MIN_VERSION_megaparsec(7,0,0)

27#if MIN_VERSION_megaparsec(7,0,0)

27import Data.List.NonEmpty as NE

28import Data.List.NonEmpty as NE

@@ -117,7 +118,7 @@ promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName)

117promptInfo sessionId conn = do

118promptInfo sessionId conn = do

118 eHeadName <- headName sessionId conn

119 eHeadName <- headName sessionId conn

119 eSchemaName <- currentSchemaName sessionId conn

120 eSchemaName <- currentSchemaName sessionId conn

120− pure (either (const "<unknown>") id eHeadName, either (const "<no schema>") id eSchemaName)

121+ pure (fromRight "<unknown>" eHeadName, fromRight "<no schema>" eSchemaName)

121

122

122sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO ()

123sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO ()

123sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]]))

124sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]]))

src/bin/ProjectM36/Server/WebSocket/websocket-client.html+1−1

@@ -126,7 +126,7 @@ margin-bottom: 5pt;

126 <li>:showrelvars</li>

127 <li>:showexpr true</li>

128 <li>:showexpr false</li>

129− <li>:importexample date</li>

129+ <li>:importexample cjdate</li>

130 <li>:showexpr s join sp</li>

131 <li>update s where city="Paris" (status:=10)</li>

132 <li>:showexpr s</li>

src/bin/ProjectM36/Server/WebSocket/websocket-server.hs+42−9

@@ -1,23 +1,40 @@

1{-# LANGUAGE CPP #-}

2−import ProjectM36.Server.WebSocket

2+

3−import ProjectM36.Server.Config

4−import ProjectM36.Server.ParseArgs

5−import ProjectM36.Server

6import Control.Concurrent

3import Control.Concurrent

7−import qualified Network.WebSockets as WS

8import Control.Exception

4import Control.Exception

5+import Control.Monad (when)

6+import Data.Maybe (isJust)

7+import Data.String (fromString)

8+import Network.HTTP.Types (status400)

9import 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

10

19

11main :: IO ()

20main :: IO ()

12main = do

21main = do

13 -- launch normal project-m36-server

22 -- launch normal project-m36-server

14 addressMVar <- newEmptyMVar

23 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+

16 --usurp the serverConfig for our websocket server and make the proxied server run locally

26 --usurp the serverConfig for our websocket server and make the proxied server run locally

27+ let serverConfig = wsServerConfig wsConfig

17− let wsHost = bindHost serverConfig

28+ wsHost = bindHost serverConfig

18 wsPort = bindPort serverConfig

29 wsPort = bindPort serverConfig

19 serverHost = "127.0.0.1"

30 serverHost = "127.0.0.1"

20 serverConfig' = serverConfig {bindPort = 0, bindHost = serverHost}

31 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+

21 _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)

38 _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)

22 --wait for server to be listening

39 --wait for server to be listening

23 addr <- takeMVar addressMVar

40 addr <- takeMVar addressMVar

@@ -25,6 +42,22 @@ main = do

25 case addr of

42 case addr of

26 SockAddrInet port' _ -> fromIntegral port'

43 SockAddrInet port' _ -> fromIntegral port'

27 _ -> error "unsupported socket address (IPv4 only currently)"

44 _ -> 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

45+ wsApp = websocketProxyServer port serverHost

46+ waiApp = WS.websocketsOr defaultConnectionOptions wsApp backupApp

29− WS.runServer wsHost (fromIntegral wsPort) (websocketProxyServer port serverHost)

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"

30

55

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.hs+3−1

@@ -34,6 +34,7 @@ import Data.Monoid

34import Data.List (isPrefixOf)

35import Control.Exception

36import System.Exit

37+import Data.Either (fromRight)

37

38

38{-

39{-

39context ops are read-only operations which only operate on the database context (relvars and constraints)

40context ops are read-only operations which only operate on the database context (relvars and constraints)

@@ -77,7 +78,7 @@ safeInterpreterParserP = fmap RODatabaseContextOp (roDatabaseContextOperatorP <*

77promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType

78promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType

78promptText eHeadName eSchemaName = "TutorialD (" <> transInfo <> "): "

79promptText eHeadName eSchemaName = "TutorialD (" <> transInfo <> "): "

79 where

80 where

80− transInfo = either (const "<unknown>") id eHeadName <> "/" <> either (const "<no schema>") id eSchemaName

81+ transInfo = fromRight "<unknown>" eHeadName <> "/" <> fromRight "<no schema>" eSchemaName

81

82

82parseTutorialD :: T.Text -> Either ParserError ParsedOperation

83parseTutorialD :: T.Text -> Either ParserError ParsedOperation

83parseTutorialD = parse interpreterParserP ""

84parseTutorialD = parse interpreterParserP ""

@@ -215,6 +216,7 @@ evalTutorialDInteractive sessionId conn safe interactive expr = case expr of

215 unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."

216 unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."

216 barf :: RelationalError -> IO TutorialDOperatorResult

217 barf :: RelationalError -> IO TutorialDOperatorResult

217 barf (ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr))

218 barf (ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr))

219+ barf (ParseError err) = pure (DisplayErrorResult err)

218 barf err = return $ DisplayErrorResult (T.pack (show err))

220 barf err = return $ DisplayErrorResult (T.pack (show err))

219 eHandler io = do

221 eHandler io = do

220 eErr <- io

222 eErr <- io

src/bin/TutorialD/Interpreter/Base.hs+18−3

@@ -17,7 +17,7 @@ import ProjectM36.Relation

17import ProjectM36.DataFrame

18

19#if MIN_VERSION_megaparsec(6,0,0)

20−import Text.Megaparsec.Char

20+import Text.Megaparsec.Char

21import qualified Text.Megaparsec.Char.Lexer as Lex

22import Text.Megaparsec

23import Data.Void

@@ -44,6 +44,7 @@ import Data.List.NonEmpty as NE

44import Data.Time.Clock

45import Data.Time.Format

46import Control.Monad (void)

47+import Data.Char

47

48

48#if !MIN_VERSION_megaparsec(7,0,0)

49#if !MIN_VERSION_megaparsec(7,0,0)

49anySingle :: Parsec Void Text (Token Text)

50anySingle :: Parsec Void Text (Token Text)

@@ -81,8 +82,9 @@ type ParseStr = Text

81type ParseStr = String

82type ParseStr = String

82#endif

83#endif

83

84

85+-- consumes only horizontal spaces

84spaceConsumer :: Parser ()

86spaceConsumer :: Parser ()

85−spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")

87+spaceConsumer = Lex.space space1 (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")

86

88

87opChar :: Parser Char

89opChar :: Parser Char

88opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces

90opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces

@@ -135,6 +137,9 @@ arrow = symbol "->"

135semi :: Parser Text

137semi :: Parser Text

136semi = symbol ";"

138semi = symbol ";"

137

139

140+nline :: Parser Text

141+nline = (T.singleton <$> newline) <|> crlf

142+

138integer :: Parser Integer

143integer :: Parser Integer

139#if MIN_VERSION_megaparsec(6,0,0)

144#if MIN_VERSION_megaparsec(6,0,0)

140integer = Lex.signed (pure ()) Lex.decimal <* spaceConsumer

145integer = Lex.signed (pure ()) Lex.decimal <* spaceConsumer

@@ -150,7 +155,7 @@ natural = Lex.integer <* spaceConsumer

150#endif

155#endif

151

156

152float :: Parser Double

157float :: Parser Double

153−float = Lex.float

158+float = Lex.float <* spaceConsumer

154

159

155capitalizedIdentifier :: Parser Text

160capitalizedIdentifier :: Parser Text

156capitalizedIdentifier =

161capitalizedIdentifier =

@@ -200,6 +205,9 @@ normalQuotedString = quote *> (T.pack <$> manyTill Lex.charLiteral quote)

200quotedString :: Parser Text

205quotedString :: Parser Text

201quotedString = try tripleQuotedString <|> normalQuotedString

206quotedString = try tripleQuotedString <|> normalQuotedString

202

207

208+quoted :: Parser a -> Parser a

209+quoted = between quote quote

210+

203uuidP :: Parser U.UUID

211uuidP :: Parser U.UUID

204uuidP = do

212uuidP = do

205 uuidStart <- count 8 hexDigitChar

213 uuidStart <- count 8 hexDigitChar

@@ -228,3 +236,10 @@ colonOp :: Text -> Parser ()

228colonOp opStr = do

236colonOp opStr = do

229 _ <- string opStr <* (void spaceChar <|> eof) <* spaceConsumer

237 _ <- string opStr <* (void spaceChar <|> eof) <* spaceConsumer

230 pure ()

238 pure ()

239+

240+hex :: Parser Text

241+hex = takeWhileP (Just "hexadecimal")

242+ (\c ->

243+ isDigit c

244+ || (c >= 'a' && c <= 'f'))

245+

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+3−2

@@ -53,8 +53,9 @@ multilineSep :: Parser T.Text

53multilineSep = newline >> pure "\n"

54

55multipleDatabaseContextExprP :: Parser DatabaseContextExpr

56−multipleDatabaseContextExprP =

56+multipleDatabaseContextExprP = do

57− MultipleExpr <$> sepBy1 databaseContextExprP semi

57+ exprs <- filter (/= NoOperation) <$> sepBy1 databaseContextExprP semi

58+ pure (MultipleExpr exprs)

58

59

59insertP :: Parser DatabaseContextExpr

60insertP :: Parser DatabaseContextExpr

60insertP = do

61insertP = do

src/bin/TutorialD/Interpreter/Import/Base.hs+8−3

@@ -2,6 +2,8 @@

2module TutorialD.Interpreter.Import.Base where

3import ProjectM36.Base

4import ProjectM36.Error

5+import Text.URI (URI)

6+import Data.Text (Text)

5#if __GLASGOW_HASKELL__ < 804

7#if __GLASGOW_HASKELL__ < 804

6import Data.Monoid

8import Data.Monoid

7#endif

9#endif

@@ -12,11 +14,14 @@ data RelVarDataImportOperator = RelVarDataImportOperator RelVarName FilePath (Re

12instance Show RelVarDataImportOperator where

14instance Show RelVarDataImportOperator where

13 show (RelVarDataImportOperator rv path _) = "RelVarDataImportOperator " <> show rv <> " " <> path

15 show (RelVarDataImportOperator rv path _) = "RelVarDataImportOperator " <> show rv <> " " <> path

14

16

17+type HashVerification = Maybe Text

18+

15-- | import data into a database context

19-- | import data into a database context

16−data DatabaseContextDataImportOperator = DatabaseContextDataImportOperator FilePath (FilePath -> IO (Either RelationalError DatabaseContextExpr))

20+data DatabaseContextDataImportOperator = DatabaseContextDataImportOperator URI HashVerification (URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr))

17

21

18instance Show DatabaseContextDataImportOperator where

22instance Show DatabaseContextDataImportOperator where

19− show (DatabaseContextDataImportOperator path _) = "DatabaseContextDataImportOperator " <> path

23+ show (DatabaseContextDataImportOperator uri hash _) =

24+ "DatabaseContextDataImportOperator " <> show uri <> " " <> show hash

20

25

21-- perhaps create a structure to import a whole transaction graph section in the future

26-- perhaps create a structure to import a whole transaction graph section in the future

22

27

@@ -24,4 +29,4 @@ evalRelVarDataImportOperator :: RelVarDataImportOperator -> TypeConstructorMappi

24evalRelVarDataImportOperator (RelVarDataImportOperator relVarName path importFunc) tConsMap attrs = importFunc relVarName tConsMap attrs path

29evalRelVarDataImportOperator (RelVarDataImportOperator relVarName path importFunc) tConsMap attrs = importFunc relVarName tConsMap attrs path

25

30

26evalDatabaseContextDataImportOperator :: DatabaseContextDataImportOperator -> IO (Either RelationalError DatabaseContextExpr)

31evalDatabaseContextDataImportOperator :: DatabaseContextDataImportOperator -> IO (Either RelationalError DatabaseContextExpr)

27−evalDatabaseContextDataImportOperator (DatabaseContextDataImportOperator path importFunc) = importFunc path

32+evalDatabaseContextDataImportOperator (DatabaseContextDataImportOperator uri hash importFunc) = importFunc uri hash

src/bin/TutorialD/Interpreter/Import/BasicExamples.hs+2−2

@@ -20,8 +20,8 @@ importBasicExampleOperatorP :: Parser ImportBasicExampleOperator

20importBasicExampleOperatorP = do

21 reservedOp ":importexample"

22 example <- identifier

23− if example == "date" then

23+ if example == "cjdate" then

24 pure ImportBasicDateExampleOperator

25 else

26 fail "Unknown example name"

27−

27+

src/bin/TutorialD/Interpreter/Import/CSV.hs+3−3

@@ -14,10 +14,10 @@ importCSVRelation relVarName tConsMap attrs pathIn = do

14 --TODO: handle filesystem errors

15 csvData <- try (BS.readFile pathIn) :: IO (Either IOError BS.ByteString)

16 case csvData of

17− Left err -> return $ Left (ImportError $ T.pack (show err))

17+ Left err -> pure $ Left (ImportError (ImportFileError (T.pack (show err))))

18 Right csvData' -> case csvAsRelation attrs tConsMap csvData' of

19− Left err -> return $ Left (ParseError $ T.pack (show err))

19+ Left err -> pure $ Left (ParseError $ T.pack (show err))

20− Right csvRel -> return $ Right (Insert relVarName (ExistingRelation csvRel))

20+ Right csvRel -> pure $ Right (Insert relVarName (ExistingRelation csvRel))

21

22importCSVP :: Parser RelVarDataImportOperator

23importCSVP = do

src/bin/TutorialD/Interpreter/Import/TutorialD.hs+70−17

@@ -9,25 +9,78 @@ import qualified Data.Text as T

9import Control.Exception

10import qualified Data.ByteString as BS

11import qualified Data.Text.Encoding as TE

12+import qualified Text.URI as URI

13+import Text.URI (URI)

14+import Crypto.Hash.SHA256

15+import Data.ByteString.Base16 as B16

16+import Network.HTTP.Simple

17+import Network.HTTP.Types

12−--import a file containing TutorialD database context expressions

18+--import a file containing TutorialD database context expressions via local files or HTTP/HTTPS

13

19

14−importTutorialD :: FilePath -> IO (Either RelationalError DatabaseContextExpr)

20+importTutorialDFromFile :: URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr)

15−importTutorialD pathIn = do

21+importTutorialDFromFile fileURI mHash = do

22+ case URI.uriPath fileURI of

23+ Just (False, _) -> do

16− eTutdBytes <- try (BS.readFile pathIn) :: IO (Either IOError BS.ByteString)

24+ eTutdBytes <- try (BS.readFile filePath) :: IO (Either IOError BS.ByteString)

17− case eTutdBytes of

25+ case eTutdBytes of

18− Left err -> return $ Left (ImportError $ T.pack (show err))

26+ Left err -> pure $ Left (ImportError (ImportFileError (T.pack (show err))))

27+ Right tutdBytes ->

28+ case validateBytes tutdBytes mHash of

29+ Left err -> pure (Left err)

19− Right tutdBytes ->

30+ Right tutdBytes' -> importTutorialDBytes tutdBytes'

31+ _ -> pure (Left (ImportError (InvalidFileURIError (URI.render fileURI))))

32+ where

33+ filePath = drop (length ("file://" :: String)) (URI.renderStr fileURI)

34+

35+

36+importTutorialDBytes :: BS.ByteString -> IO (Either RelationalError DatabaseContextExpr)

37+importTutorialDBytes tutdBytes =

20− case TE.decodeUtf8' tutdBytes of

38+ case TE.decodeUtf8' tutdBytes of

21− Left err -> pure (Left (ImportError $ T.pack (show err)))

39+ Left err -> pure (Left (ImportError (ImportFileDecodeError (T.pack (show err)))))

22− Right tutdUtf8 ->

40+ Right tutdUtf8 ->

23− case parse multipleDatabaseContextExprP "import" tutdUtf8 of

41+ case parse (multipleDatabaseContextExprP <* eof) "import" tutdUtf8 of

24− --parseErrorPretty is new in megaparsec 5

42+ --parseErrorPretty is new in megaparsec 5

25− Left err -> pure (Left (PM36E.ParseError (T.pack (show err))))

43+ Left err -> pure (Left (PM36E.ParseError (T.pack (errorBundlePretty err))))

26− Right expr -> pure (Right expr)

44+ Right expr -> pure (Right expr)

27−

45+

46+importTutorialDViaHTTP :: URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr)

47+importTutorialDViaHTTP uri mHash = do

48+ reqURI <- parseRequest (URI.renderStr uri)

49+ response <- httpBS reqURI

50+ let scode = getResponseStatus response

51+ if scode == ok200 then

52+ let byteBody = getResponseBody response in

53+ case validateBytes byteBody mHash of

54+ Right byteBody' -> do

55+ importTutorialDBytes byteBody'

56+ Left err -> pure (Left err)

57+ else

58+ pure (Left (ImportError (ImportDownloadError (T.pack ("download failed: " <> show scode)))))

59+

60+validateBytes :: BS.ByteString -> HashVerification -> Either RelationalError BS.ByteString

61+validateBytes tutdBytes mHash =

62+ case mHash of

63+ Nothing -> pure tutdBytes

64+ Just expectedHashText ->

65+ case B16.decode (TE.encodeUtf8 expectedHashText) of

66+ Left _ -> Left (ImportError (InvalidSHA256Error expectedHashText))

67+ Right expectedHash | hashBytes == expectedHash -> pure tutdBytes

68+ | otherwise ->

69+ let p = TE.decodeUtf8 . B16.encode in

70+ Left (ImportError (SHA256MismatchError (p expectedHash) (p hashBytes)))

71+ where

72+ hashBytes = hash tutdBytes

73+

74+

28tutdImportP :: Parser DatabaseContextDataImportOperator

75tutdImportP :: Parser DatabaseContextDataImportOperator

29tutdImportP = do

76tutdImportP = do

30 reserved ":importtutd"

77 reserved ":importtutd"

31− path <- quotedString

78+ uri <- quoted URI.parser

32 spaceConsumer

79 spaceConsumer

80+ mhash <- optional (quoted hex)

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)

33− return $ DatabaseContextDataImportOperator (T.unpack path) importTutorialD

86+ pure $ DatabaseContextDataImportOperator uri mhash handler

src/bin/TutorialD/Interpreter/RelationalExpr.hs+3−2

@@ -216,6 +216,7 @@ consumeAtomExprP consume = try functionAtomExprP <|>

216 attributeAtomExprP <|>

217 try nakedAtomExprP <|>

218 relationalAtomExprP

219+

219

220

220attributeAtomExprP :: Parser (AtomExprBase a)

221attributeAtomExprP :: Parser (AtomExprBase a)

221attributeAtomExprP = do

222attributeAtomExprP = do

@@ -234,7 +235,7 @@ constructedAtomExprP consume = do

234-- used only for primitive type parsing ?

235-- used only for primitive type parsing ?

235atomP :: Parser Atom

236atomP :: Parser Atom

236atomP = stringAtomP <|>

237atomP = stringAtomP <|>

237− doubleAtomP <|>

238+ try doubleAtomP <|>

238 integerAtomP <|>

239 integerAtomP <|>

239 boolAtomP

240 boolAtomP

240

241

@@ -249,7 +250,7 @@ stringAtomP :: Parser Atom

249stringAtomP = TextAtom <$> quotedString

250stringAtomP = TextAtom <$> quotedString

250

251

251doubleAtomP :: Parser Atom

252doubleAtomP :: Parser Atom

252−doubleAtomP = DoubleAtom <$> try float

253+doubleAtomP = DoubleAtom <$> float

253

254

254integerAtomP :: Parser Atom

255integerAtomP :: Parser Atom

255integerAtomP = IntegerAtom <$> integer

256integerAtomP = IntegerAtom <$> integer

src/lib/ProjectM36/Attribute.hs+6−6

@@ -87,12 +87,12 @@ joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length

87 overlappingAttributes = V.filter (`V.elem` attrs2) attrs1

88-}

89joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes

90−joinAttributes attrs1 attrs2 =

90+joinAttributes attrs1 attrs2

91− if S.size overlappingNames == 0 then -- fast path, no overlapping names

91+ | S.size overlappingNames == 0 = -- fast path, no overlapping names

92 pure (concated id)

93− else if attributesForNames overlappingNames attrs1 == attributesForNames overlappingNames attrs2 then -- check that atomtypes match

93+ | attributesForNames overlappingNames attrs1 == attributesForNames overlappingNames attrs2 = -- that atomtypes match

94 pure (concated vectorUniqueify)

95− else

95+ | otherwise =

96 --special handling to validate that overlapping names have the same atom types

97 Left (TupleAttributeTypeMismatchError (attributesForNames overlappingNames attrs1))

98 where

@@ -111,7 +111,7 @@ member :: Attribute -> Attributes -> Bool

111member attr attrs = HS.member attr (attributesSet attrs)

112

113deleteAttributeName :: AttributeName -> Attributes -> Attributes

114−deleteAttributeName attrName attrs = deleteAttributeNames (S.singleton attrName) attrs

114+deleteAttributeName attrName = deleteAttributeNames (S.singleton attrName)

115

116deleteAttributeNames :: S.Set AttributeName -> Attributes -> Attributes

117deleteAttributeNames attrNames attrs = Attributes {

@@ -215,7 +215,7 @@ attributesDifference attrsA attrsB =

215 hset = HS.difference setA setB <> HS.difference setB setA

216 setA = attributesSet attrsA

217 setB = attributesSet attrsB

218− vec = V.filter (\attr -> HS.member attr hset) (attributesVec attrsA <> attributesVec attrsB)

218+ vec = V.filter (`HS.member` hset) (attributesVec attrsA <> attributesVec attrsB)

219

220vectorUniqueify :: (Hash.Hashable a, Eq a) => V.Vector a -> V.Vector a

221vectorUniqueify vecIn = V.fromList $ HS.toList $ HS.fromList $ V.toList vecIn

src/lib/ProjectM36/Base.hs+2−2

@@ -1,4 +1,4 @@

1−{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies, DeriveFoldable, DeriveTraversable #-}

1+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies #-}

2{-# OPTIONS_GHC -fno-warn-orphans #-}

3

4module ProjectM36.Base where

@@ -102,7 +102,7 @@ instance Hashable Attribute where

102type AttributesHash = Int

103

104-- | 'Attributes' represent the head of a relation.

105−data Attributes = Attributes {

105+newtype Attributes = Attributes {

106 attributesVec :: V.Vector Attribute

107 --,attributesSet :: HS.HashSet Attribute --compare with this generated in heap profile and benchmarks

108 }

src/lib/ProjectM36/Client.hs+1−1

@@ -248,7 +248,7 @@ createScriptSession :: [String] -> IO (Maybe ScriptSession)

248createScriptSession ghcPkgPaths = do

249 eScriptSession <- initScriptSession ghcPkgPaths

250 case eScriptSession of

251− Left err -> hPutStrLn stderr ("Failed to load scripting engine- scripting disabled: " ++ show err) >> pure Nothing --not a fatal error, but the scripting feature must be disabled

251+ Left err -> hPutStrLn stderr ("Warning: Haskell scripting disabled: " ++ show err) >> pure Nothing --not a fatal error, but the scripting feature must be disabled

252 Right s -> pure (Just s)

253

254

src/lib/ProjectM36/Error.hs+10−2

@@ -81,7 +81,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

81 | RelationValuedAttributesNotSupportedError [AttributeName]

82 | NotificationNameInUseError NotificationName

83 | NotificationNameNotInUseError NotificationName

84− | ImportError T.Text -- really? This should be broken out into some other error type- this has nothing to do with relational algebra

84+ | ImportError ImportError'

85 | ExportError T.Text

86 | UnhandledExceptionError String

87 | MergeTransactionError MergeError

@@ -144,4 +144,12 @@ data SchemaError = RelVarReferencesMissing (S.Set RelVarName) |

144 RelVarInReferencedMoreThanOnce RelVarName |

145 RelVarOutReferencedMoreThanOnce RelVarName

146 deriving (Show, Eq, Generic, Typeable, NFData)

147−

147+

148+

149+data ImportError' = InvalidSHA256Error T.Text

150+ | SHA256MismatchError T.Text T.Text

151+ | InvalidFileURIError T.Text

152+ | ImportFileDecodeError T.Text

153+ | ImportFileError T.Text

154+ | ImportDownloadError T.Text

155+ deriving (Show, Eq, Generic, Typeable, NFData)

src/lib/ProjectM36/Relation.hs+2−2

@@ -244,8 +244,8 @@ relMap mapper (Relation attrs tupleSet) =

244

245relMogrify :: (RelationTuple -> Either RelationalError RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation

246relMogrify mapper newAttributes (Relation _ tupSet) = do

247− newTuples <- mapM (\tup ->

248− reorderTuple newAttributes <$> mapper tup) (asList tupSet)

247+ newTuples <- mapM (fmap (reorderTuple newAttributes) . mapper) (asList tupSet)

248+

249 mkRelationFromTuples newAttributes newTuples

250

251relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a

src/lib/ProjectM36/RelationalExpression.hs+40−11

@@ -42,6 +42,7 @@ import ProjectM36.NormalizeExpr

42import ProjectM36.WithNameExpr

43import Test.QuickCheck

44import qualified Data.Functor.Foldable as Fold

45+import Control.Applicative

45#ifdef PM36_HASKELL_SCRIPTING

46#ifdef PM36_HASKELL_SCRIPTING

46import GHC hiding (getContext)

47import GHC hiding (getContext)

47import Control.Exception

48import Control.Exception

@@ -298,14 +299,15 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

298

299

299evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do

300evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do

300 gfExpr <- relVarByName relVarName

301 gfExpr <- relVarByName relVarName

301− let optExpr = applyStaticUnionCollapse (Union

302+ let optExpr = applyUnionCollapse (Union

302− gfExpr

303− relExpr)

303+ relExpr

304+ gfExpr)

304 evalGraphRefDatabaseContextExpr (Assign relVarName optExpr)

305 evalGraphRefDatabaseContextExpr (Assign relVarName optExpr)

305

306

306evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do

307evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do

307 gfExpr <- relVarByName relVarName

308 gfExpr <- relVarByName relVarName

308− setRelVar relVarName (Restrict (NotPredicate predicate) gfExpr)

309+ let optExpr = applyRestrictionCollapse (Restrict (NotPredicate predicate) gfExpr)

310+ setRelVar relVarName optExpr

309

311

310--union of restricted+updated portion and the unrestricted+unupdated portion

312--union of restricted+updated portion and the unrestricted+unupdated portion

311evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

313evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

@@ -1351,13 +1353,40 @@ instance ResolveGraphRefTransactionMarker GraphRefAtomExpr where

1351--convert series of simple Union queries into MakeStaticRelation

1353--convert series of simple Union queries into MakeStaticRelation

1352-- this is especially useful for long, nested applications of Union with simple tuples

1354-- this is especially useful for long, nested applications of Union with simple tuples

1353-- Union (MakeRelation x y) (MakeRelation x y') -> MakeRelation x (y + y')

1355-- Union (MakeRelation x y) (MakeRelation x y') -> MakeRelation x (y + y')

1356+

1357+--MakeRelationFromExprs Nothing (TupleExprs UncommittedContextMarker [TupleExpr (fromList [("name", NakedAtomExpr (TextAtom "steve"))])])

1358+

1354−applyStaticUnionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr

1359+applyUnionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr

1355−applyStaticUnionCollapse = Fold.cata opt

1360+applyUnionCollapse = Fold.cata opt

1356 where

1361 where

1362+ opt :: RelationalExprBaseF GraphRefTransactionMarker GraphRefRelationalExpr -> GraphRefRelationalExpr

1363+ opt (UnionF exprA exprB) | exprA == exprB = exprA

1357 opt (UnionF

1364 opt (UnionF

1358− a@(MakeStaticRelation attrsA tupsA)

1365+ exprA@(MakeRelationFromExprs mAttrs1 tupExprs1)

1359− b@(MakeStaticRelation attrsB tupsB)) = if attrsA == attrsB then

1366+ exprB@(MakeRelationFromExprs mAttrs2 tupExprs2)) | tupExprs1 == tupExprs2 = MakeRelationFromExprs (mAttrs1 <|> mAttrs2) tupExprs1

1360− MakeStaticRelation attrsA (tupleSetUnion attrsA tupsA tupsB)

1367+ | tupExprsNull tupExprs1 = exprB

1361− else

1368+ | tupExprsNull tupExprs2 = exprA

1362− Union a b

1363 opt x = Fold.embed x

1369 opt x = Fold.embed x

1370+ tupExprsNull (TupleExprs _ []) = True

1371+ tupExprsNull _ = False

1372+

1373+

1374+--UPDATE optimization- find matching where clause in "lower" levels of renaming

1375+--update x where y=1 set (x:=5,z:=10); update x where y=1 set(x:=6,z:=11)

1376+-- =>

1377+-- update x where y=1 set (x:=6,z:=11)

1378+-- future opt: match individual attributes update x where y=1 set (x:=5); update x where y=1 set (z:=11) => update x where y=1 set (x:=5,z:=11)

1379+

1380+--strategy: try to collapse the top-level update (union (restrict pred MakeRelationFromExpr) expr) if it contains the same predicate and resultant relation

1381+

1382+--DELETE optimization

1383+-- if a restriction matches a previous restriction, combine them

1384+-- O(1) since it only scans at the top level, critical in benchmarks generating redundant deletions

1385+applyRestrictionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr

1386+applyRestrictionCollapse orig@(Restrict npred@(NotPredicate _) expr) =

1387+ case expr of

1388+ orig'@(Restrict npred'@(NotPredicate _) _) | npred == npred' -> orig'

1389+ _ -> orig

1390+applyRestrictionCollapse expr = expr

1391+

1392+

src/lib/ProjectM36/ScriptSession.hs−2

@@ -128,8 +128,6 @@ initScriptSession ghcPkgPaths = do

128 "uuid",

129 "vector",

130 "text",

131− "binary",

132− "vector-binary-instances",

133 "time",

131 "time",

134 "project-m36",

132 "project-m36",

135 "bytestring"]

133 "bytestring"]

src/lib/ProjectM36/Serialise/Error.hs+1

@@ -12,3 +12,4 @@ deriving via WineryVariant MergeError instance Serialise MergeError

12deriving via WineryVariant ScriptCompilationError instance Serialise ScriptCompilationError

13deriving via WineryVariant PersistenceError instance Serialise PersistenceError

14deriving via WineryVariant SchemaError instance Serialise SchemaError

15+deriving via WineryVariant ImportError' instance Serialise ImportError'

src/lib/ProjectM36/Server/Config.hs+6

@@ -12,6 +12,12 @@ data ServerConfig = ServerConfig { persistenceStrategy :: PersistenceStrategy,

12 }

13 deriving (Show)

14

15+data WebsocketServerConfig = WebsocketServerConfig { wsServerConfig :: ServerConfig,

16+ tlsCertificatePath :: Maybe String,

17+ tlsKeyPath :: Maybe String

18+ }

19+ deriving (Show)

20+

15defaultServerConfig :: ServerConfig

21defaultServerConfig :: ServerConfig

16defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,

22defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,

17 checkFS = True,

23 checkFS = True,

src/lib/ProjectM36/Server/EntryPoints.hs+2−2

@@ -5,8 +5,8 @@ import ProjectM36.IsomorphicSchema

5import ProjectM36.Client as C

6import Data.Map

7import Control.Concurrent (threadDelay)

8−import Network.RPC.Curryer.Server

8+import Network.RPC.Curryer.Server

9−import System.Timeout

9+import System.Timeout hiding (Timeout)

10import Network.Socket

11import Control.Exception

12

src/lib/ProjectM36/Server/ParseArgs.hs+31−14

@@ -17,14 +17,14 @@ parseArgsWithDefaults defaults = ServerConfig <$>

17 many parseGhcPkgPath <*>

18 parseTimeout (perRequestTimeout defaults) <*>

19 parseTestMode

20−

20+

21parsePersistenceStrategy :: Parser PersistenceStrategy

22parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>

23 MinimalPersistence <$> dbdirOpt <|>

24 pure NoPersistence

25− where

25+ where

26− dbdirOpt = strOption (short 'd' <>

26+ dbdirOpt = strOption (short 'd' <>

27− long "database-directory" <>

27+ long "database-directory" <>

28 metavar "DIRECTORY" <>

29 showDefaultWith show

30 )

@@ -34,43 +34,60 @@ parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>

34

35parseTestMode :: Parser Bool

36parseTestMode = flag True False (long "test-mode" <> hidden)

37−

37+

38−parseCheckFS :: Parser Bool

38+parseCheckFS :: Parser Bool

39parseCheckFS = flag True False (long "disable-fscheck" <>

40 help "Disable filesystem check for journaling.")

41−

41+

42parseDatabaseName :: Parser DatabaseName

43parseDatabaseName = strOption (short 'n' <>

44 long "database" <>

45 metavar "DATABASE_NAME")

46

47−parseHostname :: Hostname -> Parser Hostname

47+parseHostname :: Hostname -> Parser Hostname

48parseHostname defHostname = strOption (short 'h' <>

49 long "hostname" <>

50 metavar "HOST_NAME" <>

51 value defHostname)

52−

52+

53parsePort :: Port -> Parser Port

54parsePort defPort = option auto (short 'p' <>

55 long "port" <>

56 metavar "PORT_NUMBER" <>

57 value defPort)

58−

58+

59parseGhcPkgPath :: Parser String

60parseGhcPkgPath = strOption (long "ghc-pkg-dir" <>

61 metavar "GHC_PACKAGE_DIRECTORY")

62−

62+

63−parseTimeout :: Int -> Parser Int

63+parseTimeout :: Int -> Parser Int

64parseTimeout defTimeout = option auto (long "timeout" <>

65 metavar "MICROSECONDS" <>

66 value defTimeout)

67

68parseConfig :: IO ServerConfig

69parseConfig = parseConfigWithDefaults defaultServerConfig

70−

70+

71parseConfigWithDefaults :: ServerConfig -> IO ServerConfig

72parseConfigWithDefaults defaults = execParser (info (parseArgsWithDefaults defaults <**> helpOption) idm)

73

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")

74

91

75helpOption :: Parser (a -> a)

92helpOption :: Parser (a -> a)

76helpOption = abortOption helpText $ mconcat

93helpOption = abortOption helpText $ mconcat

@@ -80,6 +97,6 @@ helpOption = abortOption helpText $ mconcat

80 where

97 where

81#if MIN_VERSION_optparse_applicative(0,16,0)

98#if MIN_VERSION_optparse_applicative(0,16,0)

82 helpText = ShowHelpText Nothing

99 helpText = ShowHelpText Nothing

83−#else

100+#else

84 helpText = ShowHelpText

101 helpText = ShowHelpText

85#endif

102#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/StaticOptimizer.hs+4−3

@@ -22,8 +22,6 @@ import qualified Data.Set as S

22

23-- the static optimizer performs optimizations which need not take any specific-relation statistics into account

24

25−--import Debug.Trace

26−

27data GraphRefSOptRelationalExprEnv =

25data GraphRefSOptRelationalExprEnv =

28 GraphRefSOptRelationalExprEnv

26 GraphRefSOptRelationalExprEnv

29 {

27 {

@@ -179,7 +177,7 @@ fullOptimizeGraphRefRelationalExpr expr = do

179optimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr

177optimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr

180optimizeGraphRefRelationalExpr e@(MakeStaticRelation _ _) = pure e

178optimizeGraphRefRelationalExpr e@(MakeStaticRelation _ _) = pure e

181

179

182−optimizeGraphRefRelationalExpr e@(MakeRelationFromExprs _ _) = pure e

180+optimizeGraphRefRelationalExpr e@MakeRelationFromExprs{} = pure e

183

181

184optimizeGraphRefRelationalExpr e@(ExistingRelation _) = pure e

182optimizeGraphRefRelationalExpr e@(ExistingRelation _) = pure e

185

183

@@ -209,6 +207,8 @@ optimizeGraphRefRelationalExpr (Union exprA exprB) = do

209 case (optExprA, optExprB) of

207 case (optExprA, optExprB) of

210 (Restrict predA (RelationVariable nameA sA),

208 (Restrict predA (RelationVariable nameA sA),

211 Restrict predB (RelationVariable nameB sB)) | nameA == nameB && sA == sB -> pure (Restrict (AndPredicate predA predB) (RelationVariable nameA sA))

209 Restrict predB (RelationVariable nameB sB)) | nameA == nameB && sA == sB -> pure (Restrict (AndPredicate predA predB) (RelationVariable nameA sA))

210+ (exprA', exprB') | isEmptyRelationExpr exprA' -> pure exprB'

211+ | isEmptyRelationExpr exprB' -> pure exprA'

212 _ -> if optExprA == optExprB then

213 pure optExprA

214 else

@@ -575,3 +575,4 @@ applyStaticRestrictionPushdown expr = case expr of

575-- no optimizations available

576optimizeDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextIOExpr

577optimizeDatabaseContextIOExpr = pure

578+

src/lib/ProjectM36/TransactionGraph.hs+1−1

@@ -384,7 +384,7 @@ subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans trav

384 else do

385 currentTransChildren <- childTransactions currentTrans' origGraph

386 let searchChildren = S.difference (S.insert currentTrans' traverseSet) currentTransChildren

387− searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans' traverseSet)

387+ searchChild start' = pathToTransaction origGraph start' goalTrans (S.insert currentTrans' traverseSet)

388 childSearches = map searchChild (S.toList searchChildren)

389 errors = lefts childSearches

390 pathsFound = rights childSearches

src/lib/ProjectM36/WithNameExpr.hs+4−2

@@ -42,9 +42,11 @@ substituteWithNameMacros macros (NotEquals exprA exprB) =

42substituteWithNameMacros macros (Extend extendTup expr) =

43 Extend (substituteWitNameMacrosExtendTupleExpr macros extendTup) (substituteWithNameMacros macros expr)

44substituteWithNameMacros macros (With moreMacros expr) =

45− --collect and override existing macros and recurse

45+ --collect and update nested with exprs

46 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

48 --scan for a match- if it exists, replace it (representing a with clause at a lower level

50 --scan for a match- if it exists, replace it (representing a with clause at a lower level

49 substituteWithNameMacros newMacros expr

51 substituteWithNameMacros newMacros expr

50

52

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

6

7# Local packages, usually specified by relative directory name

8packages:

9−- '.'

9+ - "."

10# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)

11extra-deps:

12−- git: https://github.com/agentm/curryer.git

12+ - git: https://github.com/agentm/curryer.git

13− commit: 28ff1d031078af4a17fa326d43340474571df0c3

13+ commit: 74ecaac619ad1165a4517d5c0f4e530493bda130

14−- git: https://github.com/composewell/streamly.git

14+ - git: https://github.com/composewell/streamly.git

15− commit: ac3af8749194f1788704dda8667d0b3807075cc2

15+ commit: ac3af8749194f1788704dda8667d0b3807075cc2

16−- fast-builder-0.1.2.1

16+ - fast-builder-0.1.2.1

17−- winery-1.3.2

17+ - winery-1.3.2

18−- barbies-2.0.2.0

18+ - barbies-2.0.2.0

19−- barbies-th-0.1.7

19+ - barbies-th-0.1.7

20−- extended-reals-0.2.3.0

20+ - extended-reals-0.2.3.0

21−- data-interval-2.0.1

21+ - data-interval-2.0.1

22−- stm-containers-1.1.0.4

22+ - stm-containers-1.1.0.4

23−- stm-hamt-1.2.0.4

23+ - stm-hamt-1.2.0.4

24−- rset-1.0.0

24+ - rset-1.0.0

25−- hashable-time-0.2.0.2

25+ - hashable-time-0.2.0.2

26−- network-transport-tcp-0.6.0

26+ - network-transport-tcp-0.6.0

27−- megaparsec-7.0.5

27+ - megaparsec-7.0.5

28−- prettyprinter-1.7.0

28+ - prettyprinter-1.7.0

29−- prettyprinter-ansi-terminal-1.1.2

29+ - prettyprinter-ansi-terminal-1.1.2

30−- fusion-plugin-types-0.1.0

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

31

35

32# Override default flag values for local packages and extra-deps

36# Override default flag values for local packages and extra-deps

33flags:

37flags:

stack.ghc8.8.yaml+24−22

@@ -6,30 +6,32 @@ resolver: lts-16.4

6

7# Local packages, usually specified by relative directory name

8packages:

9−- '.'

9+ - "."

10# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)

11extra-deps:

12−- git: https://github.com/agentm/curryer.git

12+ - git: https://github.com/agentm/curryer.git

13− commit: 28ff1d031078af4a17fa326d43340474571df0c3

13+ commit: 74ecaac619ad1165a4517d5c0f4e530493bda130

14−- git: https://github.com/composewell/streamly.git

14+ - git: https://github.com/composewell/streamly.git

15− commit: ac3af8749194f1788704dda8667d0b3807075cc2

15+ commit: ac3af8749194f1788704dda8667d0b3807075cc2

16−- fast-builder-0.1.2.1

16+ - fast-builder-0.1.2.1

17−- winery-1.3.2

17+ - winery-1.3.2

18−- barbies-2.0.2.0

18+ - barbies-2.0.2.0

19−- barbies-th-0.1.7

19+ - barbies-th-0.1.7

20−- extended-reals-0.2.3.0

20+ - extended-reals-0.2.3.0

21−- data-interval-2.0.1

21+ - data-interval-2.0.1

22−- stm-containers-1.1.0.4

22+ - stm-containers-1.1.0.4

23−- stm-hamt-1.2.0.4

23+ - stm-hamt-1.2.0.4

24−- rset-1.0.0

24+ - rset-1.0.0

25−- hashable-time-0.2.0.2

25+ - hashable-time-0.2.0.2

26−- network-transport-tcp-0.7.0

26+ - network-transport-tcp-0.7.0

27−- megaparsec-7.0.5

27+ - megaparsec-7.0.5

28−- network-2.8.0.1

28+ - network-2.8.0.1

29−- primitive-extras-0.8

29+ - primitive-extras-0.8

30−- primitive-unlifted-0.1.3.0

30+ - primitive-unlifted-0.1.3.0

31−- prettyprinter-1.7.0

31+ - prettyprinter-1.7.0

32−- prettyprinter-ansi-terminal-1.1.2

32+ - prettyprinter-ansi-terminal-1.1.2

33+ - base16-bytestring-1.0.1.0

34+ - modern-uri-0.3.4.0

33

35

34# Override default flag values for local packages and extra-deps

36# Override default flag values for local packages and extra-deps

35flags:

37flags:

test/Server/Main.hs+3−4

@@ -241,9 +241,8 @@ testFileDescriptorCount = TestCase (pure ())

241

242testClientConnectFail :: Test

243testClientConnectFail = TestCase $ do

244− let connInfo = RemoteConnectionInfo "non-existent-db" "127.0.0.1" "8888" emptyNotificationCallback

244+ let connInfo = RemoteConnectionInfo "nonexistentdb" "127.0.0.1" "7777" emptyNotificationCallback

245 eConn <- connectProjectM36 connInfo

246 case eConn of

247− Left err -> pure ()

247+ Left (IOExceptionError _) -> pure ()

248− Right _ -> assertFailure "unexpected connection success"

248+ _ -> assertFailure "connection failure failed"

249−

test/TutorialD/Interpreter/Import/ImportTest.hsnew file+47

@@ -0,0 +1,47 @@

1+import Test.HUnit

2+import ProjectM36.Base

3+import TutorialD.Interpreter.Import.TutorialD

4+import System.Exit

5+import qualified Data.Text as T

6+import System.IO.Temp

7+import System.FilePath

8+import qualified Data.Map as M

9+import System.IO

10+import System.Directory

11+import qualified Data.ByteString as BS

12+import qualified Data.Text.Encoding as TE

13+import Text.URI hiding (makeAbsolute)

14+

15+main :: IO ()

16+main = do

17+ tcounts <- runTestTT $ TestList [testTutdFileImport

18+ ,testTutdHTTPSImport

19+ ]

20+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

21+

22+testTutdFileImport :: Test

23+testTutdFileImport = TestCase $

24+ withSystemTempFile "m.tutd" $ \tempPath handle -> do

25+ BS.hPut handle (TE.encodeUtf8 "x:=relation{tuple{a 5,b \"spam\"}}; y:=relation{tuple{b \"漢字\"}}")

26+ hClose handle

27+ let expectedExpr = MultipleExpr [

28+ Assign "x" (MakeRelationFromExprs Nothing

29+ $ TupleExprs () [TupleExpr (M.fromList [("a", NakedAtomExpr $ IntegerAtom 5),

30+ ("b", NakedAtomExpr $ TextAtom "spam")])]),

31+ Assign "y" (MakeRelationFromExprs Nothing

32+ $ TupleExprs () [TupleExpr (M.fromList [("b", NakedAtomExpr (TextAtom "漢字"))])])]

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)

36+ imported <- importTutorialDFromFile fileURI Nothing

37+ assertEqual "import tutd" (Right expectedExpr) imported

38+

39+testTutdHTTPSImport :: Test

40+testTutdHTTPSImport = TestCase $ do

41+ uri <- mkURI "https://raw.githubusercontent.com/agentm/project-m36/master/test/TutorialD/Interpreter/Import/httpimporttest.tutd"

42+ let hash = "effe32b247586dc3ac0079fc241b9618d41d189afcaeb7907edbe5a8b45992a4"

43+ expected = Right (MultipleExpr [Assign "x" (RelationVariable "true" ()),Assign "y" (RelationVariable "false" ())])

44+ actual <- importTutorialDViaHTTP uri (Just hash)

45+ assertEqual "github https" expected actual

46+

47+

test/TutorialD/Interpreter/Import/TutorialD.hsdeleted−29

@@ -1,29 +0,0 @@

1−import Test.HUnit

2−import ProjectM36.Base

3−import TutorialD.Interpreter.Import.TutorialD

4−import System.Exit

5−import System.IO.Temp

6−import qualified Data.Map as M

7−import System.IO

8−import qualified Data.ByteString as BS

9−import qualified Data.Text.Encoding as TE

10−

11−main :: IO ()

12−main = do

13− tcounts <- runTestTT $ TestList [testTutdImport]

14− if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

15−

16−testTutdImport :: Test

17−testTutdImport = TestCase $

18− withSystemTempFile "m.tutd" $ \tempPath handle -> do

19− BS.hPut handle (TE.encodeUtf8 "x:=relation{tuple{a 5,b \"spam\"}}; y:=relation{tuple{b \"漢字\"}}")

20− hClose handle

21− let expectedExpr = MultipleExpr [

22− Assign "x" (MakeRelationFromExprs Nothing

23− $ TupleExprs () [TupleExpr (M.fromList [("a", NakedAtomExpr $ IntegerAtom 5),

24− ("b", NakedAtomExpr $ TextAtom "spam")])]),

25− Assign "y" (MakeRelationFromExprs Nothing

26− $ TupleExprs () [TupleExpr (M.fromList [("b", NakedAtomExpr (TextAtom "漢字"))])])]

27− imported <- importTutorialD tempPath

28− assertEqual "import tutd" (Right expectedExpr) imported

29−

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+5−1

@@ -362,7 +362,7 @@ testComments :: Test

362testComments = TestCase $ do

363 (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

364 mapM_ (executeTutorialD sessionId dbconn) [

365− ":branch testbranch --test comment\n",

365+ ":branch testbranch --test comment",

366 ":jumphead {- test comment -} master"]

367

368-- create a graph and query from two disparate contexts

@@ -665,6 +665,10 @@ testWithClause = TestCase $ do

665 executeTutorialD sessionId dbconn "x:=with (x as s) x"

666 eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())

667 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

668

672

669 let err1 = "RelVarAlreadyDefinedError"

673 let err1 = "RelVarAlreadyDefinedError"

670 expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as s) s"

674 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.

test/scripts.hs+5−2

@@ -4,6 +4,8 @@ import TutorialD.Interpreter.Import.TutorialD

4import System.Directory

5import Data.List (isSuffixOf)

6import System.Exit

7+import qualified Data.Text as T

8+import Text.URI

7

9

8testList :: IO Test

10testList :: IO Test

9testList = do

11testList = do

@@ -20,7 +22,8 @@ main = do

20

22

21testScript :: FilePath -> Test

23testScript :: FilePath -> Test

22testScript tutdFile = TestCase $ do

24testScript tutdFile = TestCase $ do

23− eImport <- importTutorialD tutdFile

25+ fileURI <- mkURI (T.pack ("file://" <> tutdFile))

26+ eImport <- importTutorialDFromFile fileURI Nothing

24 case eImport of

27 case eImport of

25 Left err -> assertFailure ("tutd import failure in " ++ tutdFile ++ ": " ++ show err)

28 Left err -> assertFailure ("tutd import failure in " ++ tutdFile ++ ": " ++ show err)

26− Right _ -> pure ()

29+ Right _ -> pure ()