Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Proof of concept for higher-order DSL API #36

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
Open

Proof of concept for higher-order DSL API #36

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
c8ab10c
Proof of concept for higher-order DSL API
gergoerdi Jan 14, 2021
3d2c80c
Everything becomes so much simpler if we just don't try to curry
gergoerdi Jan 14, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
22 changes: 22 additions & 0 deletions lib/Language/Souffle/Experimental.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
{-# LANGUAGE UndecidableInstances, UndecidableSuperClasses, FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DerivingVia, ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds, TypeFamilyDependencies #-}
{-# LANGUAGE FunctionalDependencies, TypeApplications #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

{-| This module provides an experimental DSL for generating Souffle Datalog code,
Expand Down Expand Up @@ -92,6 +93,7 @@ module Language.Souffle.Experimental
, __
, underscore
, (|-)
, (||-)
Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Naming is hard, let's go shopping!

I think if this is finished, you can just use |- for the new one, and get rid of the old one everywhere.

, (\/)
, not'
-- ** Souffle operators
Expand Down Expand Up @@ -477,6 +479,17 @@ Head name terms |- body =

infixl 0 |-

(||-)
:: forall args prog. (GenVars args)
=> (forall f. Fragment f 'Relation => args -> f 'Relation ())
-> (args -> Body 'Relation ())
-> DSL prog 'Definition ()
h ||- f = do
vars <- genVars
h vars |- f vars

infixl 0 ||-

-- | A typeclass used for generating AST fragments of Datalog code.
-- The generated fragments can be further glued together using the
-- various functions in this module.
Expand Down Expand Up @@ -991,6 +1004,15 @@ accessorNames _ = case toStrings (Proxy :: Proxy (AccessorNames a)) of
-- Only tuples containing up to 10 elements are currently supported.
type Tuple ctx ts = TupleOf (MapType (Term ctx) ts)

class GenVars a where
genVars :: DSL prog 'Definition a

instance GenVars (Term 'Relation a) where
genVars = var "x"

instance (GenVars a, GenVars b) => GenVars (a, b) where
genVars = (,) <$> genVars <*> genVars

class ToTerms (ts :: [Type]) where
toTerms :: Proxy ctx -> TypeInfo a ts -> Tuple ctx ts -> NonEmpty SimpleTerm

Expand Down
6 changes: 2 additions & 4 deletions tests/Test/Language/Souffle/ExperimentalSpec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -236,9 +236,8 @@ spec = describe "Souffle DSL" $ parallel $ do
let prog = do
Predicate edge <- predicateFor @Edge
Predicate reachable <- predicateFor @Reachable
a <- var "a"
b <- var "b"
reachable(a, b) |- edge(a, b)
reachable ||- \ (a, b) -> edge(a, b)
reachable ||- \ (a, b) -> reachable(a, b)
prog ==> [text|
.decl edge(t1: symbol, t2: symbol)
.input edge
Expand Down Expand Up @@ -1114,4 +1113,3 @@ spec = describe "Souffle DSL" $ parallel $ do
C.run prog
C.getFacts prog
rs `shouldBe` [F.Reachable "b" "c", F.Reachable "a" "c", F.Reachable "a" "b"]