Commit 679fb2e4 authored by Paul Ogris's avatar Paul Ogris
Browse files

Implement handling of choices

This requires some more testing, but works on the basic example in choice.lp
parent ef296721
{-# LANGUAGE OverloadedStrings #-}
module Language.LARS
(
Statement(..),
Atom,
Relation,
Rule(..),
BodyElement(..),
SignedAtom(..),
( Statement(..)
, Atom
, Relation
, Rule(..)
, Head(..)
, BodyElement(..)
, SignedAtom(..)
,
-- * Pretty Printing
prettyOneLine,
prettyProgram,
errorBundlePretty,
prettyOneLine
, prettyProgram
, errorBundlePretty
,
-- * Parsing
parse,
stmt,
atom,
relation,
signedAtom,
rule,
bodyElement,
program
)
parse
, stmt
, atom
, relation
, signedAtom
, rule
, head_
, bodyElement
, program
)
where
import Data.Text (Text, pack)
import Data.Text ( Text
, pack
)
import Text.Megaparsec
import Data.Void
import Text.PrettyPrint.Leijen.Text (Pretty, (<+>))
import Text.PrettyPrint.Leijen.Text ( Pretty
, (<+>)
)
import Data.String
import Data.List.NonEmpty ( NonEmpty
, toList
, fromList
)
import qualified Text.Megaparsec.Char as P
import qualified Text.PrettyPrint.Leijen.Text as PP
......@@ -44,17 +56,30 @@ type Atom = Text
type Relation = Text
data Rule = Rule Atom [BodyElement]
data Rule = Rule Head [BodyElement]
deriving (Eq, Show, Ord, Read)
instance Pretty Rule where
pretty (Rule h []) = PP.textStrict h <> PP.dot
pretty (Rule h []) = PP.pretty h <> PP.dot
pretty (Rule h bs) =
PP.textStrict h
PP.pretty h
<+> ":-"
<+> PP.hcat (PP.punctuate (PP.comma <> PP.space) (map PP.pretty bs))
<> PP.dot
data Head = HeadAtom Atom | HeadChoice (NonEmpty Atom) [Atom]
deriving (Eq, Show, Ord, Read)
instance Pretty Head where
pretty (HeadAtom h ) = PP.textStrict h
pretty (HeadChoice a b) = PP.braces $ PP.hcat (PP.punctuate (PP.semi <> PP.space) (toList $ fmap PP.textStrict a)) <+>
case b of
[] -> PP.empty
_ -> PP.colon <+> PP.hcat (PP.punctuate (PP.comma <> PP.space) (fmap PP.textStrict b))
instance IsString Head where
fromString s = HeadAtom (pack s)
data BodyElement = BodyAtom SignedAtom | BodyRelation Relation
deriving (Eq, Show, Ord, Read)
......@@ -69,7 +94,6 @@ instance Pretty SignedAtom where
pretty (Positive x) = PP.textStrict x
pretty (Negative x) = "not" <+> PP.textStrict x
prettyOneLine :: Pretty a => a -> Text
prettyOneLine = PP.displayTStrict . PP.renderOneLine . PP.pretty
......@@ -95,17 +119,24 @@ symbol = L.symbol sc
atom :: Parser Atom
atom = lexeme $ do
identifier <- pack <$> ((:) <$> (P.char '-' <|> P.lowerChar) <*> many P.alphaNumChar)
identifier <-
pack <$> ((:) <$> (P.char '-' <|> P.lowerChar) <*> many P.alphaNumChar)
arguments <- option "" . lexeme $ do
_ <- P.char '('
_ <- P.char '('
args <- takeWhileP Nothing (/= ')')
_ <- P.char ')'
_ <- P.char ')'
pure $ "(" <> args <> ")"
pure $ identifier <> arguments
rule :: Parser Rule
rule =
Rule <$> atom <*> option [] (ruleIf *> bodyElement `sepBy1` comma) <* dot
Rule <$> head_ <*> option [] (ruleIf *> bodyElement `sepBy1` comma) <* dot
head_ :: Parser Head
head_ = (HeadAtom <$> atom) <|> choice_
where choice_ = between openBrace closeBrace (sc *> (HeadChoice <$> choiceList <*> option [] choiceCondition))
choiceList = fromList <$> atom `sepBy1` semicolon
choiceCondition = colon *> atom `sepBy1` comma
ruleIf :: Parser Text
ruleIf = symbol ":-"
......@@ -116,17 +147,29 @@ bodyElement = (BodyAtom <$> signedAtom) <|> (BodyRelation <$> relation)
comma :: Parser Text
comma = symbol ","
semicolon :: Parser Text
semicolon = symbol ";"
colon :: Parser Text
colon = symbol ":"
dot :: Parser Text
dot = symbol "."
negation :: Parser Text
negation = symbol "not"
openBrace :: Parser Text
openBrace = symbol "{"
closeBrace :: Parser Text
closeBrace = symbol "}"
signedAtom :: Parser SignedAtom
signedAtom = (try (negation *> (Negative <$> atom))) <|> (Positive <$> atom)
signedAtom = try (negation *> (Negative <$> atom)) <|> (Positive <$> atom)
relation :: Parser Relation
relation = lexeme $ takeWhileP Nothing (\x -> x `notElem` [',','.'])
relation = lexeme $ takeWhileP Nothing (\x -> x `notElem` [',', '.'])
stmt :: Parser Statement
stmt = StmtRule <$> rule
......
module Relax where
import Language.LARS
import Data.Maybe (mapMaybe)
import Language.LARS
import Data.Maybe ( mapMaybe )
import Data.Foldable ( toList )
relax :: [Statement] -> [Statement]
relax = map go
where go (StmtRule (Rule h bs)) = StmtRule (Rule h (mapMaybe removeNegation bs))
relax = map normalRules . concatMap splitChoices
where
normalRules (StmtRule (Rule h@HeadAtom{} bs)) =
StmtRule (Rule h (mapMaybe removeNegation bs))
normalRules x = x
splitChoices (StmtRule (Rule (HeadChoice hs cs) bs)) = map StmtRule $ do
h <- toList hs
let bs' = map (BodyAtom . Positive) cs <> bs
pure $ Rule (HeadAtom h) bs'
splitChoices x = [x]
removeNegation :: BodyElement -> Maybe BodyElement
removeNegation (BodyAtom (Negative _)) = Nothing
removeNegation (BodyAtom (Positive x)) = Just (BodyAtom (Positive x))
removeNegation (BodyRelation r) = Just (BodyRelation r)
removeNegation (BodyAtom (Negative _)) = Nothing
removeNegation (BodyAtom (Positive x)) = Just (BodyAtom (Positive x))
removeNegation (BodyRelation r ) = Just (BodyRelation r)
{ a; b } :- c, not d.
c.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
import qualified Test.Tasty
import Test.Tasty.Hspec
import Test.Hspec.Megaparsec
......@@ -48,6 +49,16 @@ pprint = parallel $ do
]
)
`shouldBe` "head(a,X) :- body(X), not foo(Y), X = Y."
it "pretty prints simple choice heads"
$ prettyOneLine (HeadChoice ["a"] [])
`shouldBe` "{a}"
it "pretty prints complex choice heads"
$ prettyOneLine (HeadChoice ["a(X)"] ["b(X)"])
`shouldBe` "{a(X) : b(X)}"
it "pretty prints choice rules"
$ prettyOneLine
(Rule (HeadChoice ["a(X)"] ["b(X)"]) [BodyAtom (Positive "c(X)")])
`shouldBe` "{a(X) : b(X)} :- c(X)."
parser :: Spec
parser = parallel $ do
......@@ -77,3 +88,13 @@ parser = parallel $ do
, BodyAtom (Negative "foo(Y)")
, BodyRelation "X = Y"
]
it "parses simple choice heads"
$ parse head_ "" "{ a }"
`shouldParse` HeadChoice ["a"] []
it "parses complex choice heads"
$ parse head_ "" "{ a(X) : b(X) }"
`shouldParse` HeadChoice ["a(X)"] ["b(X)"]
it "parses choice rules"
$ parse rule "" "{ a(X) : b(X) } :- c(X)."
`shouldParse` Rule (HeadChoice ["a(X)"] ["b(X)"])
[BodyAtom (Positive "c(X)")]
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment