Addresses nwf/dyna#49; leaving open for subsequent discussion.
-- 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)
-- 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,
(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
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
--
-- 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)])
(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"
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 ]
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)
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
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" []
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':
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
, try $ spanned $ TBase . TNumeric <$> naturalOrDouble
+ , try $ spanned $ TBase . TBool <$> boolean
+
, try $ spanned $ flip TFunctor [] <$> parseAtom
<* (notFollowedBy $ char '(')
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 ',')
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.
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
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
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 "
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."
dynaRevConjOpers :: (IsString s) => [s]
dynaRevConjOpers = ["whenever","for"]
-dynaUnitTerm :: (IsString s) => s
-dynaUnitTerm = "true"
+dynaUnitTerm :: TBase
+dynaUnitTerm = TBool True
dynaUnifOpers :: (IsString s) => [s]
dynaUnifOpers = [ "=", "==" ]
------------------------------------------------------------------------}}}
-- 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
└─ := 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
│ |
└─ := 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
│ |
projects / dyna2 / commitdiff