├── stack.yaml ├── test ├── Spec.hs └── Language │ └── Exalog │ ├── DeltaSpec.hs │ ├── WellModingSpec.hs │ ├── RangeRestrictionSpec.hs │ ├── ProvenanceSpec.hs │ ├── AdornmentSpec.hs │ ├── SolverSpec.hs │ └── DataflowSpec.hs ├── .gitignore ├── ChangeLog.md ├── stack.yaml.lock ├── .travis.yml ├── src └── Language │ └── Exalog │ ├── Wildcard.hs │ ├── Error.hs │ ├── Fresh.hs │ ├── KnowledgeBase │ ├── Class.hs │ ├── Knowledge.hs │ └── Set.hs │ ├── Logger.hs │ ├── Pretty │ └── Helper.hs │ ├── Util │ └── List │ │ └── Zipper.hs │ ├── Stratification.hs │ ├── Unification.hs │ ├── Annotation.hs │ ├── RangeRestriction.hs │ ├── WellModing.hs │ ├── SrcLoc.hs │ ├── Solver.hs │ ├── Pretty.hs │ ├── Dependency.hs │ ├── DataflowRepair.hs │ ├── SemiNaive.hs │ ├── Provenance.hs │ ├── Delta.hs │ ├── ForeignFunction.hs │ ├── Adornment.hs │ ├── Renamer.hs │ └── Dataflow.hs ├── README.md ├── LICENSE ├── fixtures └── Fixture │ ├── Ancestor │ ├── Common.hs │ ├── LinearAncestor.hs │ ├── NonLinearAncestor.hs │ └── EDB.hs │ ├── DomainDependent.hs │ ├── RepeatedVars.hs │ ├── SpanIrrelevance.hs │ ├── Wildcard.hs │ ├── Constant.hs │ ├── Util.hs │ ├── WellModing.hs │ ├── Unification.hs │ ├── Negation.hs │ ├── RangeRestriction.hs │ ├── Foreign.hs │ └── Dataflow.hs ├── package.yaml └── exalog-engine.cabal /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-15.11 2 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | dist-newstyle/ 3 | *~ 4 | .DS_Store 5 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for exalog-engine 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 494638 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/11.yaml 11 | sha256: 5747328cdcbb8fe9c96fc048b5566167c80dd176a41b52d3b363058e3cc1dc5d 12 | original: lts-15.11 13 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | 3 | dist: bionic 4 | 5 | language: generic 6 | 7 | # Caching so the next build will be fast too. 8 | cache: 9 | directories: 10 | - $HOME/.stack 11 | 12 | before_install: 13 | # Download and unpack the stack executable 14 | - mkdir -p ~/.local/bin 15 | - export PATH=$HOME/.local/bin:$PATH 16 | - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 17 | 18 | install: 19 | # Build dependencies 20 | - stack --no-terminal --install-ghc test --only-dependencies 21 | 22 | script: 23 | # Build the package, its tests and run the tests 24 | - stack --no-terminal test 25 | -------------------------------------------------------------------------------- /test/Language/Exalog/DeltaSpec.hs: -------------------------------------------------------------------------------- 1 | module Language.Exalog.DeltaSpec (spec) where 2 | 3 | import Protolude hiding (head) 4 | 5 | import Data.List (head) 6 | 7 | import Test.Hspec 8 | 9 | import qualified Fixture.Ancestor.LinearAncestor as LAnc 10 | import qualified Fixture.Ancestor.NonLinearAncestor as NLAnc 11 | 12 | import Language.Exalog.Core (Program(..)) 13 | import Language.Exalog.Delta 14 | 15 | spec :: Spec 16 | spec = 17 | describe "Delta analysis" $ 18 | parallel $ describe "Ancestor" $ do 19 | 20 | it "deltaifies linear ancestor correctly" $ 21 | mkDeltaStratum (head $ _strata LAnc.program) `shouldBe` LAnc.deltaStratum 22 | 23 | it "deltaifies non-linear ancestor correctly" $ 24 | mkDeltaStratum (head $ _strata NLAnc.program) `shouldBe` NLAnc.deltaStratum 25 | -------------------------------------------------------------------------------- /test/Language/Exalog/WellModingSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Language.Exalog.WellModingSpec (spec) where 4 | 5 | import Protolude 6 | 7 | import Test.Hspec 8 | 9 | import qualified Fixture.WellModing as WM 10 | 11 | import Language.Exalog.Annotation 12 | import Language.Exalog.Logger 13 | import Language.Exalog.WellModing 14 | import qualified Language.Exalog.KnowledgeBase.Set as KB 15 | 16 | spec :: Spec 17 | spec = 18 | describe "Well moding" $ 19 | describe "Repair" $ 20 | it "programSimple can be repaired" $ do 21 | let input = (WM.prSimple, mempty :: KB.Set ('ARename 'ABase)) 22 | let output = (WM.prSimpleRepaired, mempty :: KB.Set 'ABase) 23 | runLoggerT vanillaEnv (fixModing input) `shouldReturn` Just output 24 | -------------------------------------------------------------------------------- /src/Language/Exalog/Wildcard.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE MonoLocalBinds #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | 6 | module Language.Exalog.Wildcard (checkWildcards) where 7 | 8 | import Protolude 9 | 10 | import Language.Exalog.Core 11 | import Language.Exalog.Logger 12 | import Language.Exalog.SrcLoc (Spannable(span)) 13 | 14 | -- |Clause heads cannot contain wildcards 15 | checkWildcards :: Spannable (Clause ann) => Program ann -> Logger () 16 | checkWildcards Program{..} = 17 | traverse_ (stratumOverA_ $ traverse_ checkWildcardsInClause) _strata 18 | 19 | checkWildcardsInClause :: Spannable (Clause ann) => Clause ann -> Logger () 20 | checkWildcardsInClause cl@Clause{_head = Literal{..}} = 21 | when (TWild `elem` _terms) $ 22 | scold (span cl) "Clause heads cannot have wildcards." 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Exalog: Datalog as a library 2 | 3 | [![Build Status](https://travis-ci.com/madgen/exalog.svg?branch=master)](https://travis-ci.com/madgen/exalog) 4 | 5 | This project provides a Datalog backend as a library written in Haskell. It is meant to facilitate implementation of Datalog progeny that can compile down to range restricted Datalog wih perfect models. 6 | 7 | What we provide: 8 | 9 | - Semi-Naïve evaluation engine 10 | - Stratifier 11 | - Foreign predicate support (from Haskell) 12 | - Data provenance tracking 13 | - Range restriction checker 14 | - Well-modedness checker (sufficient binding for foreign predicates) 15 | - Dataflow repair (achieve range restriction and well-modedness via program transformation) 16 | - Adornment transformation 17 | - Pretty printer 18 | 19 | The road map: 20 | 21 | - Incremental evaluation 22 | - Type-level enforcement of range restriction and well-modedness 23 | - Inliner 24 | - Magic set transformation 25 | - Deduplicator 26 | - Interface files 27 | -------------------------------------------------------------------------------- /src/Language/Exalog/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Language.Exalog.Error 4 | ( Error(..) 5 | , Severity(..) 6 | ) where 7 | 8 | import Protolude hiding ((<>)) 9 | 10 | import Text.PrettyPrint 11 | 12 | import Language.Exalog.Pretty.Helper (Pretty(..), ($+?$)) 13 | import Language.Exalog.SrcLoc (SrcSpan, prettySpan) 14 | 15 | data Severity = 16 | -- |Error that should never be thrown 17 | Impossible 18 | -- |Standard user error 19 | | User 20 | -- |Warning 21 | | Warning 22 | deriving (Eq) 23 | 24 | data Error = Error 25 | { _severity :: Severity 26 | , _mSource :: Maybe Text 27 | , _span :: SrcSpan 28 | , _message :: Text 29 | } 30 | 31 | instance Pretty Severity where 32 | pretty Impossible = "Impossible happened! Please submit a bug report" 33 | pretty User = "Error" 34 | pretty Warning = "Warning" 35 | 36 | instance Pretty Error where 37 | pretty Error{..} = 38 | brackets (pretty _severity) <> colon 39 | $+$ nest 2 prettyError 40 | where 41 | prettyError = pretty _span 42 | $+$ pretty _message 43 | $+$ maybe mempty 44 | (("" $+?$) . (`prettySpan` _span)) 45 | _mSource 46 | -------------------------------------------------------------------------------- /src/Language/Exalog/Fresh.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | 4 | module Language.Exalog.Fresh 5 | ( FreshT 6 | , Fresh 7 | , runFreshT 8 | , runFresh 9 | , fresh 10 | ) where 11 | 12 | import Protolude 13 | 14 | import Data.Text (pack) 15 | import qualified Data.Set as S 16 | 17 | import Control.Monad.Trans.Class (MonadTrans) 18 | 19 | data FreshSt = FreshSt 20 | { _prefix :: Maybe Text 21 | , _reserved :: S.Set Text 22 | , _counter :: Int 23 | } 24 | 25 | newtype FreshT m a = FreshT (StateT FreshSt m a) 26 | deriving (Functor, Applicative, Monad, MonadTrans, MonadState FreshSt) 27 | type Fresh = FreshT Identity 28 | 29 | runFreshT :: Monad m => Maybe Text -> [ Text ] -> FreshT m a -> m a 30 | runFreshT mPrefix reserved (FreshT action) = evalStateT action $ FreshSt 31 | { _prefix = mPrefix 32 | , _reserved = S.fromList reserved 33 | , _counter = 0 34 | } 35 | 36 | runFresh :: Maybe Text -> [ Text ] -> Fresh a -> a 37 | runFresh prefix reserved = runIdentity . runFreshT prefix reserved 38 | 39 | fresh :: Monad m => FreshT m Text 40 | fresh = do 41 | st@FreshSt{..} <- get 42 | 43 | put st {_counter = _counter + 1} 44 | 45 | let candidate = fromMaybe "" _prefix <> (pack . show) _counter 46 | 47 | if candidate `elem` _reserved 48 | then fresh 49 | else pure candidate 50 | -------------------------------------------------------------------------------- /src/Language/Exalog/KnowledgeBase/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | 5 | module Language.Exalog.KnowledgeBase.Class 6 | ( Knowledgeable(..) 7 | , map 8 | ) where 9 | 10 | import qualified Protolude as P 11 | import Protolude hiding (pred, filter, toList, map) 12 | 13 | import qualified Data.Vector.Sized as V 14 | 15 | import Language.Exalog.Core 16 | 17 | import Language.Exalog.KnowledgeBase.Knowledge 18 | 19 | class Knowledgeable sol a where 20 | fromList :: [ Knowledge a ] -> sol a 21 | toList :: sol a -> [ Knowledge a ] 22 | 23 | add :: Knowledge a -> sol a -> sol a 24 | partition :: (Knowledge a -> Bool) -> sol a -> (sol a, sol a) 25 | filter :: (Knowledge a -> Bool) -> sol a -> sol a 26 | difference :: sol a -> sol a -> sol a 27 | findByPred :: Predicate n a -> sol a -> [ V.Vector n Sym ] 28 | 29 | atEach :: forall b id1 id2 30 | . IdentifiableAnn (PredicateAnn b) id1 31 | => IdentifiableAnn (KnowledgeAnn b) id2 32 | => Ord id1 33 | => Ord id2 34 | => (Knowledge a -> Knowledge b) -> sol a -> sol b 35 | 36 | singleton :: Knowledge a -> sol a 37 | 38 | size :: sol a -> Int 39 | null :: sol a -> Bool 40 | 41 | map :: Knowledgeable kb a => (Knowledge a -> b) -> kb a -> [ b ] 42 | map f = P.map f . toList 43 | -------------------------------------------------------------------------------- /test/Language/Exalog/RangeRestrictionSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Language.Exalog.RangeRestrictionSpec (spec) where 4 | 5 | import Protolude 6 | 7 | import Test.Hspec 8 | 9 | import qualified Fixture.RangeRestriction as RRes 10 | import qualified Fixture.DomainDependent as DDep 11 | 12 | import Language.Exalog.Annotation 13 | import qualified Language.Exalog.KnowledgeBase.Set as KB 14 | import Language.Exalog.Logger 15 | import Language.Exalog.RangeRestriction 16 | 17 | spec :: Spec 18 | spec = 19 | describe "Range restriction" $ do 20 | parallel $ describe "Checking" $ do 21 | it "programGood is range-restricted" $ 22 | runLoggerT vanillaEnv (checkRangeRestriction DDep.programGood) `shouldReturn` Just () 23 | 24 | it "programBad1 violates range restriction" $ 25 | runLoggerT vanillaEnv (checkRangeRestriction DDep.programBad1) `shouldReturn` Nothing 26 | 27 | it "programBad2 violates range restriction" $ 28 | runLoggerT vanillaEnv (checkRangeRestriction DDep.programBad2) `shouldReturn` Nothing 29 | 30 | describe "Repair" $ 31 | it "programSimple can be repaired" $ do 32 | let input = (RRes.prSimple, mempty :: KB.Set ('ARename 'ABase)) 33 | let output = (RRes.prSimpleRepaired, mempty :: KB.Set 'ABase) 34 | runLoggerT vanillaEnv (fixRangeRestriction input) `shouldReturn` Just output 35 | -------------------------------------------------------------------------------- /test/Language/Exalog/ProvenanceSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ExplicitNamespaces #-} 5 | 6 | module Language.Exalog.ProvenanceSpec (spec) where 7 | 8 | import Protolude hiding (head, Set) 9 | 10 | import Test.Hspec 11 | 12 | import qualified Fixture.Ancestor.LinearAncestor as LAnc 13 | import qualified Fixture.Ancestor.NonLinearAncestor as NLAnc 14 | import qualified Fixture.Ancestor.EDB as AncEDB 15 | 16 | import Language.Exalog.Core 17 | import Language.Exalog.SolverSpec (execSolver) 18 | import Language.Exalog.Provenance () 19 | import Language.Exalog.KnowledgeBase.Set 20 | 21 | spec :: Spec 22 | spec = 23 | describe "Provenance recording" $ 24 | describe "Ancestor" $ do 25 | let initEDB = decorate AncEDB.initEDB :: Set ('AProvenance 'ABase) 26 | 27 | finalEDB <- execSolver (decorate LAnc.program) initEDB 28 | it "records provenance for linear ancestor correctly" $ 29 | finalEDB `shouldBe` Just AncEDB.finalLinearProvEDB 30 | 31 | finalEDB <- execSolver (decorate NLAnc.program) initEDB 32 | it "records provenance for non-linear ancestor correctly" $ 33 | finalEDB `shouldBe` Just AncEDB.finalNonLinearProvEDB 34 | 35 | finalEDBL <- execSolver (decorate LAnc.program) initEDB 36 | finalEDBNL <- execSolver (decorate NLAnc.program) initEDB 37 | 38 | it "provenance of non-linear ancestor differs from provenance of linear ancestor" $ 39 | finalEDBL `shouldNotBe` finalEDBNL 40 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Mistral Contrastin (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Mistral Contrastin nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /fixtures/Fixture/Ancestor/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.Ancestor.Common 4 | ( parPred, anc 5 | , ancPred, par 6 | , ancProv, parProv 7 | , parPredProv, ancPredProv 8 | ) where 9 | 10 | import Protolude 11 | 12 | import Data.Maybe (fromJust) 13 | import qualified Data.Vector.Sized as V 14 | import Data.Singletons.TypeLits 15 | 16 | import Language.Exalog.Core 17 | import Language.Exalog.SrcLoc 18 | import Language.Exalog.Provenance 19 | 20 | import Fixture.Util 21 | 22 | anc :: Term -> Term -> Literal 'ABase 23 | anc t t' = lit ancPred $ fromJust $ V.fromList [ t, t' ] 24 | 25 | par :: Term -> Term -> Literal 'ABase 26 | par t t' = lit parPred $ fromJust $ V.fromList [ t, t' ] 27 | 28 | parPred :: Predicate 2 'ABase 29 | parPred = Predicate (PredABase NoSpan) "par" SNat Logical 30 | 31 | ancPred :: Predicate 2 'ABase 32 | ancPred = Predicate (PredABase NoSpan) "anc" SNat Logical 33 | 34 | -- Decorated with provenance 35 | litProv :: Predicate n ('AProvenance 'ABase) -> V.Vector n Term -> Literal ('AProvenance 'ABase) 36 | litProv = Literal (LitAProvenance (LitABase NoSpan)) Positive 37 | 38 | ancProv :: Term -> Term -> Literal ('AProvenance 'ABase) 39 | ancProv t t' = litProv ancPredProv $ fromJust $ V.fromList [ t, t' ] 40 | 41 | parProv :: Term -> Term -> Literal ('AProvenance 'ABase) 42 | parProv t t' = litProv parPredProv $ fromJust $ V.fromList [ t, t' ] 43 | 44 | parPredProv :: Predicate 2 ('AProvenance 'ABase) 45 | parPredProv = Predicate (PredAProvenance (PredABase NoSpan)) "par" SNat Logical 46 | 47 | ancPredProv :: Predicate 2 ('AProvenance 'ABase) 48 | ancPredProv = Predicate (PredAProvenance (PredABase NoSpan)) "anc" SNat Logical -------------------------------------------------------------------------------- /fixtures/Fixture/DomainDependent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.DomainDependent 4 | ( programGood 5 | , programBad1 6 | , programBad2 7 | ) where 8 | 9 | import Protolude hiding (SrcLoc) 10 | 11 | import Data.Maybe (fromJust) 12 | 13 | import qualified Data.List.NonEmpty as NE 14 | import qualified Data.Vector.Sized as V 15 | import Data.Singletons.TypeLits 16 | 17 | import Language.Exalog.Core 18 | import Language.Exalog.SrcLoc 19 | 20 | import Fixture.Util 21 | 22 | cPred, rPred :: Predicate 2 'ABase 23 | cPred = Predicate (PredABase NoSpan) "c" SNat Logical 24 | rPred = Predicate (PredABase NoSpan) "r" SNat Logical 25 | 26 | c, r :: Term -> Term -> Literal 'ABase 27 | c t t' = lit cPred $ fromJust $ V.fromList [ t, t' ] 28 | r t t' = lit rPred $ fromJust $ V.fromList [ t, t' ] 29 | 30 | {- 31 | - r(X,Y) :- c(X,Y). 32 | -} 33 | programGood :: Program 'ABase 34 | programGood = Program (ProgABase NoSpan) 35 | (Stratum <$> 36 | [ [ Clause (ClABase NoSpan) (r (tvar "X") (tvar "Y")) $ 37 | NE.fromList [ c (tvar "X") (tvar "Y") ] 38 | ] 39 | ]) 40 | [] 41 | 42 | {- 43 | - r(X,Y) :- c(X,X). 44 | -} 45 | programBad1 :: Program 'ABase 46 | programBad1 = Program (ProgABase NoSpan) 47 | (Stratum <$> 48 | [ [ Clause (ClABase NoSpan) (r (tvar "X") (tvar "Y")) $ 49 | NE.fromList [ c (tvar "X") (tvar "X") ] 50 | ] 51 | ]) 52 | [] 53 | 54 | {- 55 | - r(X,Y) :- c("a","b"). 56 | -} 57 | programBad2 :: Program 'ABase 58 | programBad2 = Program (ProgABase NoSpan) 59 | (Stratum <$> 60 | [ [ Clause (ClABase NoSpan) (r (tvar "X") (tvar "Y")) $ 61 | NE.fromList [ c (tsym ("a" :: Text)) (tsym ("b" :: Text)) ] 62 | ] 63 | ]) 64 | [] 65 | -------------------------------------------------------------------------------- /fixtures/Fixture/RepeatedVars.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.RepeatedVars 4 | ( program 5 | , initEDB 6 | , pPred 7 | , pTuples 8 | ) where 9 | 10 | import Protolude hiding (Set) 11 | 12 | import Data.Maybe (fromJust) 13 | 14 | import qualified Data.List.NonEmpty as NE 15 | import qualified Data.Vector.Sized as V 16 | import Data.Singletons.TypeLits 17 | 18 | import Language.Exalog.Core 19 | import Language.Exalog.KnowledgeBase.Class 20 | import Language.Exalog.KnowledgeBase.Knowledge 21 | import Language.Exalog.KnowledgeBase.Set 22 | import Language.Exalog.SrcLoc (SrcSpan(NoSpan)) 23 | 24 | import Fixture.Util 25 | 26 | pPred :: Predicate 1 'ABase 27 | pPred = Predicate (PredABase NoSpan) "p" SNat Logical 28 | 29 | qPred :: Predicate 2 'ABase 30 | qPred = Predicate (PredABase NoSpan) "q" SNat Logical 31 | 32 | p :: Term -> Literal 'ABase 33 | p t = lit pPred $ fromJust $ V.fromList [ t ] 34 | 35 | q :: Term -> Term -> Literal 'ABase 36 | q t t' = lit qPred $ fromJust $ V.fromList [ t, t' ] 37 | 38 | {-| Repeated variable program 39 | - 40 | - p(X) :- q(X,X). 41 | |-} 42 | program :: Program 'ABase 43 | program = Program (ProgABase NoSpan) 44 | ( Stratum <$> 45 | [ [ Clause (ClABase NoSpan) (p (tvar "X")) $ NE.fromList [ q (tvar "X") (tvar "X") ] 46 | ] 47 | ]) 48 | [ PredicateBox pPred ] 49 | 50 | qTuples :: [ V.Vector 2 Int ] 51 | qTuples = fromJust . V.fromList <$> 52 | [ [ 1 , 2 ] 53 | , [ 2 , 2 ] 54 | ] 55 | 56 | qKB :: Set 'ABase 57 | qKB = fromList $ Knowledge KnowABase qPred . fmap symbol <$> qTuples 58 | 59 | initEDB :: Set 'ABase 60 | initEDB = qKB 61 | 62 | pTuples :: [ V.Vector 1 Sym ] 63 | pTuples = fmap symbol . fromJust . V.fromList <$> ([ [ 2 ] ] :: [ [ Int ] ]) 64 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: exalog-engine 2 | version: 0.1.0.0 3 | github: "madgen/exalog-engine" 4 | license: BSD-3-Clause 5 | author: "Mistral Contrastin" 6 | maintainer: "madgenhetic@gmail.com" 7 | copyright: "2018" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | synopsis: A Datalog engine with support for external processes as predicates 15 | category: Language 16 | description: Please see the README on GitHub at 17 | 18 | default-extensions: 19 | - NoImplicitPrelude 20 | - LambdaCase 21 | - OverloadedStrings 22 | 23 | ghc-options: 24 | - -Wall 25 | - -fwarn-tabs 26 | - -fwarn-incomplete-uni-patterns 27 | - -fwarn-incomplete-record-updates 28 | 29 | dependencies: 30 | - aeson >= 1.4 && < 1.5 31 | - base >= 4.7 && < 5 32 | - bimap >= 0.4 && < 0.5 33 | - containers >= 0.6 && < 0.7 34 | - comonad >= 5.0 && < 5.1 35 | - fgl >= 5.7 && < 5.8 36 | - finite-typelits >= 0.1.4 && < 0.1.5 37 | - ghc-prim >= 0.5 && < 0.6 38 | - ghc-typelits-natnormalise >= 0.7 && < 0.8 39 | - protolude >= 0.2 && < 0.3 40 | - pretty >= 1.1 && < 1.2 41 | - singletons >= 2.6 && < 2.7 42 | - text >= 1.2 && < 1.3 43 | - transformers >= 0.5 && < 0.6 44 | - unordered-containers >= 0.2 && < 0.3 45 | - vector-sized >= 1.4 && < 1.5 46 | 47 | library: 48 | source-dirs: src 49 | 50 | tests: 51 | exalog-engine-test: 52 | main: Spec.hs 53 | source-dirs: 54 | - test 55 | - fixtures 56 | ghc-options: 57 | - -threaded 58 | - -rtsopts 59 | - -with-rtsopts=-N 60 | dependencies: 61 | - hspec >= 2.7 && < 2.8 62 | - QuickCheck >= 2.13 && < 2.14 63 | - exalog-engine 64 | build-tools: 65 | - hspec-discover >= 2.7 && < 2.8 66 | -------------------------------------------------------------------------------- /test/Language/Exalog/AdornmentSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 2 | 3 | module Language.Exalog.AdornmentSpec (spec) where 4 | 5 | import Protolude 6 | 7 | import Test.Hspec 8 | 9 | import qualified Fixture.Ancestor.LinearAncestor as LAnc 10 | import qualified Fixture.Ancestor.NonLinearAncestor as NLAnc 11 | import qualified Fixture.Ancestor.EDB as AncEDB 12 | 13 | import Language.Exalog.Adornment 14 | import Language.Exalog.Core (decorate) 15 | import Language.Exalog.KnowledgeBase.Class 16 | import Language.Exalog.KnowledgeBase.Knowledge 17 | 18 | import Language.Exalog.SolverSpec (execSolver) 19 | 20 | spec :: Spec 21 | spec = 22 | describe "Adornment transformation" $ 23 | parallel $ describe "Ancestor" $ do 24 | 25 | it "adorns linear ancestor correctly" $ 26 | adornProgram LAnc.program `shouldBe` LAnc.adornedProgram 27 | 28 | it "adorns non-linear ancestor correctly" $ 29 | adornProgram NLAnc.program `shouldBe` NLAnc.adornedProgram 30 | 31 | it "adorns swapped non-linear ancestor correctly" $ 32 | adornProgram NLAnc.programSwapped `shouldBe` NLAnc.adornedProgramSwapped 33 | 34 | finalEDB <- execSolver NLAnc.adornedProgram (atEach (\(Knowledge ann pred syms) -> Knowledge (KnowAAdornment ann) (decorate pred) syms) AncEDB.initEDB) 35 | it "adornment preserves non-linear ancestor solutions" $ 36 | finalEDB `shouldBe` Just (atEach (\(Knowledge ann pred syms) -> Knowledge (KnowAAdornment ann) (decorate pred) syms) AncEDB.finalEDB) 37 | 38 | finalEDB <- execSolver LAnc.adornedProgram (atEach (\(Knowledge ann pred syms) -> Knowledge (KnowAAdornment ann) (decorate pred) syms) AncEDB.initEDB) 39 | it "adornment preserves linear ancestor solutions" $ 40 | finalEDB `shouldBe` Just (atEach (\(Knowledge ann pred syms) -> Knowledge (KnowAAdornment ann) (decorate pred) syms) AncEDB.finalEDB) 41 | -------------------------------------------------------------------------------- /src/Language/Exalog/Logger.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Language.Exalog.Logger 4 | ( LoggerT 5 | , Logger 6 | , LoggerEnv(..) 7 | , vanillaEnv 8 | , runLoggerT 9 | , whisper 10 | , scold 11 | , scream 12 | , Err.Error 13 | , Err.Severity(..) 14 | ) where 15 | 16 | import Protolude hiding (log) 17 | 18 | import Control.Monad.Trans.Class (MonadTrans(..)) 19 | import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) 20 | 21 | import Language.Exalog.Pretty (pp) 22 | import qualified Language.Exalog.Error as Err 23 | import Language.Exalog.SrcLoc (SrcSpan) 24 | 25 | newtype LoggerEnv = LoggerEnv 26 | { -- |Optional because test cases don't have source code 27 | _mSource :: Maybe Text 28 | } 29 | 30 | vanillaEnv :: LoggerEnv 31 | vanillaEnv = LoggerEnv 32 | { _mSource = Nothing 33 | } 34 | 35 | newtype LoggerT m a = LoggerT (ReaderT LoggerEnv (MaybeT m) a) 36 | deriving (Functor, Applicative, Monad, MonadIO, MonadReader LoggerEnv) 37 | type Logger = LoggerT IO 38 | 39 | instance MonadTrans LoggerT where 40 | lift m = LoggerT (lift (lift m)) 41 | 42 | runLoggerT :: Monad m => LoggerEnv -> LoggerT m a -> m (Maybe a) 43 | runLoggerT env (LoggerT act) = runMaybeT (runReaderT act env) 44 | 45 | whisper :: MonadIO m => SrcSpan -> Text -> LoggerT m () 46 | whisper = common Err.Warning 47 | 48 | scold :: MonadIO m => SrcSpan -> Text -> LoggerT m a 49 | scold mSpan msg = do 50 | common Err.User mSpan msg 51 | LoggerT (lift $ MaybeT (pure Nothing)) 52 | 53 | scream :: MonadIO m => SrcSpan -> Text -> LoggerT m a 54 | scream mSpan msg = do 55 | common Err.Impossible mSpan msg 56 | LoggerT (lift $ MaybeT (pure Nothing)) 57 | 58 | common :: MonadIO m => Err.Severity -> SrcSpan -> Text -> LoggerT m () 59 | common severity mSpan msg = do 60 | mSrc <- _mSource <$> ask 61 | let renderedErr = pp $ Err.Error severity mSrc mSpan msg 62 | liftIO $ putStrLn renderedErr 63 | -------------------------------------------------------------------------------- /src/Language/Exalog/Pretty/Helper.hs: -------------------------------------------------------------------------------- 1 | module Language.Exalog.Pretty.Helper 2 | ( pp 3 | , Pretty(..) 4 | , PrettyCollection(..) 5 | , () 6 | , (<+?>) 7 | , ($?$) 8 | , ($+?$) 9 | , cond 10 | , csep 11 | ) where 12 | 13 | import Protolude hiding ((<>), empty, head) 14 | 15 | import Data.String (fromString) 16 | import Data.Text (unpack) 17 | 18 | import Text.PrettyPrint 19 | 20 | -- | Render as text 21 | pp :: Pretty a => a -> Text 22 | pp = fromString . render . pretty 23 | 24 | class Pretty a where 25 | pretty :: a -> Doc 26 | 27 | class PrettyCollection a where 28 | prettyC :: a -> [ Doc ] 29 | 30 | infixl 7 31 | infix 7 <+?> 32 | 33 | -- | Same as `<>` but `empty` acts as an annihilator 34 | () :: Doc -> Doc -> Doc 35 | d1 d2 36 | | isEmpty d1 || isEmpty d2 = empty 37 | | otherwise = d1 <> d2 38 | 39 | -- | Same as `<+>` but `empty` acts as an annihilator 40 | (<+?>) :: Doc -> Doc -> Doc 41 | d1 <+?> d2 42 | | isEmpty d1 || isEmpty d2 = empty 43 | | otherwise = d1 <+> d2 44 | 45 | -- | Same as `$$` but `empty` acts as an annihilator 46 | ($?$) :: Doc -> Doc -> Doc 47 | d1 $?$ d2 48 | | isEmpty d1 || isEmpty d2 = empty 49 | | otherwise = d1 $$ d2 50 | 51 | -- | Same as `$+?$` but `empty` acts as an annihilator 52 | ($+?$) :: Doc -> Doc -> Doc 53 | d1 $+?$ d2 54 | | isEmpty d1 || isEmpty d2 = empty 55 | | otherwise = d1 $+$ d2 56 | 57 | -- | Conditionally return the second argument 58 | cond :: Bool -> Doc -> Doc 59 | cond True doc = doc 60 | cond False _ = empty 61 | 62 | -- | Comma separate Docs 63 | csep :: [ Doc ] -> Doc 64 | csep = hsep . punctuate comma 65 | 66 | -- Common instances 67 | 68 | instance {-# OVERLAPPABLE #-} Pretty a => PrettyCollection [ a ] where 69 | prettyC = map pretty 70 | 71 | instance Pretty Text where 72 | pretty = text . unpack 73 | 74 | instance Pretty () where 75 | pretty _ = empty 76 | 77 | instance Pretty Int where 78 | pretty = int 79 | -------------------------------------------------------------------------------- /src/Language/Exalog/Util/List/Zipper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | 3 | module Language.Exalog.Util.List.Zipper 4 | ( Zipper 5 | , focus, left, right 6 | , leftMaybe, rightMaybe 7 | , fromNonEmptyList, toNonEmptyList 8 | , fromListMaybe, toList 9 | , threeWayMap 10 | ) where 11 | 12 | import Protolude hiding (toList) 13 | 14 | import qualified Data.List.NonEmpty as NE 15 | 16 | import Control.Comonad (Comonad(..)) 17 | 18 | data Zipper a = Zipper [ a ] a [ a ] deriving (Functor) 19 | 20 | fromNonEmptyList :: NE.NonEmpty a -> Zipper a 21 | fromNonEmptyList (a NE.:| as) = Zipper [] a as 22 | 23 | toNonEmptyList :: Zipper a -> NE.NonEmpty a 24 | toNonEmptyList (Zipper ls a rs) = 25 | case reverse ls of 26 | [] -> a NE.:| rs 27 | (x:xs) -> x NE.:| xs ++ a : rs 28 | 29 | toList :: Zipper a -> [ a ] 30 | toList (Zipper ls a rs) = reverse ls ++ a : rs 31 | 32 | fromListMaybe :: [ a ] -> Maybe (Zipper a) 33 | fromListMaybe [] = Nothing 34 | fromListMaybe (x:xs) = Just $ Zipper [] x xs 35 | 36 | focus :: Zipper a -> a 37 | focus (Zipper _ a _) = a 38 | 39 | leftMaybe :: Zipper a -> Maybe (Zipper a) 40 | leftMaybe (Zipper (l:ls) a rs) = Just $ Zipper ls l (a:rs) 41 | leftMaybe _ = Nothing 42 | 43 | rightMaybe :: Zipper a -> Maybe (Zipper a) 44 | rightMaybe (Zipper ls a (r:rs)) = Just $ Zipper (a:ls) r rs 45 | rightMaybe _ = Nothing 46 | 47 | left :: Zipper a -> Zipper a 48 | left z = fromMaybe z (leftMaybe z) 49 | 50 | right :: Zipper a -> Zipper a 51 | right z = fromMaybe z (rightMaybe z) 52 | 53 | threeWayMap :: (a -> b) -> (a -> b) -> (a -> b) -> Zipper a -> Zipper b 54 | threeWayMap f g h (Zipper ls a rs) = Zipper (fmap f ls) (g a) (fmap h rs) 55 | 56 | instance Comonad Zipper where 57 | extract (Zipper _ a _) = a 58 | duplicate w = Zipper (go' leftMaybe w) w (go' rightMaybe w) 59 | where 60 | go' :: (Zipper a -> Maybe (Zipper a)) -> Zipper a -> [ Zipper a ] 61 | go' f = unfoldr (fmap (\s -> (s,s)) . f) 62 | -------------------------------------------------------------------------------- /fixtures/Fixture/SpanIrrelevance.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.SpanIrrelevance 4 | ( program 5 | , initEDB 6 | , rPred 7 | , rTuples 8 | ) where 9 | 10 | import Protolude hiding (SrcLoc, Set) 11 | 12 | import Data.Maybe (fromJust) 13 | 14 | import qualified Data.List.NonEmpty as NE 15 | import qualified Data.Vector.Sized as V 16 | import Data.Singletons.TypeLits 17 | 18 | import Language.Exalog.Core 19 | import Language.Exalog.KnowledgeBase.Class 20 | import Language.Exalog.KnowledgeBase.Knowledge 21 | import Language.Exalog.KnowledgeBase.Set 22 | import Language.Exalog.SrcLoc 23 | 24 | import Fixture.Util 25 | 26 | cPred, rPred, rPred' :: Predicate 1 'ABase 27 | cPred = Predicate (PredABase NoSpan) "c" SNat Logical 28 | rPred = Predicate (PredABase NoSpan) "r" SNat Logical 29 | rPred' = Predicate (PredABase (Span None (SrcLoc 1 2) (SrcLoc 2 3))) "r" SNat Logical 30 | 31 | c,r,r' :: Term -> Literal 'ABase 32 | c t = lit cPred $ fromJust $ V.fromList [ t ] 33 | r t = lit rPred $ fromJust $ V.fromList [ t ] 34 | r' t = lit rPred' $ fromJust $ V.fromList [ t ] 35 | 36 | {- 37 | - r("a") :- c("1"). 38 | - r("b") :- c("2"). 39 | -} 40 | program :: Program 'ABase 41 | program = Program (ProgABase NoSpan) 42 | (Stratum <$> 43 | [ [ Clause (ClABase NoSpan) (r (tsym ("a" :: Text))) $ NE.fromList [ c (tsym ("1" :: Text)) ] 44 | , Clause (ClABase NoSpan) (r' (tsym ("b" :: Text))) $ NE.fromList [ c (tsym ("2" :: Text)) ] 45 | ] 46 | ]) 47 | [ PredicateBox rPred ] 48 | 49 | cTuples :: [ V.Vector 1 Text ] 50 | cTuples = fromJust . V.fromList <$> 51 | [ [ "1" ] 52 | , [ "2" ] 53 | ] 54 | 55 | cKB :: Set 'ABase 56 | cKB = fromList $ Knowledge KnowABase cPred . fmap symbol <$> cTuples 57 | 58 | initEDB :: Set 'ABase 59 | initEDB = cKB 60 | 61 | rTuples :: [ V.Vector 1 Sym ] 62 | rTuples = fmap symbol . fromJust . V.fromList <$> 63 | ([ [ "a" ] , [ "b" ] ] :: [ [ Text ] ]) 64 | -------------------------------------------------------------------------------- /fixtures/Fixture/Wildcard.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.Wildcard 4 | ( program 5 | , initEDB 6 | , pPred 7 | , pTuples 8 | ) where 9 | 10 | import Protolude hiding (not, Set) 11 | 12 | import Data.Maybe (fromJust) 13 | 14 | import qualified Data.List.NonEmpty as NE 15 | import qualified Data.Vector.Sized as V 16 | import Data.Singletons.TypeLits 17 | 18 | import Language.Exalog.Core 19 | import Language.Exalog.KnowledgeBase.Class 20 | import Language.Exalog.KnowledgeBase.Knowledge 21 | import Language.Exalog.KnowledgeBase.Set 22 | import Language.Exalog.SrcLoc (SrcSpan(NoSpan)) 23 | 24 | import Fixture.Util 25 | 26 | pPred :: Predicate 1 'ABase 27 | pPred = Predicate (PredABase NoSpan) "p" SNat Logical 28 | 29 | qPred :: Predicate 2 'ABase 30 | qPred = Predicate (PredABase NoSpan) "q" SNat Logical 31 | 32 | p :: Term -> Literal 'ABase 33 | p t = lit pPred $ fromJust $ V.fromList [ t ] 34 | 35 | q :: Term -> Term -> Literal 'ABase 36 | q t t' = lit qPred $ fromJust $ V.fromList [ t, t' ] 37 | 38 | {-| Repeated variable program 39 | - 40 | - p(1) :- q(_,_). 41 | - p(X) :- q(X,_), ! q(_,X). 42 | |-} 43 | program :: Program 'ABase 44 | program = Program (ProgABase NoSpan) 45 | (Stratum <$> 46 | [ [ Clause (ClABase NoSpan) (p (tsym (1 :: Int))) $ NE.fromList [ q TWild TWild ] 47 | , Clause (ClABase NoSpan) (p (tvar "X")) 48 | $ NE.fromList 49 | [ q (tvar "X") TWild 50 | , not $ q TWild (tvar "X")] 51 | ] 52 | ]) 53 | [ PredicateBox pPred ] 54 | 55 | qTuples :: [ V.Vector 2 Int ] 56 | qTuples = fromJust . V.fromList <$> 57 | [ [ 1 , 2 ] 58 | , [ 2 , 2 ] 59 | , [ 2 , 1 ] 60 | , [ 3 , 1 ] 61 | , [ 4 , 3 ] 62 | , [ 5 , 6 ] 63 | ] 64 | 65 | qKB :: Set 'ABase 66 | qKB = fromList $ Knowledge KnowABase qPred . fmap symbol <$> qTuples 67 | 68 | initEDB :: Set 'ABase 69 | initEDB = qKB 70 | 71 | pTuples :: [ V.Vector 1 Sym ] 72 | pTuples = fmap symbol . fromJust . V.fromList <$> 73 | ([ [ 1 ], [ 4 ], [ 5 ] ] :: [ [ Int ] ]) 74 | -------------------------------------------------------------------------------- /src/Language/Exalog/Stratification.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE DuplicateRecordFields #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | module Language.Exalog.Stratification 9 | ( stratify 10 | ) where 11 | 12 | import Protolude hiding (head) 13 | 14 | import qualified Data.Graph.Inductive.Graph as G 15 | import Data.Graph.Inductive.Query.DFS (condensation, topsort) 16 | import Data.List (lookup) 17 | import Data.Maybe (fromJust) 18 | 19 | import Language.Exalog.Core 20 | import Language.Exalog.SrcLoc (SrcSpan(NoSpan)) 21 | import Language.Exalog.Dependency 22 | import Language.Exalog.Logger 23 | 24 | -- |Returns a stratified program in the form of a list to be executed in 25 | -- order. 26 | stratify :: forall a b. Identifiable (PredicateAnn a) b 27 | => Program ('ADependency a) -> Logger (Program a) 28 | stratify pr@Program{} = do 29 | strata <- sequence $ do 30 | comp <- sccs 31 | let polarities = sccPolarities comp 32 | if Negative `elem` polarities 33 | then pure $ 34 | scold NoSpan "Stratification failed due to cyclic use of negation." 35 | else do 36 | let cls = concatMap (search peeledPr) . findPreds depGrDict $ comp 37 | guard (not . null $ cls) 38 | pure $ pure cls 39 | pure $ peeledPr {_strata = Stratum <$> strata} 40 | where 41 | depGr = dependencyGr pr 42 | depGrDict = G.labNodes depGr 43 | 44 | peeledPr = peel pr 45 | 46 | -- Find SCCs like `Data.Graph.Inductive.Query.DFS.scc` but in topological 47 | -- order. 48 | sccs :: [ [ G.Node ] ] 49 | sccs = 50 | let gr = condensation depGr 51 | in findPreds (G.labNodes gr) (topsort gr) 52 | 53 | findPreds :: forall c. [ G.LNode c ] -> [ G.Node ] -> [ c ] 54 | findPreds nodeDict = map (fromJust . flip lookup nodeDict) 55 | 56 | sccPolarities :: [ G.Node ] -> [ Polarity ] 57 | sccPolarities nodes = map (\(_,_,lab) -> lab) 58 | . filter (\(_,dst,_) -> dst `elem` nodes) 59 | . concatMap (G.out' . fromJust . fst . flip G.match depGr) 60 | $ nodes 61 | -------------------------------------------------------------------------------- /src/Language/Exalog/Unification.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module Language.Exalog.Unification 5 | ( Unifier 6 | , empty 7 | , extend 8 | , substitute 9 | , unify 10 | ) where 11 | 12 | import Protolude hiding (empty, sym) 13 | 14 | import Data.List (lookup) 15 | import qualified Data.Vector.Sized as V 16 | 17 | import Language.Exalog.Core 18 | 19 | newtype Unifier = Unifier [ (Var, Sym) ] deriving (Eq, Show) 20 | 21 | empty :: Unifier 22 | empty = Unifier [] 23 | 24 | extend :: Unifier -> Unifier -> Maybe Unifier 25 | Unifier us `extend` Unifier us' = Unifier <$> us `extend'` us' 26 | 27 | extend' :: [ (Var, Sym) ] -> [ (Var, Sym) ] -> Maybe [ (Var, Sym) ] 28 | extend' [] u' = Just u' 29 | extend' (binding@(v,s) : u) u' = 30 | case v `lookup` u' of 31 | Just s' -> if s == s' then extend' u u' else Nothing 32 | Nothing -> (binding:) <$> extend' u u' 33 | 34 | unify :: V.Vector n Term -> V.Vector n Sym -> Maybe Unifier 35 | unify v w = Unifier <$> foldr' attempt (Just []) (V.zip v w) 36 | where 37 | attempt :: (Term, Sym) -> Maybe [ (Var, Sym) ] -> Maybe [ (Var, Sym) ] 38 | attempt _ Nothing = Nothing 39 | attempt (TWild, _) mus = mus 40 | attempt (TSym sym, sym') mus | sym == sym' = mus 41 | | otherwise = Nothing 42 | attempt (TVar var, sym) mus@(Just unifierAcc) = 43 | case var `lookup` unifierAcc of 44 | Just sym' 45 | | sym == sym' -> mus 46 | | otherwise -> Nothing 47 | Nothing -> ((var,sym) :) <$> mus 48 | 49 | class Substitutable a where 50 | substitute :: Unifier -> a -> a 51 | 52 | instance Substitutable (V.Vector n Term) where 53 | substitute (Unifier u) = fmap $ \t -> 54 | case t of 55 | TVar v -> maybe t TSym (v `lookup` u) 56 | TSym{} -> t 57 | TWild -> t 58 | 59 | instance Substitutable (Literal a) where 60 | substitute unifier Literal{..} = 61 | Literal {_terms = unifier `substitute` _terms, ..} 62 | 63 | instance Substitutable (Clause a) where 64 | substitute unifier Clause{..} = 65 | Clause { 66 | _head = unifier `substitute` _head, 67 | _body = substitute unifier <$> _body, 68 | ..} 69 | -------------------------------------------------------------------------------- /fixtures/Fixture/Constant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.Constant 4 | ( program 5 | , initEDB 6 | , rPred 7 | , rTuples 8 | ) where 9 | 10 | import Protolude hiding (Set) 11 | 12 | import Data.Maybe (fromJust) 13 | 14 | import qualified Data.List.NonEmpty as NE 15 | import qualified Data.Vector.Sized as V 16 | import Data.Singletons.TypeLits 17 | 18 | import Language.Exalog.Core 19 | import Language.Exalog.KnowledgeBase.Class 20 | import Language.Exalog.KnowledgeBase.Knowledge 21 | import Language.Exalog.KnowledgeBase.Set 22 | import Language.Exalog.SrcLoc 23 | 24 | import Fixture.Util 25 | 26 | cPred, rPred :: Predicate 2 'ABase 27 | cPred = Predicate (PredABase NoSpan) "c" SNat Logical 28 | rPred = Predicate (PredABase NoSpan) "r" SNat Logical 29 | 30 | c,r :: Term -> Term -> Literal 'ABase 31 | c t t' = lit cPred $ fromJust $ V.fromList [ t, t' ] 32 | r t t' = lit rPred $ fromJust $ V.fromList [ t, t' ] 33 | 34 | {- 35 | - r("c","1") :- c("a","b"). 36 | - r(X ,"2") :- c("a",X). 37 | - r("c","3") :- c("q","b"). 38 | - r("e","4") :- r(X,Y), c("a",X). 39 | - r("f","5") :- c("a",X), r(X,Y). 40 | -} 41 | program :: Program 'ABase 42 | program = Program (ProgABase NoSpan) 43 | (Stratum <$> 44 | [ [ Clause (ClABase NoSpan) (r (tsym ("c" :: Text)) (tsym ("1" :: Text))) $ NE.fromList [ c (tsym ("a" :: Text)) (tsym ("b" :: Text)) ] 45 | , Clause (ClABase NoSpan) (r (tvar "X") (tsym ("2" :: Text))) $ NE.fromList [ c (tsym ("a" :: Text)) (tvar "X") ] 46 | , Clause (ClABase NoSpan) (r (tsym ("c" :: Text)) (tsym ("3" :: Text))) $ NE.fromList [ c (tsym ("q" :: Text)) (tsym ("b" :: Text)) ] 47 | , Clause (ClABase NoSpan) (r (tsym ("e" :: Text)) (tsym ("4" :: Text))) $ NE.fromList 48 | [ r (tvar "X") (tvar "Y") 49 | , c (tsym ("a" :: Text)) (tvar "X") ] 50 | , Clause (ClABase NoSpan) (r (tsym ("f" :: Text)) (tsym ("5" :: Text))) $ NE.fromList 51 | [ c (tsym ("a" :: Text)) (tvar "X") 52 | , r (tvar "X") (tvar "Y") ] 53 | ] 54 | ]) 55 | [ PredicateBox rPred ] 56 | 57 | cTuples :: [ V.Vector 2 Text ] 58 | cTuples = fromJust . V.fromList <$> 59 | [ [ "a" , "b" ] 60 | , [ "a" , "c" ] 61 | , [ "a" , "d" ] 62 | ] 63 | 64 | initEDB :: Set 'ABase 65 | initEDB = fromList $ Knowledge KnowABase cPred . fmap symbol <$> cTuples 66 | 67 | rTuples :: [ V.Vector 2 Sym ] 68 | rTuples = fmap symbol . fromJust . V.fromList <$> 69 | ([ [ "c", "1" ] 70 | , [ "b", "2" ] 71 | , [ "c", "2" ] 72 | , [ "d", "2" ] 73 | , [ "e", "4" ] 74 | , [ "f", "5" ] 75 | ] :: [ [ Text ] ]) 76 | -------------------------------------------------------------------------------- /fixtures/Fixture/Util.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE MonoLocalBinds #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Fixture.Util 11 | ( tvar 12 | , tsym 13 | , symbol 14 | , lit 15 | , not 16 | ) where 17 | 18 | import Protolude hiding (pred, not) 19 | 20 | import Data.String (fromString) 21 | import Data.Singletons 22 | import Data.Singletons.TypeLits 23 | import qualified Data.Vector.Sized as V 24 | 25 | import Test.QuickCheck.Arbitrary 26 | import Test.QuickCheck.Gen 27 | import Language.Exalog.Core 28 | import qualified Language.Exalog.KnowledgeBase.Knowledge as KB 29 | import qualified Language.Exalog.KnowledgeBase.Class as KB 30 | import qualified Language.Exalog.KnowledgeBase.Set as KBS 31 | import Language.Exalog.SrcLoc (SrcSpan(NoSpan)) 32 | 33 | not :: Literal 'ABase -> Literal 'ABase 34 | not l@Literal{_polarity = pol} = 35 | l {_polarity = if pol == Positive then Negative else Positive} 36 | 37 | lit :: Predicate n 'ABase -> V.Vector n Term -> Literal 'ABase 38 | lit = Literal (LitABase NoSpan) Positive 39 | 40 | -- |Smart constructor for terms 41 | tvar :: Text -> Term 42 | tvar = TVar . Var 43 | 44 | class Termable a where 45 | symbol :: a -> Sym 46 | tsym :: a -> Term 47 | tsym = TSym . symbol 48 | {-# MINIMAL symbol #-} 49 | 50 | instance Termable Text where 51 | symbol = SymText 52 | 53 | instance Termable Int where 54 | symbol = SymInt 55 | 56 | instance Termable Bool where 57 | symbol = SymBool 58 | 59 | -- Common and generic arbitrary instances 60 | 61 | -- For Core 62 | instance Arbitrary PredicateSymbol where 63 | arbitrary = fromString <$> arbitrary 64 | 65 | instance SingI n => Arbitrary (Predicate n 'ABase) where 66 | arbitrary = Predicate (PredABase NoSpan) 67 | <$> arbitrary 68 | <*> pure (sing :: SNat n) 69 | <*> pure Logical 70 | 71 | instance Arbitrary Sym => Arbitrary (KB.Knowledge 'ABase) where 72 | arbitrary = do 73 | n <- oneof $ return <$> [1..10] 74 | withSomeSing n $ 75 | \(snat :: SNat n) -> 76 | withKnownNat snat $ 77 | KB.Knowledge KnowABase 78 | <$> (arbitrary :: Gen (Predicate n 'ABase)) 79 | <*> (arbitrary :: Gen (V.Vector n Sym)) 80 | 81 | instance (KnownNat n, Arbitrary a) => Arbitrary (V.Vector n a) where 82 | arbitrary = V.replicateM arbitrary 83 | 84 | instance Arbitrary Sym => Arbitrary (KBS.Set 'ABase) where 85 | arbitrary = KB.fromList <$> arbitrary 86 | -------------------------------------------------------------------------------- /src/Language/Exalog/KnowledgeBase/Knowledge.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE DuplicateRecordFields #-} 11 | {-# LANGUAGE ExistentialQuantification #-} 12 | 13 | module Language.Exalog.KnowledgeBase.Knowledge where 14 | 15 | import Protolude hiding (pred) 16 | 17 | import Data.Aeson (ToJSON(..), (.=), object) 18 | import Data.Singletons 19 | import Data.Singletons.Decide (Decision(..)) 20 | import qualified Data.Vector.Sized as V 21 | 22 | import Language.Exalog.Core 23 | 24 | data Knowledge a = forall n. Knowledge 25 | { _annotation :: KnowledgeAnn a 26 | , _predicate :: Predicate n a 27 | , _terms :: V.Vector n Sym 28 | } 29 | 30 | type instance Ann Knowledge = KnowledgeAnn 31 | 32 | type instance Decored (Knowledge ann) f = Knowledge (f ann) 33 | 34 | type instance Peeled (Knowledge (f ann)) = Knowledge ann 35 | 36 | class KnowledgeMaker ann where 37 | mkKnowledge :: Clause ann -> Predicate n ann -> V.Vector n Sym -> Knowledge ann 38 | 39 | instance KnowledgeMaker 'ABase where 40 | mkKnowledge _ = Knowledge KnowABase 41 | 42 | deriving instance 43 | ( Show (KnowledgeAnn ann) 44 | , Show (PredicateAnn ann) 45 | ) => Show (Knowledge ann) 46 | 47 | instance 48 | ( IdentifiableAnn (PredicateAnn a) b 49 | , IdentifiableAnn (KnowledgeAnn a) c 50 | , Ord b 51 | , Ord c 52 | ) => Ord (Knowledge a) where 53 | Knowledge{_annotation = ann, _predicate = pred, _terms = terms} `compare` 54 | Knowledge{_annotation = ann', _predicate = pred', _terms = terms'} 55 | | Proved Refl <- sameArity pred pred' = 56 | (idFragment ann, pred, terms) `compare` (idFragment ann', pred', terms') 57 | | otherwise = fromSing (_arity pred) `compare` fromSing (_arity pred') 58 | 59 | instance 60 | ( IdentifiableAnn (PredicateAnn a) b 61 | , IdentifiableAnn (KnowledgeAnn a) c 62 | , Eq b 63 | , Eq c 64 | ) => Eq (Knowledge a) where 65 | Knowledge{_annotation = ann, _predicate = pred, _terms = terms} == 66 | Knowledge{_annotation = ann', _predicate = pred', _terms = terms'} 67 | | Proved Refl <- pred `sameArity` pred' = 68 | idFragment ann == idFragment ann' && 69 | pred == pred' && 70 | terms == terms' 71 | | otherwise = False 72 | 73 | instance ToJSON (Knowledge 'ABase) where 74 | toJSON Knowledge{..} = object 75 | [ "predicate" .= toJSON _predicate 76 | , "terms" .= toJSON _terms 77 | ] 78 | -------------------------------------------------------------------------------- /fixtures/Fixture/WellModing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.WellModing where 4 | 5 | import Protolude hiding (pred, guard, not) 6 | 7 | import Data.Maybe (fromJust) 8 | import qualified Data.List.NonEmpty as NE 9 | import qualified Data.Vector.Sized as V 10 | import Data.Singletons.TypeLits 11 | 12 | import Language.Exalog.Core 13 | import Language.Exalog.SrcLoc 14 | import Language.Exalog.Renamer 15 | 16 | import Fixture.Util hiding (lit) 17 | 18 | pred :: Int -> PredicateSymbol -> SNat n -> Nature n -> Predicate n ('ARename 'ABase) 19 | pred id = Predicate (PredARename (PredicateID id) $ PredABase NoSpan) 20 | lit :: Int -> Polarity -> Predicate n ('ARename 'ABase) -> V.Vector n Term -> Literal ('ARename 'ABase) 21 | lit id = Literal (LitARename (LiteralID id) $ LitABase NoSpan) 22 | cl :: Int -> Head ('ARename 'ABase) -> Body ('ARename 'ABase) -> Clause ('ARename 'ABase) 23 | cl id = Clause (ClARename (ClauseID id) $ ClABase NoSpan) 24 | 25 | pPred, qPred, aPred, guardPred :: Predicate 1 ('ARename 'ABase) 26 | pPred = pred 0 "p" SNat Logical 27 | qPred = pred 1 "q" SNat Logical 28 | aPred = pred 2 "q" SNat Logical 29 | guardPred = pred 3 "guard0" SNat Logical 30 | 31 | queryPred :: Predicate 0 ('ARename 'ABase) 32 | queryPred = pred 4 "query" SNat Logical 33 | 34 | p, notq, a, guard :: Int -> Term -> Literal ('ARename 'ABase) 35 | p id t = lit id Positive pPred (fromJust $ V.fromList [ t ]) 36 | notq id t = lit id Negative qPred (fromJust $ V.fromList [ t ]) 37 | a id t = lit id Positive aPred (fromJust $ V.fromList [ t ]) 38 | guard id t = lit id Positive guardPred (fromJust $ V.fromList [ t ]) 39 | 40 | query :: Int -> Literal ('ARename 'ABase) 41 | query id = lit id Positive queryPred (fromJust $ V.fromList [ ]) 42 | 43 | {-| 44 | - p(X) :- ! q(X). 45 | - query() :- a(X), p(X). 46 | |-} 47 | prSimple :: Program ('ARename 'ABase) 48 | prSimple = Program (ProgARename $ ProgABase NoSpan) 49 | (Stratum <$> 50 | [ [ cl 100 (p 10 (tvar "X")) $ NE.fromList [ notq 99 (tvar "X") ] 51 | , cl 200 (query 20) $ NE.fromList [ a 30 (tvar "X"), p 40 (tvar "X") ] 52 | ] 53 | ]) 54 | [ PredicateBox queryPred ] 55 | 56 | {-| 57 | - p(X) :- ! q(X). 58 | - query() :- a(X), p(X). 59 | |-} 60 | prSimpleRepaired :: Program 'ABase 61 | prSimpleRepaired = peel $ Program (ProgARename $ ProgABase NoSpan) 62 | (Stratum <$> 63 | [ [ cl 100 (p 10 (tvar "X")) $ NE.fromList [ guard 50 (tvar "X"), notq 99 (tvar "X") ] 64 | , cl 200 (query 20) $ NE.fromList [ a 30 (tvar "X") , p 40 (tvar "X") ] 65 | , cl 300 (guard 70 (tvar "X")) $ NE.fromList [ a 60 (tvar "X") ] 66 | ] 67 | ]) 68 | [ PredicateBox queryPred ] 69 | -------------------------------------------------------------------------------- /src/Language/Exalog/Annotation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE AllowAmbiguousTypes #-} 7 | {-# LANGUAGE DuplicateRecordFields #-} 8 | {-# LANGUAGE FunctionalDependencies #-} 9 | 10 | module Language.Exalog.Annotation 11 | ( AnnType(..) 12 | , PredicateAnn(..) 13 | , LiteralAnn(..) 14 | , ClauseAnn(..) 15 | , ProgramAnn(..) 16 | , KnowledgeAnn(..) 17 | , type Ann 18 | , PeelableAnn(..) 19 | , DecorableAnn(..) 20 | , SpannableAnn(..) 21 | , IdentifiableAnn(..) 22 | , Identifiable 23 | ) where 24 | 25 | import Protolude 26 | 27 | import Language.Exalog.SrcLoc 28 | import Language.Exalog.Pretty.Helper (Pretty) 29 | 30 | data AnnType = 31 | ABase 32 | | ADelta AnnType 33 | | ADependency AnnType 34 | | AAdornment AnnType 35 | | ARename AnnType 36 | | AProvenance AnnType 37 | 38 | data family PredicateAnn (a :: AnnType) 39 | data instance PredicateAnn 'ABase = PredABase {_span :: SrcSpan} 40 | deriving (Eq, Ord, Show) 41 | 42 | data family LiteralAnn (a :: AnnType) 43 | data instance LiteralAnn 'ABase = LitABase {_span :: SrcSpan} 44 | deriving (Eq, Ord, Show) 45 | 46 | data family ClauseAnn (a :: AnnType) 47 | data instance ClauseAnn 'ABase = ClABase {_span :: SrcSpan} 48 | deriving (Eq, Ord, Show) 49 | 50 | data family ProgramAnn (a :: AnnType) 51 | data instance ProgramAnn 'ABase = ProgABase {_span :: SrcSpan} 52 | deriving (Eq, Ord, Show) 53 | 54 | data family KnowledgeAnn (a :: AnnType) 55 | data instance KnowledgeAnn 'ABase = KnowABase 56 | deriving (Eq, Ord, Show) 57 | 58 | type family Ann (a :: AnnType -> Type) :: (AnnType -> Type) 59 | 60 | class PeelableAnn (f :: AnnType -> Type) (ann :: AnnType -> AnnType) where 61 | peelA :: f (ann a) -> f a 62 | 63 | class DecorableAnn (f :: AnnType -> Type) (ann :: AnnType -> AnnType) where 64 | decorA :: f a -> f (ann a) 65 | 66 | class SpannableAnn a where 67 | annSpan :: a -> SrcSpan 68 | 69 | instance SpannableAnn (PredicateAnn 'ABase) where annSpan = span 70 | instance SpannableAnn (LiteralAnn 'ABase) where annSpan = span 71 | instance SpannableAnn (ClauseAnn 'ABase) where annSpan = span 72 | instance SpannableAnn (ProgramAnn 'ABase) where annSpan = span 73 | 74 | class IdentifiableAnn a b | a -> b where 75 | idFragment :: a -> b 76 | 77 | instance IdentifiableAnn (PredicateAnn 'ABase) () where idFragment = const () 78 | instance IdentifiableAnn (LiteralAnn 'ABase) () where idFragment = const () 79 | instance IdentifiableAnn (ClauseAnn 'ABase) () where idFragment = const () 80 | instance IdentifiableAnn (ProgramAnn 'ABase) () where idFragment = const () 81 | instance IdentifiableAnn (KnowledgeAnn 'ABase) () where idFragment = const () 82 | 83 | type Identifiable a b = (IdentifiableAnn a b, Eq b, Ord b, Pretty b) 84 | -------------------------------------------------------------------------------- /fixtures/Fixture/Ancestor/LinearAncestor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.Ancestor.LinearAncestor 4 | ( program 5 | , deltaStratum 6 | , adornedProgram 7 | ) where 8 | 9 | import Protolude 10 | 11 | import qualified Data.List.NonEmpty as NE 12 | 13 | import Language.Exalog.Core 14 | import Language.Exalog.Delta 15 | import Language.Exalog.Adornment 16 | import Language.Exalog.SrcLoc 17 | 18 | import Fixture.Ancestor.Common 19 | import Fixture.Util 20 | 21 | {-| Linear ancestor program: 22 | - 23 | - anc(X,Z) :- par(X,Y), anc(Y,Z). 24 | - anc(X,Y) :- par(X,Y). 25 | |-} 26 | program :: Program 'ABase 27 | program = Program (ProgABase NoSpan) 28 | (Stratum <$> 29 | [ [ Clause (ClABase NoSpan) (anc (tvar "X") (tvar "Z")) $ NE.fromList 30 | [ par (tvar "X") (tvar "Y"), anc (tvar "Y") (tvar "Z") ] 31 | , Clause (ClABase NoSpan) (anc (tvar "X") (tvar "Y")) $ NE.fromList 32 | [ par (tvar "X") (tvar "Y") ] 33 | ] 34 | ]) 35 | [ PredicateBox ancPred, PredicateBox parPred ] 36 | 37 | {-| Linear ancestor program deltafied: 38 | - 39 | - delta_{i+1}_anc(X,Z) :- par(X,Y), delta_anc_i(Y,Z). 40 | |-} 41 | deltaStratum :: Stratum ('ADelta 'ABase) 42 | deltaStratum = Stratum 43 | [ Clause (decorA (ClABase NoSpan)) (mkDeltaLiteral Delta $ anc (tvar "X") (tvar "Z")) 44 | $ NE.fromList 45 | [ mkDeltaLiteral Constant $ par (tvar "X") (tvar "Y") 46 | , mkDeltaLiteral Delta $ anc (tvar "Y") (tvar "Z") ] 47 | ] 48 | 49 | {-| Linear ancestor program adorned: 50 | - 51 | - anc_ff(X,Z) :- par_ff(X,Y), anc_bf(Y,Z). 52 | - anc_bf(X,Z) :- par_bf(X,Y), anc_bf(Y,Z). 53 | - anc_ff(X,Y) :- par_ff(X,Y). 54 | - anc_bf(X,Y) :- par_bf(X,Y). 55 | |-} 56 | adornedProgram :: Program ('AAdornment 'ABase) 57 | adornedProgram = Program (decorA (ProgABase NoSpan)) 58 | (Stratum <$> 59 | [ [ Clause (decorA (ClABase NoSpan)) 60 | (adornLiteral [ Free, Free ] $ anc (tvar "X") (tvar "Z")) 61 | $ NE.fromList 62 | [ adornLiteral [ Free, Free ] $ par (tvar "X") (tvar "Y") 63 | , adornLiteral [ Bound, Free ] $ anc (tvar "Y") (tvar "Z") ] 64 | , Clause (decorA (ClABase NoSpan)) 65 | (adornLiteral [ Bound, Free ] $ anc (tvar "X") (tvar "Z")) 66 | $ NE.fromList 67 | [ adornLiteral [ Bound, Free ] $ par (tvar "X") (tvar "Y") 68 | , adornLiteral [ Bound, Free ] $ anc (tvar "Y") (tvar "Z") ] 69 | , Clause (decorA (ClABase NoSpan)) 70 | (adornLiteral [ Free, Free ] $ anc (tvar "X") (tvar "Y")) 71 | $ NE.fromList 72 | [ adornLiteral [ Free, Free ] $ par (tvar "X") (tvar "Y") ] 73 | , Clause (decorA (ClABase NoSpan)) 74 | (adornLiteral [ Bound, Free ] $ anc (tvar "X") (tvar "Y")) 75 | $ NE.fromList 76 | [ adornLiteral [ Bound, Free ] $ par (tvar "X") (tvar "Y") ] 77 | ] 78 | ]) 79 | [ PredicateBox . decorate $ ancPred 80 | , PredicateBox . decorate $ parPred 81 | ] 82 | -------------------------------------------------------------------------------- /src/Language/Exalog/RangeRestriction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | module Language.Exalog.RangeRestriction 9 | ( RangeRestriction(..) 10 | , fixRangeRestriction 11 | ) where 12 | 13 | import Protolude hiding (diff, head, pred, sym) 14 | 15 | import Control.Arrow ((&&&)) 16 | 17 | import Data.List ((\\)) 18 | import qualified Data.List.NonEmpty as NE 19 | 20 | import Language.Exalog.Core 21 | import Language.Exalog.Logger 22 | import Language.Exalog.Dataflow 23 | import Language.Exalog.DataflowRepair 24 | import qualified Language.Exalog.KnowledgeBase.Class as KB 25 | import Language.Exalog.SrcLoc (Spannable(..)) 26 | 27 | -- |Checks if all variables in the head appear in the bodies of the 28 | -- clauses. 29 | -- 30 | -- This allows domain independence (changing the underlying types in a way 31 | -- compatible with the data in the database/EDB) does not cause a change in 32 | -- the query results. 33 | -- 34 | -- It also contributes to finiteness of results (allowing tabulation of all 35 | -- ground facts) by preventing concluding facts such as $p(X,X)$. 36 | -- 37 | -- A final benefit is facilitating data provenance. This restriction does 38 | -- not solely ensure but contribute to the fact that all ground terms we 39 | -- use come from somewhere in the original EDB. 40 | class RangeRestriction ast where 41 | checkRangeRestriction :: ast -> Logger () 42 | isRangeRestricted :: ast -> Bool 43 | 44 | instance SpannableAnn (ClauseAnn ann) => RangeRestriction (Program ann) where 45 | checkRangeRestriction Program{..} = traverse_ checkRangeRestriction (join $ map _unStratum _strata) 46 | isRangeRestricted Program{..} = all isRangeRestricted (join $ map _unStratum _strata) 47 | 48 | instance SpannableAnn (ClauseAnn ann) => RangeRestriction (Clause ann) where 49 | checkRangeRestriction cl = 50 | unless (isRangeRestricted cl) $ 51 | scold (span cl) "Range restriction is violated." 52 | 53 | isRangeRestricted Clause{..} = 54 | null $ variables _head \\ mconcat (variables <$> NE.toList _body) 55 | 56 | fixRangeRestriction :: KB.Knowledgeable kb 'ABase 57 | => Monoid (kb 'ABase) 58 | => KB.Knowledgeable kb ('ARename 'ABase) 59 | => (Program ('ARename 'ABase), kb ('ARename 'ABase)) 60 | -> Logger (Program 'ABase, kb 'ABase) 61 | fixRangeRestriction = 62 | fixDataflow (pure <$> rangeRestrictionViolations) 63 | "Not range-restricted and cannot be repaired due to its dataflow." 64 | 65 | rangeRestrictionViolations :: Clause ('ARename ann) -> [ (FlowSink ann, Var) ] 66 | rangeRestrictionViolations Clause{..} = map (genSink . fst &&& snd) 67 | . filter (isRestriction . snd) 68 | . zip [0..] 69 | $ variables _head 70 | where 71 | isRestriction var = var `notElem` bodyVariables 72 | genSink = FSinkPredicate (predicateBox _head) 73 | bodyVariables = mconcat $ variables <$> NE.toList _body 74 | -------------------------------------------------------------------------------- /fixtures/Fixture/Unification.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.Unification 4 | ( program 5 | , initEDB 6 | , samePred 7 | , sameTuples 8 | ) where 9 | 10 | import Protolude hiding (Set) 11 | 12 | import Data.Maybe (fromJust) 13 | 14 | import qualified Data.List.NonEmpty as NE 15 | import qualified Data.Vector.Sized as V 16 | import Data.Singletons.TypeLits 17 | 18 | import Language.Exalog.Core 19 | import Language.Exalog.KnowledgeBase.Class 20 | import Language.Exalog.KnowledgeBase.Knowledge 21 | import Language.Exalog.KnowledgeBase.Set 22 | import Language.Exalog.SrcLoc 23 | 24 | import Fixture.Util 25 | 26 | samePred :: Predicate 2 'ABase 27 | samePred = Predicate (PredABase NoSpan) "same" SNat Logical 28 | 29 | fxPred :: Predicate 3 'ABase 30 | fxPred = Predicate (PredABase NoSpan) "fx" SNat Logical 31 | 32 | same :: Term -> Term -> Literal 'ABase 33 | same t t' = lit samePred $ fromJust $ V.fromList [ t, t' ] 34 | 35 | fx :: Term -> Term -> Term -> Literal 'ABase 36 | fx t t' t'' = lit fxPred $ fromJust $ V.fromList [ t, t', t'' ] 37 | 38 | {- 39 | - fx(A, B, C) :- fx(A', B, C), same(A, A'). 40 | - fx(A, B, C) :- fx(A, B', C), same(B, B'). 41 | - fx(A, B, C) :- fx(A, B, C'), same(C, C'). 42 | 43 | same(A, A') :- fx(A, B, C), fx(A', B, C). 44 | same(C, C') :- fx(A, _, C), fx(A, _, C'). 45 | same(B, B') :- fx(A, B, _), fx(A, B', _). 46 | -} 47 | program :: Program 'ABase 48 | program = Program (ProgABase NoSpan) 49 | (Stratum <$> 50 | [ [ Clause (ClABase NoSpan) (fx (tvar "A") (tvar "B") (tvar "C")) $ NE.fromList [ fx (tvar "A'") (tvar "B") (tvar "C"), same (tvar "A") (tvar "A'") ] 51 | , Clause (ClABase NoSpan) (fx (tvar "A") (tvar "B") (tvar "C")) $ NE.fromList [ fx (tvar "A") (tvar "B'") (tvar "C"), same (tvar "B") (tvar "B'") ] 52 | , Clause (ClABase NoSpan) (fx (tvar "A") (tvar "B") (tvar "C")) $ NE.fromList [ fx (tvar "A") (tvar "B") (tvar "C'"), same (tvar "C") (tvar "C'") ] 53 | 54 | , Clause (ClABase NoSpan) (same (tvar "A") (tvar "A'")) $ NE.fromList [ fx (tvar "A") (tvar "B") (tvar "C"), fx (tvar "A'") (tvar "B") (tvar "C") ] 55 | , Clause (ClABase NoSpan) (same (tvar "C") (tvar "C'")) $ NE.fromList [ fx (tvar "A") TWild (tvar "C"), fx (tvar "A") TWild (tvar "C'") ] 56 | , Clause (ClABase NoSpan) (same (tvar "B") (tvar "B'")) $ NE.fromList [ fx (tvar "A") (tvar "B") TWild, fx (tvar "A'") (tvar "B'") TWild ] 57 | ] 58 | ]) 59 | [ PredicateBox samePred, PredicateBox fxPred ] 60 | 61 | sameTuples :: [ V.Vector 2 Text ] 62 | sameTuples = fromJust . V.fromList <$> 63 | [ [ "1" , "5" ] 64 | , [ "1" , "7" ] 65 | , [ "12" , "14" ] 66 | , [ "3" , "9" ] -- Remove for mildly bad performance 67 | ] 68 | 69 | fxTuples :: [ V.Vector 3 Text ] 70 | fxTuples = fromJust . V.fromList <$> 71 | [ [ "12" , "1" , "8" ] -- Remove for mildly bad performance 72 | , [ "13" , "10" , "10" ] -- Remove for mildly bad performance 73 | , [ "14" , "13" , "11" ] -- Remove for mildly bad performance 74 | , [ "4" , "2" , "2" ] 75 | , [ "5" , "4" , "3" ] 76 | , [ "7" , "int" , "6" ] 77 | , [ "9" , "6" , "8" ] 78 | ] 79 | 80 | initEDB :: Set 'ABase 81 | initEDB = fromList 82 | $ (Knowledge KnowABase samePred . fmap symbol <$> sameTuples) 83 | <> (Knowledge KnowABase fxPred . fmap symbol <$> fxTuples) 84 | -------------------------------------------------------------------------------- /src/Language/Exalog/KnowledgeBase/Set.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE GeneralisedNewtypeDeriving #-} 12 | 13 | module Language.Exalog.KnowledgeBase.Set where 14 | 15 | import Protolude hiding (Set, toList, pred) 16 | 17 | import GHC.Prim (coerce) 18 | 19 | import qualified Data.Set as S 20 | import Data.Singletons.Decide (Decision(Proved)) 21 | 22 | import Language.Exalog.Core 23 | import Language.Exalog.KnowledgeBase.Class 24 | import Language.Exalog.KnowledgeBase.Knowledge 25 | 26 | newtype Set ann = Set (S.Set (Knowledge ann)) 27 | 28 | instance 29 | ( IdentifiableAnn (Ann Knowledge ann) id1 30 | , IdentifiableAnn (Ann (Predicate n) ann) id2 31 | , Ord id1, Ord id2 32 | ) => Knowledgeable Set ann where 33 | fromList = Set . S.fromList 34 | toList = S.toList . coerce 35 | 36 | add x = coerce . S.insert x . coerce 37 | 38 | partition p = coerce . S.partition p . coerce 39 | 40 | filter p = coerce . S.filter p . coerce 41 | 42 | difference kb kb' = coerce $ S.difference (coerce kb) (coerce kb') 43 | 44 | findByPred pred kb = foldr' go mempty (toList kb) 45 | where 46 | go (Knowledge _ pred' syms) acc 47 | | Proved Refl <- pred `sameArity` pred' 48 | , pred == pred' = syms : acc 49 | | otherwise = acc 50 | 51 | atEach f = coerce . S.map f . coerce 52 | 53 | singleton = coerce . S.singleton 54 | 55 | size = S.size . coerce 56 | 57 | null = S.null . coerce 58 | 59 | type instance Decored (Set ann) f = Set (f ann) 60 | 61 | instance ( IdentifiableAnn (PredicateAnn a) id 62 | , IdentifiableAnn (PredicateAnn (ann a)) id' 63 | , IdentifiableAnn (KnowledgeAnn a) id'' 64 | , IdentifiableAnn (KnowledgeAnn (ann a)) id''' 65 | , Ord id, Ord id', Ord id'', Ord id''' 66 | , DecorableAST (Knowledge a) ann 67 | ) => DecorableAST (Set a) ann where 68 | decorate = atEach decorate 69 | 70 | type instance Peeled (Set (ann a)) = Set a 71 | 72 | instance ( IdentifiableAnn (PredicateAnn a) id1 73 | , IdentifiableAnn (PredicateAnn (f a)) id2 74 | , IdentifiableAnn (KnowledgeAnn a) id3 75 | , IdentifiableAnn (KnowledgeAnn (f a)) id4 76 | , Ord id1, Ord id2, Ord id3, Ord id4 77 | , PeelableAST (Knowledge (f a)) 78 | ) => PeelableAST (Set (f (a :: AnnType))) where 79 | peel = atEach peel 80 | 81 | deriving instance 82 | ( IdentifiableAnn (Ann Knowledge ann) id1 83 | , IdentifiableAnn (PredicateAnn ann) id2 84 | , Ord id1, Ord id2 85 | ) => Eq (Set ann) 86 | 87 | deriving instance 88 | ( IdentifiableAnn (Ann Knowledge ann) id1 89 | , IdentifiableAnn (PredicateAnn ann) id2 90 | , Ord id1, Ord id2 91 | ) => Semigroup (Set ann) 92 | 93 | deriving instance 94 | ( IdentifiableAnn (Ann Knowledge ann) id1 95 | , IdentifiableAnn (PredicateAnn ann) id2 96 | , Ord id1, Ord id2 97 | ) => Monoid (Set ann) 98 | 99 | deriving instance (Show (KnowledgeAnn ann), Show (PredicateAnn ann)) => Show (Set ann) 100 | -------------------------------------------------------------------------------- /fixtures/Fixture/Negation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.Negation where 4 | 5 | import Protolude hiding (not, Set) 6 | 7 | import qualified Data.List.NonEmpty as NE 8 | import Data.Maybe (fromJust) 9 | import qualified Data.Vector.Sized as V 10 | import Data.Singletons.TypeLits 11 | 12 | import Language.Exalog.Core 13 | import Language.Exalog.KnowledgeBase.Class 14 | import Language.Exalog.KnowledgeBase.Knowledge 15 | import Language.Exalog.KnowledgeBase.Set 16 | import Language.Exalog.SrcLoc (SrcSpan(NoSpan)) 17 | 18 | import Fixture.Util 19 | 20 | rPred, tPred, tcPred :: Predicate 2 'ABase 21 | rPred = Predicate (PredABase NoSpan) "r" SNat Logical 22 | tPred = Predicate (PredABase NoSpan) "t" SNat Logical 23 | tcPred = Predicate (PredABase NoSpan) "tc" SNat Logical 24 | 25 | vPred :: Predicate 1 'ABase 26 | vPred = Predicate (PredABase NoSpan) "v" SNat Logical 27 | 28 | r, t, tc :: Term -> Term -> Literal 'ABase 29 | r term term' = lit rPred $ fromJust $ V.fromList [ term, term' ] 30 | t term term' = lit tPred $ fromJust $ V.fromList [ term, term' ] 31 | tc term term' = lit tcPred $ fromJust $ V.fromList [ term, term' ] 32 | 33 | v :: Term -> Literal 'ABase 34 | v term = lit vPred $ fromJust $ V.fromList [ term ] 35 | 36 | {- Compute complement of transitive closure of a graph 37 | - 38 | - v(x) :- r(x,y) 39 | - v(y) :- r(x,y). 40 | - t(x,y) :- r(x,y). 41 | - t(x,y) :- t(x,z), r(z,y). 42 | - tc(x,y):- v(x), v(y), not t(x,y). 43 | -} 44 | program :: Program 'ABase 45 | program = Program (ProgABase NoSpan) 46 | (Stratum <$> 47 | [ [ Clause (ClABase NoSpan) (v (tvar "X")) $ NE.fromList [ r (tvar "X") (tvar "Y") ] 48 | , Clause (ClABase NoSpan) (v (tvar "Y")) $ NE.fromList [ r (tvar "X") (tvar "Y") ] 49 | , Clause (ClABase NoSpan) (t (tvar "X") (tvar "Y")) $ NE.fromList 50 | [ r (tvar "X") (tvar "Y") ] 51 | , Clause (ClABase NoSpan) (t (tvar "X") (tvar "Y")) $ NE.fromList 52 | [ t (tvar "X") (tvar "Z"), r (tvar "Z") (tvar "Y") ] 53 | , Clause (ClABase NoSpan) (tc (tvar "X") (tvar "Y")) $ NE.fromList 54 | [ v (tvar "X"), v (tvar "Y"), not $ t (tvar "X") (tvar "Y") ] 55 | ] ]) 56 | [ PredicateBox rPred 57 | , PredicateBox tPred 58 | , PredicateBox tcPred 59 | , PredicateBox vPred 60 | ] 61 | 62 | rKB :: Set 'ABase 63 | rKB = fromList $ Knowledge KnowABase rPred . fmap symbol . fromJust . V.fromList <$> 64 | ([ [ "x" , "y" ] 65 | , [ "x" , "z" ] 66 | , [ "z" , "x" ] 67 | , [ "y" , "w" ] 68 | , [ "x" , "x" ] 69 | ] :: [ [ Text ] ]) 70 | 71 | initEDB :: Set 'ABase 72 | initEDB = rKB 73 | 74 | vKB :: Set 'ABase 75 | vKB = fromList $ Knowledge KnowABase vPred . fmap symbol . fromJust . V.fromList <$> 76 | ([ [ "x" ], [ "y" ], [ "z" ], [ "w" ] ] :: [ [ Text ] ]) 77 | 78 | tKB :: Set 'ABase 79 | tKB = fromList $ Knowledge KnowABase tPred . fmap symbol . fromJust . V.fromList <$> 80 | ([ [ "x" , "x" ] 81 | , [ "x" , "y" ] 82 | , [ "y" , "w" ] 83 | , [ "x" , "w" ] 84 | , [ "x" , "z" ] 85 | , [ "z" , "x" ] 86 | , [ "z" , "y" ] 87 | , [ "z" , "w" ] 88 | , [ "z" , "z" ] 89 | ] :: [ [ Text ] ]) 90 | 91 | tcKB :: Set 'ABase 92 | tcKB = fromList $ Knowledge KnowABase tcPred . fmap symbol . fromJust . V.fromList <$> 93 | ([ [ "y" , "x" ] 94 | , [ "y" , "z" ] 95 | , [ "w" , "z" ] 96 | , [ "w" , "x" ] 97 | , [ "y" , "y" ] 98 | , [ "w" , "w" ] 99 | , [ "w" , "y" ] 100 | ] :: [ [ Text ] ]) 101 | 102 | finalEDB :: Set 'ABase 103 | finalEDB = initEDB <> vKB <> tKB <> tcKB 104 | -------------------------------------------------------------------------------- /src/Language/Exalog/WellModing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | module Language.Exalog.WellModing 8 | ( WellModed(..) 9 | , Moded(..) 10 | , fixModing 11 | ) where 12 | 13 | import Protolude hiding (head) 14 | 15 | import Data.Finite (getFinite) 16 | import Data.Singletons (fromSing) 17 | import qualified Data.Vector.Sized as V 18 | 19 | import Language.Exalog.Adornment 20 | import Language.Exalog.Core 21 | import Language.Exalog.Dataflow 22 | import Language.Exalog.DataflowRepair 23 | import qualified Language.Exalog.KnowledgeBase.Class as KB 24 | import Language.Exalog.Logger 25 | import Language.Exalog.SrcLoc (span) 26 | 27 | class WellModed ast where 28 | checkWellModedness :: ast -> Logger () 29 | isWellModed :: ast -> Bool 30 | 31 | instance ( SpannableAnn (LiteralAnn ann) 32 | , Moded (Program ('AAdornment ann)) 33 | ) => WellModed (Program ann) where 34 | checkWellModedness Program{..} = traverse_ checkWellModedness (join $ map _unStratum _strata) 35 | isWellModed Program{..} = all isWellModed $ join $ map _unStratum _strata 36 | 37 | instance ( SpannableAnn (LiteralAnn ann) 38 | , Moded (Clause ('AAdornment ann)) 39 | ) => WellModed (Clause ann) where 40 | checkWellModedness cl@Clause{..} = checkWellModability $ adornClause (allFree _head) cl 41 | isWellModed cl@Clause{..} = isWellModable $ adornClause (allFree _head) cl 42 | 43 | allFree :: Literal ann -> [ Adornment ] 44 | allFree Literal{_predicate = Predicate{..}} = 45 | replicate (fromIntegral . fromSing $ _arity) Free 46 | 47 | class Moded ast where 48 | checkWellModability :: ast -> Logger () 49 | isWellModable :: ast -> Bool 50 | 51 | instance SpannableAnn (LiteralAnn ann) 52 | => Moded (Program ('AAdornment ann)) where 53 | checkWellModability Program{..} = traverse_ checkWellModability $ join $ map _unStratum _strata 54 | isWellModable Program{..} = all isWellModable $ join $ map _unStratum _strata 55 | 56 | instance SpannableAnn (LiteralAnn ann) => Moded (Clause ('AAdornment ann)) where 57 | checkWellModability Clause{..} = traverse_ checkWellModability _body 58 | isWellModable Clause{..} = all isWellModable _body 59 | 60 | instance SpannableAnn (LiteralAnn ann) 61 | => Moded (Literal ('AAdornment ann)) where 62 | checkWellModability lit = 63 | unless (isWellModable lit) $ scold (span lit) "Not well-modable." 64 | isWellModable lit@Literal{..} 65 | | Positive <- _polarity = True 66 | | otherwise = (`all` zip (adornment lit) (V.toList _terms)) $ \case 67 | (Free, TVar{}) -> False 68 | _ -> True 69 | 70 | fixModing :: KB.Knowledgeable kb 'ABase 71 | => KB.Knowledgeable kb ('ARename 'ABase) 72 | => Monoid (kb 'ABase) 73 | => (Program ('ARename 'ABase), kb ('ARename 'ABase)) 74 | -> Logger (Program 'ABase, kb 'ABase) 75 | fixModing = 76 | fixDataflow modingViolations 77 | "Not well-moded and cannot be repaired due to its dataflow." 78 | 79 | modingViolations :: Monad m 80 | => Clause ('ARename 'ABase) 81 | -> RepairT m [ (FlowSink 'ABase, Var) ] 82 | modingViolations Clause{_body = body} = do 83 | flowGr <- getPositiveFlowGraph 84 | 85 | pure $ sconcat $ (<$> body) $ \lit@Literal{..} -> 86 | catMaybes . V.toList $ (`V.imap` _terms) $ \fin -> \case 87 | TVar var -> 88 | let ix = fromInteger $ getFinite fin 89 | in if _polarity == Negative && isPredPredicate flowGr lit ix 90 | then Just (FSinkLiteral lit ix, var) 91 | else Nothing 92 | _ -> Nothing 93 | -------------------------------------------------------------------------------- /fixtures/Fixture/RangeRestriction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.RangeRestriction where 4 | 5 | import Protolude 6 | 7 | import Data.Maybe (fromJust) 8 | import qualified Data.List.NonEmpty as NE 9 | import qualified Data.Vector.Sized as V 10 | import Data.Singletons.TypeLits 11 | 12 | import Language.Exalog.Core 13 | import Language.Exalog.Renamer 14 | import Language.Exalog.SrcLoc 15 | import qualified Language.Exalog.KnowledgeBase.Class as KB 16 | import qualified Language.Exalog.KnowledgeBase.Knowledge as KB 17 | import qualified Language.Exalog.KnowledgeBase.Set as KB 18 | 19 | import Fixture.Util 20 | 21 | pPred, rPred, guard0Pred, queryPred :: Predicate 1 'ABase 22 | pPred = Predicate (PredABase NoSpan) "p" SNat Logical 23 | rPred = Predicate (PredABase NoSpan) "r" SNat Logical 24 | guard0Pred = Predicate (PredABase NoSpan) "guard0" SNat Logical 25 | queryPred = Predicate (PredABase NoSpan) "query" SNat Logical 26 | 27 | pPred', rPred', guard0Pred', queryPred' :: Predicate 1 ('ARename 'ABase) 28 | pPred' = Predicate (PredARename (PredicateID 0) $ PredABase NoSpan) "p" SNat Logical 29 | rPred' = Predicate (PredARename (PredicateID 1) $ PredABase NoSpan) "r" SNat Logical 30 | guard0Pred' = Predicate (PredARename (PredicateID 2) $ PredABase NoSpan) "guard0" SNat Logical 31 | queryPred' = Predicate (PredARename (PredicateID 3) $ PredABase NoSpan) "query" SNat Logical 32 | 33 | qPred :: Predicate 0 'ABase 34 | qPred = Predicate (PredABase NoSpan) "q" SNat Logical 35 | 36 | qPred' :: Predicate 0 ('ARename 'ABase) 37 | qPred' = Predicate (PredARename (PredicateID 4) $ PredABase NoSpan) "q" SNat Logical 38 | 39 | p, r, guard0, query :: Term -> Literal 'ABase 40 | p t = lit pPred $ fromJust $ V.fromList [ t ] 41 | r t = lit rPred $ fromJust $ V.fromList [ t ] 42 | guard0 t = lit guard0Pred $ fromJust $ V.fromList [ t ] 43 | query t = lit queryPred $ fromJust $ V.fromList [ t ] 44 | 45 | p', r', guard0', query' :: Term -> Literal ('ARename 'ABase) 46 | p' t = Literal (LitARename (LiteralID 5) $ LitABase NoSpan) Positive pPred' (fromJust $ V.fromList [ t ]) 47 | r' t = Literal (LitARename (LiteralID 6) $ LitABase NoSpan) Positive rPred' (fromJust $ V.fromList [ t ]) 48 | guard0' t = Literal (LitARename (LiteralID 7) $ LitABase NoSpan) Positive guard0Pred' (fromJust $ V.fromList [ t ]) 49 | query' t = Literal (LitARename (LiteralID 8) $ LitABase NoSpan) Positive queryPred' (fromJust $ V.fromList [ t ]) 50 | 51 | q :: Literal 'ABase 52 | q = lit qPred $ fromJust $ V.fromList [ ] 53 | 54 | q' :: Literal ('ARename 'ABase) 55 | q' = Literal (LitARename (LiteralID 9) $ LitABase NoSpan) Positive qPred' (fromJust $ V.fromList [ ]) 56 | 57 | {-| 58 | - p(X) :- q() 59 | - query(X) :- r(X), p(X) 60 | |-} 61 | prSimple :: Program ('ARename 'ABase) 62 | prSimple = Program (ProgARename $ ProgABase NoSpan) 63 | (Stratum <$> 64 | [ [ Clause (ClARename (ClauseID 10) $ ClABase NoSpan) (p' (tvar "X")) $ NE.fromList [ q' ] 65 | , Clause (ClARename (ClauseID 11) $ ClABase NoSpan) (query' (tvar "X")) $ NE.fromList 66 | [ r' (tvar "X"), p' (tvar "X") ] 67 | ] 68 | ]) 69 | [ PredicateBox queryPred' ] 70 | 71 | {-| 72 | - p(X) :- guard(X), q() 73 | - query(X) :- r(X), p(X) 74 | - guard(X) :- r(X) 75 | |-} 76 | prSimpleRepaired :: Program 'ABase 77 | prSimpleRepaired = Program (ProgABase NoSpan) 78 | (Stratum <$> 79 | [ [ Clause (ClABase NoSpan) (p (tvar "X")) $NE.fromList 80 | [ guard0 (tvar "X"), q ] 81 | , Clause (ClABase NoSpan) (query (tvar "X")) $ NE.fromList 82 | [ r (tvar "X"), p (tvar "X") ] 83 | , Clause (ClABase NoSpan) (guard0 (tvar "X")) $ NE.fromList 84 | [ r (tvar "X") ] 85 | ] 86 | ]) 87 | [ PredicateBox queryPred ] 88 | 89 | guard0Tuples :: [ V.Vector 1 Int ] 90 | guard0Tuples = fromJust . V.fromList <$> [ [ 1 ] ] 91 | 92 | guard0Rel :: KB.Set 'ABase 93 | guard0Rel = KB.fromList $ KB.Knowledge KnowABase guard0Pred . fmap symbol <$> guard0Tuples 94 | -------------------------------------------------------------------------------- /src/Language/Exalog/SrcLoc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | module Language.Exalog.SrcLoc 9 | ( SrcLoc(..) 10 | , InputSource(..) 11 | , SrcSpan(..) 12 | , transSpan 13 | , listSpan 14 | , prettySpan 15 | , Spannable(..) 16 | ) where 17 | 18 | import Protolude hiding ((<>), empty, SrcLoc) 19 | 20 | import Data.Text (justifyLeft, pack, unpack) 21 | 22 | import Text.PrettyPrint 23 | 24 | import Language.Exalog.Pretty.Helper 25 | 26 | data SrcLoc = 27 | SrcLoc 28 | { _line :: !Int 29 | , _col :: !Int 30 | } 31 | deriving (Eq, Ord, Show) 32 | 33 | data InputSource = File !FilePath | Stdin | None deriving (Eq, Ord, Show) 34 | 35 | data SrcSpan = 36 | Span !InputSource !SrcLoc !SrcLoc 37 | | NoSpan 38 | deriving (Eq, Ord, Show) 39 | 40 | isBefore :: SrcLoc -> SrcLoc -> Bool 41 | isBefore loc@SrcLoc{} loc'@SrcLoc{} = 42 | _line loc < _line loc' || 43 | (_line loc == _line loc' && _col loc < _col loc') 44 | 45 | transSpan :: SrcSpan -> SrcSpan -> SrcSpan 46 | transSpan NoSpan sp = sp 47 | transSpan sp NoSpan = sp 48 | transSpan (Span file1 loc1 loc2) (Span file2 loc2' loc3) 49 | | file1 /= file2 = panic "Trying to compute transitive span of two different files." 50 | | loc2 `isBefore` loc2' = Span file1 loc1 loc3 51 | | otherwise = panic "The first span is not before the second." 52 | 53 | listSpan :: [ SrcSpan ] -> SrcSpan 54 | listSpan = foldr transSpan 55 | (panic "A span of an empty list of spans is undefined.") 56 | 57 | -------------------------------------------------------------------------------- 58 | -- Spans of various nodes 59 | -------------------------------------------------------------------------------- 60 | 61 | class Spannable a where 62 | span :: a -> SrcSpan 63 | 64 | instance {-# OVERLAPPABLE #-} HasField "_span" r SrcSpan => Spannable r where 65 | span = getField @"_span" 66 | 67 | -- |Unsafe 68 | instance {-# OVERLAPPING #-} (Spannable a, Spannable b) => Spannable (a,b) where 69 | span (a,b) = transSpan (span a) (span b) 70 | 71 | -- |Unsafe 72 | instance {-# OVERLAPPING #-} Spannable a => Spannable [ a ] where 73 | span as = listSpan (map span as) 74 | 75 | instance Spannable Void where 76 | span = absurd 77 | 78 | prettySpan :: Text -> SrcSpan -> Doc 79 | prettySpan _ NoSpan = mempty 80 | prettySpan src (Span _ loc1 loc2) = vcat 81 | [ "Context:" 82 | , vcat $ map (uncurry contextLine) contextLines 83 | , if nOfLines == 1 84 | then hcat 85 | $ replicate 6 " " -- Line number gap 86 | ++ replicate (_col loc1 - 1) " " -- Up to the beginning of the error 87 | ++ replicate nOfCols "^" -- Highlight 88 | else mempty 89 | ] 90 | where 91 | contents = zip [(1 :: Int)..] . lines $ src 92 | contextLines = take nOfLines $ drop (_line loc1 - 1) contents 93 | 94 | contextLine ix line = 95 | (text . unpack . justifyLeft 6 ' ' . pack . show) ix <> (text . unpack) line 96 | 97 | nOfLines = _line loc2 - _line loc1 + 1 98 | nOfCols = _col loc2 - _col loc1 + 1 99 | 100 | -------------------------------------------------------------------------------- 101 | -- Pretty instances 102 | -------------------------------------------------------------------------------- 103 | 104 | instance Pretty SrcLoc where 105 | pretty SrcLoc{..} = int _line <> colon <> int _col 106 | 107 | -- |This is really ought to be better. 108 | instance Pretty SrcSpan where 109 | pretty (Span file loc1 loc2) = 110 | (pretty file colon) <+> pretty loc1 <> "-" <> pretty loc2 111 | pretty NoSpan = mempty 112 | 113 | instance Pretty (Maybe SrcSpan) where 114 | pretty Nothing = empty 115 | pretty (Just s) = pretty s 116 | 117 | instance Pretty InputSource where 118 | pretty (File file) = text file 119 | pretty Stdin = "STDIN" 120 | pretty None = mempty 121 | -------------------------------------------------------------------------------- /src/Language/Exalog/Solver.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE MonoLocalBinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Language.Exalog.Solver 7 | ( solve 8 | , compute 9 | , evalSolver 10 | ) where 11 | 12 | import Protolude 13 | 14 | import Data.List (partition) 15 | 16 | import Language.Exalog.Core 17 | import Language.Exalog.Logger 18 | import Language.Exalog.Delta ( mkDeltaStratum 19 | , mkDeltaSolution 20 | , cleanDeltaSolution 21 | ) 22 | import Language.Exalog.SemiNaive ( SemiNaive 23 | , evalSemiNaiveT 24 | , semiNaive 25 | , evalClauses 26 | ) 27 | import qualified Language.Exalog.KnowledgeBase.Knowledge as KB 28 | import qualified Language.Exalog.KnowledgeBase.Class as KB 29 | 30 | data SolverSt kb ann = SolverSt 31 | { _program :: Program ann 32 | , _initEDB :: kb ann 33 | } 34 | 35 | type Solver kb ann = StateT (SolverSt kb ann) (SemiNaive (kb ann)) 36 | 37 | solve :: SpannableAST a 38 | => Identifiable (PredicateAnn a) b 39 | => Identifiable (KnowledgeAnn a) c 40 | => KB.Knowledgeable kb a => KB.Knowledgeable kb ('ADelta a) 41 | => KB.KnowledgeMaker a 42 | => Monoid (kb a) => Semigroup (kb ('ADelta a)) 43 | => Program a -> kb a -> Logger (kb a) 44 | solve = evalSolver compute 45 | 46 | evalSolver :: Identifiable (PredicateAnn ann) b 47 | => KB.Knowledgeable kb ann 48 | => Monoid (kb ann) 49 | => Solver kb ann a -> Program ann -> kb ann -> Logger a 50 | evalSolver action pr sol = evalSemiNaiveT (evalStateT action (SolverSt pr sol)) mempty 51 | 52 | compute :: SpannableAST a 53 | => Identifiable (PredicateAnn a) b 54 | => Identifiable (KnowledgeAnn a) c 55 | => KB.Knowledgeable kb a => KB.Knowledgeable kb ('ADelta a) 56 | => KB.KnowledgeMaker a 57 | => Semigroup (kb a) => Semigroup (kb ('ADelta a)) 58 | => Solver kb a (kb a) 59 | compute = do 60 | pr <- _program <$> get 61 | initEDB <- _initEDB <$> get 62 | let strat = _strata pr 63 | 64 | finalEDB <- lift $ 65 | foldM (\edb -> local (const edb) . evalStratum) initEDB strat 66 | 67 | -- Filter out non-query solutions 68 | let qPreds = _queries pr 69 | pure $ KB.filter (\(KB.Knowledge _ p _) -> PredicateBox p `elem` qPreds) finalEDB 70 | 71 | evalStratum :: forall a b c kb 72 | . SpannableAST a 73 | => Identifiable (PredicateAnn a) b 74 | => Identifiable (KnowledgeAnn a) c 75 | => KB.Knowledgeable kb a => KB.Knowledgeable kb ('ADelta a) 76 | => KB.KnowledgeMaker a 77 | => Semigroup (kb a) => Semigroup (kb ('ADelta a)) 78 | => Stratum a -> SemiNaive (kb a) (kb a) 79 | evalStratum stratum@(Stratum cls) = do 80 | simpleEDB <- 81 | if null simpleClauses 82 | then ask 83 | else evalClauses simpleClauses 84 | 85 | local (const simpleEDB) $ 86 | if null (_unStratum complexStratum) 87 | then ask 88 | else cleanDeltaSolution <$> 89 | (withDifferentEnvironment envMap 90 | . semiNaive 91 | $ deltaStratum) 92 | where 93 | (simpleClauses, complexStratum) = second Stratum $ partitionBySimplicity cls 94 | deltaStratum = mkDeltaStratum complexStratum 95 | 96 | envMap = mkDeltaSolution (intentionals complexStratum) 97 | 98 | intentionalPreds = intentionals stratum 99 | 100 | partitionBySimplicity :: [ Clause a ] -> ([ Clause a ], [ Clause a ]) 101 | partitionBySimplicity = 102 | partition (all ((`notElem` intentionalPreds) . predicateBox) . _body) 103 | 104 | withDifferentEnvironment :: Monad m 105 | => (r -> s) -> ReaderT s m a -> ReaderT r m a 106 | withDifferentEnvironment envMap (ReaderT f) = 107 | ReaderT $ f . envMap 108 | -------------------------------------------------------------------------------- /src/Language/Exalog/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | module Language.Exalog.Pretty 10 | ( pp 11 | ) where 12 | 13 | import Protolude hiding ((<>), empty, head, pred) 14 | 15 | import qualified Data.List.NonEmpty as NE 16 | import qualified Data.Vector.Sized as V 17 | 18 | import Text.PrettyPrint 19 | 20 | import Language.Exalog.Core 21 | import qualified Language.Exalog.KnowledgeBase.Class as KB 22 | import qualified Language.Exalog.KnowledgeBase.Knowledge as KB 23 | import qualified Language.Exalog.KnowledgeBase.Set as KB 24 | import Language.Exalog.Pretty.Helper 25 | 26 | -- Core pretty instances 27 | 28 | instance Pretty PredicateSymbol where 29 | pretty (PredicateSymbol predSym) = pretty predSym 30 | 31 | instance ( IdentifiableAnn (Ann (Predicate n) ann) id 32 | , Pretty id 33 | ) 34 | => Pretty (Predicate n ann) where 35 | pretty Predicate{..} = 36 | pretty _predSym 37 | <> "_" <> 38 | case _nature of 39 | Logical{} -> char 'L' 40 | Extralogical{} -> char 'E' 41 | <> ("PA" <> colon) pretty (idFragment _annotation) 42 | 43 | instance Pretty Sym where 44 | pretty (SymText t) = doubleQuotes $ pretty t 45 | pretty (SymInt i) = int i 46 | pretty (SymBool b) = pretty b 47 | 48 | instance Pretty Var where 49 | pretty (Var v) = char '\'' <> pretty v 50 | 51 | instance Pretty Term where 52 | pretty (TSym s) = pretty s 53 | pretty (TVar v) = pretty v 54 | pretty TWild = "_" 55 | 56 | instance ( IdentifiableAnn (PredicateAnn ann) id 57 | , Pretty id 58 | ) => Pretty (PredicateBox ann) where 59 | pretty (PredicateBox p) = pretty p 60 | 61 | instance ( IdentifiableAnn (Ann (Predicate n) ann) id 62 | , IdentifiableAnn (Ann Literal ann) id' 63 | , Pretty id 64 | , Pretty id' 65 | ) => Pretty (Literal ann) where 66 | pretty Literal{..} = 67 | cond (_polarity == Negative) (text "not" <> space) 68 | <+> pretty _predicate 69 | <> ("LA" <> colon) pretty (idFragment _annotation) 70 | <> (parens . csep . prettyC $ _terms) 71 | 72 | instance Pretty (Literal ann) => Pretty (Clause ann) where 73 | pretty Clause{..} = 74 | pretty _head <+> ":-" <+> (csep . prettyC $ _body) <> "." 75 | 76 | instance Pretty (Clause ann) => Pretty (Stratum ann) where 77 | pretty (Stratum cls) = vcat $ prettyC cls 78 | 79 | instance Pretty (Stratum ann) => Pretty (Program ann) where 80 | pretty Program{..} = vcat . punctuate "\n" 81 | $ prettyStratum <$> zip [(0 :: Int)..] _strata 82 | where 83 | prettyStratum (i, stratum) = 84 | vcat [ "Stratum #" <> pretty i <> ":", pretty stratum ] 85 | 86 | -- Annotation instances 87 | 88 | instance Pretty (PredicateAnn 'ABase) where pretty _ = empty 89 | instance Pretty (LiteralAnn 'ABase) where pretty _ = empty 90 | instance Pretty (ClauseAnn 'ABase) where pretty _ = empty 91 | instance Pretty (ProgramAnn 'ABase) where pretty _ = empty 92 | instance Pretty (KnowledgeAnn 'ABase) where pretty _ = empty 93 | 94 | -- Knowledge base related instances 95 | 96 | instance 97 | ( Pretty (KnowledgeAnn ann) 98 | , Identifiable (KnowledgeAnn ann) id 99 | , Identifiable (PredicateAnn ann) id' 100 | ) => Pretty (KB.Knowledge ann) where 101 | pretty (KB.Knowledge ann pred syms) = 102 | pretty pred <> pretty ann <> (csep . prettyC) syms 103 | 104 | instance 105 | ( Pretty (KnowledgeAnn ann) 106 | , Identifiable (KnowledgeAnn ann) id 107 | , Identifiable (PredicateAnn ann) id' 108 | ) => Pretty (KB.Set ann) where 109 | pretty = vcat . map pretty . KB.toList 110 | 111 | -- Common pretty instances 112 | 113 | instance Pretty Bool where 114 | pretty True = "true" 115 | pretty False = "false" 116 | 117 | -- Collections 118 | 119 | instance Pretty a => PrettyCollection (NE.NonEmpty a) where 120 | prettyC = map pretty . NE.toList 121 | 122 | instance Pretty a => PrettyCollection (V.Vector n a) where 123 | prettyC = map pretty . V.toList 124 | -------------------------------------------------------------------------------- /fixtures/Fixture/Ancestor/NonLinearAncestor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.Ancestor.NonLinearAncestor 4 | ( program 5 | , programSwapped 6 | , deltaStratum 7 | , adornedProgram 8 | , adornedProgramSwapped 9 | ) where 10 | 11 | import Protolude 12 | 13 | import qualified Data.List.NonEmpty as NE 14 | 15 | import Language.Exalog.Adornment 16 | import Language.Exalog.Core 17 | import Language.Exalog.Delta 18 | import Language.Exalog.SrcLoc 19 | 20 | import Fixture.Ancestor.Common 21 | import Fixture.Util 22 | 23 | {-| Non-linear ancestor program: 24 | - 25 | - anc(X,Z) :- anc(X,Y), anc(Y,Z). 26 | - anc(X,Y) :- par(X,Y). 27 | |-} 28 | program :: Program 'ABase 29 | program = Program (ProgABase NoSpan) 30 | (Stratum <$> 31 | [ [ Clause (ClABase NoSpan) (anc (tvar "X") (tvar "Z")) $ NE.fromList 32 | [ anc (tvar "X") (tvar "Y"), anc (tvar "Y") (tvar "Z") ] 33 | , Clause (ClABase NoSpan) (anc (tvar "X") (tvar "Y")) $ NE.fromList 34 | [ par (tvar "X") (tvar "Y") ] 35 | ] 36 | ]) 37 | [ PredicateBox ancPred 38 | , PredicateBox parPred 39 | ] 40 | 41 | {-| Non-linear ancestor program deltafied: 42 | - 43 | - delta_{i+1}_anc(X,Z) :- delta_i_anc(X,Y), anc_{i-1}(Y,Z). 44 | - delta_{i+1}_anc(X,Z) :- anc_i(X,Y), delta_i_anc(Y,Z). 45 | |-} 46 | deltaStratum :: Stratum ('ADelta 'ABase) 47 | deltaStratum = Stratum 48 | [ Clause (decorA (ClABase NoSpan)) (mkDeltaLiteral Delta $ anc (tvar "X") (tvar "Z")) 49 | $ NE.fromList 50 | [ mkDeltaLiteral Delta $ anc (tvar "X") (tvar "Y") 51 | , mkDeltaLiteral Prev $ anc (tvar "Y") (tvar "Z") ] 52 | , Clause (decorA (ClABase NoSpan)) (mkDeltaLiteral Delta $ anc (tvar "X") (tvar "Z")) 53 | $ NE.fromList 54 | [ mkDeltaLiteral Current $ anc (tvar "X") (tvar "Y") 55 | , mkDeltaLiteral Delta $ anc (tvar "Y") (tvar "Z") ] 56 | ] 57 | 58 | {-| Non-linear ancestor program adorned: 59 | - 60 | - anc_ff(X,Z) :- anc_ff(X,Y), anc_bf(Y,Z). 61 | - anc_ff(X,Y) :- par_ff(X,Y). 62 | - anc_bf(X,Z) :- anc_bf(X,Y), anc_bf(Y,Z). 63 | - anc_bf(X,Y) :- par_bf(X,Y). 64 | |-} 65 | adornedProgram :: Program ('AAdornment 'ABase) 66 | adornedProgram = Program (decorA (ProgABase NoSpan)) 67 | (Stratum <$> 68 | [ [ Clause (decorA (ClABase NoSpan)) (adornLiteral [Free, Free] $ anc (tvar "X") (tvar "Z")) 69 | $ NE.fromList 70 | [ adornLiteral [Free, Free] $ anc (tvar "X") (tvar "Y") 71 | , adornLiteral [Bound, Free] $ anc (tvar "Y") (tvar "Z") ] 72 | , Clause (decorA (ClABase NoSpan)) (adornLiteral [Bound, Free] $ anc (tvar "X") (tvar "Z")) 73 | $ NE.fromList 74 | [ adornLiteral [Bound, Free] $ anc (tvar "X") (tvar "Y") 75 | , adornLiteral [Bound, Free] $ anc (tvar "Y") (tvar "Z") ] 76 | , Clause (decorA (ClABase NoSpan)) 77 | (adornLiteral [Free, Free] $ anc (tvar "X") (tvar "Y")) 78 | $ NE.fromList 79 | [ adornLiteral [Free, Free] $ par (tvar "X") (tvar "Y") ] 80 | , Clause (decorA (ClABase NoSpan)) 81 | (adornLiteral [Bound, Free] $ anc (tvar "X") (tvar "Y")) 82 | $ NE.fromList 83 | [ adornLiteral [Bound, Free] $ par (tvar "X") (tvar "Y") ] 84 | ] 85 | ]) 86 | [ PredicateBox . decorate $ ancPred 87 | , PredicateBox . decorate $ parPred 88 | ] 89 | 90 | {-| Same non-linear ancestor program except anc atoms are swapped 91 | - (minus base case): 92 | - 93 | - anc(X,Z) :- anc(Y,Z), anc(X,Y). 94 | |-} 95 | programSwapped :: Program 'ABase 96 | programSwapped = Program (ProgABase NoSpan) 97 | (Stratum <$> 98 | [ [ Clause (ClABase NoSpan) (anc (tvar "X") (tvar "Z")) $ NE.fromList 99 | [ anc (tvar "Y") (tvar "Z"), anc (tvar "X") (tvar "Y") ] 100 | ] 101 | ]) 102 | [ PredicateBox ancPred 103 | , PredicateBox parPred 104 | ] 105 | 106 | {-| Adorned swapped non-linear ancestor program: 107 | - 108 | - anc_ff(X,Z) :- anc_ff(Y,Z), anc_fb(X,Y). 109 | - anc_fb(X,Z) :- anc_fb(Y,Z), anc_fb(X,Y). 110 | |-} 111 | adornedProgramSwapped :: Program ('AAdornment 'ABase) 112 | adornedProgramSwapped = Program (decorA $ ProgABase NoSpan) 113 | (Stratum <$> 114 | [ [ Clause (decorA $ ClABase NoSpan) 115 | (adornLiteral [Free, Free] $ anc (tvar "X") (tvar "Z")) 116 | $ NE.fromList 117 | [ adornLiteral [ Free, Free ] $ anc (tvar "Y") (tvar "Z") 118 | , adornLiteral [ Free, Bound ] $ anc (tvar "X") (tvar "Y") ] 119 | , Clause (decorA $ ClABase NoSpan) 120 | (adornLiteral [Free, Bound] $ anc (tvar "X") (tvar "Z")) 121 | $ NE.fromList 122 | [ adornLiteral [ Free, Bound ] $ anc (tvar "Y") (tvar "Z") 123 | , adornLiteral [ Free, Bound ] $ anc (tvar "X") (tvar "Y") ] 124 | ] 125 | ]) 126 | [ PredicateBox . decorate $ ancPred 127 | , PredicateBox . decorate $ parPred 128 | ] 129 | -------------------------------------------------------------------------------- /exalog-engine.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 7442fb98b92785215ea7fffbd875c318f6808c7177d68d9a2a3f71f973485363 8 | 9 | name: exalog-engine 10 | version: 0.1.0.0 11 | synopsis: A Datalog engine with support for external processes as predicates 12 | description: Please see the README on GitHub at 13 | category: Language 14 | homepage: https://github.com/madgen/exalog-engine#readme 15 | bug-reports: https://github.com/madgen/exalog-engine/issues 16 | author: Mistral Contrastin 17 | maintainer: madgenhetic@gmail.com 18 | copyright: 2018 19 | license: BSD-3-Clause 20 | license-file: LICENSE 21 | build-type: Simple 22 | extra-source-files: 23 | README.md 24 | ChangeLog.md 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/madgen/exalog-engine 29 | 30 | library 31 | hs-source-dirs: 32 | src 33 | default-extensions: NoImplicitPrelude LambdaCase OverloadedStrings 34 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates 35 | build-depends: 36 | aeson >=1.4 && <1.5 37 | , base >=4.7 && <5 38 | , bimap >=0.4 && <0.5 39 | , comonad >=5.0 && <5.1 40 | , containers >=0.6 && <0.7 41 | , fgl >=5.7 && <5.8 42 | , finite-typelits >=0.1.4 && <0.1.5 43 | , ghc-prim >=0.5 && <0.6 44 | , ghc-typelits-natnormalise >=0.7 && <0.8 45 | , pretty >=1.1 && <1.2 46 | , protolude >=0.2 && <0.3 47 | , singletons >=2.6 && <2.7 48 | , text >=1.2 && <1.3 49 | , transformers >=0.5 && <0.6 50 | , unordered-containers >=0.2 && <0.3 51 | , vector-sized >=1.4 && <1.5 52 | exposed-modules: 53 | Language.Exalog.Adornment 54 | Language.Exalog.Annotation 55 | Language.Exalog.Core 56 | Language.Exalog.Dataflow 57 | Language.Exalog.DataflowRepair 58 | Language.Exalog.Delta 59 | Language.Exalog.Dependency 60 | Language.Exalog.Error 61 | Language.Exalog.ForeignFunction 62 | Language.Exalog.Fresh 63 | Language.Exalog.KnowledgeBase.Class 64 | Language.Exalog.KnowledgeBase.Knowledge 65 | Language.Exalog.KnowledgeBase.Set 66 | Language.Exalog.Logger 67 | Language.Exalog.Pretty 68 | Language.Exalog.Pretty.Helper 69 | Language.Exalog.Provenance 70 | Language.Exalog.RangeRestriction 71 | Language.Exalog.Renamer 72 | Language.Exalog.SemiNaive 73 | Language.Exalog.Solver 74 | Language.Exalog.SrcLoc 75 | Language.Exalog.Stratification 76 | Language.Exalog.Unification 77 | Language.Exalog.Util.List.Zipper 78 | Language.Exalog.WellModing 79 | Language.Exalog.Wildcard 80 | other-modules: 81 | Paths_exalog_engine 82 | default-language: Haskell2010 83 | 84 | test-suite exalog-engine-test 85 | type: exitcode-stdio-1.0 86 | main-is: Spec.hs 87 | hs-source-dirs: 88 | test 89 | fixtures 90 | default-extensions: NoImplicitPrelude LambdaCase OverloadedStrings 91 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded -rtsopts -with-rtsopts=-N 92 | build-tool-depends: 93 | hspec-discover:hspec-discover >=2.7 && <2.8 94 | build-depends: 95 | QuickCheck >=2.13 && <2.14 96 | , aeson >=1.4 && <1.5 97 | , base >=4.7 && <5 98 | , bimap >=0.4 && <0.5 99 | , comonad >=5.0 && <5.1 100 | , containers >=0.6 && <0.7 101 | , exalog-engine 102 | , fgl >=5.7 && <5.8 103 | , finite-typelits >=0.1.4 && <0.1.5 104 | , ghc-prim >=0.5 && <0.6 105 | , ghc-typelits-natnormalise >=0.7 && <0.8 106 | , hspec >=2.7 && <2.8 107 | , pretty >=1.1 && <1.2 108 | , protolude >=0.2 && <0.3 109 | , singletons >=2.6 && <2.7 110 | , text >=1.2 && <1.3 111 | , transformers >=0.5 && <0.6 112 | , unordered-containers >=0.2 && <0.3 113 | , vector-sized >=1.4 && <1.5 114 | other-modules: 115 | Language.Exalog.AdornmentSpec 116 | Language.Exalog.DataflowSpec 117 | Language.Exalog.DeltaSpec 118 | Language.Exalog.ProvenanceSpec 119 | Language.Exalog.RangeRestrictionSpec 120 | Language.Exalog.SolverSpec 121 | Language.Exalog.WellModingSpec 122 | Fixture.Ancestor.Common 123 | Fixture.Ancestor.EDB 124 | Fixture.Ancestor.LinearAncestor 125 | Fixture.Ancestor.NonLinearAncestor 126 | Fixture.Constant 127 | Fixture.Dataflow 128 | Fixture.DomainDependent 129 | Fixture.Foreign 130 | Fixture.Negation 131 | Fixture.RangeRestriction 132 | Fixture.RepeatedVars 133 | Fixture.SpanIrrelevance 134 | Fixture.Unification 135 | Fixture.Util 136 | Fixture.WellModing 137 | Fixture.Wildcard 138 | Paths_exalog_engine 139 | default-language: Haskell2010 140 | -------------------------------------------------------------------------------- /test/Language/Exalog/SolverSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 3 | {-# OPTIONS_GHC -Wno-missing-signatures #-} 4 | 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | 10 | module Language.Exalog.SolverSpec (spec, execSolver) where 11 | 12 | import Protolude hiding (Set) 13 | 14 | import qualified Data.Set as S 15 | 16 | import Test.Hspec 17 | import Test.Hspec.QuickCheck 18 | import Test.QuickCheck.Arbitrary 19 | import Test.QuickCheck.Gen 20 | 21 | import System.IO.Unsafe (unsafePerformIO) 22 | 23 | import qualified Fixture.Ancestor.LinearAncestor as LAnc 24 | import qualified Fixture.Ancestor.NonLinearAncestor as NLAnc 25 | import qualified Fixture.Ancestor.EDB as AncEDB 26 | import qualified Fixture.Constant as Const 27 | import qualified Fixture.Foreign as Foreign 28 | import qualified Fixture.Negation as NegFix 29 | import qualified Fixture.RepeatedVars as Repeated 30 | import qualified Fixture.SpanIrrelevance as SpanIrr 31 | import qualified Fixture.Unification as Unification 32 | import Fixture.Util 33 | import qualified Fixture.Wildcard as Wildcard 34 | 35 | import Language.Exalog.Core hiding (Positive) 36 | import Language.Exalog.Dependency () 37 | import qualified Language.Exalog.KnowledgeBase.Class as KB 38 | import qualified Language.Exalog.KnowledgeBase.Set as KB 39 | import Language.Exalog.Logger 40 | import Language.Exalog.Solver 41 | import Language.Exalog.Stratification 42 | 43 | execSolver pr edb = runIO $ runLoggerT vanillaEnv $ do 44 | stratifiedPr <- stratify (decorate pr) 45 | solve stratifiedPr edb 46 | 47 | infixr 1 `shouldBeish` 48 | shouldBeish xs ys = S.fromList <$> xs `shouldBe` S.fromList <$> ys 49 | 50 | spec :: Spec 51 | spec = 52 | describe "Solver " $ do 53 | -- finalEDB <- execSolver Unification.program Unification.initEDB 54 | it "unification runs to completion" $ 55 | -- Activate for scalability tests 56 | -- KB.size <$> finalEDB `shouldBe` Nothing 57 | pendingWith "Engine is not efficient enough to run this test yet =(" 58 | 59 | finalEDB <- execSolver NegFix.program NegFix.initEDB 60 | it "evaluates complement of a subgraph correctly" $ 61 | finalEDB `shouldBe` Just NegFix.finalEDB 62 | 63 | describe "SemiNaive evaluation" $ do 64 | describe "Ancestor" $ do 65 | 66 | finalEDB <- execSolver LAnc.program AncEDB.initEDB 67 | it "evaluates linear ancestor correctly" $ 68 | finalEDB `shouldBe` Just AncEDB.finalEDB 69 | 70 | finalEDB <- execSolver NLAnc.program AncEDB.initEDB 71 | it "evaluates non-linear ancestor correctly" $ 72 | finalEDB `shouldBe` Just AncEDB.finalEDB 73 | 74 | prop "linear & non-linear versions produce the same result" $ 75 | \(edb :: KB.Set 'ABase) -> unsafePerformIO $ liftM2 (==) 76 | (runLoggerT vanillaEnv $ evalSolver compute LAnc.program edb) 77 | (runLoggerT vanillaEnv $ evalSolver compute NLAnc.program edb) 78 | 79 | finalEDB <- execSolver Const.program Const.initEDB 80 | it "evaluates constants correctly" $ 81 | KB.findByPred Const.rPred <$> finalEDB `shouldBeish` Just Const.rTuples 82 | 83 | finalEDB <- execSolver Repeated.program Repeated.initEDB 84 | it "does not forget repeated variables" $ 85 | KB.findByPred Repeated.pPred <$> finalEDB `shouldBeish` Just Repeated.pTuples 86 | 87 | finalEDB <- execSolver Wildcard.program Wildcard.initEDB 88 | it "evaluates literals with wildcads correctly" $ 89 | KB.findByPred Wildcard.pPred <$> finalEDB `shouldBeish` Just Wildcard.pTuples 90 | 91 | describe "Foreign function" $ do 92 | 93 | finalEDB <- execSolver Foreign.programLeq100 Foreign.initLeq100EDB 94 | it "interprets 'x < 100' correctly" $ 95 | KB.findByPred Foreign.leq100Pred <$> finalEDB `shouldBeish` Just Foreign.leq100Tuples 96 | 97 | finalEDB <- execSolver Foreign.programPrefixOf Foreign.initPrefixOfEDB 98 | it "interprets 'isPrefixOf' correctly" $ 99 | KB.findByPred Foreign.prefixOfPred <$> finalEDB `shouldBeish` Just Foreign.prefixOfTuples 100 | 101 | finalEDB <- execSolver Foreign.programCartesian23 Foreign.initCartesian23EDB 102 | it "interprets 'cartesian23' correctly" $ 103 | KB.findByPred Foreign.cartesian23Pred <$> finalEDB `shouldBeish` Just Foreign.cartesian23Tuples 104 | 105 | finalEDB <- execSolver Foreign.programImpure Foreign.initImpureEDB 106 | it "interprets 'impure' correctly" $ 107 | KB.findByPred Foreign.impurePred <$> finalEDB `shouldBeish` Just Foreign.impureTuples 108 | 109 | finalEDB <- execSolver SpanIrr.program SpanIrr.initEDB 110 | it "evaluates correctly with different spans" $ 111 | KB.findByPred SpanIrr.rPred <$> finalEDB `shouldBeish` Just SpanIrr.rTuples 112 | 113 | 114 | -- Arbitrary instances for solution 115 | instance Arbitrary Sym where 116 | arbitrary = oneof $ return . symbol <$> 117 | ([ "mistral", "emir", "nilufer", "laurent", "gulseren", "orhan" 118 | , "jean-pierre", "simone", "nazli", "hulusi" ] :: [ Text ]) 119 | -------------------------------------------------------------------------------- /src/Language/Exalog/Dependency.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module Language.Exalog.Dependency 13 | ( DependencyGr 14 | , dependencyGr 15 | ) where 16 | 17 | import Protolude hiding (pred) 18 | 19 | import qualified Data.Graph.Inductive.Graph as G 20 | import qualified Data.Graph.Inductive.PatriciaTree as P 21 | import Data.List (lookup, nub) 22 | import qualified Data.List.NonEmpty as NE 23 | 24 | import Language.Exalog.Core 25 | import qualified Language.Exalog.KnowledgeBase.Knowledge as KB 26 | 27 | type DependencyGr (a :: AnnType) = P.Gr (PredicateBox a) Polarity 28 | 29 | newtype instance PredicateAnn ('ADependency a) = 30 | PredADependency (PredicateAnn a) 31 | newtype instance LiteralAnn ('ADependency a) = LitADependency (LiteralAnn a) 32 | newtype instance ClauseAnn ('ADependency a) = ClADependency (ClauseAnn a) 33 | data instance ProgramAnn ('ADependency a) = 34 | ProgADependency (DependencyGr a) (ProgramAnn a) 35 | newtype instance KnowledgeAnn ('ADependency a) = 36 | KnowADependency (KnowledgeAnn a) 37 | 38 | instance KB.KnowledgeMaker ann => KB.KnowledgeMaker ('ADependency ann) where 39 | mkKnowledge clause pred syms = 40 | KB.Knowledge (KnowADependency oldAnn) pred syms 41 | where 42 | oldAnn = KB._annotation (KB.mkKnowledge (peel clause) (peel pred) syms) 43 | 44 | instance SpannableAnn (PredicateAnn a) => SpannableAnn (PredicateAnn ('ADependency a)) where 45 | annSpan (PredADependency ann) = annSpan ann 46 | instance SpannableAnn (LiteralAnn a) => SpannableAnn (LiteralAnn ('ADependency a)) where 47 | annSpan (LitADependency ann) = annSpan ann 48 | instance SpannableAnn (ClauseAnn a) => SpannableAnn (ClauseAnn ('ADependency a)) where 49 | annSpan (ClADependency ann) = annSpan ann 50 | instance SpannableAnn (ProgramAnn a) => SpannableAnn (ProgramAnn ('ADependency a)) where 51 | annSpan (ProgADependency _ ann) = annSpan ann 52 | 53 | instance IdentifiableAnn (PredicateAnn ann) b 54 | => IdentifiableAnn (PredicateAnn ('ADependency ann)) b where 55 | idFragment (PredADependency rest) = idFragment rest 56 | instance IdentifiableAnn (LiteralAnn ann) b 57 | => IdentifiableAnn (LiteralAnn ('ADependency ann)) b where 58 | idFragment (LitADependency rest) = idFragment rest 59 | instance IdentifiableAnn (ClauseAnn ann) b 60 | => IdentifiableAnn (ClauseAnn ('ADependency ann)) b where 61 | idFragment (ClADependency rest) = idFragment rest 62 | instance IdentifiableAnn (ProgramAnn ann) b 63 | => IdentifiableAnn (ProgramAnn ('ADependency ann)) b where 64 | idFragment (ProgADependency _ rest) = idFragment rest 65 | 66 | instance PeelableAnn PredicateAnn 'ADependency where 67 | peelA (PredADependency a) = a 68 | instance PeelableAnn LiteralAnn 'ADependency where 69 | peelA (LitADependency a) = a 70 | instance PeelableAnn ClauseAnn 'ADependency where 71 | peelA (ClADependency a) = a 72 | instance PeelableAnn ProgramAnn 'ADependency where 73 | peelA (ProgADependency _ a) = a 74 | 75 | instance PeelableAST (Literal ('ADependency a)) where 76 | peel Literal{..} = 77 | Literal { _annotation = peelA _annotation 78 | , _predicate = peel _predicate 79 | , ..} 80 | instance PeelableAST (PredicateBox ('ADependency a)) where 81 | peel (PredicateBox pred) = PredicateBox $ peel pred 82 | 83 | instance DecorableAnn PredicateAnn 'ADependency where 84 | decorA = PredADependency 85 | instance DecorableAnn LiteralAnn 'ADependency where 86 | decorA = LitADependency 87 | instance DecorableAnn ClauseAnn 'ADependency where 88 | decorA = ClADependency 89 | 90 | instance DecorableAST (Literal a) 'ADependency where 91 | decorate Literal{..} = 92 | Literal { _annotation = decorA _annotation 93 | , _predicate = decorate _predicate 94 | , ..} 95 | 96 | instance {-# OVERLAPPING #-} 97 | Identifiable (PredicateAnn a) b 98 | => DecorableAST (Program a) 'ADependency where 99 | decorate pr@Program{..} = 100 | Program { _annotation = ProgADependency (mkDependencyGr pr) _annotation 101 | , _strata = stratumOver (map decorate) <$> _strata 102 | , _queries = map decorate _queries 103 | } 104 | 105 | dependencyGr :: Program ('ADependency a) -> DependencyGr a 106 | dependencyGr Program{_annotation = ProgADependency gr _} = gr 107 | 108 | mkDependencyGr :: forall a b. Identifiable (PredicateAnn a) b 109 | => Program a -> DependencyGr a 110 | mkDependencyGr pr@Program{..} = G.mkGraph nodes (nub edges) 111 | where 112 | nodeDict :: [ (PredicateBox a, G.Node) ] 113 | nodeDict = zip (predicates pr) [1..] 114 | 115 | findID :: Predicate n a -> Maybe G.Node 116 | findID p = lookup (PredicateBox p) nodeDict 117 | 118 | nodes :: [ G.LNode (PredicateBox a) ] 119 | nodes = map (\(a,b) -> (b,a)) nodeDict 120 | 121 | edges :: [ G.LEdge Polarity ] 122 | edges = do 123 | Clause{_head = Literal{_predicate = headPred}, _body = body} 124 | <- concatMap _unStratum _strata 125 | Literal{_polarity = pol, _predicate = bodyPred} <- NE.toList body 126 | case bimap findID findID (bodyPred, headPred) of 127 | (Just src, Just dst) -> return (src, dst, pol) 128 | _ -> panic "Impossible: predicate is not in the program." 129 | -------------------------------------------------------------------------------- /fixtures/Fixture/Ancestor/EDB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.Ancestor.EDB 4 | ( initEDB 5 | , finalEDB 6 | , ancAncKnowledge 7 | , parKnowledge 8 | , parAncKnowledge 9 | , finalLinearProvEDB 10 | , finalNonLinearProvEDB 11 | ) where 12 | 13 | import Protolude hiding (Set, head) 14 | 15 | import Data.Maybe (fromJust) 16 | import qualified Data.Vector.Sized as V 17 | import qualified Data.List.NonEmpty as NE 18 | import Data.List 19 | 20 | import Language.Exalog.Core 21 | import qualified Language.Exalog.KnowledgeBase.Class as KB 22 | import Language.Exalog.KnowledgeBase.Knowledge 23 | import Language.Exalog.KnowledgeBase.Set 24 | import Language.Exalog.Provenance 25 | import Language.Exalog.SrcLoc 26 | 27 | import Fixture.Ancestor.Common 28 | import Fixture.Util 29 | 30 | parentTuples :: [ V.Vector 2 Text ] 31 | parentTuples = fromJust . V.fromList <$> 32 | [ [ "Laurent" , "Mistral" ] 33 | , [ "Nilufer" , "Mistral" ] 34 | , [ "Jean-Pierre" , "Laurent" ] 35 | , [ "Simone" , "Laurent" ] 36 | , [ "Orhan" , "Nilufer" ] 37 | , [ "Orhan" , "Hulusi" ] 38 | , [ "Nazli" , "Emir" ] 39 | , [ "Hulusi" , "Emir" ] 40 | , [ "Omer" , "Orhan" ] 41 | ] 42 | 43 | parentKB :: Set 'ABase 44 | parentKB = KB.fromList $ Knowledge KnowABase parPred . fmap symbol <$> parentTuples 45 | 46 | ancestorTuples :: [ V.Vector 2 Text ] 47 | ancestorTuples = 48 | -- From the first clause 49 | (parentTuples ++) $ fromJust . V.fromList <$> 50 | -- From the second clause 51 | [ [ "Orhan" , "Mistral" ] 52 | , [ "Jean-Pierre" , "Mistral" ] 53 | , [ "Simone" , "Mistral" ] 54 | , [ "Orhan" , "Emir" ] 55 | , [ "Omer" , "Nilufer" ] 56 | , [ "Omer" , "Hulusi" ] 57 | , [ "Omer" , "Mistral" ] 58 | , [ "Omer" , "Emir" ] 59 | ] 60 | 61 | ancestorKB :: Set 'ABase 62 | ancestorKB = KB.fromList $ Knowledge KnowABase ancPred . fmap symbol <$> ancestorTuples 63 | 64 | initEDB :: Set 'ABase 65 | initEDB = parentKB 66 | 67 | finalEDB :: Set 'ABase 68 | finalEDB = parentKB <> ancestorKB 69 | 70 | -- EDB construction with Provenance 71 | 72 | -- anc(X,Z) :- anc(X,Y), anc(Y,Z). 73 | ancAncClause :: Term -> Term -> Term -> Term -> Term -> Term -> Clause ('AProvenance 'ABase) 74 | ancAncClause h1 h2 b1 b2 b3 b4 = Clause 75 | (ClAProvenance (ClABase NoSpan)) 76 | (ancProv h1 h2) 77 | (NE.fromList [ ancProv b1 b2, ancProv b3 b4 ]) 78 | 79 | ancAncKnowledge :: [ Text ] -> Knowledge ('AProvenance 'ABase) 80 | ancAncKnowledge t = 81 | mkKnowledge 82 | (ancAncClause 83 | (TSym (SymText $ head t)) 84 | (TSym (SymText $ t !! 1)) 85 | (TSym (SymText $ t !! 2)) 86 | (TSym (SymText $ t !! 3)) 87 | (TSym (SymText $ t !! 4)) 88 | (TSym (SymText $ t !! 5))) 89 | ancPredProv 90 | (V.fromTuple (SymText $ head t, SymText $ t !! 1)) 91 | 92 | ancAncTuples :: [ [ Text ] ] 93 | ancAncTuples = 94 | [ [ "Jean-Pierre" , "Mistral" , "Jean-Pierre", "Laurent", "Laurent", "Mistral"] 95 | , [ "Omer" , "Emir" , "Omer", "Orhan", "Orhan", "Emir"] 96 | , [ "Omer" , "Hulusi" , "Omer", "Orhan", "Orhan", "Hulusi"] 97 | , [ "Omer" , "Mistral" , "Omer", "Orhan", "Orhan", "Mistral"] 98 | , [ "Omer" , "Nilufer" , "Omer", "Orhan", "Orhan", "Nilufer"] 99 | , [ "Orhan" , "Emir" , "Orhan", "Hulusi", "Hulusi", "Emir"] 100 | , [ "Orhan" , "Mistral" , "Orhan", "Nilufer", "Nilufer", "Mistral"] 101 | , [ "Simone" , "Mistral" , "Simone", "Laurent", "Laurent", "Mistral"] 102 | -- The diff from linear 103 | , [ "Omer" , "Emir" , "Omer", "Hulusi", "Hulusi", "Emir"] 104 | , [ "Omer" , "Mistral" , "Omer", "Nilufer", "Nilufer", "Mistral"] 105 | ] 106 | 107 | ancAncEDB :: Set ('AProvenance 'ABase) 108 | ancAncEDB = KB.fromList $ Data.List.map ancAncKnowledge ancAncTuples 109 | 110 | -- anc(X,Y) :- par(X,Y). 111 | parClause :: Term -> Term -> Term -> Term -> Clause ('AProvenance 'ABase) 112 | parClause h1 h2 b1 b2 = Clause 113 | (ClAProvenance (ClABase NoSpan)) 114 | (ancProv h1 h2) 115 | (NE.fromList [ parProv b1 b2 ]) 116 | 117 | parKnowledge :: [ Text ] -> Knowledge ('AProvenance 'ABase) 118 | parKnowledge t = 119 | mkKnowledge 120 | (parClause 121 | (TSym (SymText (head t))) 122 | (TSym (SymText (t !! 1))) 123 | (TSym (SymText (t !! 2))) 124 | (TSym (SymText (t !! 3)))) 125 | ancPredProv 126 | (V.fromTuple (SymText (head t), SymText (t!!1))) 127 | 128 | parTuples :: [ [ Text ] ] 129 | parTuples = 130 | [ [ "Hulusi" , "Emir" , "Hulusi" , "Emir" ] 131 | , [ "Jean-Pierre" , "Laurent" , "Jean-Pierre" , "Laurent" ] 132 | , [ "Laurent" , "Mistral" , "Laurent" , "Mistral" ] 133 | , [ "Nazli" , "Emir" , "Nazli" , "Emir" ] 134 | , [ "Nilufer" , "Mistral" , "Nilufer" , "Mistral" ] 135 | , [ "Omer" , "Orhan" , "Omer" , "Orhan" ] 136 | , [ "Orhan" , "Hulusi" , "Orhan" , "Hulusi" ] 137 | , [ "Orhan" , "Nilufer" , "Orhan" , "Nilufer" ] 138 | , [ "Simone" , "Laurent" , "Simone" , "Laurent" ] 139 | ] 140 | 141 | parEDB :: Set ('AProvenance 'ABase) 142 | parEDB = KB.fromList $ Data.List.map parKnowledge parTuples 143 | 144 | -- anc(X,Z) :- par(X,Y), anc(Y,Z). 145 | parAncClause :: Term -> Term -> Term -> Term -> Term -> Term -> Clause ('AProvenance 'ABase) 146 | parAncClause h1 h2 b1 b2 b3 b4 = Clause 147 | (ClAProvenance (ClABase NoSpan)) 148 | (ancProv h1 h2) 149 | (NE.fromList [ parProv b1 b2, ancProv b3 b4 ]) 150 | 151 | parAncKnowledge :: [ Text ]-> Knowledge ('AProvenance 'ABase) 152 | parAncKnowledge t = 153 | mkKnowledge 154 | (parAncClause 155 | (TSym (SymText $ head t)) 156 | (TSym (SymText $ t !! 1)) 157 | (TSym (SymText $ t !! 2)) 158 | (TSym (SymText $ t !! 3)) 159 | (TSym (SymText $ t !! 4)) 160 | (TSym (SymText $ t !! 5))) 161 | ancPredProv 162 | (V.fromTuple (SymText $ head t, SymText $ t !! 1)) 163 | 164 | parAncTuples :: [ [ Text ] ] 165 | parAncTuples = 166 | [ [ "Jean-Pierre" , "Mistral" , "Jean-Pierre", "Laurent", "Laurent", "Mistral"] 167 | , [ "Omer" , "Emir" , "Omer", "Orhan", "Orhan", "Emir"] 168 | , [ "Omer" , "Hulusi" , "Omer", "Orhan", "Orhan", "Hulusi"] 169 | , [ "Omer" , "Mistral" , "Omer", "Orhan", "Orhan", "Mistral"] 170 | , [ "Omer" , "Nilufer" , "Omer", "Orhan", "Orhan", "Nilufer"] 171 | , [ "Orhan" , "Emir" , "Orhan", "Hulusi", "Hulusi", "Emir"] 172 | , [ "Orhan" , "Mistral" , "Orhan", "Nilufer", "Nilufer", "Mistral"] 173 | , [ "Simone" , "Mistral" , "Simone", "Laurent", "Laurent", "Mistral"] 174 | ] 175 | 176 | parAncEDB :: Set ('AProvenance 'ABase) 177 | parAncEDB = KB.fromList $ parAncKnowledge <$> parAncTuples 178 | 179 | initProvEDB :: Set ('AProvenance 'ABase) 180 | initProvEDB = KB.atEach decorate initEDB 181 | 182 | finalLinearProvEDB :: Set ('AProvenance 'ABase) 183 | finalLinearProvEDB = initProvEDB <> parAncEDB <> parEDB 184 | 185 | finalNonLinearProvEDB :: Set ('AProvenance 'ABase) 186 | finalNonLinearProvEDB = initProvEDB <> ancAncEDB <> parEDB 187 | -------------------------------------------------------------------------------- /src/Language/Exalog/DataflowRepair.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | module Language.Exalog.DataflowRepair 8 | ( fixDataflow 9 | , RepairT 10 | , getPositiveFlowGraph 11 | ) where 12 | 13 | import Protolude hiding (sym, head, pred) 14 | 15 | import Data.List (unzip3) 16 | import Data.Singletons (sing, fromSing) 17 | import Data.Singletons.TypeLits (SNat) 18 | import Data.Singletons.Decide (Decision(..), (%~)) 19 | import qualified Data.Vector.Sized as V 20 | import qualified Data.List.NonEmpty as NE 21 | 22 | import Language.Exalog.Core 23 | import Language.Exalog.Dataflow 24 | import Language.Exalog.Fresh 25 | import qualified Language.Exalog.KnowledgeBase.Class as KB 26 | import qualified Language.Exalog.KnowledgeBase.Knowledge as KB 27 | import Language.Exalog.Renamer () 28 | import Language.Exalog.Logger 29 | import Language.Exalog.SrcLoc 30 | 31 | data RepairResult kb = 32 | NotFixable 33 | | Guard (Literal 'ABase) [ Clause 'ABase ] (kb 'ABase) 34 | 35 | type Repair = RepairT Logger 36 | 37 | fixDataflow :: KB.Knowledgeable kb 'ABase 38 | => KB.Knowledgeable kb ('ARename 'ABase) 39 | => Monoid (kb 'ABase) 40 | => (Clause ('ARename 'ABase) -> Repair [ (FlowSink 'ABase, Var) ]) 41 | -> Text 42 | -> (Program ('ARename 'ABase), kb ('ARename 'ABase)) 43 | -> Logger (Program 'ABase, kb 'ABase) 44 | fixDataflow violationFinder errMsg (pr@Program{..}, sol) 45 | | [ Stratum clauses ] <- _strata = runRepairT pr $ do 46 | (originalClauses, guardClausess, guardSols) <- unzip3 <$> 47 | traverse (fixDataflowClause violationFinder errMsg) clauses 48 | 49 | pure ( Program 50 | { _annotation = peelA _annotation 51 | , _strata = [ Stratum $ originalClauses <> join guardClausess ] 52 | , _queries = (PredicateBox . peel $$) <$> _queries 53 | , ..} 54 | , mconcat (KB.atEach (\(KB.Knowledge ann pred syms) -> KB.Knowledge (peelA ann) (peel pred) syms) sol : guardSols) 55 | ) 56 | | otherwise = scream NoSpan 57 | "Dataflow repair can only be performed prior to stratification." 58 | 59 | fixDataflowClause :: Monoid (kb 'ABase) 60 | => KB.Knowledgeable kb 'ABase 61 | => (Clause ('ARename 'ABase) -> Repair [ (FlowSink 'ABase, Var) ]) 62 | -> Text 63 | -> Clause ('ARename 'ABase) 64 | -> Repair (Clause 'ABase, [ Clause 'ABase ], kb 'ABase) 65 | fixDataflowClause violationFinder errMsg cl@Clause{..} = do 66 | violations <- violationFinder cl 67 | repairResults <- traverse (uncurry (attemptFix $ span _head)) violations 68 | 69 | (guardLits, guardClausess, guardSols) <- 70 | fmap (unzip3 . catMaybes) $ forM repairResults $ \case 71 | Guard gLit gCls gSol -> pure $ Just (gLit, gCls, gSol) 72 | NotFixable -> lift $ lift $ scold (span _head) errMsg 73 | 74 | pure ( Clause 75 | { _annotation = peelA _annotation 76 | , _head = peel _head 77 | , _body = foldr' NE.cons (peel <$> _body) guardLits 78 | } 79 | , join guardClausess 80 | , mconcat guardSols 81 | ) 82 | 83 | attemptFix :: Monad m 84 | => Monoid (kb 'ABase) 85 | => KB.Knowledgeable kb 'ABase 86 | => SrcSpan 87 | -> FlowSink 'ABase 88 | -> Var 89 | -> RepairT m (RepairResult kb) 90 | attemptFix sp flowSink var = do 91 | flowGr <- getPositiveFlowGraph 92 | 93 | case nearestCoveringPositives flowGr flowSink of 94 | Just flowSources -> mkGuard sp flowSources var 95 | Nothing -> pure NotFixable 96 | 97 | mkGuard :: Monad m 98 | => Monoid (kb 'ABase) 99 | => KB.Knowledgeable kb 'ABase 100 | => SrcSpan 101 | -> [ FlowSource 'ABase ] 102 | -> Var 103 | -> RepairT m (RepairResult kb) 104 | mkGuard sp flowSources var = do 105 | guardSym <- getFreshPredSym 106 | 107 | let guardPred = mkGuardPredicate guardSym sp 108 | let guardLit = mkGuardLiteral guardPred sp (TVar var) 109 | 110 | let mGuard = do 111 | eClausesFacts <- forM flowSources $ \case 112 | FSourceLiteral lit ix -> Just $ Left $ 113 | mkGuardClause sp guardLit (mkGuardBody sp lit var ix) 114 | 115 | FSourceConstant constant -> 116 | case constant of 117 | CSym sym -> Just $ Right $ mkGuardFact guardPred sym 118 | CWild -> Nothing 119 | 120 | pure $ partitionEithers eClausesFacts 121 | 122 | pure $ maybe NotFixable (uncurry (Guard guardLit) . second mconcat) mGuard 123 | 124 | mkGuardFact :: KB.Knowledgeable kb 'ABase 125 | => Predicate 1 'ABase -> Sym -> kb 'ABase 126 | mkGuardFact guardPred sym = KB.singleton $ 127 | KB.Knowledge KnowABase guardPred (V.singleton sym) 128 | 129 | mkGuardClause :: SrcSpan -> Literal 'ABase -> Body 'ABase -> Clause 'ABase 130 | mkGuardClause sp head body = Clause 131 | { _annotation = ClABase sp 132 | , _head = head 133 | , _body = body 134 | } 135 | 136 | mkGuardBody :: SrcSpan -> Literal ('ARename 'ABase) -> Var -> Int -> Body 'ABase 137 | mkGuardBody sp Literal{_predicate = guardPred@Predicate{..}} var ix = do 138 | let ts = replicate (fromIntegral . fromSing $ _arity) TWild 139 | 140 | V.withSizedList ts $ \(vts :: V.Vector n Term) -> 141 | case (sing :: SNat n) %~ _arity of 142 | Proved Refl -> (NE.:| []) $ Literal 143 | { _annotation = LitABase sp 144 | , _predicate = peel guardPred 145 | , _terms = V.unsafeUpd vts [(ix,TVar var)] 146 | , _polarity = Positive 147 | } 148 | _ -> panic "Argument vector generation failed." 149 | 150 | mkGuardPredicate :: PredicateSymbol -> SrcSpan -> Predicate 1 'ABase 151 | mkGuardPredicate predSym sp = Predicate 152 | { _annotation = PredABase sp 153 | , _predSym = predSym 154 | , _nature = Logical 155 | , _arity = sing :: SNat 1 156 | } 157 | 158 | mkGuardLiteral :: Predicate 1 'ABase -> SrcSpan -> Term -> Literal 'ABase 159 | mkGuardLiteral pred sp term = Literal 160 | { _annotation = LitABase sp 161 | , _predicate = pred 162 | , _terms = V.singleton term 163 | , _polarity = Positive 164 | } 165 | 166 | type RepairEnv = PositiveFlowGr 'ABase 167 | type RepairT m = ReaderT RepairEnv (FreshT m) 168 | 169 | runRepairT :: Monad m => Program ('ARename 'ABase) -> RepairT m a -> m a 170 | runRepairT pr = runFreshT (Just "guard") reserved . (`runReaderT` flowGr) 171 | where 172 | flowGr = analysePositiveFlow pr 173 | reserved = ((\Predicate{_predSym = PredicateSymbol txt} -> txt) $$) 174 | <$> predicates pr 175 | 176 | getPositiveFlowGraph :: Monad m => RepairT m (PositiveFlowGr 'ABase) 177 | getPositiveFlowGraph = ask 178 | 179 | getFreshPredSym :: Monad m => RepairT m PredicateSymbol 180 | getFreshPredSym = lift $ PredicateSymbol <$> fresh 181 | -------------------------------------------------------------------------------- /src/Language/Exalog/SemiNaive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE DuplicateRecordFields #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE ExistentialQuantification #-} 12 | 13 | 14 | module Language.Exalog.SemiNaive 15 | ( semiNaive 16 | , SemiNaive 17 | , evalSemiNaiveT 18 | , evalClauses 19 | ) where 20 | 21 | import Protolude hiding (head, pred, sym) 22 | 23 | import qualified Data.Vector.Sized as V 24 | 25 | import Language.Exalog.Core 26 | import Language.Exalog.Delta 27 | import Language.Exalog.Logger 28 | import qualified Language.Exalog.KnowledgeBase.Knowledge as KB 29 | import qualified Language.Exalog.KnowledgeBase.Class as KB 30 | import Language.Exalog.SrcLoc (Spannable(..)) 31 | import qualified Language.Exalog.Unification as U 32 | 33 | type SemiNaiveT kb = ReaderT kb 34 | type SemiNaive kb = SemiNaiveT kb (LoggerT IO) 35 | 36 | evalSemiNaiveT :: KB.Knowledgeable kb ann => SemiNaiveT (kb ann) m a -> kb ann -> m a 37 | evalSemiNaiveT = runReaderT 38 | 39 | semiNaive :: forall a b c kb 40 | . SpannableAST a 41 | => Identifiable (PredicateAnn a) b 42 | => Identifiable (KnowledgeAnn a) c 43 | => KB.Knowledgeable kb ('ADelta a) 44 | => KB.KnowledgeMaker a 45 | => Semigroup (kb ('ADelta a)) 46 | => Stratum ('ADelta a) 47 | -> SemiNaive (kb ('ADelta a)) (kb ('ADelta a)) 48 | semiNaive stratum@(Stratum clss) = do 49 | initEDB <- ask 50 | 51 | (`fix` initEDB) $ \f edb -> do 52 | betterEDB <- local (const edb) step 53 | if areAllDeltaEmpty betterEDB 54 | then return betterEDB 55 | else f betterEDB 56 | where 57 | intentionalPreds :: [ PredicateBox a ] 58 | intentionalPreds = map peel $ intentionals stratum 59 | 60 | areAllDeltaEmpty :: kb ('ADelta a) -> Bool 61 | areAllDeltaEmpty = KB.null 62 | . KB.filter (\(KB.Knowledge _ p _) -> decor p == Delta) 63 | 64 | -- Adds the current deltas to the normal version of the relation. 65 | -- Basicall S_{i+1} = S_i \cup delta S_i 66 | updateFromDelta :: KB.KnowledgeMaker a => kb ('ADelta a) -> kb ('ADelta a) 67 | updateFromDelta edb = 68 | sconcat $ edb :| map (updateFromDelta' edb) intentionalPreds 69 | 70 | updateFromDelta' :: KB.KnowledgeMaker a 71 | => kb ('ADelta a) -> PredicateBox a -> kb ('ADelta a) 72 | updateFromDelta' edb (PredicateBox p) = (`KB.atEach` prevsAndDeltas) $ 73 | \knowledge@(KB.Knowledge ann pred terms) -> 74 | case decor pred of 75 | Delta -> KB.Knowledge ann (updateDecor Current pred) terms 76 | Prev -> KB.Knowledge ann (updateDecor Current pred) terms 77 | _ -> knowledge 78 | where 79 | 80 | prevsAndDeltas = (`KB.filter` edb) $ \KB.Knowledge{_predicate} -> 81 | PredicateBox _predicate `elem` 82 | [ PredicateBox (mkDeltaPredicate Delta p) 83 | , PredicateBox (mkDeltaPredicate Prev p) 84 | ] 85 | 86 | -- Current to Prev 87 | shiftPrevs :: (Identifiable (KnowledgeAnn a) id, Ord id) 88 | => kb ('ADelta a) -> kb ('ADelta a) 89 | shiftPrevs kb = (`KB.atEach` kb) $ \knowledge@(KB.Knowledge ann pred terms) -> 90 | case decor pred of 91 | Current -> KB.Knowledge ann (updateDecor Prev pred) terms 92 | _ -> knowledge 93 | 94 | axeDeltaRedundancies :: (Identifiable (KnowledgeAnn a) id, Ord id) 95 | => kb ('ADelta a) -> kb ('ADelta a) 96 | axeDeltaRedundancies edb = (deltas `KB.difference` currentsAsDeltas) <> others 97 | where 98 | (deltas,others) = 99 | KB.partition (\(KB.Knowledge _ pred _) -> decor pred == Delta) edb 100 | currents = 101 | KB.filter (\(KB.Knowledge _ pred _) -> decor pred == Current) others 102 | currentsAsDeltas = (`KB.atEach` currents) $ \KB.Knowledge{_predicate,..} -> 103 | KB.Knowledge{_predicate = updateDecor Delta _predicate,..} 104 | 105 | step :: (KB.KnowledgeMaker a, Identifiable (KnowledgeAnn a) id, Ord id) 106 | => SemiNaive (kb ('ADelta a)) (kb ('ADelta a)) 107 | step = do 108 | let evalClauses' = evalClauses clss 109 | let maintenance = updateFromDelta . shiftPrevs . elimDecor Prev 110 | axeDeltaRedundancies <$> local maintenance evalClauses' 111 | 112 | evalClauses :: SpannableAST a 113 | => Identifiable (PredicateAnn a) b 114 | => KB.Knowledgeable kb a 115 | => KB.KnowledgeMaker a 116 | => Semigroup (kb a) 117 | => [ Clause a ] -> SemiNaive (kb a) (kb a) 118 | evalClauses clss = do 119 | kbs <- mapM evalClause clss 120 | edb <- ask 121 | return $ sconcat (edb :| kbs) 122 | 123 | evalClause :: forall a b kb 124 | . SpannableAST a 125 | => Identifiable (PredicateAnn a) b 126 | => KB.Knowledgeable kb a 127 | => KB.KnowledgeMaker a 128 | => Clause a -> SemiNaive (kb a) (kb a) 129 | evalClause cl@Clause{..} = deriveHead =<< foldM walkBody [ U.empty ] _body 130 | where 131 | deriveHead :: [ U.Unifier ] -> SemiNaive (kb a) (kb a) 132 | deriveHead unifiers 133 | | Literal{_predicate = pred, _terms = terms} <- _head = 134 | fmap KB.fromList $ sequence $ do 135 | unifier <- unifiers 136 | let preTuple = unifier `U.substitute` terms 137 | let groundClause = unifier `U.substitute` cl 138 | let tupleM = lift $ extractHeadTuple preTuple 139 | pure $ KB.mkKnowledge groundClause pred <$> tupleM 140 | 141 | walkBody :: [ U.Unifier ] -> Literal a -> SemiNaive (kb a) [ U.Unifier ] 142 | walkBody unifiers lit = fmap (catMaybes . concat) $ sequence $ do 143 | unifier <- unifiers 144 | return $ fmap (`U.extend` unifier) 145 | <$> execLiteral (unifier `U.substitute` lit) 146 | 147 | extractHeadTuple :: V.Vector n Term -> Logger (V.Vector n Sym) 148 | extractHeadTuple = traverse (\case 149 | TSym sym -> pure sym 150 | TVar{} -> scream (span cl) "Range-restriction is violated" 151 | TWild -> scream (span cl) "Head contains a wildcard") 152 | 153 | execLiteral :: SpannableAST a 154 | => Identifiable (PredicateAnn a) b 155 | => KB.Knowledgeable kb a 156 | => Literal a -> SemiNaive (kb a) [ U.Unifier ] 157 | execLiteral lit@Literal{_predicate = p@Predicate{_nature = nature}, ..} 158 | | Extralogical foreignAction <- nature = do 159 | eTuples <- liftIO $ runExceptT $ foreignAction _terms 160 | case eTuples of 161 | Right tuples -> return $ handleTuples _terms tuples 162 | Left msg -> lift $ scold (span lit) $ 163 | "Fatal foreign function error: " <> msg 164 | | otherwise = handleTuples _terms . KB.findByPred p <$> ask 165 | where 166 | handleTuples :: V.Vector n Term -> [ V.Vector n Sym ] -> [ U.Unifier ] 167 | handleTuples terms tuples = 168 | case _polarity of 169 | Positive -> tuplesToUnifiers terms tuples 170 | Negative -> [ U.empty | null (tuplesToUnifiers terms tuples) ] 171 | 172 | tuplesToUnifiers :: V.Vector n Term -> [ V.Vector n Sym ] -> [ U.Unifier ] 173 | tuplesToUnifiers terms = mapMaybe (U.unify terms) 174 | -------------------------------------------------------------------------------- /src/Language/Exalog/Provenance.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE DuplicateRecordFields #-} 13 | 14 | module Language.Exalog.Provenance 15 | ( Provenance(..) 16 | , PredicateAnn(..) 17 | , LiteralAnn(..) 18 | , ClauseAnn(..) 19 | , ProgramAnn(..) 20 | , KnowledgeAnn(..) 21 | , DecorableAST 22 | , DecorableAnn) where 23 | 24 | import Protolude hiding (head, pred) 25 | 26 | import Data.Aeson (ToJSON(..), Value(..)) 27 | import qualified Data.HashMap.Strict as HM 28 | 29 | import Language.Exalog.Core 30 | import qualified Language.Exalog.KnowledgeBase.Knowledge as KB 31 | import Language.Exalog.Pretty.Helper (Pretty(..)) 32 | import Language.Exalog.Pretty () 33 | 34 | data Provenance a = Derived (Clause a) | Given deriving Generic 35 | 36 | deriving instance Eq (Clause a) => Eq (Provenance a) 37 | deriving instance Ord (Clause a) => Ord (Provenance a) 38 | deriving instance Show (Clause a) => Show (Provenance a) 39 | 40 | instance (Pretty (Clause a)) => Pretty (Provenance a) where 41 | pretty Given = "G" 42 | pretty (Derived cl) = "D:" <> pretty cl 43 | 44 | instance ToJSON (Provenance a) where 45 | 46 | instance 47 | ( Pretty (Provenance a) 48 | , Pretty b 49 | ) => Pretty (Provenance a, b) where 50 | pretty (prov, b) = pretty prov <> "_" <> pretty b 51 | 52 | newtype instance PredicateAnn ('AProvenance a) = PredAProvenance (PredicateAnn a) 53 | newtype instance LiteralAnn ('AProvenance a) = LitAProvenance (LiteralAnn a) 54 | newtype instance ClauseAnn ('AProvenance a) = ClAProvenance (ClauseAnn a) 55 | newtype instance ProgramAnn ('AProvenance a) = ProgAProvenance (ProgramAnn a) 56 | data instance KnowledgeAnn ('AProvenance a) = KnowAProvenance 57 | { _provenance :: Provenance ('AProvenance a) 58 | , _prevAnn :: KnowledgeAnn a 59 | } 60 | 61 | instance 62 | ( Identifiable (PredicateAnn a) id 63 | , Identifiable (Ann Literal a) id2 64 | , Pretty (KnowledgeAnn a) 65 | ) => Pretty (KnowledgeAnn ('AProvenance a)) where 66 | pretty (KnowAProvenance prov prev) = pretty prov <> pretty prev 67 | 68 | instance KB.KnowledgeMaker ann => KB.KnowledgeMaker ('AProvenance ann) where 69 | mkKnowledge clause pred syms = KB.Knowledge 70 | (KnowAProvenance 71 | (Derived clause) 72 | (KB._annotation previousKnowledge) 73 | ) 74 | pred 75 | syms 76 | where 77 | previousKnowledge = 78 | KB.mkKnowledge 79 | (peel clause) 80 | (peel pred) 81 | syms 82 | 83 | deriving instance Show (PredicateAnn a) => Show (PredicateAnn ('AProvenance a)) 84 | deriving instance Show (LiteralAnn a) => Show (LiteralAnn ('AProvenance a)) 85 | deriving instance Show (ClauseAnn a) => Show (ClauseAnn ('AProvenance a)) 86 | deriving instance Show (ProgramAnn a) => Show (ProgramAnn ('AProvenance a)) 87 | deriving instance (Show (Clause ('AProvenance a)), Show (KnowledgeAnn a)) => Show (KnowledgeAnn ('AProvenance a)) 88 | 89 | deriving instance Eq (PredicateAnn a) => Eq (PredicateAnn ('AProvenance a)) 90 | deriving instance Eq (LiteralAnn a) => Eq (LiteralAnn ('AProvenance a)) 91 | deriving instance Eq (ClauseAnn a) => Eq (ClauseAnn ('AProvenance a)) 92 | deriving instance Eq (ProgramAnn a) => Eq (ProgramAnn ('AProvenance a)) 93 | deriving instance ( 94 | IdentifiableAnn (ClauseAnn a) id1, 95 | IdentifiableAnn (PredicateAnn a) id2, 96 | IdentifiableAnn (LiteralAnn a) id3, 97 | Eq id1, Eq id2, Eq id3, 98 | Eq (KnowledgeAnn a) 99 | ) => Eq (KnowledgeAnn ('AProvenance a)) 100 | 101 | deriving instance Ord (PredicateAnn a) => Ord (PredicateAnn ('AProvenance a)) 102 | deriving instance Ord (LiteralAnn a) => Ord (LiteralAnn ('AProvenance a)) 103 | deriving instance Ord (ClauseAnn a) => Ord (ClauseAnn ('AProvenance a)) 104 | deriving instance Ord (ProgramAnn a) => Ord (ProgramAnn ('AProvenance a)) 105 | deriving instance ( 106 | IdentifiableAnn (ClauseAnn a) id1, 107 | IdentifiableAnn (PredicateAnn a) id2, 108 | IdentifiableAnn (LiteralAnn a) id3, 109 | Ord id1, Ord id2, Ord id3, 110 | Ord (KnowledgeAnn a) 111 | ) => Ord (KnowledgeAnn ('AProvenance a)) 112 | 113 | instance SpannableAnn (PredicateAnn a) => SpannableAnn (PredicateAnn ('AProvenance a)) where 114 | annSpan (PredAProvenance ann) = annSpan ann 115 | instance SpannableAnn (LiteralAnn a) => SpannableAnn (LiteralAnn ('AProvenance a)) where 116 | annSpan (LitAProvenance ann) = annSpan ann 117 | instance SpannableAnn (ClauseAnn a) => SpannableAnn (ClauseAnn ('AProvenance a)) where 118 | annSpan (ClAProvenance ann) = annSpan ann 119 | instance SpannableAnn (ProgramAnn a) => SpannableAnn (ProgramAnn ('AProvenance a)) where 120 | annSpan (ProgAProvenance ann) = annSpan ann 121 | 122 | instance IdentifiableAnn (PredicateAnn ann) b 123 | => IdentifiableAnn (PredicateAnn ('AProvenance ann)) b where 124 | idFragment (PredAProvenance rest) = idFragment rest 125 | instance IdentifiableAnn (LiteralAnn ann) b 126 | => IdentifiableAnn (LiteralAnn ('AProvenance ann)) b where 127 | idFragment (LitAProvenance rest) = idFragment rest 128 | instance IdentifiableAnn (ClauseAnn ann) b 129 | => IdentifiableAnn (ClauseAnn ('AProvenance ann)) b where 130 | idFragment (ClAProvenance rest) = idFragment rest 131 | instance IdentifiableAnn (ProgramAnn ann) b 132 | => IdentifiableAnn (ProgramAnn ('AProvenance ann)) b where 133 | idFragment (ProgAProvenance rest) = idFragment rest 134 | instance IdentifiableAnn (KnowledgeAnn ann) b 135 | => IdentifiableAnn (KnowledgeAnn ('AProvenance ann)) (Provenance ('AProvenance ann), b) where 136 | idFragment (KnowAProvenance provenance rest) = (provenance, idFragment rest) 137 | 138 | instance PeelableAnn PredicateAnn 'AProvenance where 139 | peelA (PredAProvenance prevAnn) = prevAnn 140 | instance PeelableAnn ClauseAnn 'AProvenance where 141 | peelA (ClAProvenance prevAnn) = prevAnn 142 | instance PeelableAnn LiteralAnn 'AProvenance where 143 | peelA (LitAProvenance prevAnn) = prevAnn 144 | instance PeelableAnn KnowledgeAnn 'AProvenance where 145 | peelA (KnowAProvenance _ prevAnn) = prevAnn 146 | 147 | instance PeelableAST (Literal ('AProvenance a)) where 148 | peel Literal{..} = Literal 149 | { _annotation = peelA _annotation 150 | , _predicate = peel _predicate 151 | , ..} 152 | 153 | instance PeelableAST (KB.Knowledge ('AProvenance a)) where 154 | peel KB.Knowledge{..} = KB.Knowledge 155 | { _annotation = peelA _annotation 156 | , _predicate = peel _predicate 157 | , ..} 158 | 159 | instance DecorableAnn PredicateAnn 'AProvenance where 160 | decorA = PredAProvenance 161 | instance DecorableAnn LiteralAnn 'AProvenance where 162 | decorA = LitAProvenance 163 | instance DecorableAnn ClauseAnn 'AProvenance where 164 | decorA = ClAProvenance 165 | instance DecorableAnn KnowledgeAnn 'AProvenance where 166 | decorA = KnowAProvenance Given 167 | instance DecorableAnn ProgramAnn 'AProvenance where 168 | decorA = ProgAProvenance 169 | 170 | instance DecorableAST (Literal a) 'AProvenance where 171 | decorate Literal{..} = 172 | Literal { _annotation = decorA _annotation 173 | , _predicate = decorate _predicate 174 | , ..} 175 | 176 | instance DecorableAST (KB.Knowledge a) 'AProvenance where 177 | decorate KB.Knowledge{..} = 178 | KB.Knowledge { _annotation = decorA _annotation 179 | , _predicate = decorate _predicate 180 | , ..} 181 | 182 | instance ToJSON (KB.Knowledge ('AProvenance 'ABase)) where 183 | toJSON kb@KB.Knowledge{..} = 184 | case (_provenance _annotation, toJSON $ peel kb) of 185 | (Given, json) -> json 186 | (Derived clause, Object o) -> 187 | Object $ HM.insert "provenance" (toJSON clause) o 188 | _ -> panic "Knowledge does not produce a JSON object." 189 | -------------------------------------------------------------------------------- /test/Language/Exalog/DataflowSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Language.Exalog.DataflowSpec (spec) where 4 | 5 | import Protolude hiding (not) 6 | 7 | import Test.Hspec 8 | 9 | import Data.List ((!!)) 10 | import qualified Data.List.NonEmpty as NE 11 | import Data.Maybe (fromJust) 12 | 13 | import qualified Fixture.RangeRestriction as RR 14 | import qualified Fixture.Negation as Neg 15 | import qualified Fixture.Dataflow as DF 16 | import Fixture.Util 17 | 18 | import Language.Exalog.Core 19 | import Language.Exalog.Dataflow 20 | import Language.Exalog.Renamer 21 | import qualified Language.Exalog.KnowledgeBase.Set as KB 22 | import Language.Exalog.Logger 23 | 24 | edgeShouldExist :: (Show (f ann), Show (g ann), HasEdge f g ann) 25 | => PositiveFlowGr ann -> (f ann, Int) -> (g ann, Int) 26 | -> Expectation 27 | edgeShouldExist flowGr src dst = 28 | shouldSatisfy (src, dst) (uncurry (isAnEdge flowGr)) 29 | 30 | edgeShouldntExist :: (Show (f ann), Show (g ann), HasEdge f g ann) 31 | => PositiveFlowGr ann -> (f ann, Int) -> (g ann, Int) 32 | -> Expectation 33 | edgeShouldntExist flowGr src dst = 34 | shouldNotSatisfy (src, dst) (uncurry (isAnEdge flowGr)) 35 | 36 | findRenamedPred :: [ PredicateBox ('ARename 'ABase) ] -> PredicateBox 'ABase -> PredicateBox ('ARename 'ABase) 37 | findRenamedPred pBoxes pBox = fromMaybe (panic "Predicate is not in the program.") 38 | . head 39 | . filter ((== pBox) . peel) 40 | $ pBoxes 41 | 42 | findRenamedLit :: [ Literal ('ARename 'ABase) ] -> Literal 'ABase -> Literal ('ARename 'ABase) 43 | findRenamedLit lits literal = fromMaybe (panic "Literal is not in the program.") 44 | . head 45 | . filter ((== literal) . peel) 46 | $ lits 47 | 48 | spec :: Spec 49 | spec = 50 | describe "Dataflow" $ 51 | describe "Positive" $ do 52 | let rrGr = analysePositiveFlow RR.prSimple 53 | renamedNegPr <- fromJust 54 | <$> (runIO . runLoggerT vanillaEnv 55 | $ fst 56 | <$> rename (Neg.program,mempty :: KB.Set 'ABase)) 57 | let negGr = analysePositiveFlow renamedNegPr 58 | describe "Overall graph" $ do 59 | it "programSimple has expected edges" $ do 60 | edgeShouldExist rrGr (RR.r (tvar "X"), 0) (PredicateBox RR.pPred, 0) 61 | edgeShouldExist rrGr (PredicateBox RR.queryPred, 0) (RR.r (tvar "X"), 0) 62 | 63 | it "negation fixture has expected edges" $ do 64 | -- Clause 1 65 | edgeShouldExist negGr (PredicateBox Neg.vPred, 0) (Neg.r (tvar "X") (tvar "Y"), 0) 66 | -- Clause 2 67 | edgeShouldExist negGr (PredicateBox Neg.vPred, 0) (Neg.r (tvar "X") (tvar "Y"), 1) 68 | -- Clause 3 69 | edgeShouldExist negGr (PredicateBox Neg.tPred, 0) (Neg.r (tvar "X") (tvar "Y"), 0) 70 | edgeShouldExist negGr (PredicateBox Neg.tPred, 1) (Neg.r (tvar "X") (tvar "Y"), 1) 71 | -- Clause 4 72 | edgeShouldExist negGr (PredicateBox Neg.tPred, 0) (Neg.t (tvar "X") (tvar "Z"), 0) 73 | edgeShouldExist negGr (PredicateBox Neg.tPred, 1) (Neg.r (tvar "Z") (tvar "Y"), 1) 74 | edgeShouldExist negGr (Neg.t (tvar "X") (tvar "Z"), 1) (Neg.r (tvar "Z") (tvar "Y"), 0) 75 | -- Following shouldn't exist because r is not intentional. 76 | edgeShouldntExist negGr (Neg.t (tvar "X") (tvar "Z"), 1) (PredicateBox Neg.rPred, 0) 77 | -- Clause 5 78 | edgeShouldExist negGr (PredicateBox Neg.tcPred, 0) (Neg.v (tvar "X"), 0) 79 | edgeShouldExist negGr (PredicateBox Neg.tcPred, 1) (Neg.v (tvar "Y"), 0) 80 | edgeShouldExist negGr (Neg.v (tvar "X"), 0) (not $ Neg.t (tvar "X") (tvar "Y"), 0) 81 | edgeShouldExist negGr (Neg.v (tvar "Y"), 0) (not $ Neg.t (tvar "X") (tvar "Y"), 1) 82 | -- Following should exist because t is intentional. 83 | edgeShouldExist negGr (Neg.v (tvar "X"), 0) (PredicateBox Neg.tPred, 0) 84 | edgeShouldExist negGr (Neg.v (tvar "Y"), 0) (PredicateBox Neg.tPred, 1) 85 | 86 | describe "Nearest covering positives" $ do 87 | it "negation fixture has expected covers" $ do 88 | let prs = findRenamedPred $ predicates renamedNegPr 89 | let frs = (\cl -> findRenamedLit (NE.toList . literals $ cl)) 90 | <$> join (map _unStratum $ _strata renamedNegPr) 91 | 92 | -- v(Y) doesn't flow into r(Z,Y) because the second argument of 93 | -- the t preceding r(Z,Y) is free. 94 | let sink2 = FSinkLiteral ((frs !! 3) (Neg.r (tvar "Z") (tvar "Y"))) 1 95 | nearestCoveringPositives negGr sink2 `shouldBe` Nothing 96 | 97 | -- There is no covering for the r(X,Y) in the first clause 98 | let sink3 = FSinkLiteral ((fromJust $ head frs) (Neg.r (tvar "X") (tvar "Y"))) 1 99 | nearestCoveringPositives negGr sink3 `shouldBe` Nothing 100 | 101 | -- There is no covering for tc predicate 102 | let sink4 = FSinkPredicate (prs (PredicateBox Neg.tcPred)) 1 103 | nearestCoveringPositives negGr sink4 `shouldBe` Nothing 104 | 105 | it "constant dataflow example has proper covers" $ do 106 | let flowGr = analysePositiveFlow DF.prConst 107 | nearestCoveringPositives flowGr DF.flowSinkQ `shouldBe` DF.flowSourcesConst 108 | 109 | it "wildcard dataflow example has proper covers" $ do 110 | let flowGr = analysePositiveFlow DF.prWild 111 | nearestCoveringPositives flowGr DF.flowSinkQ `shouldBe` DF.flowSourcesWild 112 | 113 | it "single open dataflow example has proper covers" $ do 114 | let flowGr = analysePositiveFlow DF.prSingleOpen 115 | nearestCoveringPositives flowGr DF.flowSinkQ `shouldBe` DF.flowSourcesSingleOpen 116 | 117 | it "multiple closed dataflow example has proper covers" $ do 118 | let flowGr = analysePositiveFlow DF.prMultipleClosed 119 | nearestCoveringPositives flowGr DF.flowSinkQ `shouldBe` DF.flowSourcesMultipleClosed 120 | 121 | it "half open dataflow example has proper covers" $ do 122 | let flowGr = analysePositiveFlow DF.prHalfOpen 123 | nearestCoveringPositives flowGr DF.flowSinkQ `shouldBe` DF.flowSourcesHalfOpen 124 | 125 | it "alias head closed dataflow example has proper covers" $ do 126 | let flowGr = analysePositiveFlow DF.prAliasHeadClosed 127 | nearestCoveringPositives flowGr DF.flowSinkQ `shouldBe` DF.flowSourcesAliasHeadClosed 128 | 129 | it "alias head open dataflow example has proper covers" $ do 130 | let flowGr = analysePositiveFlow DF.prAliasHeadOpen 131 | nearestCoveringPositives flowGr DF.flowSinkQ `shouldBe` DF.flowSourcesAliasHeadOpen 132 | 133 | it "alias body dataflow example has proper covers" $ do 134 | let flowGr = analysePositiveFlow DF.prAliasBody 135 | nearestCoveringPositives flowGr DF.flowSinkR `shouldBe` DF.flowSourcesAliasBody 136 | 137 | it "indirection dataflow example has proper covers" $ do 138 | let flowGr = analysePositiveFlow DF.prIndirection 139 | nearestCoveringPositives flowGr DF.flowSinkQ `shouldBe` DF.flowSourcesIndirection 140 | 141 | it "closed recursion dataflow example has proper covers" $ do 142 | let flowGr = analysePositiveFlow DF.prRecClosed 143 | nearestCoveringPositives flowGr DF.flowSinkQ `shouldBe` DF.flowSourcesRecClosed 144 | 145 | it "indifferent closed recursion dataflow example has proper covers" $ do 146 | let flowGr = analysePositiveFlow DF.prRecClosedIndiff 147 | nearestCoveringPositives flowGr DF.flowSinkQ `shouldBe` DF.flowSourcesRecClosedIndiff 148 | 149 | it "exposed query dataflow example has proper covers" $ do 150 | let flowGr = analysePositiveFlow DF.prExposed 151 | nearestCoveringPositives flowGr DF.flowSinkQ `shouldBe` DF.flowSourcesExposed 152 | 153 | it "exposed query leads to null node" $ do 154 | let flowGr = analysePositiveFlow DF.prExposed 155 | nearestCoveringPositives flowGr DF.flowSinkQ `shouldBe` DF.flowSourcesExposed 156 | 157 | it "dead path does not lead to null node" $ do 158 | let flowGr = analysePositiveFlow DF.prDeadPath 159 | nearestCoveringPositives flowGr DF.flowSinkQ `shouldBe` DF.flowSourcesDeadPath 160 | -------------------------------------------------------------------------------- /fixtures/Fixture/Foreign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.Foreign 4 | -- Leq100 5 | ( programLeq100 6 | , initLeq100EDB 7 | , leq100Pred 8 | , leq100Tuples 9 | 10 | -- PrefixOf 11 | , programPrefixOf 12 | , initPrefixOfEDB 13 | , prefixOfPred 14 | , prefixOfTuples 15 | 16 | -- Cartesian 17 | , programCartesian23 18 | , initCartesian23EDB 19 | , cartesian23Pred 20 | , cartesian23Tuples 21 | 22 | -- Impure 23 | , programImpure 24 | , initImpureEDB 25 | , impurePred 26 | , impureTuples 27 | ) where 28 | 29 | import Protolude hiding (isPrefixOf, Set) 30 | 31 | import Data.Maybe (fromJust) 32 | import qualified Data.Text as Text 33 | import qualified Data.List.NonEmpty as NE 34 | import qualified Data.Vector.Sized as V 35 | import Data.Singletons.TypeLits 36 | 37 | import Language.Exalog.Core 38 | import Language.Exalog.ForeignFunction 39 | import Language.Exalog.KnowledgeBase.Class 40 | import Language.Exalog.KnowledgeBase.Knowledge 41 | import Language.Exalog.KnowledgeBase.Set 42 | import Language.Exalog.SrcLoc 43 | 44 | import Fixture.Util 45 | 46 | -------------------------------------------------------------------------------- 47 | -- leq100 Fixture 48 | -------------------------------------------------------------------------------- 49 | 50 | srcPred :: Predicate 1 'ABase 51 | srcPred = Predicate (PredABase NoSpan) "src" SNat Logical 52 | 53 | leqPred :: Predicate 2 'ABase 54 | leqPred = Predicate (PredABase NoSpan) "<" SNat (Extralogical $ liftPredicate ((<) :: Int -> Int -> Bool)) 55 | 56 | leq100Pred :: Predicate 1 'ABase 57 | leq100Pred = Predicate (PredABase NoSpan) "leq100" SNat Logical 58 | 59 | src :: Term -> Literal 'ABase 60 | src t = lit srcPred $ fromJust $ V.fromList [ t ] 61 | 62 | leq :: Term -> Term -> Literal 'ABase 63 | leq t t' = lit leqPred $ fromJust $ V.fromList [ t, t' ] 64 | 65 | leq100 :: Term -> Literal 'ABase 66 | leq100 t = lit leq100Pred $ fromJust $ V.fromList [ t ] 67 | 68 | {- 69 | - src("10"). 70 | - src("99"). 71 | - src("100"). 72 | - src("3000"). 73 | - leq100(X) :- src(X), X < 100. 74 | -} 75 | programLeq100 :: Program 'ABase 76 | programLeq100 = Program (ProgABase NoSpan) 77 | (Stratum <$> 78 | [ [ Clause (ClABase NoSpan) (leq100 (tvar "X")) $ NE.fromList 79 | [ src (tvar "X") 80 | , leq (tvar "X") (tsym (100 :: Int)) ] 81 | ] 82 | ]) 83 | [ PredicateBox leq100Pred ] 84 | 85 | srcTuples :: [ V.Vector 1 Int ] 86 | srcTuples = fromJust . V.fromList <$> 87 | [ [ 10 ], [ 99 ], [ 100 ], [ 3000 ] ] 88 | 89 | initLeq100EDB :: Set 'ABase 90 | initLeq100EDB = fromList $ Knowledge KnowABase srcPred . fmap symbol <$> srcTuples 91 | 92 | leq100Tuples :: [ V.Vector 1 Sym ] 93 | leq100Tuples = fmap symbol . fromJust . V.fromList <$> 94 | ([ [ 10 ], [ 99 ] ] :: [ [ Int ] ]) 95 | 96 | -------------------------------------------------------------------------------- 97 | -- prefixOf Fixture 98 | -------------------------------------------------------------------------------- 99 | 100 | src2Pred :: Predicate 1 'ABase 101 | src2Pred = Predicate (PredABase NoSpan) "src2" SNat Logical 102 | 103 | isPrefixOfPred :: Predicate 2 'ABase 104 | isPrefixOfPred = Predicate (PredABase NoSpan) "isPrefixOf" SNat (Extralogical $ liftPredicate (Text.isPrefixOf :: Text -> Text -> Bool)) 105 | 106 | prefixOfPred :: Predicate 2 'ABase 107 | prefixOfPred = Predicate (PredABase NoSpan) "prefixOf" SNat Logical 108 | 109 | src2 :: Term -> Literal 'ABase 110 | src2 t = lit src2Pred $ fromJust $ V.fromList [ t ] 111 | 112 | isPrefixOf :: Term -> Term -> Literal 'ABase 113 | isPrefixOf t t' = lit isPrefixOfPred $ fromJust $ V.fromList [ t, t' ] 114 | 115 | prefixOf :: Term -> Term -> Literal 'ABase 116 | prefixOf t t' = lit prefixOfPred $ fromJust $ V.fromList [ t, t' ] 117 | 118 | {- 119 | - src2(""). 120 | - src2("Mis"). 121 | - src2("Andrew"). 122 | - src2("Mistral"). 123 | - src2("Mistral Contrastin"). 124 | - prefixOf(X,Y) :- src(X), src(Y), isPrefixOf(X,Y). 125 | -} 126 | programPrefixOf :: Program 'ABase 127 | programPrefixOf = Program (ProgABase NoSpan) 128 | (Stratum <$> 129 | [ [ Clause (ClABase NoSpan) (prefixOf (tvar "X") (tvar "Y")) $ NE.fromList 130 | [ src2 (tvar "X") 131 | , src2 (tvar "Y") 132 | , tvar "X" `isPrefixOf` tvar "Y" ] 133 | ] 134 | ]) 135 | [ PredicateBox prefixOfPred ] 136 | 137 | src2Tuples :: [ V.Vector 1 Text ] 138 | src2Tuples = fromJust . V.fromList <$> 139 | ([ [ "" ], [ "Mis" ], [ "Andrew" ], [ "Mistral" ], [ "Mistral Contrastin" ] ] 140 | :: [ [ Text ] ]) 141 | 142 | initPrefixOfEDB :: Set 'ABase 143 | initPrefixOfEDB = fromList $ Knowledge KnowABase src2Pred . fmap symbol <$> src2Tuples 144 | 145 | prefixOfTuples :: [ V.Vector 2 Sym ] 146 | prefixOfTuples = fmap symbol . fromJust . V.fromList <$> 147 | ([ [ "", "" ], [ "", "Mis" ], [ "", "Andrew" ], [ "", "Mistral" ], [ "", "Mistral Contrastin" ] 148 | , [ "Mis", "Mis" ], [ "Mis", "Mistral" ], [ "Mis", "Mistral Contrastin" ] 149 | , [ "Andrew", "Andrew" ] 150 | , [ "Mistral", "Mistral" ], [ "Mistral", "Mistral Contrastin" ] 151 | , [ "Mistral Contrastin", "Mistral Contrastin" ] 152 | ] :: [ [ Text ] ]) 153 | 154 | -------------------------------------------------------------------------------- 155 | -- cartesian Fixture 156 | -------------------------------------------------------------------------------- 157 | 158 | cart :: Int -> Int -> [ (Int, Int) ] 159 | cart n m = [ (i,j) | i <- [1..n], j <- [1..m] ] 160 | 161 | cartesianPred :: Predicate 4 'ABase 162 | cartesianPred = 163 | Predicate (PredABase NoSpan) "cartesian" SNat (Extralogical $ liftFunction cart) 164 | 165 | cartesian23Pred :: Predicate 2 'ABase 166 | cartesian23Pred = Predicate (PredABase NoSpan) "cartesian23" SNat Logical 167 | 168 | cartesian :: Term -> Term -> Term -> Term -> Literal 'ABase 169 | cartesian t t' t'' t''' = lit cartesianPred $ fromJust $ V.fromList [ t, t', t'', t''' ] 170 | 171 | cartesian23 :: Term -> Term -> Literal 'ABase 172 | cartesian23 t t' = lit cartesian23Pred $ fromJust $ V.fromList [ t, t' ] 173 | 174 | {- 175 | - cartesian23(X,Y) :- cartesian(2,3,X,Y). 176 | -} 177 | programCartesian23 :: Program 'ABase 178 | programCartesian23 = Program (ProgABase NoSpan) 179 | (Stratum <$> 180 | [ [ Clause (ClABase NoSpan) (cartesian23 (tvar "X") (tvar "Y")) $ NE.fromList 181 | [ cartesian (tsym (2 :: Int)) (tsym (3 :: Int)) (tvar "X") (tvar "Y") ] 182 | ] 183 | ]) 184 | [ PredicateBox cartesian23Pred ] 185 | 186 | initCartesian23EDB :: Set 'ABase 187 | initCartesian23EDB = fromList [ ] 188 | 189 | cartesian23Tuples :: [ V.Vector 2 Sym ] 190 | cartesian23Tuples = fmap symbol . fromJust . V.fromList <$> 191 | ([ [ 1, 1 ] , [ 1, 2 ], [ 1, 3] , [ 2, 1 ] , [ 2, 2 ], [ 2, 3 ] ] :: [ [ Int ] ]) 192 | 193 | -------------------------------------------------------------------------------- 194 | -- Non-pure fixture 195 | -------------------------------------------------------------------------------- 196 | 197 | impureIDForeign :: Int -> Foreign Int 198 | impureIDForeign = pure 199 | 200 | impureIDPred :: Predicate 2 'ABase 201 | impureIDPred = Predicate 202 | (PredABase NoSpan) 203 | "impureID" 204 | SNat 205 | (Extralogical $ liftFunctionME impureIDForeign) 206 | 207 | impureID :: Term -> Term -> Literal 'ABase 208 | impureID t t' = lit impureIDPred $ fromJust $ V.fromList [ t, t' ] 209 | 210 | impureFinForeign :: Int -> Foreign [ Int ] 211 | impureFinForeign i = pure [0..i] 212 | 213 | impureFinPred :: Predicate 2 'ABase 214 | impureFinPred = Predicate 215 | (PredABase NoSpan) 216 | "impureFin" 217 | SNat 218 | (Extralogical $ liftFunctionME impureFinForeign) 219 | 220 | impureFin :: Term -> Term -> Literal 'ABase 221 | impureFin t t' = lit impureFinPred $ fromJust $ V.fromList [ t, t' ] 222 | 223 | impureEvenForeign :: Int -> Foreign Bool 224 | impureEvenForeign = pure . even 225 | 226 | impureEvenPred :: Predicate 1 'ABase 227 | impureEvenPred = Predicate 228 | (PredABase NoSpan) 229 | "impureEven" 230 | SNat 231 | (Extralogical $ liftPredicateME impureEvenForeign) 232 | 233 | impureEven :: Term -> Literal 'ABase 234 | impureEven t = lit impureEvenPred $ fromJust $ V.fromList [ t ] 235 | 236 | impurePred :: Predicate 1 'ABase 237 | impurePred = Predicate (PredABase NoSpan) "impure" SNat Logical 238 | 239 | impure :: Term -> Literal 'ABase 240 | impure t = lit impurePred $ fromJust $ V.fromList [ t ] 241 | 242 | programImpure :: Program 'ABase 243 | programImpure = Program (ProgABase NoSpan) 244 | (Stratum <$> 245 | [ [ Clause (ClABase NoSpan) (impure (tvar "Y")) $ NE.fromList 246 | [ impureFin (tsym (10 :: Int)) (tvar "X") 247 | , impureEven (tvar "X") 248 | , impureID (tvar "X") (tvar "Y")] 249 | ] 250 | ]) 251 | [ PredicateBox impurePred ] 252 | 253 | initImpureEDB :: Set 'ABase 254 | initImpureEDB = fromList [ ] 255 | 256 | impureTuples :: [ V.Vector 1 Sym ] 257 | impureTuples = fmap symbol . fromJust . V.fromList <$> 258 | ([ [ 0 ], [ 2 ], [ 4 ], [ 6 ], [ 8 ], [ 10 ] ] :: [ [ Int ] ]) 259 | -------------------------------------------------------------------------------- /src/Language/Exalog/Delta.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | {-# LANGUAGE DuplicateRecordFields #-} 13 | {-# LANGUAGE MultiParamTypeClasses #-} 14 | 15 | module Language.Exalog.Delta 16 | ( Decor(..) 17 | , updateDecor 18 | , decor 19 | , elimDecor 20 | , mkDeltaPredicate 21 | , mkDeltaLiteral 22 | , mkDeltaStratum 23 | , mkDeltaSolution 24 | , cleanDeltaSolution 25 | ) where 26 | 27 | import Protolude hiding (head, pred) 28 | 29 | import Control.Comonad (Comonad(..)) 30 | 31 | import Language.Exalog.Pretty.Helper (Pretty(..)) 32 | import Language.Exalog.Core 33 | import qualified Language.Exalog.KnowledgeBase.Knowledge as KB 34 | import qualified Language.Exalog.KnowledgeBase.Class as KB 35 | import qualified Language.Exalog.Util.List.Zipper as LZ 36 | 37 | data Decor = Constant | Current | Delta | Prev deriving (Eq, Ord, Show) 38 | 39 | instance Pretty Decor where 40 | pretty Constant = "Constant" 41 | pretty Current = "Current" 42 | pretty Delta = "Δ" 43 | pretty Prev = "-1" 44 | 45 | instance Pretty b => Pretty (Decor, b) where 46 | pretty (dec, b) = pretty dec <> "_" <> pretty b 47 | 48 | data instance PredicateAnn ('ADelta a) = PredADelta Decor (PredicateAnn a) 49 | data instance LiteralAnn ('ADelta a) = LitADelta (LiteralAnn a) 50 | newtype instance ClauseAnn ('ADelta a) = ClADelta (ClauseAnn a) 51 | newtype instance ProgramAnn ('ADelta a) = ProgADelta (ProgramAnn a) 52 | newtype instance KnowledgeAnn ('ADelta a) = KnowADelta (KnowledgeAnn a) 53 | 54 | instance KB.KnowledgeMaker ann => KB.KnowledgeMaker ('ADelta ann) where 55 | mkKnowledge clause pred syms = 56 | KB.Knowledge (KnowADelta oldAnn) pred syms 57 | where 58 | oldAnn = KB._annotation (KB.mkKnowledge (peel clause) (peel pred) syms) 59 | 60 | deriving instance Show (PredicateAnn a) => Show (PredicateAnn ('ADelta a)) 61 | deriving instance Show (LiteralAnn a) => Show (LiteralAnn ('ADelta a)) 62 | deriving instance Show (ClauseAnn a) => Show (ClauseAnn ('ADelta a)) 63 | deriving instance Show (ProgramAnn a) => Show (ProgramAnn ('ADelta a)) 64 | deriving instance Show (KnowledgeAnn a) => Show (KnowledgeAnn ('ADelta a)) 65 | 66 | deriving instance Eq (PredicateAnn a) => Eq (PredicateAnn ('ADelta a)) 67 | deriving instance Eq (LiteralAnn a) => Eq (LiteralAnn ('ADelta a)) 68 | deriving instance Eq (ClauseAnn a) => Eq (ClauseAnn ('ADelta a)) 69 | deriving instance Eq (ProgramAnn a) => Eq (ProgramAnn ('ADelta a)) 70 | deriving instance Eq (KnowledgeAnn a) => Eq (KnowledgeAnn ('ADelta a)) 71 | 72 | deriving instance Ord (PredicateAnn a) => Ord (PredicateAnn ('ADelta a)) 73 | deriving instance Ord (LiteralAnn a) => Ord (LiteralAnn ('ADelta a)) 74 | deriving instance Ord (ClauseAnn a) => Ord (ClauseAnn ('ADelta a)) 75 | deriving instance Ord (ProgramAnn a) => Ord (ProgramAnn ('ADelta a)) 76 | deriving instance Ord (KnowledgeAnn a) => Ord (KnowledgeAnn ('ADelta a)) 77 | 78 | instance SpannableAnn (PredicateAnn a) => SpannableAnn (PredicateAnn ('ADelta a)) where 79 | annSpan (PredADelta _ ann) = annSpan ann 80 | instance SpannableAnn (LiteralAnn a) => SpannableAnn (LiteralAnn ('ADelta a)) where 81 | annSpan (LitADelta ann) = annSpan ann 82 | instance SpannableAnn (ClauseAnn a) => SpannableAnn (ClauseAnn ('ADelta a)) where 83 | annSpan (ClADelta ann) = annSpan ann 84 | instance SpannableAnn (ProgramAnn a) => SpannableAnn (ProgramAnn ('ADelta a)) where 85 | annSpan (ProgADelta ann) = annSpan ann 86 | 87 | instance IdentifiableAnn (PredicateAnn ann) b 88 | => IdentifiableAnn (PredicateAnn ('ADelta ann)) (Decor,b) where 89 | idFragment (PredADelta dec rest) = (dec, idFragment rest) 90 | instance IdentifiableAnn (LiteralAnn ann) b 91 | => IdentifiableAnn (LiteralAnn ('ADelta ann)) b where 92 | idFragment (LitADelta rest) = idFragment rest 93 | instance IdentifiableAnn (ClauseAnn ann) b 94 | => IdentifiableAnn (ClauseAnn ('ADelta ann)) b where 95 | idFragment (ClADelta rest) = idFragment rest 96 | instance IdentifiableAnn (ProgramAnn ann) b 97 | => IdentifiableAnn (ProgramAnn ('ADelta ann)) b where 98 | idFragment (ProgADelta rest) = idFragment rest 99 | instance IdentifiableAnn (KnowledgeAnn ann) b 100 | => IdentifiableAnn (KnowledgeAnn ('ADelta ann)) b where 101 | idFragment (KnowADelta rest) = idFragment rest 102 | 103 | updateDecor :: Decor -> Predicate n ('ADelta a) -> Predicate n ('ADelta a) 104 | updateDecor dec p@Predicate{_annotation = PredADelta _ prevAnn} = 105 | p {_annotation = PredADelta dec prevAnn} 106 | 107 | elimDecor :: KB.Knowledgeable kb ('ADelta a) => Decor -> kb ('ADelta a) -> kb ('ADelta a) 108 | elimDecor d sol = (`KB.filter` sol) $ \(KB.Knowledge _ p _) -> decor p /= d 109 | 110 | decor :: Predicate n ('ADelta a) -> Decor 111 | decor Predicate{_annotation = PredADelta dec _} = dec 112 | 113 | instance DecorableAnn LiteralAnn 'ADelta where decorA = LitADelta 114 | instance DecorableAnn ClauseAnn 'ADelta where decorA = ClADelta 115 | instance DecorableAnn ProgramAnn 'ADelta where decorA = ProgADelta 116 | instance DecorableAnn KnowledgeAnn 'ADelta where decorA = KnowADelta 117 | 118 | instance PeelableAnn PredicateAnn 'ADelta where 119 | peelA (PredADelta _ prevAnn) = prevAnn 120 | instance PeelableAnn LiteralAnn 'ADelta where 121 | peelA (LitADelta prevAnn) = prevAnn 122 | instance PeelableAnn ClauseAnn 'ADelta where 123 | peelA (ClADelta prevAnn) = prevAnn 124 | instance PeelableAnn KnowledgeAnn 'ADelta where 125 | peelA (KnowADelta prevAnn) = prevAnn 126 | 127 | instance PeelableAST (Literal ('ADelta a)) where 128 | peel Literal{..} = 129 | Literal { _annotation = peelA _annotation 130 | , _predicate = peel _predicate 131 | , ..} 132 | 133 | -- |For each clause, generate a version for each IDB predicate where the 134 | -- IDB predicate appears in delta form i.e. we focus on the newly generated 135 | -- facts for the predicate in focus. 136 | -- 137 | -- The IDB predicates that precede the delta predicate refer to the 138 | -- previous generation and those that follow refer to the generation 139 | -- before. This optimises repeated predicates. 140 | -- 141 | -- It eliminates all clauses that does not have any intensional predicates 142 | -- in its body. 143 | mkDeltaStratum :: forall a b. Eq (PredicateBox a) 144 | => IdentifiableAnn (PredicateAnn a) b => Ord b 145 | => Stratum a -> Stratum ('ADelta a) 146 | mkDeltaStratum stratum@(Stratum cls) = Stratum $ concatMap mkCls cls 147 | where 148 | intentionalPreds = intentionals stratum 149 | 150 | mkCls :: Clause a -> [ Clause ('ADelta a) ] 151 | mkCls Clause{..} = 152 | fmap (Clause (decorA _annotation) (mkDeltaLiteral Delta _head) . LZ.toNonEmptyList) 153 | . mapMaybe processBody 154 | . LZ.toList 155 | . duplicate 156 | . LZ.fromNonEmptyList $ _body 157 | 158 | processBody :: LZ.Zipper (Literal a) 159 | -> Maybe (LZ.Zipper (Literal ('ADelta a))) 160 | processBody lits 161 | | (`elem` intentionalPreds) . predicateBox . LZ.focus $ lits = Just 162 | . LZ.threeWayMap (mkPrev Current) (mkDeltaLiteral Delta) (mkPrev Prev) $ lits 163 | | otherwise = Nothing 164 | 165 | mkPrev :: Decor -> Literal a -> Literal ('ADelta a) 166 | mkPrev deco lit 167 | | predicateBox lit `elem` intentionalPreds = mkDeltaLiteral deco lit 168 | | otherwise = mkDeltaLiteral Constant lit 169 | 170 | mkDeltaLiteral :: Decor -> Literal a -> Literal ('ADelta a) 171 | mkDeltaLiteral deco Literal{..} = Literal 172 | { _annotation = decorA _annotation 173 | , _predicate = mkDeltaPredicate deco _predicate 174 | , ..} 175 | 176 | mkDeltaPredicate :: Decor -> Predicate n a -> Predicate n ('ADelta a) 177 | mkDeltaPredicate deco Predicate{..} = Predicate 178 | { _annotation = PredADelta deco _annotation 179 | , ..} 180 | 181 | mkDeltaSolution :: Semigroup (kb ('ADelta a)) 182 | => Identifiable (PredicateAnn a) id 183 | => Identifiable (KnowledgeAnn a) id1 184 | => KB.Knowledgeable kb a 185 | => [ PredicateBox a ] -> kb a -> kb ('ADelta a) 186 | mkDeltaSolution intentionalPreds kb = 187 | intDeltas <> intPrevs <> extCurrents 188 | where 189 | (intentionalKB, extensionalKB) = 190 | KB.partition (\(KB.Knowledge _ p _) -> PredicateBox p `elem` intentionalPreds) kb 191 | 192 | intDeltas = KB.atEach (mkDeltaKnowledge Delta) intentionalKB 193 | intPrevs = KB.atEach (mkDeltaKnowledge Prev) intentionalKB 194 | extCurrents = KB.atEach (mkDeltaKnowledge Constant) extensionalKB 195 | 196 | mkDeltaKnowledge :: Decor -> KB.Knowledge ann -> KB.Knowledge ('ADelta ann) 197 | mkDeltaKnowledge decoration (KB.Knowledge ann pred syms) = 198 | KB.Knowledge (decorA ann) (mkDeltaPredicate decoration pred) syms 199 | 200 | cleanDeltaSolution :: KB.Knowledgeable kb ('ADelta a) 201 | => Identifiable (PredicateAnn a) id 202 | => Identifiable (KnowledgeAnn a) id1 203 | => kb ('ADelta a) -> kb a 204 | cleanDeltaSolution = KB.atEach (\(KB.Knowledge ann pred syms) -> KB.Knowledge (peelA ann) (peel pred) syms) 205 | . KB.filter isCurrentOrConstant 206 | where 207 | isCurrentOrConstant (KB.Knowledge _ p _) = decor p `elem` [ Current, Constant ] 208 | -------------------------------------------------------------------------------- /fixtures/Fixture/Dataflow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Fixture.Dataflow where 4 | 5 | import Protolude hiding (pred) 6 | 7 | import Data.Maybe (fromJust) 8 | import qualified Data.List.NonEmpty as NE 9 | import qualified Data.Vector.Sized as V 10 | import Data.Singletons.TypeLits 11 | 12 | import Language.Exalog.Core 13 | import Language.Exalog.Dataflow 14 | import Language.Exalog.SrcLoc 15 | import Language.Exalog.Renamer 16 | 17 | import Fixture.Util hiding (lit) 18 | 19 | pred :: Int -> PredicateSymbol -> SNat n -> Nature n -> Predicate n ('ARename 'ABase) 20 | pred id = Predicate (PredARename (PredicateID id) $ PredABase NoSpan) 21 | lit :: Int -> Polarity -> Predicate n ('ARename 'ABase) -> V.Vector n Term -> Literal ('ARename 'ABase) 22 | lit id = Literal (LitARename (LiteralID id) $ LitABase NoSpan) 23 | cl :: Int -> Head ('ARename 'ABase) -> Body ('ARename 'ABase) -> Clause ('ARename 'ABase) 24 | cl id = Clause (ClARename (ClauseID id) $ ClABase NoSpan) 25 | 26 | pPred, qPred, sPred, aPred :: Predicate 1 ('ARename 'ABase) 27 | pPred = pred 0 "p" SNat Logical 28 | qPred = pred 1 "q" SNat Logical 29 | sPred = pred 2 "s" SNat Logical 30 | aPred = pred 3 "a" SNat Logical 31 | 32 | rPred :: Predicate 2 ('ARename 'ABase) 33 | rPred = pred 4 "r" SNat Logical 34 | 35 | queryPred :: Predicate 0 ('ARename 'ABase) 36 | queryPred = pred 5 "query" SNat Logical 37 | 38 | p, q, s, a :: Int -> Term -> Literal ('ARename 'ABase) 39 | p id t = lit id Positive pPred (fromJust $ V.fromList [ t ]) 40 | q id t = lit id Positive qPred (fromJust $ V.fromList [ t ]) 41 | s id t = lit id Positive sPred (fromJust $ V.fromList [ t ]) 42 | a id t = lit id Positive aPred (fromJust $ V.fromList [ t ]) 43 | 44 | r :: Int -> Term -> Term -> Literal ('ARename 'ABase) 45 | r id t t' = lit id Positive rPred (fromJust $ V.fromList [ t, t' ]) 46 | 47 | query :: Int -> Literal ('ARename 'ABase) 48 | query id = lit id Positive queryPred (fromJust $ V.fromList [ ]) 49 | 50 | flowSinkQ :: FlowSink 'ABase 51 | flowSinkQ = FSinkLiteral (q 99 (tvar "X")) 0 52 | 53 | flowSinkR :: FlowSink 'ABase 54 | flowSinkR = FSinkLiteral (r 98 (tvar "X") (tvar "X")) 0 55 | 56 | {-| Constant flow 57 | - 58 | - p(X) :- q(X). 59 | - query() :- p(1). 60 | |-} 61 | prConst :: Program ('ARename 'ABase) 62 | prConst = Program (ProgARename $ ProgABase NoSpan) 63 | (Stratum <$> 64 | [ [ cl 100 (p 10 (tvar "X")) $ NE.fromList [ q 99 (tvar "X") ] 65 | , cl 200 (query 30) $ NE.fromList [ p 40 (tsym (1 :: Int)) ] 66 | ] 67 | ]) 68 | [ PredicateBox queryPred ] 69 | 70 | flowSourcesConst :: Maybe [ FlowSource 'ABase ] 71 | flowSourcesConst = Just [ FSourceConstant (CSym (symbol (1 :: Int))) ] 72 | 73 | {-| Dead path 74 | - 75 | - Dead dataflow paths won't be evaluated, so we don't care if they lead to 76 | - a dead end. Here only "query" is a query predicate. 77 | - 78 | - p(X) :- q(X). 79 | - query() :- p(1). 80 | - s(X) :- p(X). 81 | |-} 82 | prDeadPath :: Program ('ARename 'ABase) 83 | prDeadPath = Program (ProgARename $ ProgABase NoSpan) 84 | (Stratum <$> 85 | [ [ cl 100 (p 10 (tvar "X")) $ NE.fromList [ q 99 (tvar "X") ] 86 | , cl 200 (query 30) $ NE.fromList [ p 40 (tsym (1 :: Int)) ] 87 | , cl 300 (s 50 (tvar "X")) $ NE.fromList [ p 60 (tvar "X") ] 88 | ] 89 | ]) 90 | [ PredicateBox queryPred ] 91 | 92 | flowSourcesDeadPath :: Maybe [ FlowSource 'ABase ] 93 | flowSourcesDeadPath = flowSourcesConst 94 | 95 | {-| Dead exposed 96 | - 97 | - Same as constant flow ficture but p is exposed as a query predicate. 98 | - 99 | - p(X) :- q(X). 100 | - query() :- p(1). 101 | |-} 102 | prExposed :: Program ('ARename 'ABase) 103 | prExposed = 104 | prConst {_queries = [ PredicateBox queryPred, PredicateBox pPred ]} 105 | 106 | flowSourcesExposed :: Maybe [ FlowSource 'ABase ] 107 | flowSourcesExposed = Nothing 108 | 109 | {-| Wildcard flow 110 | - 111 | - p(X) :- q(X). 112 | - query() :- p(_). 113 | |-} 114 | prWild :: Program ('ARename 'ABase) 115 | prWild = Program (ProgARename $ ProgABase NoSpan) 116 | (Stratum <$> 117 | [ [ cl 100 (p 10 (tvar "X")) $ NE.fromList [ q 99 (tvar "X") ] 118 | , cl 200 (query 30) $ NE.fromList [ p 40 TWild ] 119 | ] 120 | ]) 121 | [ PredicateBox queryPred ] 122 | 123 | flowSourcesWild :: Maybe [ FlowSource 'ABase ] 124 | flowSourcesWild = Just [ FSourceConstant CWild ] 125 | 126 | {-| Single open 127 | - 128 | - p(X) :- q(X). 129 | - query() :- p(X). 130 | |-} 131 | prSingleOpen :: Program ('ARename 'ABase) 132 | prSingleOpen = Program (ProgARename $ ProgABase NoSpan) 133 | (Stratum <$> 134 | [ [ cl 100 (p 10 (tvar "X")) $ NE.fromList [ q 99 (tvar "X") ] 135 | , cl 200 (query 30) $ NE.fromList [ p 40 (tvar "X") ] 136 | ] 137 | ]) 138 | [ PredicateBox queryPred ] 139 | 140 | flowSourcesSingleOpen :: Maybe [ FlowSource 'ABase ] 141 | flowSourcesSingleOpen = Nothing 142 | 143 | {-| Multiple closed 144 | - 145 | - p(X) :- q(X). 146 | - query() :- a(X), p(X). 147 | - query() :- p(1). 148 | |-} 149 | prMultipleClosed :: Program ('ARename 'ABase) 150 | prMultipleClosed = Program (ProgARename $ ProgABase NoSpan) 151 | (Stratum <$> 152 | [ [ cl 100 (p 10 (tvar "X")) $ NE.fromList [ q 99 (tvar "X") ] 153 | , cl 200 (query 30) $ NE.fromList [ a 40 (tvar "X"), p 50 (tvar "X") ] 154 | , cl 300 (query 60) $ NE.fromList [ p 70 (tsym (1 :: Int)) ] 155 | ] 156 | ]) 157 | [ PredicateBox queryPred ] 158 | 159 | flowSourcesMultipleClosed :: Maybe [ FlowSource 'ABase ] 160 | flowSourcesMultipleClosed = Just 161 | [ FSourceLiteral (a 40 (tvar "X")) 0 162 | , FSourceConstant (CSym $ symbol (1 :: Int)) 163 | ] 164 | 165 | {-| Multiple half-open 166 | - 167 | - p(X) :- q(X). 168 | - query() :- a(X), p(X). 169 | - query() :- p(X). 170 | |-} 171 | prHalfOpen :: Program ('ARename 'ABase) 172 | prHalfOpen = Program (ProgARename $ ProgABase NoSpan) 173 | (Stratum <$> 174 | [ [ cl 100 (p 10 (tvar "X")) $ NE.fromList [ q 99 (tvar "X") ] 175 | , cl 200 (query 30) $ NE.fromList [ a 40 (tvar "X"), p 50 (tvar "X") ] 176 | , cl 300 (query 60) $ NE.fromList [ p 70 (tvar "X") ] 177 | ] 178 | ]) 179 | [ PredicateBox queryPred ] 180 | 181 | flowSourcesHalfOpen :: Maybe [ FlowSource 'ABase ] 182 | flowSourcesHalfOpen = Nothing 183 | 184 | {-| Alias at head closed 185 | - 186 | - r(X,X) :- q(X). 187 | - query() :- a(X), r(X,1). 188 | |-} 189 | prAliasHeadClosed :: Program ('ARename 'ABase) 190 | prAliasHeadClosed = Program (ProgARename $ ProgABase NoSpan) 191 | (Stratum <$> 192 | [ [ cl 100 (r 10 (tvar "X") (tvar "X")) $ NE.fromList [ q 99 (tvar "X") ] 193 | , cl 200 (query 30) $ NE.fromList [ a 40 (tvar "X"), r 50 (tvar "X") (tsym (1 :: Int)) ] 194 | ] 195 | ]) 196 | [ PredicateBox queryPred ] 197 | 198 | flowSourcesAliasHeadClosed :: Maybe [ FlowSource 'ABase ] 199 | flowSourcesAliasHeadClosed = Just 200 | [ FSourceConstant (CSym $ symbol (1 :: Int)) 201 | , FSourceLiteral (a 40 (tvar "X")) 0 202 | ] 203 | 204 | {-| Alias at head open 205 | - 206 | - r(X,X) :- q(X). 207 | - query() :- r(X,1). 208 | |-} 209 | prAliasHeadOpen :: Program ('ARename 'ABase) 210 | prAliasHeadOpen = Program (ProgARename $ ProgABase NoSpan) 211 | (Stratum <$> 212 | [ [ cl 100 (r 10 (tvar "X") (tvar "X")) $ NE.fromList [ q 99 (tvar "X") ] 213 | , cl 200 (query 30) $ NE.fromList [ r 40 (tvar "X") (tsym (1 :: Int)) ] 214 | ] 215 | ]) 216 | [ PredicateBox queryPred ] 217 | 218 | flowSourcesAliasHeadOpen :: Maybe [ FlowSource 'ABase ] 219 | flowSourcesAliasHeadOpen = Nothing 220 | 221 | {-| Alias at body 222 | - 223 | - query() :- a(X), r(X,X). 224 | |-} 225 | prAliasBody :: Program ('ARename 'ABase) 226 | prAliasBody = Program (ProgARename $ ProgABase NoSpan) 227 | (Stratum <$> 228 | [ [ cl 100 (query 10) $ NE.fromList [ a 20 (tvar "X"), r 98 (tvar "X") (tvar "X") ] 229 | ] 230 | ]) 231 | [ PredicateBox queryPred ] 232 | 233 | flowSourcesAliasBody :: Maybe [ FlowSource 'ABase ] 234 | flowSourcesAliasBody = Just [ FSourceLiteral (a 20 (tvar "X")) 0 ] 235 | 236 | {-| Indirection 237 | - 238 | - s(X) :- q(X). 239 | - p(X) :- s(X). 240 | - query() :- p(1), s(2). 241 | |-} 242 | prIndirection :: Program ('ARename 'ABase) 243 | prIndirection = Program (ProgARename $ ProgABase NoSpan) 244 | (Stratum <$> 245 | [ [ cl 100 (s 10 (tvar "X")) $ NE.fromList [ q 99 (tvar "X") ] 246 | , cl 200 (p 30 (tvar "X")) $ NE.fromList [ s 40 (tvar "X") ] 247 | , cl 300 (query 50) $ NE.fromList [ p 60 (tsym (1 :: Int)), s 70 (tsym (2 :: Int)) ] 248 | ] 249 | ]) 250 | [ PredicateBox queryPred ] 251 | 252 | flowSourcesIndirection :: Maybe [ FlowSource 'ABase ] 253 | flowSourcesIndirection = Just 254 | [ FSourceConstant (CSym $ symbol (1 :: Int)) 255 | , FSourceConstant (CSym $ symbol (2 :: Int)) 256 | ] 257 | 258 | {-| Recursion closed 259 | - 260 | - p(X) :- q(X). 261 | - p(1) :- a(Y), p(Y). 262 | - query() :- p(1). 263 | |-} 264 | prRecClosed :: Program ('ARename 'ABase) 265 | prRecClosed = Program (ProgARename $ ProgABase NoSpan) 266 | (Stratum <$> 267 | [ [ cl 100 (p 10 (tvar "X")) $ NE.fromList [ q 99 (tvar "X") ] 268 | , cl 200 (p 30 (tsym (1 :: Int))) $ NE.fromList [ a 40 (tvar "Y"), p 50 (tvar "Y") ] 269 | , cl 300 (query 60) $ NE.fromList [ p 70 (tsym (1 :: Int)) ] 270 | ] 271 | ]) 272 | [ PredicateBox queryPred ] 273 | 274 | flowSourcesRecClosed :: Maybe [ FlowSource 'ABase ] 275 | flowSourcesRecClosed = Just 276 | [ FSourceLiteral (a 40 (tvar "Y")) 0 277 | , FSourceConstant (CSym $ symbol (1 :: Int)) 278 | ] 279 | 280 | {-| Recursion closed but indifferent 281 | - 282 | - p(X) :- q(X). 283 | - p(X) :- p(X). 284 | - query() :- p(1). 285 | |-} 286 | prRecClosedIndiff :: Program ('ARename 'ABase) 287 | prRecClosedIndiff = Program (ProgARename $ ProgABase NoSpan) 288 | (Stratum <$> 289 | [ [ cl 100 (p 10 (tvar "X")) $ NE.fromList [ q 99 (tvar "X") ] 290 | , cl 200 (p 30 (tvar "X")) $ NE.fromList [ p 40 (tvar "X") ] 291 | , cl 300 (query 50) $ NE.fromList [ p 60 (tsym (1 :: Int)) ] 292 | ] 293 | ]) 294 | [ PredicateBox queryPred ] 295 | 296 | flowSourcesRecClosedIndiff :: Maybe [ FlowSource 'ABase ] 297 | flowSourcesRecClosedIndiff = Just 298 | [ FSourceConstant (CSym $ symbol (1 :: Int)) ] 299 | -------------------------------------------------------------------------------- /src/Language/Exalog/ForeignFunction.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin-opt GHC.TypeLits.Normalise #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE ConstraintKinds #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE AllowAmbiguousTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | {-# LANGUAGE MultiParamTypeClasses #-} 14 | {-# LANGUAGE InstanceSigs #-} 15 | 16 | module Language.Exalog.ForeignFunction 17 | ( liftPredicate 18 | , liftPredicateME 19 | , liftFunction 20 | , liftFunctionME 21 | ) where 22 | 23 | import Protolude hiding (TypeError, sym) 24 | 25 | import Control.Monad.Trans.Except (except) 26 | 27 | import Data.Type.Bool (If) 28 | import qualified Data.Vector.Sized as V 29 | 30 | import GHC.TypeLits as TL (type (+)) 31 | 32 | import Language.Exalog.Core 33 | 34 | type Err = Either Text 35 | 36 | -------------------------------------------------------------------------------- 37 | -- Lift functions that return Bool 38 | -------------------------------------------------------------------------------- 39 | 40 | {- | Lifts Haskell functions that returns Bool to 'ForeignFunc' to back 41 | - extralogical predicates. 42 | - 43 | - For example, if an extralogical predicate @p@ is backed by a Haskell 44 | - function of type @'Int' -> 'Char' -> 'Bool'@, a subgoal involving @p@ 45 | - would be of the form @p(I,C)@, where I and C are 'Text' representations 46 | - of inhabitants of 'Int' and 'Char' respectively. 47 | - 48 | - While evaluating @p(I,C)@, the variables have to be bound or are 49 | - constants, or it is an error. This subgoal holds when the Haskell 50 | - function backing them returns 'True' in which case we return a singleton 51 | - answer set. Otherwise, it returns an empty answer set. 52 | -} 53 | liftPredicate :: (Applicable f, RetTy f ~ Bool) => f -> ForeignFunc (Arity f) 54 | liftPredicate p v = except $ do 55 | syms <- traverse fromTerm v 56 | cond <- p @@ syms 57 | pure [ syms | cond ] 58 | 59 | {- | A variant of 'liftPredicate' for functions that have side effects and 60 | - may produce errors. 61 | -} 62 | liftPredicateME :: (Applicable f, RetTy f ~ Foreign Bool) 63 | => f -> ForeignFunc (Arity f) 64 | liftPredicateME p v = do 65 | syms <- except $ traverse fromTerm v 66 | cond <- join $ except $ p @@ syms 67 | pure [ syms | cond ] 68 | 69 | -------------------------------------------------------------------------------- 70 | -- Lift functions that do not return Bool 71 | -------------------------------------------------------------------------------- 72 | 73 | {- | Lifts Haskell functions to 'ForeignFunc' to back extralogical predicates. 74 | - 75 | - For example, if an extralogical predicate @p@ is backed by a Haskell 76 | - function of type @'Int' -> 'Char' -> [ 'Int' ]@, a subgoal involving @p@ 77 | - would be of the form @p(I1,C,I2)@, where @I1@, @C@, @I2@ are 'Text' 78 | - representations of inhabitants of 'Int', 'Char' and 'Int' respectively. 79 | - 80 | - While evaluating @p(I1,C,I2)@, the variables @I1@ and @C@ have to be 81 | - bound or are constants, or it is an error. Variable @I2@ may or may not 82 | - be bound or ground. This subgoal holds when the Haskell function backing 83 | - it returns a value of type @[ 'Int' ]@ and if @IS@ happens to be bound, 84 | - its value needs to be in the returned list of integers. Otherwise, it 85 | - returns an empty answer set. 86 | -} 87 | liftFunction :: forall f r 88 | . (Applicable f, RetTy f ~ r, Returnable r, KnownNat (Arity f)) 89 | => f -> ForeignFunc (Arity f + NRets r) 90 | liftFunction f v = except $ do 91 | argSyms <- traverse fromTerm args 92 | ress <- f @@ argSyms 93 | genTuples (fromForeignFxReturn ress) v 94 | where 95 | args :: V.Vector (Arity f) Term 96 | args = V.take' (Proxy :: Proxy (Arity f)) v 97 | 98 | {- | A variant of 'liftFunction' for functions that have side effects and 99 | - may produce errors. 100 | -} 101 | liftFunctionME :: forall f r 102 | . (Applicable f, RetTy f ~ Foreign r, Returnable r, KnownNat (Arity f)) 103 | => f -> ForeignFunc (Arity f + NRets r) 104 | liftFunctionME f v = do 105 | argSyms <- except $ traverse fromTerm args 106 | ress <- except $ f @@ argSyms 107 | resss <- fromForeignFxReturn <$> ress 108 | except $ genTuples resss v 109 | where 110 | args :: V.Vector (Arity f) Term 111 | args = V.take' (Proxy :: Proxy (Arity f)) v 112 | 113 | genTuples :: forall na nr 114 | . KnownNat na 115 | => [ V.Vector nr Sym ] 116 | -> V.Vector (na + nr) Term 117 | -> Err [ V.Vector (na + nr) Sym ] 118 | genTuples resss v = do 119 | symArgs <- traverse fromTerm args 120 | pure [ symArgs V.++ ress 121 | | ress <- filterFakeResults rets resss ] 122 | where 123 | (args, rets) = V.splitAt @na v 124 | 125 | -- Eliminate tuples with results that contradict with what is bound in the 126 | -- subgoal for that result. 127 | filterFakeResults :: V.Vector nr Term 128 | -> [ V.Vector nr Sym ] 129 | -> [ V.Vector nr Sym ] 130 | filterFakeResults ts = 131 | filter (\ress -> all (uncurry consistent) $ V.zip ress ts) 132 | 133 | -- Check if a particular result is consistent with the given term 134 | consistent :: Sym -> Term -> Bool 135 | consistent sym = \case 136 | TSym sym' -> sym == sym' 137 | TVar{} -> True 138 | TWild -> True 139 | 140 | -------------------------------------------------------------------------------- 141 | -- Util 142 | -------------------------------------------------------------------------------- 143 | 144 | -- |Number of terms used as used as output based on the return type of the 145 | -- foreign function 146 | type family NRets a :: Nat where 147 | NRets Text = 1 148 | NRets Int = 1 149 | NRets Bool = 1 150 | NRets (a,b) = NRets a + NRets b 151 | NRets (a,b,c) = NRets a + NRets b + NRets c 152 | NRets (a,b,c,d) = NRets a + NRets b + NRets c + NRets d 153 | NRets [ a ] = NRets a 154 | 155 | -- |Typeclass for converting the return type of the foreign function to a 156 | -- vector of symbols 157 | class ReturnableBase r where 158 | toReturnV :: r -> V.Vector (NRets r) Sym 159 | 160 | instance ReturnableBase Text where 161 | toReturnV t = V.singleton (SymText t) 162 | 163 | instance ReturnableBase Int where 164 | toReturnV i = V.singleton (SymInt i) 165 | 166 | instance ReturnableBase Bool where 167 | toReturnV b = V.singleton (SymBool b) 168 | 169 | instance (ReturnableBase a, ReturnableBase b) => ReturnableBase (a,b) where 170 | toReturnV (a,b) = toReturnV a V.++ toReturnV b 171 | 172 | instance (ReturnableBase a, ReturnableBase b, ReturnableBase c) 173 | => ReturnableBase (a,b,c) where 174 | toReturnV (a,b,c) = toReturnV a V.++ toReturnV b V.++ toReturnV c 175 | 176 | instance (ReturnableBase a, ReturnableBase b, ReturnableBase c, ReturnableBase d) 177 | => ReturnableBase (a,b,c,d) where 178 | toReturnV (a,b,c,d) = 179 | toReturnV a V.++ toReturnV b V.++ toReturnV c V.++ toReturnV d 180 | 181 | -- |Indicate returnable types 182 | type family IsReturnable' r :: Bool where 183 | IsReturnable' Text = 'True 184 | IsReturnable' Int = 'True 185 | IsReturnable' Bool = 'True 186 | IsReturnable' (a,b) = 'True 187 | IsReturnable' (a,b,c) = 'True 188 | IsReturnable' (a,b,c,d) = 'True 189 | IsReturnable' _ = 'False 190 | 191 | -- |Determines the returnable type regardless the multitude of the results 192 | -- returned by the foreign function 193 | type family IsReturnable a :: Bool where 194 | IsReturnable (Foreign [ a ]) = IsReturnable' a 195 | IsReturnable (Foreign a) = IsReturnable' a 196 | IsReturnable [ a ] = IsReturnable' a 197 | IsReturnable a = IsReturnable' a 198 | 199 | data Multiplicity = Multiple | Single 200 | 201 | -- Flag to whether there will be multiple results or not. 202 | type family GetMultiplicity a :: Multiplicity where 203 | GetMultiplicity [ a ] = 'Multiple 204 | GetMultiplicity _ = 'Single 205 | 206 | -- |Type class to convert the result of the foreign function to output symbols 207 | class Returnable r where 208 | fromForeignFxReturn :: r -> [ V.Vector (NRets r) Sym ] 209 | 210 | -- Instance defined in terms of Returnable' to avoid overlapping instances 211 | instance (GetMultiplicity r ~ mult, Returnable' mult r) => Returnable r where 212 | fromForeignFxReturn = fromForeignFxReturn' (Proxy @mult) 213 | 214 | class Returnable' (mult :: Multiplicity) r where 215 | fromForeignFxReturn' :: Proxy mult -> r -> [ V.Vector (NRets r) Sym ] 216 | 217 | instance ReturnableBase a => Returnable' 'Single a where 218 | fromForeignFxReturn' _ x = [ toReturnV x ] 219 | 220 | instance ReturnableBase a => Returnable' 'Multiple [ a ] where 221 | fromForeignFxReturn' _ = map toReturnV 222 | 223 | interpretAt :: forall i n a 224 | . (KnownNat i, Argumentable a) 225 | => V.Vector ((i + n) + 1) Sym 226 | -> Err a 227 | interpretAt v = interpret . V.index' v $ (Proxy :: Proxy i) 228 | 229 | class Argumentable a where 230 | interpret :: Sym -> Err a 231 | 232 | instance Argumentable Text where 233 | interpret (SymText t) = pure t 234 | interpret _ = 235 | Left "Fatal error: Foreign function was expecting arugment of type Text." 236 | 237 | instance Argumentable Int where 238 | interpret (SymInt i) = pure i 239 | interpret _ = 240 | Left "Fatal error: Foreign function was expecting arugment of type Int." 241 | 242 | instance Argumentable Bool where 243 | interpret (SymBool b) = pure b 244 | interpret _ = 245 | Left "Fatal error: Foreign function was expecting arugment of type Bool." 246 | 247 | type family RetTy f where 248 | RetTy (a -> r) = If (IsReturnable r) r (RetTy r) 249 | 250 | type family Arity f :: Nat where 251 | Arity (a -> r) = If (IsReturnable r) 1 (Arity r + 1) 252 | 253 | type Applicable f = Applicable' f (Arity f) 254 | 255 | class ari ~ Arity f => Applicable' f (ari :: Nat) where 256 | (@@) :: f -> V.Vector ari Sym -> Err (RetTy f) 257 | 258 | instance ( IsReturnable r ~ 'True 259 | , Argumentable a 260 | ) => Applicable' (a -> r) 1 where 261 | f @@ v = f <$> interpretAt @0 v 262 | 263 | instance ( IsReturnable r ~ 'True 264 | , Argumentable a, Argumentable b 265 | ) => Applicable' (a -> b -> r) 2 where 266 | f @@ v = f 267 | <$> interpretAt @0 v 268 | <*> interpretAt @1 v 269 | 270 | instance ( IsReturnable r ~ 'True 271 | , Argumentable a, Argumentable b, Argumentable c 272 | ) => Applicable' (a -> b -> c -> r) 3 where 273 | f @@ v = f 274 | <$> interpretAt @0 v 275 | <*> interpretAt @1 v 276 | <*> interpretAt @2 v 277 | 278 | instance ( IsReturnable r ~ 'True 279 | , Argumentable a, Argumentable b, Argumentable c, Argumentable d 280 | ) => Applicable' (a -> b -> c -> d -> r) 4 where 281 | f @@ v = f 282 | <$> interpretAt @0 v 283 | <*> interpretAt @1 v 284 | <*> interpretAt @2 v 285 | <*> interpretAt @3 v 286 | 287 | instance ( IsReturnable r ~ 'True 288 | , Argumentable a, Argumentable b, Argumentable c, Argumentable d, Argumentable e 289 | ) => Applicable' (a -> b -> c -> d -> e -> r) 5 where 290 | f @@ v = f 291 | <$> interpretAt @0 v 292 | <*> interpretAt @1 v 293 | <*> interpretAt @2 v 294 | <*> interpretAt @3 v 295 | <*> interpretAt @4 v 296 | 297 | fromTerm :: Term -> Err Sym 298 | fromTerm = \case 299 | TSym s -> pure s 300 | _ -> Left 301 | "Mode error: Foreign function argument is not sufficiently bound." 302 | -------------------------------------------------------------------------------- /src/Language/Exalog/Adornment.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | 13 | module Language.Exalog.Adornment 14 | ( Adornment(..) 15 | , PredicateAnn(..) 16 | , LiteralAnn(..) 17 | , ClauseAnn(..) 18 | , ProgramAnn(..) 19 | , KnowledgeAnn(..) 20 | , adornment 21 | , adornProgram 22 | , adornClauses 23 | , adornClause 24 | , adornLiteral 25 | ) where 26 | 27 | import Protolude hiding (head) 28 | 29 | import Data.List (nub, (\\)) 30 | import qualified Data.List.NonEmpty as NE 31 | import Data.Singletons (fromSing) 32 | import qualified Data.Vector.Sized as V 33 | 34 | import Text.PrettyPrint (hcat) 35 | 36 | import Language.Exalog.Pretty.Helper (Pretty(..), prettyC) 37 | import Language.Exalog.Core 38 | import qualified Language.Exalog.KnowledgeBase.Knowledge as KB 39 | 40 | data Adornment = Free | Bound deriving (Eq, Ord, Show) 41 | 42 | instance Pretty Adornment where 43 | pretty Free = "f" 44 | pretty Bound = "b" 45 | 46 | instance Pretty [ Adornment ] where 47 | pretty = hcat . prettyC 48 | 49 | instance Pretty b => Pretty ([ Adornment ], b) where 50 | pretty (dec, b) = pretty dec <> "_" <> pretty b 51 | 52 | newtype instance PredicateAnn ('AAdornment ann) = PredAAdornment (PredicateAnn ann) 53 | data instance LiteralAnn ('AAdornment ann) = LitAAdornment [ Adornment ] (LiteralAnn ann) 54 | newtype instance ClauseAnn ('AAdornment ann) = ClAAdornment (ClauseAnn ann) 55 | newtype instance ProgramAnn ('AAdornment ann) = ProgAAdornment (ProgramAnn ann) 56 | newtype instance KnowledgeAnn ('AAdornment ann) = KnowAAdornment (KnowledgeAnn ann) 57 | 58 | instance KB.KnowledgeMaker ann => KB.KnowledgeMaker ('AAdornment ann) where 59 | mkKnowledge clause predicate syms = KB.Knowledge (KnowAAdornment (KB._annotation (KB.mkKnowledge (peel clause) (peel predicate) syms))) predicate syms 60 | 61 | deriving instance Show (PredicateAnn a) => Show (PredicateAnn ('AAdornment a)) 62 | deriving instance Show (LiteralAnn a) => Show (LiteralAnn ('AAdornment a)) 63 | deriving instance Show (ClauseAnn a) => Show (ClauseAnn ('AAdornment a)) 64 | deriving instance Show (ProgramAnn a) => Show (ProgramAnn ('AAdornment a)) 65 | deriving instance Show (KnowledgeAnn a) => Show (KnowledgeAnn ('AAdornment a)) 66 | 67 | deriving instance Eq (PredicateAnn a) => Eq (PredicateAnn ('AAdornment a)) 68 | deriving instance Eq (LiteralAnn a) => Eq (LiteralAnn ('AAdornment a)) 69 | deriving instance Eq (ClauseAnn a) => Eq (ClauseAnn ('AAdornment a)) 70 | deriving instance Eq (ProgramAnn a) => Eq (ProgramAnn ('AAdornment a)) 71 | deriving instance Eq (KnowledgeAnn a) => Eq (KnowledgeAnn ('AAdornment a)) 72 | 73 | deriving instance Ord (PredicateAnn a) => Ord (PredicateAnn ('AAdornment a)) 74 | deriving instance Ord (LiteralAnn a) => Ord (LiteralAnn ('AAdornment a)) 75 | deriving instance Ord (ClauseAnn a) => Ord (ClauseAnn ('AAdornment a)) 76 | deriving instance Ord (ProgramAnn a) => Ord (ProgramAnn ('AAdornment a)) 77 | deriving instance Ord (KnowledgeAnn a) => Ord (KnowledgeAnn ('AAdornment a)) 78 | 79 | instance DecorableAnn PredicateAnn 'AAdornment where decorA = PredAAdornment 80 | instance DecorableAnn ClauseAnn 'AAdornment where decorA = ClAAdornment 81 | instance DecorableAnn ProgramAnn 'AAdornment where decorA = ProgAAdornment 82 | 83 | instance PeelableAnn PredicateAnn 'AAdornment where peelA (PredAAdornment ann) = ann 84 | instance PeelableAnn LiteralAnn 'AAdornment where peelA (LitAAdornment _ ann) = ann 85 | instance PeelableAnn ClauseAnn 'AAdornment where peelA (ClAAdornment ann) = ann 86 | instance PeelableAnn KnowledgeAnn 'AAdornment where peelA (KnowAAdornment ann) = ann 87 | 88 | instance IdentifiableAnn (PredicateAnn ann) b 89 | => IdentifiableAnn (PredicateAnn ('AAdornment ann)) b where 90 | idFragment (PredAAdornment rest) = idFragment rest 91 | instance IdentifiableAnn (LiteralAnn ann) b 92 | => IdentifiableAnn (LiteralAnn ('AAdornment ann)) ([ Adornment ], b) where 93 | idFragment (LitAAdornment ads rest) = (ads, idFragment rest) 94 | instance IdentifiableAnn (ClauseAnn ann) b 95 | => IdentifiableAnn (ClauseAnn ('AAdornment ann)) b where 96 | idFragment (ClAAdornment rest) = idFragment rest 97 | instance IdentifiableAnn (ProgramAnn ann) b 98 | => IdentifiableAnn (ProgramAnn ('AAdornment ann)) b where 99 | idFragment (ProgAAdornment rest) = idFragment rest 100 | instance IdentifiableAnn (KnowledgeAnn ann) b 101 | => IdentifiableAnn (KnowledgeAnn ('AAdornment ann)) b where 102 | idFragment (KnowAAdornment rest) = idFragment rest 103 | 104 | instance SpannableAnn (PredicateAnn a) => SpannableAnn (PredicateAnn ('AAdornment a)) where 105 | annSpan (PredAAdornment ann) = annSpan ann 106 | instance SpannableAnn (LiteralAnn a) => SpannableAnn (LiteralAnn ('AAdornment a)) where 107 | annSpan (LitAAdornment _ ann) = annSpan ann 108 | instance SpannableAnn (ClauseAnn a) => SpannableAnn (ClauseAnn ('AAdornment a)) where 109 | annSpan (ClAAdornment ann) = annSpan ann 110 | instance SpannableAnn (ProgramAnn a) => SpannableAnn (ProgramAnn ('AAdornment a)) where 111 | annSpan (ProgAAdornment ann) = annSpan ann 112 | instance SpannableAnn (KnowledgeAnn a) => SpannableAnn (KnowledgeAnn ('AAdornment a)) where 113 | annSpan (KnowAAdornment ann) = annSpan ann 114 | 115 | instance PeelableAST (Literal ('AAdornment a)) where 116 | peel Literal{..} = 117 | Literal { _annotation = peelA _annotation 118 | , _predicate = peel _predicate 119 | , ..} 120 | 121 | -------------------------------------------------------------------------------- 122 | -- Accessor to the binding pattern 123 | -------------------------------------------------------------------------------- 124 | 125 | adornment :: Literal ('AAdornment ann) -> [ Adornment ] 126 | adornment Literal{_annotation = LitAAdornment ads _} = ads 127 | 128 | -------------------------------------------------------------------------------- 129 | -- Program adornment 130 | -------------------------------------------------------------------------------- 131 | 132 | adornProgram :: ( Identifiable (PredicateAnn ann) b 133 | , Identifiable (LiteralAnn ann) b 134 | , Identifiable (ClauseAnn ann) b 135 | ) 136 | => Program ann -> Program ('AAdornment ann) 137 | adornProgram Program{..} = Program 138 | { _annotation = decorA _annotation 139 | , _strata = adornedStrata 140 | , _queries = (PredicateBox . decorate $$) <$> _queries 141 | , ..} 142 | where 143 | adornedStrata = do 144 | Stratum cls <- _strata 145 | pure $ Stratum . nub $ (`adornClauses` cls) =<< _queries 146 | 147 | -------------------------------------------------------------------------------- 148 | -- Multiple clause adornment with an entry point 149 | -------------------------------------------------------------------------------- 150 | 151 | data AdornState ann = AdornState 152 | { _toAdorn :: [ (PredicateBox ann, [ Adornment ]) ] 153 | , _alreadyAdorned :: [ (PredicateBox ann, [ Adornment ]) ] 154 | , _adornedClauses :: [ Clause ('AAdornment ann) ] 155 | } 156 | 157 | type Adorn ann = State (AdornState ann) 158 | 159 | -- Poll predicate binding pattern pair that needs to be adorned 160 | pollToAdorn :: Adorn ann (Maybe (PredicateBox ann, [ Adornment ])) 161 | pollToAdorn = do 162 | toAdorn <- _toAdorn <$> get 163 | 164 | case toAdorn of 165 | (t : ts) -> do 166 | modify (\s -> s {_toAdorn = ts, _alreadyAdorned = t : _alreadyAdorned s}) 167 | pure $ Just t 168 | [] -> pure Nothing 169 | 170 | addAdornedClauses :: Identifiable (PredicateAnn ann) b 171 | => [ Clause ('AAdornment ann) ] -> Adorn ann () 172 | addAdornedClauses clauses = do 173 | let targets = map target . join $ NE.toList . _body <$> clauses 174 | 175 | modify (\s -> s { _adornedClauses = clauses <> _adornedClauses s 176 | , _toAdorn = 177 | nub $ (targets \\ _alreadyAdorned s) <> _toAdorn s 178 | }) 179 | where 180 | target :: Literal ('AAdornment ann) -> (PredicateBox ann, [ Adornment ]) 181 | target lit@Literal{_annotation = LitAAdornment ads _} = 182 | (PredicateBox . peel $$ predicateBox lit, ads) 183 | 184 | execAdorn :: Adorn ann a 185 | -> PredicateBox ann 186 | -> [ Adornment ] 187 | -> [ Clause ('AAdornment ann) ] 188 | execAdorn action pBox ads = 189 | _adornedClauses $ execState action (AdornState [ (pBox, ads) ] [ ] [ ]) 190 | 191 | adornClauses :: Identifiable (PredicateAnn ann) b 192 | => PredicateBox ann 193 | -> [ Clause ann ] 194 | -> [ Clause ('AAdornment ann) ] 195 | adornClauses pBox@(PredicateBox p) clauses = 196 | execAdorn (adornClausesM clauses) pBox allFreeBinding 197 | where 198 | allFreeBinding = replicate (fromIntegral . fromSing . _arity $ p) Free 199 | 200 | adornClausesM :: forall ann b. Identifiable (PredicateAnn ann) b 201 | => [ Clause ann ] -> Adorn ann () 202 | adornClausesM clauses = go 203 | where 204 | go :: Adorn ann () 205 | go = do 206 | mToAdorn <- pollToAdorn 207 | 208 | case mToAdorn of 209 | Just (pBox, ads) -> do 210 | let clausesToAdorn = 211 | [ cl | cl@Clause{_head = lit} <- clauses 212 | , predicateBox lit == pBox ] 213 | 214 | let adornedClauses = map (adornClause ads) clausesToAdorn 215 | 216 | addAdornedClauses adornedClauses 217 | go 218 | Nothing -> pure () 219 | 220 | -------------------------------------------------------------------------------- 221 | -- Clause adornment 222 | -------------------------------------------------------------------------------- 223 | 224 | -- Keeps track of bound variables of the clause 225 | type AdornClause = State [ Var ] 226 | 227 | runAdornClause :: AdornClause a -> [ Var ] -> a 228 | runAdornClause = evalState 229 | 230 | getBoundVariables :: AdornClause [ Var ] 231 | getBoundVariables = get 232 | 233 | addBoundVariables :: [ Var ] -> AdornClause () 234 | addBoundVariables vars = modify (vars <>) 235 | 236 | adornClause :: [ Adornment ] -> Clause ann -> Clause ('AAdornment ann) 237 | adornClause ads cl@Clause{..} = 238 | runAdornClause (adornClauseM cl) boundVars 239 | where 240 | boundVars = boundVariables ads _head 241 | 242 | adornClauseM :: Clause ann -> AdornClause (Clause ('AAdornment ann)) 243 | adornClauseM Clause{..} = do 244 | aHead <- adornLiteralM _head 245 | 246 | aBody <-traverse 247 | (\lit -> adornLiteralM lit <* addBoundVariables (variables lit)) _body 248 | 249 | pure $ Clause{_head = aHead, _body = aBody, _annotation = decorA _annotation} 250 | 251 | -- Bound variables of a literal wrt a binding pattern 252 | boundVariables :: [ Adornment ] -> Literal ann -> [ Var ] 253 | boundVariables ads Literal{..} = 254 | (`mapMaybe` zip (V.toList _terms) ads) $ \case 255 | (TVar v, Bound) -> Just v 256 | _ -> Nothing 257 | 258 | -------------------------------------------------------------------------------- 259 | -- Literal adornment 260 | -------------------------------------------------------------------------------- 261 | 262 | -- Given a binding pattern adorn a literal 263 | adornLiteral :: [ Adornment ] -> Literal ann -> Literal ('AAdornment ann) 264 | adornLiteral ads Literal{..} = Literal 265 | { _annotation = LitAAdornment ads _annotation 266 | , _predicate = decorate _predicate 267 | , ..} 268 | 269 | adornLiteralM :: Literal ann -> AdornClause (Literal ('AAdornment ann)) 270 | adornLiteralM lit@Literal{..} = do 271 | ads <- deriveAdornmentM lit 272 | 273 | let adornedLit = adornLiteral ads lit 274 | 275 | pure adornedLit 276 | 277 | -- Use the bound variables to figure out a adornment pattern for the 278 | -- literal's terms 279 | deriveAdornment :: Literal ann -> [ Var ] -> [ Adornment ] 280 | deriveAdornment Literal{..} boundVars = 281 | (`map` V.toList _terms) $ \case 282 | TSym{} -> Bound 283 | TWild -> Free 284 | TVar v -> if v `elem` boundVars then Bound else Free 285 | 286 | deriveAdornmentM :: Literal ann -> AdornClause [ Adornment ] 287 | deriveAdornmentM lit = deriveAdornment lit <$> getBoundVariables 288 | 289 | -------------------------------------------------------------------------------- /src/Language/Exalog/Renamer.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE DuplicateRecordFields #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | 13 | module Language.Exalog.Renamer 14 | ( rename 15 | , mkPredicateMap, mkLiteralMap, mkClauseMap 16 | , PredicateIDMap, LiteralIDMap, ClauseIDMap 17 | , PredicateID(..), LiteralID(..), ClauseID(..) 18 | , PredicateAnn(PredARename), LiteralAnn(LitARename), ClauseAnn(ClARename), ProgramAnn(ProgARename) 19 | , HasPredicateID(..), HasLiteralID(..), HasClauseID(..) 20 | ) where 21 | 22 | import Protolude hiding (head, pred) 23 | 24 | import qualified Data.Bimap as BM 25 | import qualified Data.List.NonEmpty as NE 26 | import qualified Data.Set as S 27 | 28 | import Language.Exalog.Core 29 | import Language.Exalog.Logger 30 | import Language.Exalog.SrcLoc 31 | import qualified Language.Exalog.KnowledgeBase.Class as KB 32 | import qualified Language.Exalog.KnowledgeBase.Knowledge as KB 33 | 34 | newtype PredicateID = PredicateID Int deriving (Eq, Ord, Show) 35 | newtype LiteralID = LiteralID Int deriving (Eq, Ord, Show) 36 | newtype ClauseID = ClauseID Int deriving (Eq, Ord, Show) 37 | 38 | data instance PredicateAnn ('ARename a) = PredARename { _predicateID :: PredicateID, _prevAnn :: PredicateAnn a } 39 | data instance LiteralAnn ('ARename a) = LitARename { _literalID :: LiteralID , _prevAnn :: LiteralAnn a } 40 | data instance ClauseAnn ('ARename a) = ClARename { _clauseID :: ClauseID , _prevAnn :: ClauseAnn a } 41 | newtype instance ProgramAnn ('ARename a) = ProgARename { _prevAnn :: ProgramAnn a } 42 | newtype instance KnowledgeAnn ('ARename a) = KnowARename { _prevAnn :: KnowledgeAnn a } 43 | 44 | instance KB.KnowledgeMaker ann => KB.KnowledgeMaker ('ARename ann) where 45 | mkKnowledge clause pred syms = 46 | KB.Knowledge (KnowARename oldAnn) pred syms 47 | where 48 | oldAnn = KB._annotation (KB.mkKnowledge (peel clause) (peel pred) syms) 49 | 50 | type PredicateIDMap ann = BM.Bimap (PredicateBox ('ARename ann)) PredicateID 51 | type LiteralIDMap ann = BM.Bimap (Literal ('ARename ann)) LiteralID 52 | type ClauseIDMap ann = BM.Bimap (Clause ('ARename ann)) ClauseID 53 | 54 | -------------------------------------------------------------------------------- 55 | -- Accessor 56 | -------------------------------------------------------------------------------- 57 | 58 | class HasPredicateID a where predicateID :: a -> PredicateID 59 | instance HasPredicateID (PredicateAnn ('ARename ann)) where predicateID PredARename{..} = _predicateID 60 | instance HasPredicateID (Predicate n ('ARename ann)) where predicateID Predicate{..} = _predicateID _annotation 61 | 62 | instance HasPredicateID (PredicateBox ('ARename ann)) where predicateID (PredicateBox pred) = predicateID pred 63 | 64 | instance HasPredicateID (Literal ('ARename ann)) where predicateID Literal{..} = predicateID _predicate 65 | 66 | class HasLiteralID a where literalID :: a -> LiteralID 67 | instance HasLiteralID (LiteralAnn ('ARename ann)) where literalID LitARename{..} = _literalID 68 | instance HasLiteralID (Literal ('ARename ann)) where literalID Literal{..} = _literalID _annotation 69 | 70 | class HasClauseID a where clauseID :: a -> ClauseID 71 | instance HasClauseID (ClauseAnn ('ARename ann)) where clauseID ClARename{..} = _clauseID 72 | instance HasClauseID (Clause ('ARename ann)) where clauseID Clause{..} = _clauseID _annotation 73 | 74 | -------------------------------------------------------------------------------- 75 | -- Renamer 76 | -------------------------------------------------------------------------------- 77 | 78 | rename :: SpannableAnn (PredicateAnn ann) 79 | => Identifiable (PredicateAnn ann) id 80 | => KB.Knowledgeable kb ann 81 | => KB.Knowledgeable kb ('ARename ann) 82 | => (Program ann, kb ann) 83 | -> Logger (Program ('ARename ann), kb ('ARename ann)) 84 | rename (pr,kb) = evalRename preds $ 85 | (,) <$> renameProgram pr <*> renameSolution kb 86 | where 87 | preds = S.fromList $ predicates pr 88 | <> KB.map (\(KB.Knowledge _ pred _) -> PredicateBox pred) kb 89 | 90 | renameSolution :: SpannableAnn (PredicateAnn ann) 91 | => IdentifiableAnn (PredicateAnn ann) a 92 | => Ord a 93 | => KB.Knowledgeable kb ann 94 | => KB.Knowledgeable kb ('ARename ann) 95 | => kb ann 96 | -> Rename ann (kb ('ARename ann)) 97 | renameSolution = fmap KB.fromList 98 | . traverse renameKnowledge 99 | . KB.toList 100 | 101 | renameKnowledge :: SpannableAnn (PredicateAnn ann) 102 | => IdentifiableAnn (PredicateAnn ann) b 103 | => Ord b 104 | => KB.Knowledge ann 105 | -> Rename ann (KB.Knowledge ('ARename ann)) 106 | renameKnowledge (KB.Knowledge ann pred syms) = do 107 | pred' <- renamePredicate pred 108 | pure (KB.Knowledge (KnowARename ann) pred' syms) 109 | 110 | renameProgram :: SpannableAnn (PredicateAnn ann) 111 | => IdentifiableAnn (PredicateAnn ann) a 112 | => Ord a 113 | => Program ann 114 | -> Rename ann (Program ('ARename ann)) 115 | renameProgram Program{..} = do 116 | renamedStrata <- traverse (stratumOverF $ traverse renameClause) _strata 117 | renamedQueries <- traverse (\(PredicateBox pred) -> PredicateBox <$> renamePredicate pred) _queries 118 | pure Program 119 | { _annotation = ProgARename _annotation 120 | , _strata = renamedStrata 121 | , _queries = renamedQueries 122 | , ..} 123 | 124 | renameClause :: SpannableAnn (PredicateAnn ann) 125 | => IdentifiableAnn (PredicateAnn ann) b 126 | => Ord b 127 | => Clause ann 128 | -> Rename ann (Clause ('ARename ann)) 129 | renameClause Clause{..} = do 130 | renamedHead <- renameLiteral _head 131 | renamedBody <- traverse renameLiteral _body 132 | id <- freshID 133 | pure Clause 134 | { _annotation = ClARename (ClauseID id) _annotation 135 | , _head = renamedHead 136 | , _body = renamedBody 137 | } 138 | 139 | renameLiteral :: SpannableAnn (PredicateAnn ann) 140 | => IdentifiableAnn (PredicateAnn ann) b 141 | => Ord b 142 | => Literal ann 143 | -> Rename ann (Literal ('ARename ann)) 144 | renameLiteral Literal{..} = do 145 | renamedPredicate <- renamePredicate _predicate 146 | id <- freshID 147 | pure $ Literal 148 | { _annotation = LitARename (LiteralID id) _annotation 149 | , _predicate = renamedPredicate 150 | , ..} 151 | 152 | renamePredicate :: SpannableAnn (PredicateAnn ann) 153 | => IdentifiableAnn (PredicateAnn ann) b 154 | => Ord b 155 | => Predicate n ann 156 | -> Rename ann (Predicate n ('ARename ann)) 157 | renamePredicate pred@Predicate{..} = do 158 | preds <- ask 159 | case PredicateBox pred `S.lookupIndex` preds of 160 | Just ix -> pure $ 161 | Predicate{_annotation = PredARename (PredicateID ix) _annotation,..} 162 | Nothing -> lift $ lift $ scream (span pred) 163 | "Impossible happened! Renamed predicate is not a predicate of the program." 164 | 165 | mkPredicateMap :: IdentifiableAnn (PredicateAnn ann) a 166 | => Ord a 167 | => Program ('ARename ann) 168 | -> PredicateIDMap ann 169 | mkPredicateMap pr = BM.fromList $ (<$> predicates pr) $ 170 | \pBox@(PredicateBox Predicate{..}) -> (pBox, predicateID _annotation) 171 | 172 | mkLiteralMap :: IdentifiableAnn (PredicateAnn ann) a 173 | => IdentifiableAnn (LiteralAnn ann) b 174 | => Ord a => Ord b 175 | => Program ('ARename ann) 176 | -> LiteralIDMap ann 177 | mkLiteralMap Program{_strata = strata} = 178 | BM.fromList $ fmap (\lit@Literal{..} -> (lit, literalID _annotation)) 179 | . join 180 | $ NE.toList . literals 181 | <$> join (map _unStratum strata) 182 | 183 | mkClauseMap :: IdentifiableAnn (PredicateAnn ann) a 184 | => IdentifiableAnn (LiteralAnn ann) b 185 | => IdentifiableAnn (ClauseAnn ann) c 186 | => Ord a => Ord b => Ord c 187 | => Program ('ARename ann) 188 | -> ClauseIDMap ann 189 | mkClauseMap Program{_strata = strata} = 190 | BM.fromList $ (<$> join (map _unStratum strata)) 191 | $ \cl@Clause{..} -> (cl, clauseID _annotation) 192 | 193 | -------------------------------------------------------------------------------- 194 | -- Monadic actions for renaming 195 | -------------------------------------------------------------------------------- 196 | 197 | type IDCounterT = StateT Int 198 | type Rename ann = ReaderT (S.Set (PredicateBox ann)) (IDCounterT Logger) 199 | 200 | evalRename :: S.Set (PredicateBox ann) -> Rename ann a -> Logger a 201 | evalRename preds = (`evalStateT` 0) . (`runReaderT` preds) 202 | 203 | freshID :: Rename ann Int 204 | freshID = lift $ do 205 | id <- get 206 | modify (+ 1) 207 | pure id 208 | 209 | -------------------------------------------------------------------------------- 210 | -- Annotation instances 211 | -------------------------------------------------------------------------------- 212 | 213 | deriving instance Show (PredicateAnn a) => Show (PredicateAnn ('ARename a)) 214 | deriving instance Show (LiteralAnn a) => Show (LiteralAnn ('ARename a)) 215 | deriving instance Show (ClauseAnn a) => Show (ClauseAnn ('ARename a)) 216 | deriving instance Show (ProgramAnn a) => Show (ProgramAnn ('ARename a)) 217 | 218 | deriving instance Eq (PredicateAnn a) => Eq (PredicateAnn ('ARename a)) 219 | deriving instance Eq (LiteralAnn a) => Eq (LiteralAnn ('ARename a)) 220 | deriving instance Eq (ClauseAnn a) => Eq (ClauseAnn ('ARename a)) 221 | deriving instance Eq (ProgramAnn a) => Eq (ProgramAnn ('ARename a)) 222 | 223 | deriving instance Ord (PredicateAnn a) => Ord (PredicateAnn ('ARename a)) 224 | deriving instance Ord (LiteralAnn a) => Ord (LiteralAnn ('ARename a)) 225 | deriving instance Ord (ClauseAnn a) => Ord (ClauseAnn ('ARename a)) 226 | deriving instance Ord (ProgramAnn a) => Ord (ProgramAnn ('ARename a)) 227 | 228 | instance SpannableAnn (PredicateAnn a) => SpannableAnn (PredicateAnn ('ARename a)) where 229 | annSpan (PredARename _ ann) = annSpan ann 230 | instance SpannableAnn (LiteralAnn a) => SpannableAnn (LiteralAnn ('ARename a)) where 231 | annSpan (LitARename _ ann) = annSpan ann 232 | instance SpannableAnn (ClauseAnn a) => SpannableAnn (ClauseAnn ('ARename a)) where 233 | annSpan (ClARename _ ann) = annSpan ann 234 | instance SpannableAnn (ProgramAnn a) => SpannableAnn (ProgramAnn ('ARename a)) where 235 | annSpan (ProgARename ann) = annSpan ann 236 | 237 | instance IdentifiableAnn (PredicateAnn ann) b => IdentifiableAnn (PredicateAnn ('ARename ann)) Int where 238 | idFragment (PredARename (PredicateID id) _) = id 239 | instance IdentifiableAnn (LiteralAnn ann) b => IdentifiableAnn (LiteralAnn ('ARename ann)) Int where 240 | idFragment (LitARename (LiteralID id) _) = id 241 | instance IdentifiableAnn (ClauseAnn ann) b => IdentifiableAnn (ClauseAnn ('ARename ann)) Int where 242 | idFragment (ClARename (ClauseID id) _) = id 243 | instance IdentifiableAnn (ProgramAnn ann) b => IdentifiableAnn (ProgramAnn ('ARename ann)) b where 244 | idFragment (ProgARename rest) = idFragment rest 245 | instance IdentifiableAnn (KnowledgeAnn ann) b => IdentifiableAnn (KnowledgeAnn ('ARename ann)) b where 246 | idFragment (KnowARename rest) = idFragment rest 247 | 248 | instance PeelableAnn PredicateAnn 'ARename where peelA (PredARename _ prevAnn) = prevAnn 249 | instance PeelableAnn LiteralAnn 'ARename where peelA (LitARename _ prevAnn) = prevAnn 250 | instance PeelableAnn ClauseAnn 'ARename where peelA (ClARename _ prevAnn) = prevAnn 251 | instance PeelableAnn ProgramAnn 'ARename where peelA (ProgARename prevAnn) = prevAnn 252 | instance PeelableAnn KnowledgeAnn 'ARename where peelA (KnowARename prevAnn) = prevAnn 253 | 254 | instance PeelableAST (Literal ('ARename ann)) where 255 | peel Literal{..} = Literal 256 | { _annotation = peelA _annotation 257 | , _predicate = peel _predicate 258 | , ..} 259 | -------------------------------------------------------------------------------- /src/Language/Exalog/Dataflow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | 12 | module Language.Exalog.Dataflow 13 | ( PositiveFlowGr 14 | , FlowSource(..) 15 | , FlowSink(..) 16 | , Constant(..) 17 | , analysePositiveFlow 18 | , nearestCoveringPositives 19 | , isPredPredicate 20 | , HasEdge(..) 21 | ) where 22 | 23 | import Protolude hiding (head, sym, pred) 24 | 25 | import qualified Text.PrettyPrint as PP 26 | import Text.Show (Show(..)) 27 | 28 | import qualified Data.Bimap as BM 29 | import qualified Data.Graph.Inductive.Graph as Gr 30 | import qualified Data.Graph.Inductive.PatriciaTree as P 31 | import Data.List (nub) 32 | import qualified Data.List.NonEmpty as NE 33 | import qualified Data.Map.Strict as M 34 | import Data.Text (unpack) 35 | import qualified Data.Set as S 36 | import Data.Singletons (fromSing) 37 | import qualified Data.Vector.Sized as V 38 | 39 | import Language.Exalog.Core 40 | import Language.Exalog.Renamer () 41 | import Language.Exalog.Pretty.Helper (Pretty(..)) 42 | import Language.Exalog.Pretty (pp) 43 | 44 | -------------------------------------------------------------------------------- 45 | -- Exported data types 46 | -------------------------------------------------------------------------------- 47 | 48 | data PositiveFlowGr ann = 49 | PositiveFlowGr (P.Gr (Node ann) ()) (BM.Bimap (Node ann) Gr.Node) 50 | 51 | data FlowSink ann = 52 | FSinkLiteral (Literal ('ARename ann)) Int 53 | | FSinkPredicate (PredicateBox ('ARename ann)) Int 54 | 55 | data FlowSource ann = 56 | FSourceLiteral (Literal ('ARename ann)) Int 57 | | FSourceConstant Constant 58 | 59 | data Constant = CSym Sym | CWild deriving (Eq, Ord, Show) 60 | 61 | -------------------------------------------------------------------------------- 62 | -- Main operations 63 | -------------------------------------------------------------------------------- 64 | 65 | analysePositiveFlow :: IdentifiableAnn (PredicateAnn ann) a => Ord a 66 | => IdentifiableAnn (LiteralAnn ann) b => Ord b 67 | => Program ('ARename ann) -> PositiveFlowGr ann 68 | analysePositiveFlow pr = PositiveFlowGr (Gr.mkGraph lnodes ledges) nodeDict 69 | where 70 | edges = nub $ programEdges pr 71 | lnodes = zip [0..] $ nub (map fst edges ++ map snd edges) 72 | nodeDict = BM.fromList $ map swap lnodes 73 | 74 | ledges = (\(a,b) -> (a,b,())) 75 | . bimap (nodeDict BM.!) (nodeDict BM.!) 76 | <$> edges 77 | 78 | -- |Finds the nearest positive parameters of predicates or constants that 79 | -- flow into a given literal argument. The results together cover the 80 | -- domain of values the target can take. 81 | nearestCoveringPositives :: forall ann a b 82 | . IdentifiableAnn (PredicateAnn ann) a => Ord a 83 | => IdentifiableAnn (LiteralAnn ann) b => Ord b 84 | => PositiveFlowGr ann 85 | -> FlowSink ann 86 | -> Maybe [ FlowSource ann ] 87 | nearestCoveringPositives (PositiveFlowGr gr dict) fSink = do 88 | context <- mContext 89 | flowSourcess <- traverse (go []) . Gr.pre' $ context 90 | pure $ concat flowSourcess 91 | where 92 | mContext = Gr.context gr <$> toNode fSink `BM.lookup` dict 93 | 94 | go :: [ Gr.Node ] -> Gr.Node -> Maybe [ FlowSource ann ] 95 | go visitedNodes node 96 | | node `elem` visitedNodes = Just [] 97 | | context <- Gr.context gr node = 98 | case Gr.lab' context of 99 | NNull -> Nothing 100 | NConstant constant -> Just [ FSourceConstant constant ] 101 | NLiteral litID ix -> Just [ FSourceLiteral litID ix ] 102 | NPredicate _ _ -> fmap concat 103 | $ traverse (go (node : visitedNodes)) 104 | $ Gr.pre' context 105 | 106 | -- | Is the predecessor a predicate 107 | isPredPredicate :: (IdentifiableAnn (PredicateAnn ann) a) => Ord a 108 | => (IdentifiableAnn (LiteralAnn ann) b) => Ord b 109 | => PositiveFlowGr ann -> Literal ('ARename ann) -> Int -> Bool 110 | isPredPredicate (PositiveFlowGr gr nodeDict) lit ix = 111 | case NLiteral lit ix `BM.lookup` nodeDict of 112 | Just node -> any (isPredicateNode . (nodeDict BM.!>)) 113 | $ Gr.pre gr node 114 | Nothing -> False 115 | where 116 | isPredicateNode :: Node a -> Bool 117 | isPredicateNode NPredicate{} = True 118 | isPredicateNode _ = False 119 | 120 | -------------------------------------------------------------------------------- 121 | -- Internal data types 122 | -------------------------------------------------------------------------------- 123 | 124 | data Node ann = 125 | NPredicate { _predicate :: PredicateBox ('ARename ann), _paramIndex :: Int } 126 | | NLiteral { _literal :: Literal ('ARename ann), _paramIndex :: Int } 127 | | NConstant { _constant :: Constant } 128 | | NNull 129 | 130 | deriving instance 131 | ( Show (PredicateAnn ann) 132 | , Show (LiteralAnn ann) 133 | ) => Show (Node ann) 134 | deriving instance 135 | ( IdentifiableAnn (PredicateAnn ann) a, Eq a 136 | , IdentifiableAnn (LiteralAnn ann) b, Eq b 137 | ) => Eq (Node ann) 138 | deriving instance 139 | ( IdentifiableAnn (PredicateAnn ann) a, Ord a 140 | , IdentifiableAnn (LiteralAnn ann) b, Ord b 141 | ) => Ord (Node ann) 142 | 143 | type Edge ann = (Node ann, Node ann) 144 | 145 | toNode :: FlowSink ann -> Node ann 146 | toNode (FSinkLiteral lit ix) = NLiteral lit ix 147 | toNode (FSinkPredicate pBox ix) = NPredicate pBox ix 148 | 149 | -------------------------------------------------------------------------------- 150 | -- Feature extraction 151 | -------------------------------------------------------------------------------- 152 | 153 | programEdges :: IdentifiableAnn (PredicateAnn ann) a => Ord a 154 | => Program ('ARename ann) -> [ Edge ann ] 155 | programEdges pr@Program{_queries = queryPreds, _strata = strata} = 156 | concatMap mkQueryEdge queryPreds 157 | <> concatMap (clauseEdges intentionalPreds) (join $ map _unStratum strata) 158 | where 159 | intentionalPreds = S.fromList . intentionals $ pr 160 | mkQueryEdge pBox@(PredicateBox Predicate{..}) = 161 | (NNull,) . NPredicate pBox <$> [0..(fromIntegral (fromSing _arity) - 1)] 162 | 163 | clauseEdges :: IdentifiableAnn (PredicateAnn ann) a => Ord a 164 | => S.Set (PredicateBox ('ARename ann)) 165 | -> Clause ('ARename ann) 166 | -> [ Edge ann ] 167 | clauseEdges intensionalPreds Clause{..} = join 168 | . evalSideways intensionalPreds $ do 169 | handleHeadLiteral _head 170 | 171 | traverse handleBodyLiteral (NE.toList _body) 172 | 173 | handleHeadLiteral :: IdentifiableAnn (PredicateAnn ann) a => Ord a 174 | => Literal ('ARename ann) -> Sideways ann () 175 | handleHeadLiteral Literal{..} = 176 | forM_ (zip [0..] $ V.toList _terms) $ \case 177 | (ix, TVar var) -> addBinder var (NPredicate (PredicateBox _predicate) ix) 178 | _ -> pure () 179 | 180 | handleBodyLiteral :: IdentifiableAnn (PredicateAnn ann) a => Ord a 181 | => Literal ('ARename ann) -> Sideways ann [ Edge ann ] 182 | handleBodyLiteral lit@Literal{..} = do 183 | edgess <- forM (zip [0..] $ V.toList _terms) $ \(ix, term) -> do 184 | -- Bother with predicate node as a destination only if it is 185 | -- intentional. 186 | dsts <- getPredNode (PredicateBox _predicate) ix 187 | 188 | case term of 189 | TVar var -> do 190 | srcs <- getBinders var 191 | 192 | let litNode = NLiteral lit ix 193 | when (_polarity == Positive) $ updateBinders var [ litNode ] 194 | 195 | pure [ (src, dst) | src <- srcs, dst <- litNode : dsts ] 196 | TSym sym -> pure [ (NConstant (CSym sym), dst) | dst <- dsts ] 197 | TWild -> pure [ (NConstant CWild , dst) | dst <- dsts ] 198 | 199 | pure $ mconcat edgess 200 | 201 | -------------------------------------------------------------------------------- 202 | -- Monadic actions 203 | -------------------------------------------------------------------------------- 204 | 205 | newtype SidewaysSt ann = SidewaysSt { _binderMap :: M.Map Var [ Node ann ] } 206 | 207 | type Sideways ann = 208 | ReaderT (S.Set (PredicateBox ('ARename ann))) (State (SidewaysSt ann)) 209 | 210 | initSidewaysSt :: SidewaysSt ann 211 | initSidewaysSt = SidewaysSt M.empty 212 | 213 | evalSideways :: S.Set (PredicateBox ('ARename ann)) -> Sideways ann a -> a 214 | evalSideways intensionalPreds = (`evalState` initSidewaysSt) 215 | . (`runReaderT` intensionalPreds) 216 | 217 | getPredNode :: IdentifiableAnn (PredicateAnn ann) a => Ord a 218 | => PredicateBox ('ARename ann) -> Int -> Sideways ann [ Node ann ] 219 | getPredNode pBox ix = do 220 | intensionalPreds <- ask 221 | pure [ NPredicate pBox ix | pBox `S.member` intensionalPreds ] 222 | 223 | getBinders :: Var -> Sideways ann [ Node ann ] 224 | getBinders var = lift $ M.findWithDefault [ NNull ] var . _binderMap <$> get 225 | 226 | addBinder :: Var -> Node ann -> Sideways ann () 227 | addBinder var binder = lift $ 228 | modify (\st -> st {_binderMap = M.insertWith (++) var [ binder ] $ _binderMap st}) 229 | 230 | updateBinders :: Var -> [ Node ann ] -> Sideways ann () 231 | updateBinders var binders = lift $ 232 | modify (\st -> st {_binderMap = M.insert var binders $ _binderMap st}) 233 | 234 | -------------------------------------------------------------------------------- 235 | -- Useful for testing 236 | -------------------------------------------------------------------------------- 237 | 238 | class HasEdge f g ann where 239 | isAnEdge :: PositiveFlowGr ann -> (f ann, Int) -> (g ann, Int) -> Bool 240 | 241 | instance ( IdentifiableAnn (PredicateAnn ann) a, Ord a 242 | , IdentifiableAnn (LiteralAnn ann) b, Ord b 243 | ) => HasEdge Literal Literal ann where 244 | isAnEdge (PositiveFlowGr flowGr nodeDict) (lit1, ix1) (lit2, ix2) = 245 | any match (Gr.edges flowGr) 246 | where 247 | match :: (Gr.Node, Gr.Node) -> Bool 248 | match (node1, node2) = matchNode nodeDict (matchLitNode lit1 ix1) node1 249 | && matchNode nodeDict (matchLitNode lit2 ix2) node2 250 | 251 | instance ( IdentifiableAnn (PredicateAnn ann) a, Ord a 252 | , IdentifiableAnn (LiteralAnn ann) b, Ord b 253 | ) => HasEdge PredicateBox Literal ann where 254 | isAnEdge (PositiveFlowGr flowGr nodeDict) (pBox, ix1) (lit, ix2) = 255 | any match (Gr.edges flowGr) 256 | where 257 | match :: (Gr.Node, Gr.Node) -> Bool 258 | match (node1, node2) = matchNode nodeDict (matchPredNode pBox ix1) node1 259 | && matchNode nodeDict (matchLitNode lit ix2) node2 260 | 261 | instance ( IdentifiableAnn (PredicateAnn ann) a, Ord a 262 | , IdentifiableAnn (LiteralAnn ann) b, Ord b 263 | ) => HasEdge Literal PredicateBox ann where 264 | isAnEdge (PositiveFlowGr flowGr nodeDict) (lit, ix1) (pBox, ix2) = 265 | any match (Gr.edges flowGr) 266 | where 267 | match :: (Gr.Node, Gr.Node) -> Bool 268 | match (node1, node2) = matchNode nodeDict (matchLitNode lit ix1) node1 269 | && matchNode nodeDict (matchPredNode pBox ix2) node2 270 | 271 | 272 | instance ( IdentifiableAnn (PredicateAnn ann) a, Ord a 273 | , IdentifiableAnn (LiteralAnn ann) b, Ord b 274 | ) => HasEdge PredicateBox PredicateBox ann where 275 | isAnEdge (PositiveFlowGr flowGr nodeDict) (pBox1, ix1) (pBox2, ix2) = 276 | any match (Gr.edges flowGr) 277 | where 278 | match :: (Gr.Node, Gr.Node) -> Bool 279 | match (node1, node2) = matchNode nodeDict (matchPredNode pBox1 ix1) node1 280 | && matchNode nodeDict (matchPredNode pBox2 ix2) node2 281 | 282 | instance ( IdentifiableAnn (PredicateAnn ann) a, Ord a 283 | , IdentifiableAnn (LiteralAnn ann) b, Ord b 284 | ) => HasEdge (Const Constant) PredicateBox ann where 285 | isAnEdge (PositiveFlowGr flowGr nodeDict) (Const constant, _) (pBox2, ix2) = 286 | any match (Gr.edges flowGr) 287 | where 288 | match :: (Gr.Node, Gr.Node) -> Bool 289 | match (node1, node2) = matchNode nodeDict (matchConstNode constant) node1 290 | && matchNode nodeDict (matchPredNode pBox2 ix2) node2 291 | 292 | matchConstNode :: Constant -> Node ann -> Bool 293 | matchConstNode constant NConstant{..} = _constant == constant 294 | matchConstNode _ _ = False 295 | 296 | matchPredNode :: IdentifiableAnn (PredicateAnn ann) a => Eq a 297 | => PredicateBox ann -> Int -> Node ann -> Bool 298 | matchPredNode pred ix NPredicate{..} = ix == _paramIndex && peel _predicate == pred 299 | matchPredNode _ _ _ = False 300 | 301 | matchLitNode :: IdentifiableAnn (PredicateAnn ann) a => Eq a 302 | => IdentifiableAnn (LiteralAnn ann) b => Eq b 303 | => Literal ann -> Int -> Node ann -> Bool 304 | matchLitNode lit ix NLiteral{..} = ix == _paramIndex && peel _literal == lit 305 | matchLitNode _ _ _ = False 306 | 307 | matchNode :: IdentifiableAnn (PredicateAnn ann) a => Ord a 308 | => IdentifiableAnn (LiteralAnn ann) b => Ord b 309 | => BM.Bimap (Node ann) Gr.Node 310 | -> (Node ann -> Bool) 311 | -> Gr.Node 312 | -> Bool 313 | matchNode nodeDict f node = maybe False f (node `BM.lookupR` nodeDict) 314 | 315 | -------------------------------------------------------------------------------- 316 | -- Useful instances 317 | -------------------------------------------------------------------------------- 318 | 319 | deriving instance ( Show (PredicateAnn ann) 320 | , Show (LiteralAnn ann) 321 | ) => Show (FlowSink ann) 322 | deriving instance ( Show (PredicateAnn ann) 323 | , Show (LiteralAnn ann) 324 | ) => Show (FlowSource ann) 325 | 326 | deriving instance ( IdentifiableAnn (PredicateAnn ann) a, Eq a 327 | , IdentifiableAnn (LiteralAnn ann) a, Eq a 328 | ) => Eq (FlowSink ann) 329 | deriving instance ( IdentifiableAnn (PredicateAnn ann) a, Eq a 330 | , IdentifiableAnn (LiteralAnn ann) a, Eq a 331 | ) => Eq (FlowSource ann) 332 | 333 | instance Pretty Constant where 334 | pretty CWild = "_" 335 | pretty (CSym sym) = pretty sym 336 | 337 | instance ( Pretty (Literal ('ARename ann)) 338 | , Pretty (PredicateBox ('ARename ann)) 339 | ) => Pretty (Node ann) where 340 | pretty NNull = "Null node" 341 | pretty (NConstant constant) = pretty constant 342 | pretty (NPredicate pBox ix) = pretty pBox PP.<+> "@" PP.<+> pretty ix 343 | pretty (NLiteral lit ix) = pretty lit PP.<+> "@" PP.<+> pretty ix 344 | 345 | instance ( Pretty (Literal ('ARename ann)) 346 | , Pretty (PredicateBox ('ARename ann)) 347 | ) => Pretty (PositiveFlowGr ann) where 348 | pretty (PositiveFlowGr gr nodeDict) = 349 | PP.vcat ((\(n,id) -> pretty n PP.<+> ":" PP.<+> pretty id) <$> nodes) 350 | PP.$+$ 351 | PP.vcat ((\(n1,n2) -> pretty n1 PP.<+> "==>" PP.<+> pretty n2) <$> edges) 352 | where 353 | nodes = BM.toList nodeDict 354 | edges = Gr.edges gr 355 | 356 | instance Pretty (PositiveFlowGr ann) => Show (PositiveFlowGr ann) where 357 | show = unpack . pp 358 | --------------------------------------------------------------------------------