67 lines
2.4 KiB
Haskell
67 lines
2.4 KiB
Haskell
|
module Datalog.DigestedQuery where
|
||
|
|
|
||
|
|
import Data.Void
|
||
|
|
import Data.Text (Text)
|
||
|
|
import qualified Data.Text as T
|
||
|
|
import Text.Megaparsec
|
||
|
|
import Text.Megaparsec.Char
|
||
|
|
import qualified Text.Megaparsec.Char.Lexer as L
|
||
|
|
import Control.Monad (void)
|
||
|
|
import Data.Functor (($>))
|
||
|
|
import Datalog.DatalogDB (Relation, Constant, DatalogDBException (..))
|
||
|
|
import Datalog.DatalogParser
|
||
|
|
import Control.Exception (throw)
|
||
|
|
import GHC.TypeError (ErrorMessage(Text))
|
||
|
|
import Data.List (nub, elemIndex)
|
||
|
|
|
||
|
|
data DigestedQuery = DigestedQuery {
|
||
|
|
allBoundVariables :: [Text],
|
||
|
|
numSoughtVariables :: Int,
|
||
|
|
conditions :: [DigestedQueryCondition]
|
||
|
|
} deriving (Show, Eq, Ord)
|
||
|
|
|
||
|
|
data DigestedQueryCondition = DigestedQueryCondition {
|
||
|
|
__relation :: Text,
|
||
|
|
_entries :: [DigestedQueryEntry]
|
||
|
|
} deriving (Show, Eq, Ord)
|
||
|
|
|
||
|
|
data DigestedQueryEntry =
|
||
|
|
DigestedQueryEntryConstant Constant |
|
||
|
|
DigestedQueryEntryVariable Int
|
||
|
|
deriving (Show, Eq, Ord)
|
||
|
|
|
||
|
|
digestQuery :: Text -> DigestedQuery
|
||
|
|
digestQuery queryText =
|
||
|
|
case parseDatalog queryText of
|
||
|
|
Right (Query variables literals) -> digestQuerySub variables literals
|
||
|
|
Right statement0 -> throw $ NonQueryException "cannot digest non-query" statement0
|
||
|
|
Left ex -> throw ex
|
||
|
|
|
||
|
|
digestQuerySub :: [Text] -> [Literal] -> DigestedQuery
|
||
|
|
digestQuerySub variables literals =
|
||
|
|
DigestedQuery {
|
||
|
|
allBoundVariables = allBoundVariables,
|
||
|
|
numSoughtVariables =
|
||
|
|
if (null variables) then (length allBoundVariables) else (length variables),
|
||
|
|
conditions = extractCondition <$> literals
|
||
|
|
} where
|
||
|
|
allBoundVariables = nub $ variables ++ extractedVariables
|
||
|
|
extractedVariables :: [Text] =
|
||
|
|
nub $ concatMap extractVariablesSub literals
|
||
|
|
extractVariablesSub :: Literal -> [Text]
|
||
|
|
extractVariablesSub literal =
|
||
|
|
concatMap extractVariablesSubSub (arguments literal)
|
||
|
|
extractVariablesSubSub :: Term -> [Text]
|
||
|
|
extractVariablesSubSub (Var name) = [name]
|
||
|
|
extractVariablesSubSub _ = []
|
||
|
|
extractCondition :: Literal -> DigestedQueryCondition
|
||
|
|
extractCondition literal = DigestedQueryCondition {
|
||
|
|
__relation = predName literal,
|
||
|
|
_entries = extractEntry <$> (arguments literal)
|
||
|
|
}
|
||
|
|
extractEntry :: Term -> DigestedQueryEntry
|
||
|
|
extractEntry (Var varName) = case elemIndex varName allBoundVariables of
|
||
|
|
Just index -> DigestedQueryEntryVariable index
|
||
|
|
Nothing -> throw $ VariableLookupException varName allBoundVariables
|
||
|
|
extractEntry constant = DigestedQueryEntryConstant constant
|
||
|
|
|