Make BackendDefn 'constants' a function

Rather than a guaranteed finite map.  While here, make NoBackend agree more
with the Python backend and sort the lists of primitives.

diff --git a/src/Dyna/Backend/BackendDefn.hs b/src/Dyna/Backend/BackendDefn.hs
index cefb6d4b744cfd3a5fe32a244017f78d327af864..786432bba1d8c8d98789cf346c2d5a036bc176f9 100644 (file)
--- a/src/Dyna/Backend/BackendDefn.hs
+++ b/src/Dyna/Backend/BackendDefn.hs
@@ -36,7 +36,7 @@ data Backend = forall bs . Backend
                -- | Any constants made available by this backend.
                -- 
                -- XXX
-             , be_constants :: S.Set DFunctAr
+             , be_constants :: DFunctAr -> Bool
 
                -- | Debugging hook to render bits of DOpAMine which
                -- are "backend-specific"

diff --git a/src/Dyna/Backend/NoBackend.hs b/src/Dyna/Backend/NoBackend.hs
index 5202fb6e03bade4eae2bc2d6dfa58567c57337f0..818a7af70a23482f989fd81f36d98d5dafb530b6 100644 (file)
--- a/src/Dyna/Backend/NoBackend.hs
+++ b/src/Dyna/Backend/NoBackend.hs
@@ -12,6 +12,7 @@ module Dyna.Backend.NoBackend (noBackend) where
 
 import           Control.Lens
 import           Control.Monad
+import qualified Data.Maybe                   as MA
 import qualified Data.Map                     as M
 import qualified Data.Set                     as S
 import           Dyna.Analysis.ANF
@@ -35,7 +36,7 @@ import qualified Debug.Trace                as XT
 noBackend :: Backend
 noBackend = Backend
           { be_builtin        = primPossible
-          , be_constants      = M.keysSet primOps -- XXX
+          , be_constants      = MA.isJust . primOps -- XXX
           , be_debug_dop_iter = \_ _ _ _ _ -> empty
           , be_driver         = driver
           }
@@ -50,41 +51,46 @@ data PrimOp = PO
             , po_bs :: forall e . Doc e
             }
 
-primOps :: M.Map DFunctAr [QMode (NIX DFunct)] -- XXX ,UMode
-primOps = M.fromList
-       [ let ar = 2 in ( ("+"     ,ar)      , [miaod ar Det     ]
-                                           ++ opinvd ar Det )
-    , let ar = 2 in ( ("-"     ,ar)      , [miaod ar Det     ]
-                                           ++ opinvd ar Det )
-    , let ar = 2 in ( ("*"     ,ar)      , [miaod ar Det     ]
-                                           ++ opinvd ar DetSemi )
-    , let ar = 2 in ( ("/"     ,ar)      , [miaod ar DetSemi ]
-                                           ++ opinvd ar DetSemi )
-    , let ar = 2 in ( ("^"     ,ar)      , [miaod ar Det     ] )
-    , let ar = 2 in ( ("&"     ,ar)      , [miaod ar Det     ] )
-    , let ar = 2 in ( ("|"     ,ar)      , [miaod ar Det     ] )
-    , let ar = 2 in ( ("%"     ,ar)      , [miaod ar Det     ] )
-    , let ar = 2 in ( ("**"    ,ar)      , [miaod ar Det     ] )
-    , let ar = 2 in ( ("<"     ,ar)      , [miaod ar Det     ] )
-    , let ar = 2 in ( ("<="    ,ar)      , [miaod ar Det     ] )
-    , let ar = 2 in ( (">"     ,ar)      , [miaod ar Det     ] )
-    , let ar = 2 in ( (">="    ,ar)      , [miaod ar Det     ] )
-    , let ar = 2 in ( ("="     ,ar)      , [miaod ar Det     ] )
-         -- Unary boolean negation
-    , let ar = 1 in ( ("!"     ,ar)      , [miaod ar Det     ] )
-         -- Unary numeric negation
-    , let ar = 1 in ( ("-"     ,ar)      , [miaod ar Det     ] )
-    , let ar = 1 in ( ("mod"   ,ar)      , [miaod ar Det     ] )
-    , let ar = 1 in ( ("abs"   ,ar)      , [miaod ar Det     ] )
-    , let ar = 1 in ( ("log"   ,ar)      , [miaod ar Det     ] )
-    , let ar = 1 in ( ("exp"   ,ar)      , [miaod ar Det     ] )
-    , let ar = 2 in ( ("and"   ,ar)      , [miaod ar Det     ] )
-    , let ar = 2 in ( ("or"    ,ar)      , [miaod ar Det     ] )
-    , let ar = 1 in ( ("not"   ,ar)      , [miaod ar Det     ] )
-    ]
+primOps :: DFunctAr -> Maybe [QMode (NIX DFunct)] -- XXX ,UMode
+primOps = go
+ where
+  go ("-"    ,1) = Just   [miaod 1 Det     ]
+  go ("^"    ,2) = Just   [miaod 2 Det     ]
+  go ("|"    ,2) = Just   [miaod 2 Det     ]
+  go ("-"    ,2) = Just $ [miaod 2 Det     ] ++ opinvd 2 Det
+  go ("/"    ,2) = Just   [miaod 2 Det     ]
+  go ("*"    ,2) = Just   [miaod 2 Det     ]
+  go ("**"   ,2) = Just   [miaod 2 Det     ]
+  go ("&"    ,2) = Just   [miaod 2 Det     ]
+  go ("%"    ,2) = Just   [miaod 2 Det     ]
+  go ("+"    ,2) = Just $ [miaod 2 Det     ] ++ opinvd 2 Det
+
+  go ("mod"  ,1) = Just   [miaod 1 Det     ]
+  go ("abs"  ,1) = Just   [miaod 1 Det     ]
+  go ("log"  ,1) = Just   [miaod 1 Det     ]
+  go ("exp"  ,1) = Just   [miaod 1 Det     ]
+
+  go ("<="   ,2) = Just   [miaod 2 Det     ]
+  go ("<"    ,2) = Just   [miaod 2 Det     ]
+  go ("="    ,2) = Just   [miaod 2 Det     ]
+  go (">="   ,2) = Just   [miaod 2 Det     ]
+  go (">"    ,2) = Just   [miaod 2 Det     ]
+  go ("!="   ,2) = Just   [miaod 2 Det     ]
+
+  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 ("!"    ,1) = Just   [miaod 1 Det     ]
+  go ("not"  ,1) = Just   [miaod 1 Det     ]
+
+  go _           = Nothing
 
 primPossible :: (DFunct,[ModedVar],ModedVar) -> Either Bool (BackendAction ())
-primPossible (f,mvis,mvo) = maybe (Left False) go $ M.lookup (f,length mvis) primOps
+primPossible (f,mvis,mvo) = maybe (Left False) go $ primOps (f,length mvis)
  where
   go :: [QMode (NIX DFunct)] -> Either Bool (BackendAction ())
   go [] = Left True

diff --git a/src/Dyna/Backend/Python/Backend.hs b/src/Dyna/Backend/Python/Backend.hs
index 75c9da6a6f052d38922f263e97cbdf7d1235629d..279d6b1364a195a486f2182438f889efb7e270e5 100644 (file)
--- a/src/Dyna/Backend/Python/Backend.hs
+++ b/src/Dyna/Backend/Python/Backend.hs
@@ -60,7 +60,7 @@ isFree v = nSub (v^.mv_mi) nfree
 builtins :: BackendPossible PyDopeBS
 builtins (f,is,o) = case () of
   _ | all isGround is
-    -> maybe (Left False) gencall $ M.lookup (f,length is) constants
+    -> maybe (Left False) gencall $ constants (f,length is)
         where
          gencall pc = case () of
                         _ | isFree o ->
@@ -98,51 +98,54 @@ builtins (f,is,o) = case () of
                                [(x^.mv_var, nuniv)]
          _ -> Left True
 
-  _ | M.member (f,length is) constants  -> Left True
+  _ | MA.isJust (constants (f,length is)) -> Left True
   _ -> Left False
 
 infixOp op _ vis = sepBy op $ mpv vis
 mpv = map (pretty . (^.mv_var))
 
-constants :: M.Map (DFunct,Int) PyDopeBS
-constants = M.fromList
-    [(("+",2)     , PDBS $ infixOp "+"    )
-    ,(("-",2)     , PDBS $ infixOp "-"    )
-    ,(("*",2)     , PDBS $ infixOp "*"    )
-    ,(("/",2)     , PDBS $ infixOp "/"    )
-    ,(("^",2)     , PDBS $ infixOp "^"    )
-    ,(("&",2)     , PDBS $ infixOp "&"    )
-    ,(("|",2)     , PDBS $ infixOp "|"    )
-    ,(("%",2)     , PDBS $ infixOp "%"    )
-    ,(("**",2)    , PDBS $ infixOp "**"   )
-    ,(("==",2)    , PDBS $ infixOp "=="   )
-    ,(("!=",2)    , PDBS $ infixOp "!="   )
-    ,(("<",2)     , PDBS $ infixOp "<"    )
-    ,(("<=",2)    , PDBS $ infixOp "<="   )
-    ,((">",2)     , PDBS $ infixOp ">"    )
-    ,((">=",2)    , PDBS $ infixOp ">="   )
-    ,(("=",2)     , PDBS $ infixOp "="    )
-    ,(("!=",2)    , PDBS $ infixOp "!="   )
-    ,(("and",2)   , PDBS $ infixOp "and"  )
-    ,(("or",2)    , PDBS $ infixOp "or"   )
-
-    ,(("true",0)  , PDBS $ nullary "True" )
-    ,(("false",0) , PDBS $ nullary "False")
-    ,(("null",0)  , PDBS $ nullary "None" )
-
-    ,(("-",1)     , PDBS $ call "-"       )
-    ,(("!",1)     , PDBS $ call "not"     )
-    ,(("not",1)   , PDBS $ call "not"     )
-    ,(("mod",1)   , PDBS $ call "mod"     )
-    ,(("abs",1)   , PDBS $ call "abs"     )
-    ,(("log",1)   , PDBS $ call "log"     )
-    ,(("exp",1)   , PDBS $ call "exp"     )
-    ,(("eval",1)  , PDBS $ call "None;exec ")
-    -- XXX not quite what we want, but something like this might
-    -- be nice to have.
-    -- ,(("pair",2)  , PDBS $ call ""        )
-    ]
+constants :: DFunctAr -> Maybe PyDopeBS
+constants = go
  where
+  go ("-",1)     = Just $ PDBS $ call "-"
+  go ("^",2)     = Just $ PDBS $ infixOp "^"
+  go ("|",2)     = Just $ PDBS $ infixOp "|"
+  go ("-",2)     = Just $ PDBS $ infixOp "-"
+  go ("/",2)     = Just $ PDBS $ infixOp "/"
+  go ("*",2)     = Just $ PDBS $ infixOp "*"
+  go ("**",2)    = Just $ PDBS $ infixOp "**"
+  go ("&",2)     = Just $ PDBS $ infixOp "&"
+  go ("%",2)     = Just $ PDBS $ infixOp "%"
+  go ("+",2)     = Just $ PDBS $ infixOp "+"
+
+  go ("mod",1)   = Just $ PDBS $ call "mod"
+  go ("abs",1)   = Just $ PDBS $ call "abs"
+  go ("log",1)   = Just $ PDBS $ call "log"
+  go ("exp",1)   = Just $ PDBS $ call "exp"
+
+  go ("<=",2)    = Just $ PDBS $ infixOp "<="
+  go ("<",2)     = Just $ PDBS $ infixOp "<"
+  go ("=",2)     = Just $ PDBS $ infixOp "="
+  -- XXX "==" means something else in Dyna
+  go ("==",2)    = Just $ PDBS $ infixOp "=="
+  go (">=",2)    = Just $ PDBS $ infixOp ">="
+  go (">",2)     = Just $ PDBS $ infixOp ">"
+  go ("!=",2)    = Just $ PDBS $ infixOp "!="
+
+  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 ("!",1)     = Just $ PDBS $ call "not"
+  go ("not",1)   = Just $ PDBS $ call "not"
+
+  go ("eval",1)  = Just $ PDBS $ call "None;exec "
+  go ("tuple",_) = Just $ PDBS $ call ""
+  go _           = Nothing
+
   nullary v  _ _   = v
   call    fn _ vis = fn <> (parens $ sepBy "," $ mpv vis)
 
@@ -306,7 +309,7 @@ driver am um {-qm-} is fh = do
 
 pythonBackend :: Backend
 pythonBackend = Backend builtins
-                        (M.keysSet constants)
+                        (MA.isJust . constants)
                         (\o is _ _ (PDBS e) -> e o is)
                         driver
 

diff --git a/src/Dyna/Main/Driver.hs b/src/Dyna/Main/Driver.hs
index 9ba85a5d1d90952d74a7a7e2963be6b1642fcceb..d1dad604328fde4e2d436a85a23fb1ffe72c3356 100644 (file)
--- a/src/Dyna/Main/Driver.hs
+++ b/src/Dyna/Main/Driver.hs
@@ -274,8 +274,7 @@ processFile fileName = bracket openOut hClose go
    
   
             uPlans = combineUpdatePlans
-                     $ map (\x -> (x, planEachEval be_b
-                                                   (flip S.member be_c) x))
+                     $ map (\x -> (x, planEachEval be_b be_c x))
                            frs
 
 {-