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
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)
=================
+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
============
a/0
=================
-a := True
+a := true
b/0
=================
-b := True
+b := true
c/0
=================
-c := True
+c := true
+
+true/0
+=================
+
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
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])]
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)
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
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
_ -> 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
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
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.
-- 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
-- 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 {{{
-- 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)
]
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
------------------------------------------------------------------------}}}
-- 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 {{{
-- 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
------------------------------------------------------------------------}}}
module Dyna.Analysis.Base (
-- * Normalized Term Representations
- NT(..), FDT, NTV, ENF, EVF,
+ NT(..), FDT, NTV, EBF, ENF, EVF,
-- * Modes
Mode(..), Moded(..), modeOf, isBound, isFree,
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
-- 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
-- | 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
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 {{{
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
------------------------------------------------------------------------}}}
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 {{{
type Crux v n = Either (EvalCrux v) (UnifCrux v n)
+cruxIsEval :: Crux v n -> Bool
cruxIsEval (Left _) = True
cruxIsEval (Right _) = False
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
------------------------------------------------------------------------}}}
]
_ -> [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)
-- 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
, 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)
$ 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
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
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)
( "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)
. 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 $ "# --"
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))
--
-- 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 ("{ ... }")
{-# LANGUAGE UndecidableInstances #-}
module Dyna.ParserHS.Parser (
- Term(..), dterm, -- dtlexpr, dtfexpr,
+ Term(..), dterm,
Rule(..), drule, Line(..), dline, dlines
) where
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 ((<>))
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)
![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
, 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 '(')
-- 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)]]
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 ]
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")
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
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
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"
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
-- 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
:~ 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
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
]
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
]
:~ 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
]
-- * Annotations
Annotation(..),
+ -- * Term Base Cases
+ TBase(..), TBaseSkolem(..),
+
-- * Terms
TermF(..), DTermV, DVar, DFunct, DFunctAr, DTerm,
) 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 {{{
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
projects / dyna2 / commitdiff