simple POC datalog to relational algebra conversion in haskell

_output

$ ghc Datalog.hs RelAlg.hs main.hs && ./a.out
Just R
Just π[0,2](σ[1=0](R))
Just R x Q
Just π[0,1,2,4](σ[3=2](R x Q))
Just π[0,1](σ[3=0](σ[2=1](Q x Q)))
$ 

Datalog.hs

module Datalog where
import Data.List

type Predicate = String
type Variable = String

data Rule
	= Rule  [Atom]
	deriving (Eq)

instance Show Rule where
	show (Rule as) = intercalate " ∧ " $ map show as

data Atom
	= Atom  Predicate [Variable]
	deriving (Eq)

instance Show Atom where
	show (Atom pred vars) = pred ++ "[" ++ intercalate ", " vars ++ "]"

main.hs

module Main where
import qualified Datalog as D
import qualified RelAlg as RA

import Data.List
import Data.Maybe

--convert :: D.Rule -> Maybe RA.Query
convert (D.Rule []) = Nothing
convert (D.Rule atoms) =
	let products = genProducts $ map (\(D.Atom p _) -> p) atoms
	in case products of
		Nothing -> Nothing
		Just product ->
			let variables = concatMap (\(D.Atom _ vs) -> vs) atoms in
			let associations = genFieldAssociations variables in
			let selection = foldl (\q (a, b) -> RA.Selection (RA.Condition a b) q) product associations in
			if 0 == length associations then Just selection
			else
				let projectedFields = take (length variables) [0..] \\ map fst associations
				in Just $ RA.Projection projectedFields selection

genProducts :: [String] -> Maybe RA.Query
genProducts [] = Nothing
genProducts (pred:[]) = Just $ RA.Predicate pred
genProducts (p:ps) = Just $ foldl (\a b -> RA.Product a $ RA.Predicate b) (RA.Predicate p) ps

genFieldAssociations :: [String] -> [(Int, Int)]
genFieldAssociations = genFieldAssociations' 0 []

genFieldAssociations' :: Int -> [(String, Int)] -> [String] -> [(Int, Int)]
genFieldAssociations' idx assocs [] = []
genFieldAssociations' idx assocs (f:fs) = case lookup f assocs of
	Nothing -> genFieldAssociations' (idx + 1) ((f, idx) : assocs) fs
	Just i -> (idx, i) : genFieldAssociations' (idx + 1) assocs fs


main = do
	putStrLn $ show $ convert $ D.Rule [
		D.Atom "R" ["x", "y", "z"]
		]
	putStrLn $ show $ convert $ D.Rule [
		D.Atom "R" ["x", "x", "z"]
		]
	putStrLn $ show $ convert $ D.Rule [
		D.Atom "R" ["x", "y", "z"],
		D.Atom "Q" ["u", "v"]
		]
	putStrLn $ show $ convert $ D.Rule [
		D.Atom "R" ["x", "y", "z"],
		D.Atom "Q" ["z", "v"]
		]
	putStrLn $ show $ convert $ D.Rule [
		D.Atom "Q" ["x", "y"],
		D.Atom "Q" ["y", "x"]
		]

RelAlg.hs

module RelAlg where
import Data.List
import Data.Char

type FieldIdentifier = Int

data Condition
	= Condition  FieldIdentifier FieldIdentifier
	deriving (Eq)

instance Show Condition where
	show (Condition a b) = show a ++ "=" ++ show b

data Query
	= Product     Query Query
	| Selection   Condition Query
	| Projection  [FieldIdentifier] Query
	| Predicate   String
	deriving (Eq)

instance Show Query where
	show query = case query of
		Product q0 q1 -> show q0 ++ " x " ++ show q1
		Selection cond q -> "σ[" ++ show cond ++ "](" ++ show q ++ ")"
		Projection fields q -> "π[" ++ intercalate "," (map show fields) ++ "](" ++ show q ++ ")"
		Predicate pred -> (toUpper.head $ pred) : tail pred