Initial commit, we have a basic UI that lets you edit a toy-datalog program and conjunctive query and see results live.

.gitignore

@@ -0,0 +1,16 @@
+.attr-cache
+.cabal-sandbox
+*.hi
+*.o
+cabal.project.local
+cabal.sandbox.config
+ctags
+dist-newstyle/
+dist/
+ghcid-output.txt
+profile/
+result
+result-*
+tags
+TAGS
+static.out

.obelisk/impl/default.nix

@@ -0,0 +1,2 @@
+# DO NOT HAND-EDIT THIS FILE
+import (import ./thunk.nix)

.obelisk/impl/github.json

@@ -0,0 +1,8 @@
+{
+  "owner": "obsidiansystems",
+  "repo": "obelisk",
+  "branch": "develop",
+  "private": false,
+  "rev": "c0767818c990f081796cfb4017c5931d75fa4803",
+  "sha256": "0v16c1z09llramddq09ra8psh1mxxp7yvh62df84d1qq6qcgkmny"
+}

.obelisk/impl/thunk.nix

@@ -0,0 +1,12 @@
+# DO NOT HAND-EDIT THIS FILE
+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
+  if !fetchSubmodules && !private then builtins.fetchTarball {
+    url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
+  } else (import (builtins.fetchTarball {
+  url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
+  sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
+}) {}).fetchFromGitHub {
+    inherit owner repo rev sha256 fetchSubmodules private;
+  };
+  json = builtins.fromJSON (builtins.readFile ./github.json);
+in fetch json

backend/backend.cabal

@@ -0,0 +1,43 @@
+name: backend
+version: 0.1
+cabal-version: >= 1.8
+build-type: Simple
+
+library
+  hs-source-dirs: src
+  if impl(ghcjs)
+    buildable: False
+  build-depends: base
+               , common
+               , frontend
+               , obelisk-backend
+               , obelisk-route
+  exposed-modules:
+    Backend
+  ghc-options: -Wall -O -fno-show-valid-hole-fits
+               -- unsafe code
+               -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields
+               -- unneeded code
+               -Widentities -Wredundant-constraints
+  if impl(ghc >= 8.8)
+    ghc-options:
+               -Wmissing-deriving-strategies
+
+executable backend
+  main-is: main.hs
+  hs-source-dirs: src-bin
+  ghc-options: -Wall -O -fno-show-valid-hole-fits -threaded
+               -- unsafe code
+               -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields
+               -- unneeded code
+               -Widentities -Wredundant-constraints
+  if impl(ghc >= 8.8)
+    ghc-options:
+               -Wmissing-deriving-strategies
+  if impl(ghcjs)
+    buildable: False
+  build-depends: base
+               , backend
+               , common
+               , frontend
+               , obelisk-backend

backend/frontend.jsexe

@@ -0,0 +1 @@
+../frontend-js/bin/frontend.jsexe

backend/frontendJs/frontend.jsexe

@@ -0,0 +1 @@
+../../frontend-js/bin/frontend.jsexe

backend/src-bin/main.hs

@@ -0,0 +1,6 @@
+import Backend
+import Frontend
+import Obelisk.Backend
+
+main :: IO ()
+main = runBackend backend frontend

backend/src/Backend.hs

@@ -0,0 +1,10 @@
+module Backend where
+
+import Common.Route
+import Obelisk.Backend
+
+backend :: Backend BackendRoute FrontendRoute
+backend = Backend
+  { _backend_run = \serve -> serve $ const $ return ()
+  , _backend_routeEncoder = fullRouteEncoder
+  }

backend/static

@@ -0,0 +1 @@
+../static

cabal.project

@@ -0,0 +1,3 @@
+optional-packages:
+  *
+write-ghc-environment-files: never

common/common.cabal

@@ -0,0 +1,21 @@
+name: common
+version: 0.1
+cabal-version: >= 1.2
+build-type: Simple
+
+library
+  hs-source-dirs: src
+  build-depends: base
+               , obelisk-route
+               , text
+  exposed-modules:
+    Common.Api
+    Common.Route
+  ghc-options: -Wall -O -fno-show-valid-hole-fits
+               -- unsafe code
+               -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields
+               -- unneeded code
+               -Widentities -Wredundant-constraints
+  if impl(ghc >= 8.8)
+    ghc-options:
+               -Wmissing-deriving-strategies

common/src/Common/Api.hs

@@ -0,0 +1,4 @@
+module Common.Api where
+
+commonStuff :: String
+commonStuff = "Here is a string defined in Common.Api"

common/src/Common/Route.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+module Common.Route where
+
+{- -- You will probably want these imports for composing Encoders.
+import Prelude hiding (id, (.))
+import Control.Category
+-}
+
+import Data.Text (Text)
+import Data.Functor.Identity
+
+import Obelisk.Route
+import Obelisk.Route.TH
+
+data BackendRoute :: * -> * where
+  -- | Used to handle unparseable routes.
+  BackendRoute_Missing :: BackendRoute ()
+  -- You can define any routes that will be handled specially by the backend here.
+  -- i.e. These do not serve the frontend, but do something different, such as serving static files.
+
+data FrontendRoute :: * -> * where
+  FrontendRoute_Main :: FrontendRoute ()
+  -- This type is used to define frontend routes, i.e. ones for which the backend will serve the frontend.
+
+fullRouteEncoder
+  :: Encoder (Either Text) Identity (R (FullRoute BackendRoute FrontendRoute)) PageName
+fullRouteEncoder = mkFullRouteEncoder
+  (FullRoute_Backend BackendRoute_Missing :/ ())
+  (\case
+      BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty)
+  (\case
+      FrontendRoute_Main -> PathEnd $ unitEncoder mempty)
+
+concat <$> mapM deriveRouteComponent
+  [ ''BackendRoute
+  , ''FrontendRoute
+  ]

config/common/example

@@ -0,0 +1 @@
+This string comes from config/common/example

config/common/route

@@ -0,0 +1 @@
+http://localhost:8000

config/readme.md

@@ -0,0 +1,9 @@
+### Config
+
+Obelisk projects should contain a config folder with the following subfolders: common, frontend, and backend.
+
+Things that should never be transmitted to the frontend belong in backend/ (e.g., email credentials)
+
+Frontend-only configuration belongs in frontend/.
+
+Shared configuration files (e.g., the route config) belong in common/

default.nix

@@ -0,0 +1,23 @@
+{ system ? builtins.currentSystem
+, obelisk ? import ./.obelisk/impl {
+    inherit system;
+    iosSdkVersion = "16.1";
+
+    # You must accept the Android Software Development Kit License Agreement at
+    # https://developer.android.com/studio/terms in order to build Android apps.
+    # Uncomment and set this to `true` to indicate your acceptance:
+    # config.android_sdk.accept_license = false;
+
+    # In order to use Let's Encrypt for HTTPS deployments you must accept
+    # their terms of service at https://letsencrypt.org/repository/.
+    # Uncomment and set this to `true` to indicate your acceptance:
+    # terms.security.acme.acceptTerms = false;
+  }
+}:
+with obelisk;
+project ./. ({ ... }: {
+  android.applicationId = "systems.obsidian.obelisk.examples.minimal";
+  android.displayName = "Obelisk Minimal Example";
+  ios.bundleIdentifier = "systems.obsidian.obelisk.examples.minimal";
+  ios.bundleName = "Obelisk Minimal Example";
+})

dep/toy-datalog/default.nix

@@ -0,0 +1,2 @@
+# DO NOT HAND-EDIT THIS FILE
+import (import ./thunk.nix)

dep/toy-datalog/git.json

@@ -0,0 +1,8 @@
+{
+  "url": "https://code.obsidian.systems/cale/toy-datalog.git",
+  "rev": "c09e07042b633c64021c10aac0258cc117d289cc",
+  "sha256": "1fl7b5iqk02i97sdpsfpp698mj4gp9hkmzamycv9jacvq7zq1k5y",
+  "private": false,
+  "fetchSubmodules": false,
+  "branch": "master"
+}

dep/toy-datalog/thunk.nix

@@ -0,0 +1,17 @@
+# DO NOT HAND-EDIT THIS FILE
+let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:
+  let realUrl = let firstChar = builtins.substring 0 1 url; in
+    if firstChar == "/" then /. + url
+    else if firstChar == "." then ./. + url
+    else url;
+  in if !fetchSubmodules && private then builtins.fetchGit {
+    url = realUrl; inherit rev;
+    ${if branch == null then null else "ref"} = branch;
+  } else (import (builtins.fetchTarball {
+  url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
+  sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
+}) {}).fetchgit {
+    url = realUrl; inherit rev sha256;
+  };
+  json = builtins.fromJSON (builtins.readFile ./git.json);
+in fetch json

frontend/frontend.cabal

@@ -0,0 +1,60 @@
+name: frontend
+version: 0.1
+cabal-version: >= 1.8
+build-type: Simple
+
+library
+  hs-source-dirs: src
+  build-depends: base
+               , common
+               , jsaddle
+               , lens
+               , obelisk-executable-config-lookup
+               , obelisk-frontend
+               , obelisk-generated-static
+               , obelisk-route
+               , reflex-dom-core
+               , text
+               , toy-datalog
+  exposed-modules:
+    Frontend
+  default-extensions:
+    ImportQualifiedPost,
+    OverloadedStrings,
+    FlexibleContexts
+  ghc-options: -Wall -O -fno-show-valid-hole-fits
+               -- unsafe code
+               -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields
+               -- unneeded code
+               -Widentities -Wredundant-constraints
+  if impl(ghc >= 8.8)
+    ghc-options:
+               -Wmissing-deriving-strategies
+
+executable frontend
+  main-is: main.hs
+  hs-source-dirs: src-bin
+  build-depends: base
+               , common
+               , frontend
+               , obelisk-frontend
+               , obelisk-route
+               , reflex-dom
+               , toy-datalog
+  default-extensions:
+    ImportQualifiedPost,
+    OverloadedStrings,
+    FlexibleContexts
+  ghc-options: -Wall -O -fno-show-valid-hole-fits -threaded
+               -- unsafe code
+               -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields
+               -- unneeded code
+               -Widentities -Wredundant-constraints
+  if impl(ghc >= 8.8)
+    ghc-options:
+               -Wmissing-deriving-strategies
+  if impl(ghcjs)
+    ghc-options: -dedupe
+    cpp-options: -DGHCJS_BROWSER
+  if os(darwin)
+    ghc-options: -dynamic

frontend/src-bin/main.hs

@@ -0,0 +1,10 @@
+import Frontend
+import Common.Route
+import Obelisk.Frontend
+import Obelisk.Route.Frontend
+import Reflex.Dom
+
+main :: IO ()
+main = do
+  let Right validFullEncoder = checkEncoder fullRouteEncoder
+  run $ runFrontend validFullEncoder frontend

frontend/src/Frontend.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Frontend where
+
+import Control.Monad
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import Obelisk.Frontend
+import Obelisk.Route
+import Obelisk.Generated.Static
+
+import Reflex.Dom.Core
+
+import Common.Route
+
+import Datalog
+import Text.Megaparsec qualified as P
+import Data.Map (Map)
+import Data.Map qualified as Map
+
+example :: Text
+example = T.unlines
+  [ "odd(X,Y) :- r(X,Y)."
+  , "odd(X,Y) :- even(X,Z), r(Z,Y)."
+  , "even(X,Y) :- odd(X,Z), r(Z,Y)."
+  , "r(0,1)."
+  , "r(1,2)."
+  , "r(2,3)."
+  , "r(3,4)."
+  , "r(4,5)."
+  , "r(X,Y) :- r(Y,X)."
+  ]
+
+frontend :: Frontend (R FrontendRoute)
+frontend = Frontend
+  { _frontend_head = do
+      el "title" $ text "Toy Datalog"
+      elAttr "script" ("type" =: "application/javascript" <> "src" =: $(static "lib.js")) blank
+      elAttr "link" ("href" =: $(static "main.css") <> "type" =: "text/css" <> "rel" =: "stylesheet") blank
+  , _frontend_body = do
+      el "h1" $ text "Toy Datalog"
+      divClass "main" $ do
+        tp <- divClass "program" $ textAreaElement $ def & textAreaElementConfig_initialValue .~ example
+        tq <- divClass "query" $ inputElement $ def & inputElementConfig_initialValue .~ "even(A,B)"
+        let programD = ffor (value tp) $ \p -> P.parse parseProgram "<program>" p
+            queryD = ffor (value tq) $ \q -> P.parse parseQuery "<query>" q
+        dyn_ . ffor2 programD queryD $ \p q -> case (p,q) of
+          (Left e, _) -> el "pre" $ text $ T.pack (P.errorBundlePretty e)
+          (_, Left e) -> el "pre" $ text $ T.pack (P.errorBundlePretty e)
+          (Right prog, Right query) -> case extendFixedpointDb =<< addProgram prog emptyDatabase of
+            Left e -> evalErrorWidget e
+            Right db -> case evalConjunction db query of
+              Left e -> evalErrorWidget e
+              Right bindings -> divClass "bindings" $ forM_ bindings $ \b -> do
+                bindingWidget b
+      return ()
+  }
+
+evalErrorWidget :: (DomBuilder t m) => EvalError -> m ()
+evalErrorWidget e = divClass "eval-error" . el "pre" . text . T.unlines $ case e of
+  EvalError_RuleWrongArity rule wa ->
+    [ "Arity error in rule:"
+    , pretty rule
+    , "Relation " <> pretty (_wrongArity_relation wa) <> " has arity " <> T.pack (show (_wrongArity_expected wa))
+    , "but appears with arity " <> T.pack (show (_wrongArity_got wa)) <> "."
+    ]
+  EvalError_AtomWrongArity a wa ->
+    [ "Arity error in atom:"
+    , pretty a
+    , "Relation " <> pretty (_wrongArity_relation wa) <> " has arity " <> T.pack (show (_wrongArity_expected wa))
+    , "but appears with arity " <> T.pack (show (_wrongArity_got wa)) <> "."
+    ]
+
+bindingWidget :: (DomBuilder t m) => Map VarId ConId -> m ()
+bindingWidget b = do
+  divClass "binding" $ do
+    if Map.null b
+      then text "True"
+      else
+        el "ul" $ forM_ (Map.toList b) $ \(VarId v, ConId c) ->
+          el "li" $
+            text (v <> " = " <> c)

static/lib.js

@@ -0,0 +1,4 @@
+// Accessing the property via string literal prevents renaming by javascript minifiers which can cause FFI errors
+window['skeleton_lib'] = {
+  log: txt => console.log('Received "' + txt + '" from FFI'),
+};

static/main.css

@@ -0,0 +1,63 @@
+body {
+  background: #220044;
+  color: wheat;
+}
+
+.main {
+  display: flex;
+  flex-direction: column;
+}
+
+.program {
+  display: flex;
+  padding: 10px;
+}
+
+.program textarea {
+  background: #110022;
+  color: wheat;
+  width: 90%;
+  height: 30em;
+  border: solid 1px wheat;
+  border-radius: 5px;
+}
+
+.query {
+  display: flex;
+  padding: 10px;
+}
+
+.query input {
+  background: #110022;
+  color: wheat;
+  width: 90%;
+  border: solid 1px wheat;
+  border-radius: 5px;
+  padding: 5px;
+}
+
+.query input :focus {
+  outline: none;
+}
+
+.bindings {
+  display: flex;
+  flex-direction: row;
+  flex-wrap: wrap;
+  justify-content: flex-start;
+}
+
+.binding {
+  display: flex;
+  flex-direction: column;
+  background: #330055;
+  margin: 10px;
+  padding: 10px;
+  border: solid 1px wheat;
+  border-radius: 10px;
+}
+
+.binding ul {
+  margin: 0px;
+  padding-left: 1em;
+}