1b68b23..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

cabal.project+3

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

1packages: project-m36.cabal

2

3+package *

4+ split-sections: True

5+

3--high-performance streaming library

6--high-performance streaming library

4source-repository-package

7source-repository-package

5 type: git

8 type: git

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+55−42

@@ -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.3, 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

@@ -174,7 +175,7 @@ Executable tutd

174 directory,

175 directory,

175 filepath,

176 filepath,

176 temporary,

177 temporary,

177− megaparsec >= 5.2.0 && < 9,

178+ megaparsec >= 5.2.0 && < 10,

178 haskeline,

179 haskeline,

179 random, MonadRandom,

180 random, MonadRandom,

180 base64-bytestring,

181 base64-bytestring,

@@ -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,

@@ -230,7 +237,6 @@ Executable project-m36-server

230 optparse-applicative,

237 optparse-applicative,

231 hashable-time,

238 hashable-time,

232 time,

239 time,

233− vector-binary-instances,

234 text,

240 text,

235 deepseq-generics,

241 deepseq-generics,

236 mtl,

242 mtl,

@@ -252,7 +258,7 @@ Executable project-m36-server

252Executable bigrel

258Executable bigrel

253 Default-Language: Haskell2010

259 Default-Language: Haskell2010

254 Default-Extensions: OverloadedStrings

260 Default-Extensions: OverloadedStrings

255− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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

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

256 Other-Modules: TutorialD.Interpreter.Base,

262 Other-Modules: TutorialD.Interpreter.Base,

257 TutorialD.Interpreter.DatabaseContextExpr,

263 TutorialD.Interpreter.DatabaseContextExpr,

258 TutorialD.Interpreter.RelationalExpr,

264 TutorialD.Interpreter.RelationalExpr,

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

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

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

265

271

266Common commontest

272Common commontest

267− Default-Language: Haskell2010

273+ Default-Language: Haskell2010

268− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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

269 Default-Extensions: OverloadedStrings

275 Default-Extensions: OverloadedStrings

270 GHC-Options: -Wall -threaded

276 GHC-Options: -Wall -threaded

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

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

272

278

273Benchmark basic-benchmark

279Benchmark basic-benchmark

274 Default-Language: Haskell2010

280 Default-Language: Haskell2010

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

281 if flag(profiler)

287 if flag(profiler)

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

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

283

289

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

285Benchmark update-exprs

291Benchmark update-exprs

286 Default-Language: Haskell2010

292 Default-Language: Haskell2010

287 Default-Extensions: OverloadedStrings

293 Default-Extensions: OverloadedStrings

@@ -296,64 +302,64 @@ Benchmark update-exprs

296Test-Suite test-tutoriald

302Test-Suite test-tutoriald

297 import: commontest

303 import: commontest

298 type: exitcode-stdio-1.0

304 type: exitcode-stdio-1.0

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

305+ main-is: TutorialD/InterpreterTest.hs

300 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

301− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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

302

308

303Test-Suite test-tutoriald-atomfunctionscript

309Test-Suite test-tutoriald-atomfunctionscript

304 import: commontest

310 import: commontest

305 type: exitcode-stdio-1.0

311 type: exitcode-stdio-1.0

306 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

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

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

308

314

309Test-Suite test-tutoriald-databasecontextfunctionscript

315Test-Suite test-tutoriald-databasecontextfunctionscript

310 import: commontest

316 import: commontest

311 type: exitcode-stdio-1.0

317 type: exitcode-stdio-1.0

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

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

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

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

314

320

315Test-Suite test-relation

321Test-Suite test-relation

316 import: commontest

322 import: commontest

317 type: exitcode-stdio-1.0

323 type: exitcode-stdio-1.0

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

324+ main-is: Relation/Basic.hs

319

325

320Test-Suite test-static-optimizer

326Test-Suite test-static-optimizer

321 import: commontest

327 import: commontest

322 type: exitcode-stdio-1.0

328 type: exitcode-stdio-1.0

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

329+ main-is: Relation/StaticOptimizer.hs

324

330

325Test-Suite test-transactiongraph-persist

331Test-Suite test-transactiongraph-persist

326 import: commontest

332 import: commontest

327 type: exitcode-stdio-1.0

333 type: exitcode-stdio-1.0

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

334+ main-is: TransactionGraph/Persist.hs

329 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

330

336

331Test-Suite test-relation-import-csv

337Test-Suite test-relation-import-csv

332 import: commontest

338 import: commontest

333 type: exitcode-stdio-1.0

339 type: exitcode-stdio-1.0

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

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

335

341

336Test-Suite test-tutoriald-import-tutoriald

342Test-Suite test-tutoriald-import-tutoriald

337 import: commontest

343 import: commontest

338 type: exitcode-stdio-1.0

344 type: exitcode-stdio-1.0

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

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

340 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

341

347

342Test-Suite test-relation-export-csv

348Test-Suite test-relation-export-csv

343 import: commontest

349 import: commontest

344 type: exitcode-stdio-1.0

350 type: exitcode-stdio-1.0

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

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

346

352

347Test-Suite test-transactiongraph-merge

353Test-Suite test-transactiongraph-merge

348 import: commontest

354 import: commontest

349 type: exitcode-stdio-1.0

355 type: exitcode-stdio-1.0

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

356+ main-is: TransactionGraph/Merge.hs

351

357

352

358

353Test-Suite test-prettyprinter

359Test-Suite test-prettyprinter

354 import: commontest

360 import: commontest

355 type: exitcode-stdio-1.0

361 type: exitcode-stdio-1.0

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

362+ main-is: TutorialD/PrinterTest.hs

357 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

358

364

359benchmark bench

365benchmark bench

@@ -364,41 +370,48 @@ benchmark bench

364Test-Suite test-server

370Test-Suite test-server

365 import: commontest

371 import: commontest

366 type: exitcode-stdio-1.0

372 type: exitcode-stdio-1.0

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

373+ main-is: Server/Main.hs

368

374

369

375

370Executable Example-SimpleClient

376Executable Example-SimpleClient

371 Default-Language: Haskell2010

377 Default-Language: Haskell2010

372 Default-Extensions: OverloadedStrings

378 Default-Extensions: OverloadedStrings

373− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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, ghc, ghc-paths, project-m36, random, MonadRandom

379+ 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, ghc, ghc-paths, project-m36, random, MonadRandom

374 Main-Is: examples/SimpleClient.hs

380 Main-Is: examples/SimpleClient.hs

375 GHC-Options: -Wall -threaded

381 GHC-Options: -Wall -threaded

376

382

377Executable Example-OutOfTheTarpit

383Executable Example-OutOfTheTarpit

378 Default-Language: Haskell2010

384 Default-Language: Haskell2010

379 Default-Extensions: OverloadedStrings

385 Default-Extensions: OverloadedStrings

380− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery

386+ 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, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery

381 Main-Is: examples/out_of_the_tarpit.hs

387 Main-Is: examples/out_of_the_tarpit.hs

382 GHC-Options: -Wall -threaded

388 GHC-Options: -Wall -threaded

383

389

384Executable Example-Blog

390Executable Example-Blog

385 Default-Language: Haskell2010

391 Default-Language: Haskell2010

386 Default-Extensions: OverloadedStrings

392 Default-Extensions: OverloadedStrings

387− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty, blaze-html, http-types, winery

393+ 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, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty, blaze-html, http-types, winery

388 Main-Is: examples/blog.hs

394 Main-Is: examples/blog.hs

389 GHC-Options: -Wall -threaded

395 GHC-Options: -Wall -threaded

390

396

391Executable Example-Hair

397Executable Example-Hair

392 Default-Language: Haskell2010

398 Default-Language: Haskell2010

393 Default-Extensions: OverloadedStrings

399 Default-Extensions: OverloadedStrings

394− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery

400+ 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, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery

395 Main-Is: examples/hair.hs

401 Main-Is: examples/hair.hs

396 GHC-Options: -Wall -threaded

402 GHC-Options: -Wall -threaded

397

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+

398Executable Example-CustomTupleable

411Executable Example-CustomTupleable

399 Default-Language: Haskell2010

412 Default-Language: Haskell2010

400 Default-Extensions: OverloadedStrings

413 Default-Extensions: OverloadedStrings

401− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery

414+ 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, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery

402 Main-Is: examples/CustomTupleable.hs

415 Main-Is: examples/CustomTupleable.hs

403 GHC-Options: -Wall -threaded

416 GHC-Options: -Wall -threaded

404

417

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

415Test-Suite test-scripts

428Test-Suite test-scripts

416 import: commontest

429 import: commontest

417 type: exitcode-stdio-1.0

430 type: exitcode-stdio-1.0

418− main-is: test/scripts.hs

431+ main-is: scripts.hs

419 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

420

433

421Executable project-m36-websocket-server

434Executable project-m36-websocket-server

422 Default-Language: Haskell2010

435 Default-Language: Haskell2010

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

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

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

425 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

426 GHC-Options: -Wall -threaded

439 GHC-Options: -Wall -threaded

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

430Test-Suite test-websocket-server

443Test-Suite test-websocket-server

431 import: commontest

444 import: commontest

432 type: exitcode-stdio-1.0

445 type: exitcode-stdio-1.0

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

446+ main-is: Server/WebSocket.hs

434 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

435

448

436Test-Suite test-isomorphic-schemas

449Test-Suite test-isomorphic-schemas

437 import: commontest

450 import: commontest

438 type: exitcode-stdio-1.0

451 type: exitcode-stdio-1.0

439− main-is: test/IsomorphicSchema.hs

452+ main-is: IsomorphicSchema.hs

440

453

441Test-Suite test-atomable

454Test-Suite test-atomable

442 import: commontest

455 import: commontest

443 type: exitcode-stdio-1.0

456 type: exitcode-stdio-1.0

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

457+ main-is: Relation/Atomable.hs

445 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

446

459

447Test-Suite test-multiprocess-access

460Test-Suite test-multiprocess-access

448 import: commontest

461 import: commontest

449 type: exitcode-stdio-1.0

462 type: exitcode-stdio-1.0

450− main-is: test/MultiProcessDatabaseAccess.hs

463+ main-is: MultiProcessDatabaseAccess.hs

451

464

452Test-Suite test-transactiongraph-automerge

465Test-Suite test-transactiongraph-automerge

453 import: commontest

466 import: commontest

454 type: exitcode-stdio-1.0

467 type: exitcode-stdio-1.0

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

468+ main-is: TransactionGraph/Automerge.hs

456 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

457

470

458Test-Suite test-tupleable

471Test-Suite test-tupleable

459 import: commontest

472 import: commontest

460 type: exitcode-stdio-1.0

473 type: exitcode-stdio-1.0

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

474+ main-is: Relation/Tupleable.hs

462

475

463Test-Suite test-client-simple

476Test-Suite test-client-simple

464 import: commontest

477 import: commontest

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

478+ Main-Is: Client/Simple.hs

466 type: exitcode-stdio-1.0

479 type: exitcode-stdio-1.0

467

480

468-- test for file handle leaks

481-- test for file handle leaks

469Executable handles

482Executable handles

470 Default-Language: Haskell2010

483 Default-Language: Haskell2010

471 Default-Extensions: OverloadedStrings

484 Default-Extensions: OverloadedStrings

472− Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, 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

473 main-is: benchmark/Handles.hs

486 main-is: benchmark/Handles.hs

474 Other-Modules: TutorialD.Interpreter,

487 Other-Modules: TutorialD.Interpreter,

475 TutorialD.Interpreter.Base,

488 TutorialD.Interpreter.Base,

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

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

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

494 if flag(profiler)

507 if flag(profiler)

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

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

496−

509+

497Test-Suite test-dataframe

510Test-Suite test-dataframe

498 import: commontest

511 import: commontest

499 type: exitcode-stdio-1.0

512 type: exitcode-stdio-1.0

500− Main-Is: test/DataFrame.hs

513+ Main-Is: DataFrame.hs

501 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+12−10

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

@@ -297,16 +297,18 @@ connectProjectM36 (RemoteConnectionInfo dbName hostName servicePort notification

297 \(NotificationMessage notifications') ->

298 forM_ (M.toList notifications') (uncurry notificationCallback)

299 ]

300−-- TODO missing async callback

300+ let connectExcHandler (e :: IOException) = pure $ Left (IOExceptionError e)

301− conn <- RPC.connect notificationHandlers (hostAddressToTuple addr) port

301+ eConn <- (Right <$> RPC.connect notificationHandlers (hostAddressToTuple addr) port) `catch` connectExcHandler

302+ case eConn of

303+ Left err -> pure (Left err)

304+ Right conn -> do

302− eRet <- RPC.call conn (Login dbName)

305+ eRet <- RPC.call conn (Login dbName)

303−-- TODO handle connection errors

304− case eRet of

306+ case eRet of

305− Left err -> error (show err)

307+ Left err -> error (show err)

306− Right False -> error "wtf"

308+ Right False -> error "wtf"

307− Right True ->

309+ Right True ->

308 --TODO handle connection errors!

310 --TODO handle connection errors!

309− pure (Right (RemoteConnection (RemoteConnectionConf conn)))

311+ pure (Right (RemoteConnection (RemoteConnectionConf conn)))

310

312

311--convert RPC errors into exceptions

313--convert RPC errors into exceptions

312convertRPCErrors :: RPC.ConnectionError -> IO a

314convertRPCErrors :: RPC.ConnectionError -> IO a

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+61−304

@@ -1,6 +1,7 @@

1{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE OverloadedStrings #-}

4module ProjectM36.RelationalExpression where

5module ProjectM36.RelationalExpression where

5import ProjectM36.Relation

6import ProjectM36.Relation

6import ProjectM36.Tuple

7import ProjectM36.Tuple

@@ -41,14 +42,13 @@ import ProjectM36.NormalizeExpr

41import ProjectM36.WithNameExpr

42import ProjectM36.WithNameExpr

42import Test.QuickCheck

43import Test.QuickCheck

43import qualified Data.Functor.Foldable as Fold

44import qualified Data.Functor.Foldable as Fold

45+import Control.Applicative

44#ifdef PM36_HASKELL_SCRIPTING

46#ifdef PM36_HASKELL_SCRIPTING

45import GHC hiding (getContext)

47import GHC hiding (getContext)

46import Control.Exception

48import Control.Exception

47import GHC.Paths

49import GHC.Paths

48#endif

50#endif

49

51

50−--import Debug.Trace

51−

52data DatabaseContextExprDetails = CountUpdatedTuples

53

54databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc

@@ -110,11 +110,11 @@ askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv

110askEnv = R.ask

111

112mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv

113−mergeTuplesIntoGraphRefRelationalExprEnv tupIn e =

113+mergeTuplesIntoGraphRefRelationalExprEnv tupIn env =

114− e{ gre_extra = new_elems }

114+ env { gre_extra = new_elems }

115 where

116 new_elems = Just (Left newTuple)

117− mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple e))

117+ mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple env))

118 newTuple = mkRelationTupleFromMap mergedTupMap

119

120mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv

@@ -212,160 +212,6 @@ envContext = re_context

212setEnvContext :: RelationalExprEnv -> DatabaseContext -> RelationalExprEnv

213setEnvContext e ctx = e { re_context = ctx }

214

215−{-

216−--full evaluation down the graph

217−eval :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)

218−eval expr = do

219− env <- askEnv

220− eGfExpr <- processRelationalExpr expr

221− case eGfExpr of

222− Left err -> pure (Left err)

223− Right gfExpr -> pure $ evalGraphRefRelationalExpr gfExpr (re_graph env)

224−-}

225−{-

226−--relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values

227−evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError GraphRefRelationalExpr)

228−evalRelationalExpr (RelationVariable name _) = do

229− relvarTable <- fmap (relationVariables . envContext) askEnv

230− return $ case M.lookup name relvarTable of

231− Just res -> Right res

232− Nothing -> Left $ RelVarNotDefinedError name

233−

234−evalRelationalExpr (Project attrNames expr) = do

235− eAttrNameSet <- evalAttributeNames attrNames expr

236− case eAttrNameSet of

237− Left err -> pure (Left err)

238− Right attrNameSet -> do

239− rel <- evalRelationalExpr expr

240− case rel of

241− Right rel2 -> pure $ Right (Project (AttributeNames attrNameSet) rel2)

242− Left err -> pure $ Left err

243−

244−evalRelationalExpr (Union exprA exprB) = do

245− relA <- evalRelationalExpr exprA

246− relB <- evalRelationalExpr exprB

247− case relA of

248− Left err -> return $ Left err

249− Right relA2 -> case relB of

250− Left err -> return $ Left err

251− Right relB2 -> return $ Right (Union relA2 relB2)

252−

253−evalRelationalExpr (Join exprA exprB) = do

254− relA <- evalRelationalExpr exprA

255− relB <- evalRelationalExpr exprB

256− case relA of

257− Left err -> return $ Left err

258− Right relA2 -> case relB of

259− Left err -> return $ Left err

260− Right relB2 -> return $ Right (Join relA2 relB2)

261−

262−evalRelationalExpr (Difference exprA exprB) = do

263− relA <- evalRelationalExpr exprA

264− relB <- evalRelationalExpr exprB

265− case relA of

266− Left err -> return $ Left err

267− Right relA2 -> case relB of

268− Left err -> return $ Left err

269− Right relB2 -> return $ Right (Difference relA2 relB2)

270−

271−evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) =

272− case mkRelation attributeSet tupleSet of

273− Right rel -> return $ Right (ExistingRelation rel)

274− Left err -> return $ Left err

275−

276−evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

277− currentContext <- fmap envContext askEnv

278− let tConss = typeConstructorMapping currentContext

279− -- if the mAttrExprs is Nothing, then we should attempt to infer the tuple attributes from the first tuple itself- note that this is not always possible

280− runExceptT $ do

281− mAttrs <- case mAttrExprs of

282− Just _ ->

283− Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)

284− Nothing -> pure Nothing

285− tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs

286− let attrs = fromMaybe firstTupleAttrs mAttrs

287− firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)

288− expr <- either throwE pure (mkRelation attrs (RelationTupleSet tuples))

289− pure (ExistingRelation expr)

290−

291−evalRelationalExpr (ExistingRelation rel) = pure (Right (ExistingRelation rel))

292−

293−evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do

294− evald <- evalRelationalExpr relExpr

295− case evald of

296− Right expr -> return $ Right (Rename oldAttrName newAttrName expr)

297− Left err -> return $ Left err

298−

299−evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do

300− eOldAttrNameSet <- evalAttributeNames oldAttrNames relExpr

301− case eOldAttrNameSet of

302− Left err -> pure (Left err)

303− Right oldAttrNameSet -> do

304− evald <- evalRelationalExpr relExpr

305− case evald of

306− Right expr -> return $ Right (Group (AttributeNames oldAttrNameSet) newAttrName expr)

307− Left err -> return $ Left err

308−

309−evalRelationalExpr (Ungroup attrName relExpr) = do

310− evald <- evalRelationalExpr relExpr

311− case evald of

312− Right expr -> return $ Right (Ungroup attrName expr)

313− Left err -> return $ Left err

314−

315−evalRelationalExpr (Restrict predicateExpr relExpr) = do

316− evald <- evalRelationalExpr relExpr

317− pred <- processRestrictionPredicateExpr predicateExpr

318− case evald of

319− Left err -> return $ Left err

320− Right expr ->

321− pure $ Right (Restrict pred expr)

322−

323−evalRelationalExpr (Equals relExprA relExprB) = do

324− evaldA <- evalRelationalExpr relExprA

325− evaldB <- evalRelationalExpr relExprB

326− case evaldA of

327− Left err -> return $ Left err

328− Right exprA -> case evaldB of

329− Left err -> return $ Left err

330− Right exprB -> return $ Right (Equals exprA exprB)

331−{-

332−evalRelationalExpr (With views mainExpr) = do

333− rstate <- ask

334−

335− let addScopedView ctx (vname,vexpr) = if vname `M.member` relationVariables ctx then

336− Left (RelVarAlreadyDefinedError vname)

337− else

338− case runState (evalDatabaseContextExpr (Assign vname vexpr)) (freshDatabaseState ctx) of

339− (Left err,_) -> Left err

340− (Right (), (ctx',_,_)) -> Right ctx'

341−

342− case foldM addScopedView (stateElemsContext rstate) views of

343− Left err -> return $ Left err

344− Right ctx'' -> do

345− let evalMainExpr expr = runReader (evalRelationalExpr expr) (RelationalExprEnv ctx'')

346− case evalMainExpr mainExpr of

347− Left err -> return $ Left err

348− Right rel -> return $ Right rel

349−-}

350−--warning: copy-pasta from above- refactor

351−evalRelationalExpr (NotEquals relExprA relExprB) = do

352− evaldA <- evalRelationalExpr relExprA

353− evaldB <- evalRelationalExpr relExprB

354− case evaldA of

355− Left err -> return $ Left err

356− Right exprA -> case evaldB of

357− Left err -> return $ Left err

358− Right exprB -> return $ Right (NotEquals exprA exprB)

359−

360−-- extending a relation adds a single attribute with the results of the per-tuple expression evaluated

361−evalRelationalExpr (Extend tupleExpression relExpr) = do

362− eExpr <- evalRelationalExpr relExpr

363− case eExpr of

364− Left err -> pure (Left err)

365− Right expr -> do

366− tupProc <- processExtendTupleExpr tupleExpression

367− pure (Right (Extend tupProc expr))

368−-}

369--helper function to process relation variable creation/assignment

215--helper function to process relation variable creation/assignment

370setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()

216setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()

371setRelVar relVarName relExpr = do

217setRelVar relVarName relExpr = do

@@ -453,20 +299,36 @@ evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do

453

299

454evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do

300evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do

455 gfExpr <- relVarByName relVarName

301 gfExpr <- relVarByName relVarName

456− let optExpr = applyStaticUnionCollapse (Union

302+ let optExpr = applyUnionCollapse (Union

457− gfExpr

458− relExpr)

303+ relExpr

304+ gfExpr)

459 evalGraphRefDatabaseContextExpr (Assign relVarName optExpr)

305 evalGraphRefDatabaseContextExpr (Assign relVarName optExpr)

460

306

461evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do

307evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do

462 gfExpr <- relVarByName relVarName

308 gfExpr <- relVarByName relVarName

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

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

310+ setRelVar relVarName optExpr

464

311

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

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

466evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

313evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do

467 rvExpr <- relVarByName relVarName

314 rvExpr <- relVarByName relVarName

315+ graph <- re_graph <$> dbcRelationalExprEnv

316+ context <- getStateContext

317+ let reEnv = freshGraphRefRelationalExprEnv (Just context) graph

318+ --get the current attributes name in the relvar to ensure that we don't conflict when renaming

319+ eExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr rvExpr)

320+ exprType' <- case eExprType of

321+ Left err -> throwError err

322+ Right t -> pure t

468 let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr

323 let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr

469− tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict

324+ tmpAttr = tmpAttrC 1

325+ tmpAttrC :: Int -> AttributeName -> AttributeName

326+ tmpAttrC c attr =

327+ let tmpAttrName = "_tmp_" <> T.pack (show c) <> attr in

328+ if tmpAttrName `S.member` A.attributeNameSet (attributes exprType') then

329+ tmpAttrC (c+1) attr

330+ else

331+ tmpAttrName

470 updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)

332 updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)

471 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)

333 projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)

472 restrictedPortion = Restrict pred' rvExpr

334 restrictedPortion = Restrict pred' rvExpr

@@ -780,18 +642,6 @@ evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs

780 Left err -> pure (Left err)

642 Left err -> pure (Left err)

781 Right dbstate' -> putDBCIOContext (dbc_context dbstate')

643 Right dbstate' -> putDBCIOContext (dbc_context dbstate')

782

644

783−{-

784−updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> TransactionGraph -> RelationTuple -> Either RelationalError RelationTuple

785−updateTupleWithAtomExprs exprMap context graph tupIn = do

786− --resolve all atom exprs

787− let

788− atomsAssoc <- mapM (\(attrName, atomExpr) -> do

789− let atom = unimplemented

790− --atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)

791− pure (attrName, atom)

792− ) (M.toList exprMap)

793− pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)

794−-}

795--run verification on all constraints

645--run verification on all constraints

796checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()

646checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()

797checkConstraints context transId graph@(TransactionGraph graphHeads transSet) = do

647checkConstraints context transId graph@(TransactionGraph graphHeads transSet) = do

@@ -843,15 +693,6 @@ typeForRelationalExpr expr = do

843 runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

693 runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)

844 lift $ except runGf

694 lift $ except runGf

845

695

846−--returns a database context with all tuples removed

847−--this is useful for type checking and optimization

848−{-

849−contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext

850−contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }

851− where

852− relVars = M.map (\rel -> ExistingRelation (Relation (attributes rel) emptyTupleSet)) (relationVariables contextIn)

853−-}

854−

855liftE :: (Monad m) => m (Either a b) -> ExceptT a m b

696liftE :: (Monad m) => m (Either a b) -> ExceptT a m b

856liftE v = do

697liftE v = do

857 y <- lift v

698 y <- lift v

@@ -1007,58 +848,6 @@ evalGraphRefAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs _) = do

1007 mapM (evalGraphRefAtomExpr tupIn) dConsArgs

848 mapM (evalGraphRefAtomExpr tupIn) dConsArgs

1008 pure (ConstructedAtom dConsName aType argAtoms)

849 pure (ConstructedAtom dConsName aType argAtoms)

1009

850

1010−{-

1011−evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprM Atom

1012−evalAtomExpr tupIn expr =

1013− -}

1014−{-

1015−

1016−evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of

1017− Right atom -> pure (Right atom)

1018− err@(Left (NoSuchAttributeNamesError _)) -> do

1019− rstate <- ask

1020− let stateTup = stateTuple rstate

1021− pure (atomForAttributeName attrName stateTup)

1022− Left err -> pure (Left err)

1023−evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)

1024−evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do

1025− argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn)) arguments

1026− context <- fmap stateElemsContext ask

1027− runExceptT $ do

1028− let functions = atomFunctions context

1029− func <- either throwE pure (atomFunctionForName funcName functions)

1030− let expectedArgCount = length (atomFuncType func) - 1

1031− actualArgCount = length argTypes

1032− safeInit [] = [] -- different behavior from normal init

1033− safeInit xs = init xs

1034− if expectedArgCount /= actualArgCount then

1035− throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)

1036− else do

1037− let zippedArgs = zip (safeInit (atomFuncType func)) argTypes

1038− mapM_ (\(expType, eActType) -> do

1039− actType <- either throwE pure eActType

1040− either throwE pure (atomTypeVerify expType actType)) zippedArgs

1041− evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments

1042− case evalAtomFunction func evaldArgs of

1043− Left err -> throwE (AtomFunctionUserError err)

1044− Right result -> do

1045− --validate that the result matches the expected type

1046− _ <- either throwE pure (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))

1047− pure result

1048−evalAtomExpr tupIn (RelationAtomExpr relExpr) = do

1049− --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes

1050− rstate <- ask

1051− runExceptT $ do

1052− let newState = mergeTuplesIntoRelationalExprState tupIn rstate

1053− relAtom <- either throwE pure (runReader (evalRelationalExpr relExpr) newState)

1054− pure (RelationAtom relAtom)

1055−evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExceptT $ do

1056− rstate <- lift ask

1057− let newState = mergeTuplesIntoRelationalExprState tupIn rstate

1058− aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)

1059− argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs

1060− pure (ConstructedAtom dConsName aType argAtoms)

1061−-}

1062typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType

851typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType

1063typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do

852typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do

1064 renv <- askEnv

853 renv <- askEnv

@@ -1125,7 +914,7 @@ verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs tid) e

1125 let handler :: RelationalError -> GraphRefRelationalExprM AtomType

914 let handler :: RelationalError -> GraphRefRelationalExprM AtomType

1126 handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName argCount expSubType actSubType)

915 handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName argCount expSubType actSubType)

1127 handler err = throwError err

916 handler err = throwError err

1128− verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler

917+ verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler

1129 funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]

918 funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]

1130 if length funcArgTypes /= length expectedArgTypes - 1 then

919 if length funcArgTypes /= length expectedArgTypes - 1 then

1131 throwError (AtomTypeCountError funcArgTypes expectedArgTypes)

920 throwError (AtomTypeCountError funcArgTypes expectedArgTypes)

@@ -1228,56 +1017,6 @@ evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do

1228-- _ <- lift $ except (validateTuple tup' tConss)

1017-- _ <- lift $ except (validateTuple tup' tConss)

1229 pure tup'

1018 pure tup'

1230

1019

1231−{-

1232−evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprM (Either RelationalError (S.Set AttributeName))

1233−evalAttributeNames attrNames expr = do

1234− eExprType <- typeForRelationalExpr expr

1235− case eExprType of

1236− Left err -> throwError err

1237− Right exprTyp -> do

1238− let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))

1239− case attrNames of

1240− AttributeNames names ->

1241− case A.projectionAttributesForNames names (attributes exprTyp) of

1242− Left err -> pure (Left err)

1243− Right attrs -> pure (Right (S.fromList (V.toList (A.attributeNames attrs))))

1244−

1245− InvertedAttributeNames names -> do

1246− let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet

1247− if not (S.null nonExistentAttributeNames) then

1248− pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))

1249− else

1250− pure (Right (A.nonMatchingAttributeNameSet names typeNameSet))

1251−

1252− UnionAttributeNames namesA namesB -> do

1253− eNameSetA <- evalAttributeNames namesA expr

1254− case eNameSetA of

1255− Left err -> pure (Left err)

1256− Right nameSetA -> do

1257− eNameSetB <- evalAttributeNames namesB expr

1258− case eNameSetB of

1259− Left err -> pure (Left err)

1260− Right nameSetB ->

1261− pure (Right (S.union nameSetA nameSetB))

1262−

1263− IntersectAttributeNames namesA namesB -> do

1264− eNameSetA <- evalAttributeNames namesA expr

1265− case eNameSetA of

1266− Left err -> pure (Left err)

1267− Right nameSetA -> do

1268− eNameSetB <- evalAttributeNames namesB expr

1269− case eNameSetB of

1270− Left err -> pure (Left err)

1271− Right nameSetB ->

1272− pure (Right (S.intersection nameSetA nameSetB))

1273−

1274− RelationalExprAttributeNames attrExpr -> do

1275− eAttrExprType <- typeForRelationalExpr attrExpr

1276− case eAttrExprType of

1277− Left err -> pure (Left err)

1278− Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))

1279−-}

1280−

1281--temporary implementation until we have a proper planner+executor

1020--temporary implementation until we have a proper planner+executor

1282evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation

1021evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation

1283evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

1022evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do

@@ -1526,15 +1265,6 @@ evalRelationalExpr expr = do

1526 Left err -> throwError err

1265 Left err -> throwError err

1527 Right rel -> pure rel

1266 Right rel -> pure rel

1528

1267

1529−{-

1530−relVarByName :: RelVarName -> GraphRefRelationalExprM GraphRefRelationalExpr

1531−relVarByName = do

1532− relvars <- relationVariables <$> getStateContext

1533− case M.lookup relVarName relvars of

1534− Nothing -> dbErr (RelVarNotDefinedError relVarName)

1535− Just gfexpr -> pure gfExpr

1536−-}

1537−

1538class (MonadError RelationalError m, Monad m) => DatabaseContextM m where

1268class (MonadError RelationalError m, Monad m) => DatabaseContextM m where

1539 getContext :: m DatabaseContext

1269 getContext :: m DatabaseContext

1540

1270

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

1623--convert series of simple Union queries into MakeStaticRelation

1353--convert series of simple Union queries into MakeStaticRelation

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

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

1626−applyStaticUnionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr

1359+applyUnionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr

1627−applyStaticUnionCollapse = Fold.cata opt

1360+applyUnionCollapse = Fold.cata opt

1628 where

1361 where

1362+ opt :: RelationalExprBaseF GraphRefTransactionMarker GraphRefRelationalExpr -> GraphRefRelationalExpr

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

1629 opt (UnionF

1364 opt (UnionF

1630− a@(MakeStaticRelation attrsA tupsA)

1365+ exprA@(MakeRelationFromExprs mAttrs1 tupExprs1)

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

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

1632− MakeStaticRelation attrsA (tupleSetUnion attrsA tupsA tupsB)

1367+ | tupExprsNull tupExprs1 = exprB

1633− else

1368+ | tupExprsNull tupExprs2 = exprA

1634− Union a b

1635 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/Base.hs+3−4

@@ -10,10 +10,10 @@ import ProjectM36.MerkleHash

10import Data.UUID

11import Data.Proxy

12import Data.Word

13+import ProjectM36.Attribute as A

13import qualified Data.List.NonEmpty as NE

14import qualified Data.List.NonEmpty as NE

14import qualified Data.Vector as V

15import qualified Data.Vector as V

15import Data.Time.Calendar (Day,toGregorian,fromGregorian)

16import Data.Time.Calendar (Day,toGregorian,fromGregorian)

16−import qualified Data.HashSet as HS

17

18deriving via WineryVariant Atom instance Serialise Atom

19deriving via WineryVariant AtomType instance Serialise AtomType

@@ -77,10 +77,9 @@ instance Serialise Attributes where

77 schemaGen _ = SVector <$> getSchema (Proxy @Attribute)

78 toBuilder attrs = varInt (V.length (attributesVec attrs)) <> foldMap toBuilder (V.toList (attributesVec attrs))

79 extractor =

80− let mkAttrs x = Attributes x (HS.fromList (V.toList x)) in

81− mkAttrs <$> extractListBy extractor

80+ attributesFromList . V.toList <$> extractListBy extractor

82

81

83 decodeCurrent = do

82 decodeCurrent = do

84 n <- decodeVarInt

83 n <- decodeVarInt

85 l <- replicateM n decodeCurrent

84 l <- replicateM n decodeCurrent

86− pure (Attributes (V.fromList l) (HS.fromList l))

85+ pure (A.attributesFromList l)

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+10−4

@@ -23,8 +23,6 @@ import System.FilePath

23import System.Directory

24#endif

25

26−import Debug.Trace

27−

28type Timeout = Int

26type Timeout = Int

29

27

30testList :: SessionId -> Connection -> MVar () -> Test

28testList :: SessionId -> Connection -> MVar () -> Test

@@ -44,7 +42,7 @@ testList sessionId conn notificationTestMVar = TestList $ serverTests ++ session

44 testRelationVariableSummary,

42 testRelationVariableSummary,

45 testNotification notificationTestMVar

43 testNotification notificationTestMVar

46 ]

44 ]

47− serverTests = [testRequestTimeout, testFileDescriptorCount]

45+ serverTests = [testRequestTimeout, testFileDescriptorCount, testClientConnectFail]

48

46

49main :: IO ()

47main :: IO ()

50main = do

48main = do

@@ -209,7 +207,7 @@ testRequestTimeout = TestCase $ do

209 case eTestConn of

207 case eTestConn of

210 Left err -> putStrLn ("failed to connect: " ++ show err) >> exitFailure

208 Left err -> putStrLn ("failed to connect: " ++ show err) >> exitFailure

211 Right (session, testConn) -> do

209 Right (session, testConn) -> do

212− res <- catchJust (\exc -> if traceShowId exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))

210+ res <- catchJust (\exc -> if exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))

213 assertBool "timeout exception was not thrown" (not res)

211 assertBool "timeout exception was not thrown" (not res)

214 killThread serverTid

212 killThread serverTid

215

213

@@ -240,3 +238,11 @@ fdCount = do

240--pass on non-linux platforms

238--pass on non-linux platforms

241testFileDescriptorCount = TestCase (pure ())

239testFileDescriptorCount = TestCase (pure ())

242#endif

240#endif

241+

242+testClientConnectFail :: Test

243+testClientConnectFail = TestCase $ do

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

245+ eConn <- connectProjectM36 connInfo

246+ case eConn of

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

248+ _ -> assertFailure "connection failure failed"

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