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 1 commit
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
32 changes: 32 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,18 @@ Head name terms |- body =

infixl 0 |-

(||-)
:: forall a k prog. (GenVars (Structure a), ToFun (MapType (Term 'Relation) (Structure a)) (Body 'Relation ()) k)
=> Predicate a
-> k
-> DSL prog 'Definition ()
(Predicate h) ||- f = h vars |- applyFun (Proxy @(MapType (Term 'Relation) (Structure a))) f vars
where
vars :: Tuple 'Relation (Structure a)
vars = genVars (Proxy @(Structure a))

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 +1005,24 @@ 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 (ts :: [Type]) where
genVars :: Proxy ts -> Tuple 'Relation ts

varI :: Int -> Term 'Relation a
varI i = VarTerm $ "x" <> T.pack (show i)

instance GenVars '[t] where
genVars _ = varI 0

instance GenVars '[t1, t2] where
genVars _ = (varI 0, varI 1)

Copy link
Author

Choose a reason for hiding this comment

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

This sucks big-time. It should be an inductive definition, instead of requiring separate instances for each tuple length. Also, it should run in one of your variable number-tracking monads, but I decided that life's too short to worry about that for this illustration.

Copy link
Owner

Choose a reason for hiding this comment

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

Yes, tuples are really annoying to work with in Haskell :( main reason I used them is to keep the syntax the same as in Datalog. For now I limited it to 10 instances which is kinda "meh", but it gets the job done.

If you know a better way of handling raw tuples in combination with typeclasses, let me know!

Copy link
Author

Choose a reason for hiding this comment

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

Well the straightforward way would be to use an HList-like product type indexed by its coordinates, through and through, but then you have to use x :> y :> Nil instead of (x, y).

You could carry a list of types everywhere, and convert to a Haskell tuple at the last minute, but that becomes unwieldy on the way back I think -- because of one-tuples, you can't easily have a bijection between Product ts and (t1, ..., tn) :( And if you only want to do the conversion where you do know the ts ,that means you would need a special apply operator instead of . If you are willing to do that, I think you can get both

foo |- \x y -> ...

and

... foo |$| (x, y) ...

class ToFun (ts :: [Type]) r k | ts r -> k where
applyFun :: Proxy ts -> k -> TupleOf ts -> r

instance ToFun '[] r r
instance (ToFun ts r k) => ToFun (t:ts) r (t -> k)

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

Expand Down
7 changes: 3 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 @@ -235,10 +235,9 @@ spec = describe "Souffle DSL" $ parallel $ do
it "can render a relation with a single rule" $ 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'@(Predicate reachable) <- predicateFor @Reachable
reachable' ||- \ a b -> edge(a, b)
reachable' ||- \ a b -> reachable(a, b)
prog ==> [text|
.decl edge(t1: symbol, t2: symbol)
.input edge
Expand Down