From 579fa7f3ab55d70fab7bad33361deb1b24eecc32 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Sun, 30 Jun 2013 02:33:44 -0400 Subject: [PATCH] Add [,,,|Rest] syntax support to parser --- examples/expected/lists.py.out | 4 +++ examples/lists.dyna | 3 +- src/Dyna/ParserHS/Parser.hs | 57 +++++++++++++++++++++++++--------- src/Dyna/ParserHS/Selftest.hs | 23 ++++++++++++-- 4 files changed, 70 insertions(+), 17 deletions(-) diff --git a/examples/expected/lists.py.out b/examples/expected/lists.py.out index 65239f2..fce6f44 100644 --- a/examples/expected/lists.py.out +++ b/examples/expected/lists.py.out @@ -7,3 +7,7 @@ f/1 === f([1, 2]) := true +goal/1 +====== +goal([2]) := true + diff --git a/examples/lists.dyna b/examples/lists.dyna index cbcae50..c1bb6e3 100644 --- a/examples/lists.dyna +++ b/examples/lists.dyna @@ -1,4 +1,5 @@ - f([1,2]). a := [1,2]. + +goal(X) := f([1|X]). diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index bd82186..553f27b 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -109,9 +109,13 @@ mkEOT s0 f0 = EOT $ addFailSafe $ interpSpec M.empty $ M.toList s0 where go (p,f) = mapInOrCons p (interpret f o) - interpret (PFIn a) = flip Infix a . bf . spanned . bsf . symbol - interpret PFPre = Prefix . uf . spanned . bsf . symbol - interpret PFPost = Postfix . uf . spanned . bsf . symbol + interpret (PFIn a) = flip Infix a . bf . interpCore + interpret PFPre = Prefix . uf . interpCore + interpret PFPost = Postfix . uf . interpCore + + -- Make operators use the longest match + interpCore s = try (spanned (bsf (symbol s)) + <* notFollowedBy (oneOfSet usualpunct)) addFailSafe = if f0 then (++ failSafe) else id @@ -329,20 +333,44 @@ term = token $ choice , nakedbrak , spanned $ parenfunc ] + "Term" where + mkta ty te = TAnnot (AnnType ty) te + parenfunc = TFunctor <$> parseFunctor <*> parens (tlexpr `sepBy` symbolic ',') - nakedbrak = listify <$> spanned (brackets (tlexpr `sepBy` symbolic ',')) + nakedbrak = listify <$> tlist where - listify (xs :~ s) = - let (xs' :~ s') = foldr (\a@(_ :~ sa) b@(_ :~ sb) -> TFunctor "cons" [a,b] :~ (sa <> sb)) - (TFunctor "nil" [] :~ r s) + tlist = spanned (brackets ((,) <$> (tlistexpr `sepEndBy` symbolic ',') + <*> (optional (symbolic '|' *> tlexpr)) + )) + + listify ((xs,ml) :~ s) = + let (xs' :~ s') = foldr (\a@(_ :~ sa) b@(_ :~ sb) -> + TFunctor "cons" [a,b] :~ (sa <> sb)) + (maybe (TFunctor "nil" [] :~ r s) id ml) xs in (xs' :~ (s <> s')) r (Span _ e b) = Span e e b - mkta ty te = TAnnot (AnnType ty) te + + -- XXX Ick ick ick ick... there must be a more general answer, even if + -- involves patching ekmett-parsers to understand something more like + -- DOPP. + -- + -- XREF:TLEXPR + tlistexpr = do + ot <- asks dlc_opertab + (buildExpressionParser (maskPipe (unEOT ot)) term) "List Expression" + where + maskPipe ot = fmap (fmap mkpf) ot + + mkpf (Infix m a) = Infix (nfp >> m) a + mkpf (Prefix m) = Prefix (nfp >> m) + mkpf (Postfix m) = Postfix (nfp >> m) + + nfp = notFollowedBy (symbolic '|' *> notFollowedBy (oneOfSet usualpunct)) -- | Sometimes we require that a character not be followed by whitespace -- and satisfy some additional predicate before we pass it off to some other parser. @@ -397,17 +425,18 @@ bf f = do (x:~spx) <- f pure (\a@(_:~spa) b@(_:~spb) -> (TFunctor x [a,b]):~(spa <> spx <> spb)) - +-- XREF:TLEXPR tlexpr :: (DeltaParsing m, LookAheadParsing m, MonadReader DLCfg m) => m (Spanned Term) -tlexpr = asks dlc_opertab >>= flip buildExpressionParser term . unEOT +tlexpr = (asks dlc_opertab >>= flip buildExpressionParser term . unEOT) + "Core Expression" moreETable :: (LookAheadParsing m, DeltaParsing m) => [[Operator m (Spanned Term)]] -moreETable = [ [ Infix (bf (spanned $ bsf $ symbol "is" )) AssocNone ] - , [ Infix (bf (spanned $ bsf $ symbol "," )) AssocRight ] +moreETable = [ [ Infix (bf (spanned $ bsf $ symbol dynaEvalAssignOper)) AssocNone ] + , [ Infix (bf (spanned $ bsf $ symbol dynaConjOper )) AssocRight ] -- , [ Infix (bf (spanned $ commaOper )) AssocRight ] - , [ Infix (bf (spanned $ bsf $ symbol "whenever")) AssocNone - , Infix (bf (spanned $ bsf $ symbol "for" )) AssocNone ] + , map (\x -> Infix (bf (spanned $ bsf $ symbol x)) AssocNone) + dynaRevConjOpers ] -- | Full Expression diff --git a/src/Dyna/ParserHS/Selftest.hs b/src/Dyna/ParserHS/Selftest.hs index 6046736..ea6d562 100644 --- a/src/Dyna/ParserHS/Selftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -155,8 +155,8 @@ case_colonFunctor = e @=? (term pvv) :~ Span (Columns 0 0) (Columns 17 17) pvv pvv = "possible(Var:Val)" -case_bracketTuple :: Assertion -case_bracketTuple = e @=? (term s) +case_list :: Assertion +case_list = e @=? (term s) where e = TFunctor "cons" [ _tNumeric (Left 1) :~ Span (Columns 1 1) (Columns 2 2) s @@ -173,6 +173,25 @@ case_bracketTuple = e @=? (term s) :~ Span (Columns 0 0) (Columns 7 7) s s = "[1,2+3]" +case_list_bar :: Assertion +case_list_bar = e @=? (term s) + where + e = TFunctor "cons" + [ _tNumeric (Left 1) :~ Span (Columns 1 1) (Columns 2 2) s + , TFunctor "cons" + [ TFunctor "+" + [ _tNumeric (Left 2) :~ Span (Columns 3 3) (Columns 4 4) s + , _tNumeric (Left 3) :~ Span (Columns 5 5) (Columns 6 6) s + ] + :~ Span (Columns 3 3) (Columns 6 6) s + , TVar "X" :~ Span (Columns 7 7) (Columns 8 8) s + ] + :~ Span (Columns 3 3) (Columns 8 8) s + ] + :~ Span (Columns 0 0) (Columns 8 8) s + s = "[1,2+3|X]" + + -- case_nullaryStar :: Assertion -- case_nullaryStar = e @=? (term gs) -- where -- 2.50.1