From: Nathaniel Wesley Filardo Date: Sat, 12 Jan 2013 02:48:00 +0000 (-0500) Subject: Tidy source tree X-Git-Url: https://hydra-www.ietfng.org/gitweb/?a=commitdiff_plain;h=f7331ea3b24cc74a47fdfe135379deaf370dc26a;p=dyna2 Tidy source tree - Separate assignments and unifications in ANF. Assignments are now exclusively for loading (or checking) literals. - Move term base cases out from our myriad of representations into Dyna.Term.TTerm's TBase. - Fix comma and whenever handling in ANF (which is a temporary hack) and while there, make "true" and "false" a little closer to correct. - Move Analysis.Aggregation over to Main.Exception rather than Either. - Remove some dead code from Backend.Python and ParserHS.Parser - While here and there, squash some warnings --- diff --git a/bin/prototype.py b/bin/prototype.py index 430404f..5fa8a27 100644 --- a/bin/prototype.py +++ b/bin/prototype.py @@ -154,15 +154,18 @@ def isvar(x): def circuit(anf): - (agg, head, evals, unifs, result) = anf + (agg, head, evals, assigns, unifs, result) = anf g = Hypergraph() for var, op, args in evals: g.edge(head=var, label=op, body=args) - for var, op, args in unifs: + for var, op, args in assigns: g.edge(head=var, label='& %s' % op, body=args) + for var, op, val in unifs: + g.edge(head=var, label='& ', body=[op]) + g.head = head g.result = result diff --git a/bin/utils.py b/bin/utils.py index 82cdb9a..d8616eb 100644 --- a/bin/utils.py +++ b/bin/utils.py @@ -62,9 +62,10 @@ def read_anf(e): def g(x): return list(_g(x)) - for (agg, head, evals, unifs, [_,result]) in x: + for (agg, head, evals, assigns, unifs, [_,result]) in x: yield (agg, head, g(evals[1:]), + g(assigns[1:]), g(unifs[1:]), result) diff --git a/examples/expected/papa2.py.out b/examples/expected/papa2.py.out index 424292a..ddc5332 100644 --- a/examples/expected/papa2.py.out +++ b/examples/expected/papa2.py.out @@ -84,14 +84,18 @@ t/3 ================= +true/0 +================= + + word/2 ================= -word('.',7) := True -word('Papa',0) := True -word('a',5) := True -word('ate',1) := True -word('caviar',3) := True -word('spoon',6) := True -word('the',2) := True -word('with',4) := True +word('.',7) := true +word('Papa',0) := true +word('a',5) := true +word('ate',1) := true +word('caviar',3) := true +word('spoon',6) := true +word('the',2) := true +word('with',4) := true diff --git a/examples/expected/simple.py.out b/examples/expected/simple.py.out index b8b99a9..0b80033 100644 --- a/examples/expected/simple.py.out +++ b/examples/expected/simple.py.out @@ -3,13 +3,17 @@ Charts ============ a/0 ================= -a := True +a := true b/0 ================= -b := True +b := true c/0 ================= -c := True +c := true + +true/0 +================= + diff --git a/src/Dyna/Analysis/ANF.hs b/src/Dyna/Analysis/ANF.hs index 3d7b707..9580248 100644 --- a/src/Dyna/Analysis/ANF.hs +++ b/src/Dyna/Analysis/ANF.hs @@ -75,7 +75,7 @@ module Dyna.Analysis.ANF ( import Control.Monad.Reader import Control.Monad.State -import Control.Unification +-- import Control.Unification import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.UTF8 as BU import qualified Data.ByteString as B @@ -134,7 +134,7 @@ mergeDispositions = md data ANFState = AS { as_next :: !Int , as_evals :: M.Map DVar EVF - , as_assgn :: M.Map DVar ENF + , as_assgn :: M.Map DVar EBF , as_unifs :: [(DVar,DVar)] , as_annot :: M.Map DVar [Annotation (T.Spanned P.Term)] , as_warns :: [(B.ByteString, [T.Span])] @@ -155,10 +155,16 @@ newEval pfx t = do return n newAssign :: (MonadState ANFState m) => String -> ENF -> m DVar -newAssign pfx t = do +newAssign pfx t = + case t of + Left (NTVar v) -> return v + Left (NTBase b) -> go (Left b) + Right u -> go (Right u) + where + go u = do n <- nextVar pfx uns <- gets as_assgn - modify (\s -> s { as_assgn = M.insert n t uns }) + modify (\s -> s { as_assgn = M.insert n u uns }) return n newAnnot :: (MonadState ANFState m) @@ -166,9 +172,11 @@ newAnnot :: (MonadState ANFState m) newAnnot v a = do modify (\s -> s { as_annot = mapInOrApp v a (as_annot s) }) +{- newAssignNT :: (MonadState ANFState m) => String -> NTV -> m DVar newAssignNT _ (NTVar x) = return x newAssignNT pfx x = newAssign pfx $ Left x +-} doUnif :: (MonadState ANFState m) => DVar -> DVar -> m () doUnif v w = if v == w @@ -206,6 +214,8 @@ dynaFunctorSelfDispositions :: (DFunct,Int) -> SelfDispos dynaFunctorSelfDispositions x = case x of ("pair",2) -> SDQuote ("eval",1) -> SDEval + ("true",0) -> SDQuote + ("false",0) -> SDQuote (name, _) -> -- If it starts with a nonalpha, it prefers to evaluate let d = if C.isAlphaNum $ head $ BU.toString name @@ -249,26 +259,26 @@ normTerm_ c _ (P.TVar v) = do _ -> return $ NTVar v' -- Numerics get returned in-place and raise a warning if they are evaluated. -normTerm_ c ss (P.TNumeric n) = do +normTerm_ c ss (P.TBase x@(TNumeric _)) = do case c of (ECExplicit,ADEval) -> newWarn "Ignoring request to evaluate numeric" ss _ -> return () - return $ NTNumeric n + return $ NTBase x -- Strings too -normTerm_ c ss (P.TString s) = do +normTerm_ c ss (P.TBase x@(TString _)) = do case c of (ECExplicit,ADEval) -> newWarn "Ignoring request to evaluate string" ss _ -> return () - return $ NTString s + return $ NTBase x -- Annotations -- -- XXX this is probably the wrong thing to do normTerm_ c ss (P.TAnnot a (t T.:~ st)) = do - v <- normTerm_ c (st:ss) t >>= newAssignNT "_a" + v <- normTerm_ c (st:ss) t >>= newAssign "_a" . Left newAnnot v a - return (NTVar v) + return $ NTVar v -- Quote makes the context explicitly a quoting one normTerm_ _ ss (P.TFunctor "&" [t T.:~ st]) = do @@ -281,10 +291,10 @@ normTerm_ c ss (P.TFunctor "*" [t T.:~ st]) = normTerm_ (ECExplicit,ADEval) (st:ss) t >>= \nt -> case c of (_,ADEval) -> case nt of - NTVar v -> NTVar `fmap` newEval "_s" (Left v) - _ -> do - newWarn "Ignoring * of literal" ss - return nt + NTVar v -> NTVar `fmap` newEval "_s" (Left v) + NTBase b -> do + newWarn "Ignoring * of literal" ss + return $ NTBase b _ -> return nt -- "is/2" is sort of exciting. We normalize the second argument in an @@ -298,25 +308,26 @@ normTerm_ c ss (P.TFunctor "is" [x T.:~ sx, v T.:~ sv]) = do case c of (_,ADEval) -> do _ <- doUnif nx nv - return $ NTNumeric (Left 42) -- XXX ought to be NTUnit + NTVar `fmap` newAssign "_i" (Right ("true",[])) _ -> do - NTVar `fmap` newAssign "_u" (Right ("is",[nx,nv])) + NTVar `fmap` newAssign "_i" (Right ("is",[nx,nv])) -- ",/2" and "whenever/2" are also reserved words of the language and get --- handled here. XXX This may be wrong, too, of course. +-- handled here. -- --- These cases both discard their side-conditions and simply transparently --- return the normalization of their values -normTerm_ (_,ADEval) ss (P.TFunctor "whenever" [r T.:~ sr, i T.:~ si]) = do - _ <- normTerm_ (ECFunctor, ADEval) (si:ss) i - nv <- normTerm_ (ECFunctor, ADEval) (sr:ss) r >>= newAssign "_c" . Left - return $ NTVar nv - +-- XXX This is wrong, too, of course; these should really be moved into a +-- standard prelude. But there's no facility for that right now and no +-- reason to make the backend know about them since that's also wrong! normTerm_ (_,ADEval) ss (P.TFunctor "," [i T.:~ si, r T.:~ sr]) = do - _ <- normTerm_ (ECFunctor, ADEval) (si:ss) i - nv <- normTerm_ (ECFunctor, ADEval) (sr:ss) r >>= newAssign "_c" . Left + ni <- normTerm_ (ECFunctor, ADEval) (si:ss) i >>= newAssign "_e" . Left + nv <- normTerm_ (ECFunctor, ADEval) (sr:ss) r >>= newAssign "_e" . Left + + t' <- newAssign "_e" (Right ("true",[])) + _ <- doUnif ni t' return $ NTVar nv +normTerm_ c@(_,ADEval) ss (P.TFunctor "whenever" [sr, si]) = + normTerm_ c ss (P.TFunctor "," [si,sr]) -- Functors have both top-down and bottom-up dispositions on -- their handling. @@ -332,13 +343,10 @@ normTerm_ c ss (P.TFunctor f as) = do -- example, correctly reject updates that are not the right shape. normas' <- let delin (vs,r) x = do case x of - x@(NTVar v) | v `elem` vs -> do - v' <- newAssign "_x" (Left x) - return (vs,v':r) - NTVar v -> do + NTVar v | not (v `elem` vs) -> do return (v:vs,v:r) _ -> do - v' <- newAssignNT "_x" x + v' <- newAssign "_x" (Left x) return (vs,v':r) in (reverse . snd) `fmap` foldM delin ([],[]) normas @@ -374,10 +382,10 @@ data Rule = Rule { r_index :: Int -- XXX normRule :: T.Spanned P.Rule -- ^ Term to digest -> Rule -normRule (P.Rule i h a r T.:~ span) = uncurry ($) $ runNormalize $ do - nh <- normTerm False h >>= newAssignNT "_h" - nr <- normTerm True r >>= newAssignNT "_r" - return $ Rule i nh a nr span +normRule (P.Rule i h a r T.:~ sp) = uncurry ($) $ runNormalize $ do + nh <- normTerm False h >>= newAssign "_h" . Left + nr <- normTerm True r >>= newAssign "_r" . Left + return $ Rule i nh a nr sp ------------------------------------------------------------------------}}} -- Run the normalizer {{{ @@ -394,15 +402,16 @@ runNormalize = -- Pretty Printer {{{ printANF :: Rule -> Doc e -printANF (Rule i h a result span +printANF (Rule i h a result sp (AS {as_evals = evals, as_assgn = assgn, as_unifs = unifs})) = - text ";;" <+> prettySpanLoc span + text ";;" <+> prettySpanLoc sp `above` text ";; index" <+> pretty i `above` ( parens $ (pretty a) <+> valign [ (pretty h) , parens $ text "evals" <+> pev + , parens $ text "assign" <+> pas , parens $ text "unifs" <+> pun , parens $ text "result" <+> (pretty result) ] @@ -411,20 +420,15 @@ printANF (Rule i h a result span pft :: FDT -> Doc e pft (fn,args) = parens $ hsep $ (pretty fn : (map pretty args)) - pevf :: EVF -> Doc e - pevf (Left v) = pretty v - pevf (Right t) = pft t - - penf :: ENF -> Doc e - penf (Left n) = pretty n - penf (Right t) = pft t + pe :: Pretty a => Either a FDT -> Doc e + pe = either pretty pft - pev = valign $ map (\(y,z)-> parens $ pretty y <+> pevf z) + pev = valign $ map (\(y,z)-> parens $ pretty y <+> pe z) $ M.toList evals - pun = valign $ map (\(y,z)-> parens $ pretty y <+> penf z) - (M.toList assgn) - ++ map (\(y,z) -> parens $ pretty y <+> pretty z) - unifs + pas = valign $ map (\(y,z)-> parens $ pretty y <+> pe z) + (M.toList assgn) + pun = valign $ map (\(y,z) -> parens $ pretty y <+> pretty z) + unifs ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Analysis/Aggregation.hs b/src/Dyna/Analysis/Aggregation.hs index aa0e996..2cb2a0a 100644 --- a/src/Dyna/Analysis/Aggregation.hs +++ b/src/Dyna/Analysis/Aggregation.hs @@ -5,15 +5,19 @@ -- Header material {{{ +{-# LANGUAGE OverloadedStrings #-} + module Dyna.Analysis.Aggregation ( AggMap, buildAggMap ) where -import qualified Data.ByteString as B +-- import qualified Data.ByteString as B import qualified Data.Map as M import Dyna.Analysis.ANF +import Dyna.Main.Exception import Dyna.Term.TTerm import Dyna.XXX.DataUtils +import Text.PrettyPrint.Free ------------------------------------------------------------------------}}} -- Preliminaries {{{ @@ -28,24 +32,25 @@ type AggMap = M.Map DFunctAr DAgg -- XXX These functions really would like to have span information, so they -- could report which line of the source caused an error. -procANF :: Rule -> Either String (DFunctAr, DAgg) -procANF (Rule _ h a _ _ (AS { as_assgn = as })) = +procANF :: Rule -> (DFunctAr, DAgg) +procANF r@(Rule _ h a _ _ (AS { as_assgn = as })) = case M.lookup h as of - Nothing -> Left $ "I can't process head-variables" + Nothing -> dynacSorry $ "I can't process head-variables" <+> (pretty $ show r) Just t -> case t of - Left _ -> Left "Malformed head" - Right (f,as) -> Right ((f,length as),a) + Left _ -> dynacPanic $ "Malformed head" <+> (pretty $ show r) + Right (f,xs) -> ((f,length xs),a) -buildAggMap :: [Rule] -> Either String AggMap +buildAggMap :: [Rule] -> AggMap buildAggMap = go (M.empty) where - go m [] = Right m + go m [] = m go m (ar:xs) = - case procANF ar of - Left e -> Left e - Right (d,a) -> - case mapUpsert d a m of - Left a' -> Left $ "Conflicting aggregators" - Right m' -> go m' xs + let (d,a) = procANF ar + in case mapUpsert d a m of + Left a' -> dynacUserErr $ "Conflicting aggregators in rule" + <+> (pretty $ show ar) + <+> "Expected" + <+> pretty a' + Right m' -> go m' xs ------------------------------------------------------------------------}}} diff --git a/src/Dyna/Analysis/Base.hs b/src/Dyna/Analysis/Base.hs index 3e89479..85877e1 100644 --- a/src/Dyna/Analysis/Base.hs +++ b/src/Dyna/Analysis/Base.hs @@ -5,7 +5,7 @@ module Dyna.Analysis.Base ( -- * Normalized Term Representations - NT(..), FDT, NTV, ENF, EVF, + NT(..), FDT, NTV, EBF, ENF, EVF, -- * Modes Mode(..), Moded(..), modeOf, isBound, isFree, @@ -18,7 +18,7 @@ module Dyna.Analysis.Base ( Det(..), detOfDop, ) where -import qualified Data.ByteString as B +-- import qualified Data.ByteString as B import Dyna.Term.TTerm import qualified Text.PrettyPrint.Free as PP @@ -26,20 +26,13 @@ import qualified Text.PrettyPrint.Free as PP -- Normalized Term Representations {{{ -- | A Normalized Term, parametric in the variable case --- --- The Ord instance is solely for Data.Set's use -data NT v = NTBool Bool - | NTNumeric (Either Integer Double) - | NTString B.ByteString - | NTVar v +data NT v = NTVar v + | NTBase TBase deriving (Eq,Ord,Show) -instance (PP.Pretty v) => PP.Pretty (NT v) where - pretty (NTNumeric (Left x)) = PP.pretty x - pretty (NTNumeric (Right x)) = PP.pretty x - pretty (NTString s) = PP.dquotes (PP.pretty s) - pretty (NTVar v) = PP.pretty v - +instance PP.Pretty v => PP.Pretty (NT v) where + pretty (NTVar v) = PP.pretty v + pretty (NTBase t) = PP.pretty t -- | Normalized Term over 'DVar' (that is, either a primitive or a variable) type NTV = NT DVar @@ -47,6 +40,9 @@ type NTV = NT DVar -- | Flat Dyna Term (that is, a functor over variables) type FDT = (DFunct,[DVar]) +-- | Either a base case or flat term +type EBF = Either TBase FDT + -- | Either a variable or a functor of variables) type EVF = Either DVar FDT @@ -80,16 +76,14 @@ varOfMV (MB x) = x type ModedNT = NT (ModedVar) evnOfMNT :: ModedNT -> Either DVar NTV -evnOfMNT (NTVar mv) = case mv of +evnOfMNT (NTVar mv) = case mv of MB v -> Right (NTVar v) MF v -> Left v -evnOfMNT (NTString s) = Right (NTString s) -evnOfMNT (NTNumeric n) = Right (NTNumeric n) +evnOfMNT (NTBase b) = Right (NTBase b) ntvOfMNT :: ModedNT -> NTV -ntvOfMNT (NTVar mx) = NTVar $ varOfMV mx -ntvOfMNT (NTString s) = NTString s -ntvOfMNT (NTNumeric n) = NTNumeric n +ntvOfMNT (NTVar mx) = NTVar $ varOfMV mx +ntvOfMNT (NTBase b) = NTBase b ------------------------------------------------------------------------}}} -- DOpAMine {{{ diff --git a/src/Dyna/Analysis/RuleMode.hs b/src/Dyna/Analysis/RuleMode.hs index 836a497..c5419f9 100644 --- a/src/Dyna/Analysis/RuleMode.hs +++ b/src/Dyna/Analysis/RuleMode.hs @@ -31,21 +31,20 @@ module Dyna.Analysis.RuleMode ( adornedQueries ) where -import Control.Monad +-- import Control.Monad import qualified Data.ByteString.Char8 as BC -import qualified Data.List as L +-- import qualified Data.List as L import qualified Data.Map as M import qualified Data.Maybe as MA import qualified Data.Set as S -import qualified Debug.Trace as XT +-- import qualified Debug.Trace as XT import Dyna.Analysis.ANF import Dyna.Analysis.Base import Dyna.Term.TTerm import Dyna.Main.Exception -import qualified Dyna.ParserHS.Parser as DP import Dyna.XXX.DataUtils(argmin,mapInOrApp) import Dyna.XXX.Trifecta (prettySpanLoc) -import Dyna.XXX.TrifectaTest +-- import Dyna.XXX.TrifectaTest import Text.PrettyPrint.Free ------------------------------------------------------------------------}}} @@ -63,10 +62,8 @@ modedVar b x = case varMode b x of MFree -> MF x modedNT :: BindChart -> NTV -> ModedNT -modedNT b (NTVar v) = NTVar $ modedVar b v -modedNT _ (NTBool b) = NTBool b -modedNT _ (NTString s) = NTString s -modedNT _ (NTNumeric x) = NTNumeric x +modedNT b (NTVar v) = NTVar $ modedVar b v +modedNT _ (NTBase b) = NTBase b ------------------------------------------------------------------------}}} -- Cruxes {{{ @@ -81,6 +78,7 @@ data UnifCrux v n = CFStruct v [v] DFunct type Crux v n = Either (EvalCrux v) (UnifCrux v n) +cruxIsEval :: Crux v n -> Bool cruxIsEval (Left _) = True cruxIsEval (Right _) = False @@ -192,8 +190,8 @@ unif_cruxes (AS { as_assgn = assigns, as_unifs = unifs }) = M.foldrWithKey (\o i -> (crux o i :)) [] assigns ++ map (\(v1,v2) -> CFAssign v1 (NTVar v2)) unifs where - crux :: DVar -> ENF -> UnifCrux DVar NTV - crux o (Left x) = CFAssign o x + crux :: DVar -> EBF -> UnifCrux DVar NTV + crux o (Left x) = CFAssign o (NTBase x) crux o (Right (f,as)) = CFStruct o as f ------------------------------------------------------------------------}}} @@ -337,14 +335,6 @@ stepPartialPlan steps score mic p = ] _ -> [dop] -stepAgenda st sc mic = go [] . (\x -> [x]) - where - go [] [] = [] - go (r:rs) [] = go rs r - go rs (p:ps) = case stepPartialPlan st sc mic p of - Left df -> df : (go rs ps) - Right ps' -> go (ps':rs) ps - planner_ :: Possible fbs -- ^ Available steps -> (PartialPlan fbs -> Action fbs -> Cost) @@ -360,7 +350,7 @@ planner_ :: Possible fbs -- the two given for an initial crux -> [(Cost, Action fbs)] -- ^ Plans and their costs -planner_ st sc cr mic bv = stepAgenda st sc mic' +planner_ st sc cr mic bv = runAgenda $ PP { pp_cruxes = cr , pp_binds = S.union bv bi , pp_restrictSearch = False @@ -368,6 +358,14 @@ planner_ st sc cr mic bv = stepAgenda st sc mic' , pp_plan = ip } where + runAgenda = go [] . (\x -> [x]) + where + go [] [] = [] + go (r:rs) [] = go rs r + go rs (p:ps) = case stepPartialPlan st sc mic' p of + Left df -> df : (go rs ps) + Right ps' -> go (ps':rs) ps + -- XREF:INITPLAN (ip,bi,mic') = case mic of Nothing -> ([],S.empty,Nothing) @@ -387,6 +385,7 @@ anfPlanner_ st sc anf mic bv = planner_ st sc cruxes mic bv $ maybe id (\(ic,_,_) -> S.delete ic) mic $ S.fromList $ eval_cruxes anf) +bestPlan :: [(Cost, Action fbs)] -> Maybe (Cost, Action fbs) bestPlan [] = Nothing bestPlan plans = Just $ argmin fst plans @@ -424,7 +423,7 @@ planEachEval bp cs (Rule { r_anf = anf }) = CFCall _ is f | not (cs (f,length is)) -> Just (Just (f,length is), ec) CFCall _ _ _ -> Nothing - CFEval o i -> Just (Nothing,ec)) + CFEval _ _ -> Just (Nothing,ec)) -- Grab all evaluations $ eval_cruxes anf @@ -500,9 +499,9 @@ combineQueryPlans = go (M.empty) go m [] = m go m ((fr,mcva):xs) = go' xs fr mcva m - go' xs fr Nothing m = dynacUserErr - $ "No query plan for rule at" - <+> (prettySpanLoc $ r_span fr) + go' _ fr Nothing _ = dynacUserErr + $ "No query plan for rule at" + <+> (prettySpanLoc $ r_span fr) go' xs fr (Just (c,v,a)) m = go (mapInOrApp (findHeadFA fr) (fr,c,v,a) m) diff --git a/src/Dyna/Backend/Python.hs b/src/Dyna/Backend/Python.hs index 51a6d56..33db864 100644 --- a/src/Dyna/Backend/Python.hs +++ b/src/Dyna/Backend/Python.hs @@ -151,10 +151,8 @@ pycall f vs = case (f, length vs) of ( "true", 0) -> "True" ("false", 0) -> "False" - -- fall back use the call indirection table... for now non-exhaustive pattern match error - -- TODO: add useful error message. --- _ -> functorIndirect "call" f vs <> (tupled $ pretty_vs) - + x -> dynacPanic $ "Python.hs: Unknown request to pycall: " + <> pretty x where pretty_vs = map (pretty . varOfMV) vs call name = name <> (parens $ sepBy ", " $ pretty_vs) @@ -204,16 +202,6 @@ pdope _d _e = (indent 4 $ "for _ in [None]:") . go xs -py mfa mu (Rule _ h _ r span _) dope = - case mu of - Just (hv,v) -> case mfa of - Nothing -> dynacSorry "Can't register indir eval" - Nothing -> case mfa of - Nothing -> dynacPanic "Initializer without head" - `above` pdope dope emit - where - emit = "emit" <> tupled [pretty h, pretty r] - printPlanHeader :: Handle -> Rule -> Cost -> IO () printPlanHeader h r c = do hPutStrLn h $ "# --" diff --git a/src/Dyna/Main/Driver.hs b/src/Dyna/Main/Driver.hs index 88dab1a..7bbb8d8 100644 --- a/src/Dyna/Main/Driver.hs +++ b/src/Dyna/Main/Driver.hs @@ -184,9 +184,7 @@ processFile fileName = bracket openOut hClose go dump DumpANF (vcat $ map printANF frs) - aggm <- case buildAggMap frs of - Left e -> dynacThrow $ UserProgramError (text e) - Right x -> return x + aggm <- return $! buildAggMap frs dump DumpAgg (M.foldlWithKey (\d f a -> d `above` (pretty f <+> colon <+> pretty a)) diff --git a/src/Dyna/ParserHS/Parser.hs b/src/Dyna/ParserHS/Parser.hs index de827a7..d68b925 100644 --- a/src/Dyna/ParserHS/Parser.hs +++ b/src/Dyna/ParserHS/Parser.hs @@ -7,9 +7,6 @@ -- -- TODO (XXX): -- --- * There is certainly too much special handling of the comma operator, --- but see COMMAOP below for why it's not so easy to fix. --- -- * We might want to use T.T.Literate, too, in the end. -- -- * Doesn't understand dynabase literals ("{ ... }") @@ -35,7 +32,7 @@ {-# LANGUAGE UndecidableInstances #-} module Dyna.ParserHS.Parser ( - Term(..), dterm, -- dtlexpr, dtfexpr, + Term(..), dterm, Rule(..), drule, Line(..), dline, dlines ) where @@ -44,7 +41,7 @@ import Control.Monad import Control.Monad.State import qualified Data.ByteString.UTF8 as BU import qualified Data.ByteString as B -import Data.Char (isSpace) +-- import Data.Char (isSpace) import qualified Data.CharSet as CS import qualified Data.HashSet as H import Data.Semigroup ((<>)) @@ -54,7 +51,7 @@ import Text.Parser.Token.Highlight import Text.Parser.Token.Style import Text.Trifecta -import Dyna.Term.TTerm (Annotation(..)) +import Dyna.Term.TTerm (Annotation(..), TBase(..)) import Dyna.XXX.MonadUtils (incState) import Dyna.XXX.Trifecta (identNL,stringLiteralSQ) @@ -65,9 +62,8 @@ data Term = TFunctor !B.ByteString ![Spanned Term] | TAnnot !(Annotation (Spanned Term)) !(Spanned Term) - | TNumeric !(Either Integer Double) - | TString !B.ByteString | TVar !B.ByteString + | TBase !TBase deriving (Eq,Ord,Show) type RuleIx = Int @@ -260,9 +256,9 @@ term = token $ choice , spanned $ mkta <$> (colon *> term) <* whiteSpace <*> term - , try $ spanned $ TString <$> bsf stringLiteral + , try $ spanned $ TBase . TString <$> bsf stringLiteral - , try $ spanned $ TNumeric <$> naturalOrDouble + , try $ spanned $ TBase . TNumeric <$> naturalOrDouble , try $ spanned $ flip TFunctor [] <$> atom <* (notFollowedBy $ char '(') @@ -318,21 +314,6 @@ bf f = do -- XXX right now all binops are at equal precedence and left-associative; -- that's wrong. -- --- XXX I remember now why we didn't handle ',' as an operator: if it were, --- we'd have no way of distinguishing between @f(a,b)@ as --- --- > TFunctor "f" [TFunctor "a" [] :~ _, TFunctor "b" [] :~ _] --- --- and --- --- > TFunctor "f" [TFunctor "," [TFunctor "a" [] :~ _, TFunctor "b" [] :~ _] :~ _] --- --- COMMAOP --- We can fix this, but it means that we should have a separate expression --- parser for contexts where "comma means argument separation" and "comma --- means evaluation separator". I don't yet know how I feel about --- the "whenever" (and "is"?) operator(s) being available in the former table. --- -- XXX timv suggests that this should be assocnone for binops as a quick -- fix. Eventually we should still do this properly. termETable :: DeltaParsing m => [[Operator m (Spanned Term)]] @@ -346,7 +327,7 @@ termETable = [ [ Prefix $ uf (spanned $ bsf $ symbol "new") ] tlexpr :: DeltaParsing m => m (Spanned Term) tlexpr = buildExpressionParser termETable term "Limited Expression" - +fullETable :: DeltaParsing m => [[Operator m (Spanned Term)]] fullETable = [ [ Infix (bf (spanned $ bsf $ symbol "is" )) AssocNone ] , [ Infix (bf (spanned $ bsf $ symbol "," )) AssocRight ] , [ Infix (bf (spanned $ bsf $ symbol "whenever")) AssocNone ] @@ -355,40 +336,15 @@ fullETable = [ [ Infix (bf (spanned $ bsf $ symbol "is" )) AssocNone ] tfexpr :: DeltaParsing m => m (Spanned Term) tfexpr = buildExpressionParser fullETable tlexpr "Expression" -dterm, dtlexpr, dtfexpr :: DeltaParsing m => m (Spanned Term) +dterm :: DeltaParsing m => m (Spanned Term) dterm = unDL term -dtlexpr = unDL tlexpr -dtfexpr = unDL tfexpr ------------------------------------------------------------------------}}} -- Rules {{{ -{- --- | Grab the head (term!) and aggregation operator from a line that --- we hope is a rule. -rulepfx :: (MonadState RuleIx m, DeltaParsing m) - => m ([Spanned Term] -> Spanned Term -> Rule) -rulepfx = rule <*> term - <* whiteSpace - <*> (bsf $ ident dynaAggStyle "Aggregator") --} - parseRule :: (MonadState RuleIx m, DeltaParsing m) => m Rule parseRule = choice [ - -{- - -- HEAD OP= RESULTEXPR whenever EXPRS . - (try (liftA flip rulepfx - <*> tlexpr - <* hrss "whenever")) - <*> (tlexpr `sepBy1` symbolic ',') - - -- HEAD OP= EXPRS, RESULTEXPR . - , try (rulepfx - <*> many (try (tlexpr <* symbolic ',')) - <*> tlexpr) --} - + -- HEAD AGGR TFEXPR . try $ rule <*> term <* whiteSpace <*> (bsf $ ident dynaAggStyle "Aggregator") @@ -404,8 +360,6 @@ parseRule = choice [ return $ Rule ix h ":-" (TFunctor "true" [] :~ s) ] <* optional (char '.') - where - hrss = highlight ReservedOperator . spanned . symbol drule :: (DeltaParsing m) => m (Spanned Rule) drule = evalStateT (unDL (spanned parseRule)) 0 diff --git a/src/Dyna/ParserHS/Selftest.hs b/src/Dyna/ParserHS/Selftest.hs index 68cd8fa..c1f0121 100644 --- a/src/Dyna/ParserHS/Selftest.hs +++ b/src/Dyna/ParserHS/Selftest.hs @@ -31,12 +31,15 @@ import Text.Trifecta import Text.Trifecta.Delta import Dyna.ParserHS.Parser -import Dyna.Term.TTerm (Annotation(..)) +import Dyna.Term.TTerm (Annotation(..), TBase(..)) import Dyna.XXX.TrifectaTest ------------------------------------------------------------------------}}} -- Terms and basic handling {{{ +_tNumeric :: Either Integer Double -> Term +_tNumeric = TBase . TNumeric + term :: ByteString -> Spanned Term term = unsafeParse dterm @@ -89,8 +92,8 @@ case_basicFunctorNLComment :: Assertion case_basicFunctorNLComment = e @=? (term sfb) where e = TFunctor "foo" - [TNumeric (Left 1) :~ Span (Lines 1 0 9 0) (Lines 1 1 10 1) "1,2\n" - ,TNumeric (Left 2) :~ Span (Lines 1 2 11 2) (Lines 2 0 13 0) "1,2\n" + [_tNumeric (Left 1) :~ Span (Lines 1 0 9 0) (Lines 1 1 10 1) "1,2\n" + ,_tNumeric (Left 2) :~ Span (Lines 1 2 11 2) (Lines 2 0 13 0) "1,2\n" ] :~ Span (Columns 0 0) (Lines 2 1 14 1) "foo(%xxx\n" @@ -181,7 +184,7 @@ case_ruleSimple = e @=? (progline sr) where e = LRule (Rule 0 (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) "+=" - (TNumeric (Left 1) :~ Span (Columns 8 8) (Columns 9 9) sr) + (_tNumeric (Left 1) :~ Span (Columns 8 8) (Columns 9 9) sr) :~ ts) :~ ts ts = Span (Columns 0 0) (Columns 10 10) sr @@ -195,7 +198,7 @@ case_ruleSimple = e @=? (progline sr) -- e = LRule (Rule 0 (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) -- "+=" -- [] --- (TNumeric (Left 0) :~ Span (Columns 8 8) (Columns 9 9) sr) +-- (_tNumeric (Left 0) :~ Span (Columns 8 8) (Columns 9 9) sr) -- :~ ts) -- :~ ts -- ts = Span (Columns 0 0) (Columns 10 10) sr @@ -262,7 +265,7 @@ case_ruleKeywordsComma = e @=? (progline sr) :~ Span (Columns 26 26) (Columns 32 32) sr] :~ Span (Columns 21 21) (Columns 32 32) sr ,TFunctor "is" [TVar "Y" :~ Span (Columns 34 34) (Columns 36 36) sr - ,TNumeric (Left 3) :~ Span (Columns 39 39) (Columns 41 41) sr] + ,_tNumeric (Left 3) :~ Span (Columns 39 39) (Columns 41 41) sr] :~ Span (Columns 34 34) (Columns 41 41) sr] :~ Span (Columns 21 21) (Columns 41 41) sr] -- End "whenever" :~ Span (Columns 6 6) (Columns 41 41) sr) -- End expression @@ -276,12 +279,12 @@ case_rules = e @=? (proglines sr) where e = [ LRule (Rule 0 (TFunctor "goal" [] :~ Span (Columns 0 0) (Columns 5 5) sr) "+=" - (TNumeric (Left 1) :~ Span (Columns 8 8) (Columns 10 10) sr) + (_tNumeric (Left 1) :~ Span (Columns 8 8) (Columns 10 10) sr) :~ s1) :~ s1 , LRule (Rule 1 (TFunctor "goal" [] :~ Span (Columns 12 12) (Columns 17 17) sr) "+=" - (TNumeric (Left 2) :~ Span (Columns 20 20) (Columns 22 22) sr) + (_tNumeric (Left 2) :~ Span (Columns 20 20) (Columns 22 22) sr) :~ s2) :~ s2 ] @@ -294,12 +297,12 @@ case_rulesWhitespace = e @=? (proglines sr) where e = [ LRule (Rule 0 (TFunctor "goal" [] :~ Span (Columns 2 2) (Lines 1 1 16 1) l0) "+=" - (TNumeric (Left 1) :~ Span (Lines 1 4 19 4) (Lines 1 6 21 6) l1) + (_tNumeric (Left 1) :~ Span (Lines 1 4 19 4) (Lines 1 6 21 6) l1) :~ s1) :~ s1 , LRule (Rule 1 (TFunctor "goal" [] :~ Span (Lines 3 1 31 1) (Lines 3 6 36 6) l3) "+=" - (TNumeric (Left 2) :~ Span (Lines 3 9 39 9) (Lines 3 11 41 11) l3) + (_tNumeric (Left 2) :~ Span (Lines 3 9 39 9) (Lines 3 11 41 11) l3) :~ s2) :~ s2 ] @@ -327,7 +330,7 @@ case_rulesDotExpr = e @=? (proglines sr) :~ s1 , LRule (Rule 1 (TFunctor "goal" [] :~ Span (Columns 17 17) (Columns 22 22) sr) "+=" - (TNumeric (Left 1) :~ Span (Columns 25 25) (Columns 27 27) sr) + (_tNumeric (Left 1) :~ Span (Columns 25 25) (Columns 27 27) sr) :~ s2) :~ s2 ] diff --git a/src/Dyna/Term/TTerm.hs b/src/Dyna/Term/TTerm.hs index 040c6b3..2ed6aad 100644 --- a/src/Dyna/Term/TTerm.hs +++ b/src/Dyna/Term/TTerm.hs @@ -17,6 +17,9 @@ module Dyna.Term.TTerm ( -- * Annotations Annotation(..), + -- * Term Base Cases + TBase(..), TBaseSkolem(..), + -- * Terms TermF(..), DTermV, DVar, DFunct, DFunctAr, DTerm, @@ -28,9 +31,28 @@ module Dyna.Term.TTerm ( ) where import Control.Unification -import qualified Data.ByteString as B -import qualified Data.Foldable as F -import qualified Data.Traversable as T +import qualified Data.ByteString as B +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import qualified Text.PrettyPrint.Free as PP + +------------------------------------------------------------------------}}} +-- Term Base Cases {{{ + +-- | Used in mode analysis to indicate that an inst is bound to a ground +-- (but unknown) value. +data TBaseSkolem = TSNumeric | TSString + deriving (Eq,Ord,Show) + +-- | Term base cases. +data TBase = TNumeric !(Either Integer Double) + | TString !B.ByteString + deriving (Eq,Ord,Show) + +instance PP.Pretty TBase where + pretty (TNumeric (Left x)) = PP.pretty x + pretty (TNumeric (Right x)) = PP.pretty x + pretty (TString s) = PP.dquotes (PP.pretty s) ------------------------------------------------------------------------}}} -- Terms {{{ @@ -39,8 +61,7 @@ data Annotation t = AnnType t deriving (Eq,F.Foldable,Functor,Ord,Show,T.Traversable) data TermF a t = TFunctor !a ![t] - | TNumeric !(Either Integer Double) - | TString !B.ByteString + | TBase TBase deriving (Eq,F.Foldable,Functor,Ord,Show,T.Traversable) type DFunct = B.ByteString