From 5ff33881a3d15f55a790d7b8b7ef3e74b0d2c4c5 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Thu, 11 Jul 2013 01:55:25 -0400 Subject: [PATCH] Booleans are not to be treated as atoms Addresses nwf/dyna#49; leaving open for subsequent discussion. --- src/Dyna/Analysis/ANF.hs | 20 +++++++++++++++----- src/Dyna/Analysis/RuleMode.hs | 9 +++++---- src/Dyna/Backend/NoBackend.hs | 4 +--- src/Dyna/Backend/Python/Backend.hs | 10 +++++----- src/Dyna/Backend/Python/interpreter.py | 11 ----------- src/Dyna/ParserHS/Parser.hs | 10 ++++++++-- src/Dyna/ParserHS/Selftest.hs | 11 ++++++++++- src/Dyna/Term/SurfaceSyntax.hs | 4 ++-- src/Dyna/Term/TTerm.hs | 6 ++++-- test/repl/trace.dynadoc | 4 ++-- 10 files changed, 52 insertions(+), 37 deletions(-) diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index 3f4a0f9..b3ba426 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -252,7 +252,7 @@ normTerm_ a m _ d (P.TVar v) = do -- Numerics get returned in-place and raise a warning if they are evaluated. normTerm_ _ m ss d (P.TBase x@(TNumeric _)) = do case m of - (_,True) -> newWarn "Quoting numerics is unnecessary" ss + (_,True) -> newWarn "Suppressing numeric evaluation is unnecessary" ss (0,False) -> return () (_,False) -> newWarn "Ignoring request to evaluate numeric" ss maybe (newWarn "Numeric literal is discarded" ss) @@ -262,13 +262,23 @@ normTerm_ _ m ss d (P.TBase x@(TNumeric _)) = do -- Strings too normTerm_ _ m ss d (P.TBase x@(TString _)) = do case m of - (_,True) -> newWarn "Quoting strings is unnecessary" ss + (_,True) -> newWarn "Suppressing string evaluation is unnecessary" ss (0,False) -> return () (_,False) -> newWarn "Ignoring request to evaluate string" ss maybe (newWarn "String literal is discarded" ss) (doLoadBase x) d +-- Booleans too +normTerm_ _ m ss d (P.TBase x@(TBool _)) = do + case m of + (_,True) -> newWarn "Suppressing boolean evaluation is unnecessary" ss + (0,False) -> return () + (_,False) -> newWarn "Ignoring request to evaluate boolean" ss + maybe (newWarn "Boolean literal is discarded" ss) + (doLoadBase x) + d + -- "is/2" is sort of exciting. We normalize the second argument in an -- evaluation context and the first in a quoted context. Then, if the -- result is quoted, we simply build up some structure. If it's evaluated, @@ -288,7 +298,7 @@ normTerm_ a m ss d (P.TFunctor f [x T.:~ sx, v T.:~ sv]) (Nothing, 1) -> doUnif nx nv (_ , n) -> do _ <- doUnif nx nv - t <- newLoad "_x" (Right (dynaUnitTerm,[])) + t <- newLoad "_x" (Left $ NTBase dynaUnitTerm) r <- timesM (newEval "_x" . Left) (n-1) t maybe (return ()) (doUnif r) d @@ -388,10 +398,10 @@ normConjunct ss f i si r sr n d rev = go di dr doStruct (selfstruct di dr) d' (1,Just d') -> do - di <- newLoad "_b" (Right $ (dynaUnitTerm,[])) + di <- newLoad "_b" (Left $ NTBase dynaUnitTerm) go di d' (_,_ ) -> do - di <- newLoad "_b" (Right $ (dynaUnitTerm,[])) + di <- newLoad "_b" (Left $ NTBase dynaUnitTerm) dr <- nextVar "_c" go di dr ct <- timesM (newEval "_x" . Left) (n-1) dr diff --git a/src/Dyna/Analysis/RuleMode.hs b/src/Dyna/Analysis/RuleMode.hs index dce4559..e1ff945 100644 --- a/src/Dyna/Analysis/RuleMode.hs +++ b/src/Dyna/Analysis/RuleMode.hs @@ -222,8 +222,9 @@ possible fp bcs co lf cr = -- -- XXX Special casing ought not be necessary! Left (_, CCall vo [va,vb] funct) | funct `elem` dynaUnifOpers -> do - pfx <- fgn vo (return (OPWrap vo [] dynaUnitTerm)) - (return (OPPeel [] vo dynaUnitTerm DetSemi)) + pfx <- fgn vo (return [OPAsgn vo (NTBase dynaUnitTerm)]) + (let c = "_chk" in return [ OPAsgn c (NTBase dynaUnitTerm) + , OPCheq vo c]) (throwError UFExDomain) unif <- fgn va (fgn vb (throwError UFExDomain) (bind va >> return [OPAsgn va (NTVar vb)]) @@ -232,13 +233,13 @@ possible fp bcs co lf cr = (gencall) (throwError UFExDomain)) (throwError UFExDomain) - return (pfx:unif) + return (pfx++unif) where gencall = do is <- mapM mkMV [va,vb] o <- mkMV vo - case fp (funct,is,o) of + case fp ("=",is,o) of -- XXX; should we really be using "="? Right (BAct a m) -> runbact m >> return a Left _ -> dynacPanic "Backend failed to generate unification call" diff --git a/src/Dyna/Backend/NoBackend.hs b/src/Dyna/Backend/NoBackend.hs index 1f8de6f..29fec87 100644 --- a/src/Dyna/Backend/NoBackend.hs +++ b/src/Dyna/Backend/NoBackend.hs @@ -84,9 +84,7 @@ primOps = go go ("and" ,2) = Just [miaod 2 Det ] go ("or" ,2) = Just [miaod 2 Det ] - go ("true" ,0) = Just [miaod 0 Det ] - go ("false",0) = Just [miaod 0 Det ] - go ("null" ,0) = Just [miaod 0 Det ] + -- go ("null" ,0) = Just [miaod 0 Det ] go ("!" ,1) = Just [miaod 1 Det ] go ("not" ,1) = Just [miaod 1 Det ] diff --git a/src/Dyna/Backend/Python/Backend.hs b/src/Dyna/Backend/Python/Backend.hs index 74419af..267568e 100644 --- a/src/Dyna/Backend/Python/Backend.hs +++ b/src/Dyna/Backend/Python/Backend.hs @@ -36,7 +36,9 @@ import Dyna.Backend.BackendDefn import Dyna.Main.Exception import qualified Dyna.ParserHS.Types as P import qualified Dyna.ParserHS.Parser as P +import Dyna.Term.Normalized (NT (NTBase)) import Dyna.Term.TTerm +import Dyna.Term.SurfaceSyntax (dynaUnitTerm) import Dyna.XXX.PPrint import Dyna.XXX.MonadUtils import Dyna.XXX.Trifecta (prettySpanLoc) @@ -129,11 +131,11 @@ builtins (f,is,o) = case () of cdop = [OPIter x [y] "iter" DetNon (Just $ PDBS call)] cmod = [(x^.mv_var, nuniv)] in if isFree o - then Right $ BAct (OPWrap (o^.mv_var) [] "true" : cdop) + then Right $ BAct (OPAsgn (o^.mv_var) (NTBase dynaUnitTerm) : cdop) ((o^.mv_var, nuniv) : cmod) else if isGround o then let _chk = "_chk" - in Right $ BAct ( OPWrap _chk [] "true" + in Right $ BAct ( OPAsgn _chk (NTBase dynaUnitTerm) : OPCheq _chk (o^.mv_var) : cdop) cmod @@ -191,9 +193,7 @@ constants = go go ("and",2) = Just $ PDBS $ infixOp "and" go ("or",2) = Just $ PDBS $ infixOp "or" - go ("true",0) = Just $ PDBS $ nullary "True" - go ("false",0) = Just $ PDBS $ nullary "False" - go ("null",0) = Just $ PDBS $ nullary "None" + go ("null",0) = Just $ PDBS $ nullary "None" -- XXX go ("!",1) = Just $ PDBS $ call "not" [] go ("not",1) = Just $ PDBS $ call "not" [] diff --git a/src/Dyna/Backend/Python/interpreter.py b/src/Dyna/Backend/Python/interpreter.py index 83a2499..dfabf28 100644 --- a/src/Dyna/Backend/Python/interpreter.py +++ b/src/Dyna/Backend/Python/interpreter.py @@ -263,11 +263,6 @@ class Interpreter(object): print def build(self, fn, *args): - # TODO: codegen should handle true/0 is True and false/0 is False - if fn == 'true/0': - return True - if fn == 'false/0': - return False if fn == 'cons/2': return Cons(*args) if fn == 'nil/0': @@ -591,12 +586,6 @@ def peel(fn, item): functor/arity, `fn`. Returns the arguments of term as a tuple of intern idxs and constants (possibly an empty tuple). """ - if fn == "true/0": - assert item is True - return - if fn == "false/0": - assert item is False - return assert isinstance(item, Term) assert item.fn == fn return item.args diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index d15c3e5..d51273d 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -326,6 +326,8 @@ term = token $ choice , try $ spanned $ TBase . TNumeric <$> naturalOrDouble + , try $ spanned $ TBase . TBool <$> boolean + , try $ spanned $ flip TFunctor [] <$> parseAtom <* (notFollowedBy $ char '(') @@ -337,6 +339,10 @@ term = token $ choice where mkta ty te = TAnnot (AnnType ty) te + boolean = choice [ symbol "true" *> return True + , symbol "false" *> return False + ] + parenfunc = TFunctor <$> parseFunctor <*> parens (tlexpr `sepBy` symbolic ',') @@ -370,7 +376,7 @@ term = token $ choice mkpf (Prefix m) = Prefix (nfp >> m) mkpf (Postfix m) = Postfix (nfp >> m) - nfp = notFollowedBy (symbolic '|' *> notFollowedBy (oneOfSet usualpunct)) + 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. @@ -465,7 +471,7 @@ rule = token $ do h@(_ :~ hs) <- term choice [ do (_ :~ ds) <- try (spanned (char '.') <* lookAhead whiteSpace) - return (Rule h ":-" (TFunctor "true" [] :~ ds) :~ (hs <> ds)) + return (Rule h ":-" (TBase dynaUnitTerm :~ ds) :~ (hs <> ds)) , do aggr <- token $ join $ asks dlc_aggrs body <- tfexpr diff --git a/src/Dyna/ParserHS/Selftest.hs b/src/Dyna/ParserHS/Selftest.hs index 2d8b7f4..fd62e00 100644 --- a/src/Dyna/ParserHS/Selftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -30,6 +30,7 @@ import Dyna.ParserHS.OneshotDriver import Dyna.ParserHS.Types import Dyna.Term.SurfaceSyntax import Dyna.Term.TTerm (Annotation(..), TBase(..)) +import Dyna.XXX.Trifecta (unSpan) import Dyna.XXX.TrifectaTest import Test.Framework as TF import Test.Framework.Providers.HUnit @@ -61,6 +62,14 @@ case_basicAtom :: Assertion case_basicAtom = e @=? (strictterm "foo") where e = TFunctor "foo" [] :~ Span (Columns 0 0) (Columns 3 3) "foo" +case_booleans_not_atoms :: Assertion +case_booleans_not_atoms = map snd t @=? map (unSpan.strictterm.fst) t + where t = [ ("true" , TBase (TBool True)) + , ("false" , TBase (TBool False)) + , ("'true'" , TFunctor "true" []) + , ("'false'", TFunctor "false" []) + ] + case_basicAtomTWS :: Assertion case_basicAtomTWS = e @=? (strictterm "foo ") where e = TFunctor "foo" [] :~ Span (Columns 0 0) (Columns 4 4) "foo " @@ -297,7 +306,7 @@ case_ruleFact = e @=? (progrule sr) e = Rule (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 4 4) sr) ":-" - (TFunctor "true" [] :~ Span (Columns 4 4) (Columns 5 5) sr) + (TBase (dynaUnitTerm) :~ Span (Columns 4 4) (Columns 5 5) sr) :~ ts ts = Span (Columns 0 0) (Columns 5 5) sr sr = "goal." diff --git a/src/Dyna/Term/SurfaceSyntax.hs b/src/Dyna/Term/SurfaceSyntax.hs index 2fac827..e0c8456 100644 --- a/src/Dyna/Term/SurfaceSyntax.hs +++ b/src/Dyna/Term/SurfaceSyntax.hs @@ -39,8 +39,8 @@ dynaConjOper = "," dynaRevConjOpers :: (IsString s) => [s] dynaRevConjOpers = ["whenever","for"] -dynaUnitTerm :: (IsString s) => s -dynaUnitTerm = "true" +dynaUnitTerm :: TBase +dynaUnitTerm = TBool True dynaUnifOpers :: (IsString s) => [s] dynaUnifOpers = [ "=", "==" ] diff --git a/src/Dyna/Term/TTerm.hs b/src/Dyna/Term/TTerm.hs index 32938e8..64f2355 100644 --- a/src/Dyna/Term/TTerm.hs +++ b/src/Dyna/Term/TTerm.hs @@ -43,15 +43,17 @@ import qualified Data.ByteString.Char8() ------------------------------------------------------------------------}}} -- Term Base Cases {{{ -data TBaseSkolem = TSNumeric | TSString +data TBaseSkolem = TSBool | TSNumeric | TSString deriving (Eq,Ord,Show) -- | Term base cases. -data TBase = TNumeric !(Either Integer Double) +data TBase = TBool !Bool + | TNumeric !(Either Integer Double) | TString !B.ByteString deriving (D.Data,D.Typeable,Eq,Ord,Show) instance PP.Pretty TBase where + pretty (TBool x) = PP.pretty x pretty (TNumeric (Left x)) = PP.pretty x pretty (TNumeric (Right x)) = PP.pretty x pretty (TString s) = PP.text $ show s diff --git a/test/repl/trace.dynadoc b/test/repl/trace.dynadoc index eadb790..1c6345e 100644 --- a/test/repl/trace.dynadoc +++ b/test/repl/trace.dynadoc @@ -45,7 +45,7 @@ b = 3 └─ := 3 f(X=3) := (f((X=3 - 1)=2)=2 + f((X=3 - 2)=1)=1)=3, - for ((X=3 > 1)=true) = (&true=true). + for ((X=3 > 1)=true) = (true=true). | ├─ f(1) = 1 │ | @@ -58,7 +58,7 @@ b = 3 └─ := 2 f(X=2) := (f((X=2 - 1)=1)=1 + f((X=2 - 2)=0)=1)=2, - for ((X=2 > 1)=true) = (&true=true). + for ((X=2 > 1)=true) = (true=true). | ├─ f(0) = 1 │ | -- 2.50.1