Commit b88066d0 authored by Paul Ogris's avatar Paul Ogris
Browse files

Add support for guards in choices

parent 679fb2e4
......@@ -67,15 +67,24 @@ instance Pretty Rule where
<+> PP.hcat (PP.punctuate (PP.comma <> PP.space) (map PP.pretty bs))
<> PP.dot
data Head = HeadAtom Atom | HeadChoice (NonEmpty Atom) [Atom]
data Head = HeadAtom Atom | HeadChoice (Maybe Int) (NonEmpty Atom) [Atom] (Maybe Int)
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))
pretty (HeadAtom h) = PP.textStrict h
pretty (HeadChoice l a b u) =
let
set =
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))
in maybe mempty PP.int l <+> set <+> maybe mempty PP.int u
instance IsString Head where
fromString s = HeadAtom (pack s)
......@@ -134,9 +143,14 @@ rule =
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
where
choice_ = do
l <- optional (lexeme L.decimal)
(set, conditions) <- between openBrace closeBrace $ (,) <$> choiceList <*> option [] choiceCondition
u <- optional (lexeme L.decimal)
pure $ HeadChoice l set conditions u
choiceList = fromList <$> atom `sepBy1` semicolon
choiceCondition = colon *> atom `sepBy1` comma
ruleIf :: Parser Text
ruleIf = symbol ":-"
......
......@@ -11,7 +11,7 @@ relax = map normalRules . concatMap splitChoices
StmtRule (Rule h (mapMaybe removeNegation bs))
normalRules x = x
splitChoices (StmtRule (Rule (HeadChoice hs cs) bs)) = map StmtRule $ do
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'
......
pigeon(1..5). hole(1..4).
{ place(P,H) : hole(H) } :- pigeon(P).
pigeon(1..5). hole(1..4).
1 { place(P,H) : hole(H) } 1 :- pigeon(P).
......@@ -50,15 +50,20 @@ pprint = parallel $ do
)
`shouldBe` "head(a,X) :- body(X), not foo(Y), X = Y."
it "pretty prints simple choice heads"
$ prettyOneLine (HeadChoice ["a"] [])
$ prettyOneLine (HeadChoice Nothing ["a"] [] Nothing)
`shouldBe` "{a}"
it "pretty prints complex choice heads"
$ prettyOneLine (HeadChoice ["a(X)"] ["b(X)"])
$ prettyOneLine (HeadChoice Nothing ["a(X)"] ["b(X)"] Nothing)
`shouldBe` "{a(X) : b(X)}"
it "pretty prints choice rules"
$ prettyOneLine
(Rule (HeadChoice ["a(X)"] ["b(X)"]) [BodyAtom (Positive "c(X)")])
(Rule (HeadChoice Nothing ["a(X)"] ["b(X)"] Nothing)
[BodyAtom (Positive "c(X)")]
)
`shouldBe` "{a(X) : b(X)} :- c(X)."
it "pretty prints choices with guards"
$ prettyOneLine (HeadChoice (Just 1) ["a", "b"] [] (Just 1))
`shouldBe` "1 {a; b} 1"
parser :: Spec
parser = parallel $ do
......@@ -90,11 +95,14 @@ parser = parallel $ do
]
it "parses simple choice heads"
$ parse head_ "" "{ a }"
`shouldParse` HeadChoice ["a"] []
`shouldParse` HeadChoice Nothing ["a"] [] Nothing
it "parses complex choice heads"
$ parse head_ "" "{ a(X) : b(X) }"
`shouldParse` HeadChoice ["a(X)"] ["b(X)"]
`shouldParse` HeadChoice Nothing ["a(X)"] ["b(X)"] Nothing
it "parses choice rules"
$ parse rule "" "{ a(X) : b(X) } :- c(X)."
`shouldParse` Rule (HeadChoice ["a(X)"] ["b(X)"])
`shouldParse` Rule (HeadChoice Nothing ["a(X)"] ["b(X)"] Nothing)
[BodyAtom (Positive "c(X)")]
it "parses choices with guards"
$ parse head_ "" "1 { a; b } 1"
`shouldParse` HeadChoice (Just 1) ["a", "b"] [] (Just 1)
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