forked from GitHub/gf-core
Adding a new experimental partial evalutator
GF.Compile.Compute.ConcreteNew + two new modules contain a new
partial evaluator intended to solve some performance problems with the old
partial evalutator in GF.Compile.Compute.ConcreteLazy. It has been around for
a while, but is now complete enough to compile the RGL and the Phrasebook.
The old partial evaluator is still used by default. The new one can be activated
in two ways:
- by using the command line option -new-comp when invoking GF.
- by using cabal configure -fnew-comp to make -new-comp the default. In this
case you can also use the command line option -old-comp to revert to the old
partial evaluator.
In the GF shell, the cc command uses the old evaluator regardless of -new-comp
for now, but you can use "cc -new ..." to invoke the new evaluator.
With -new-comp, computations happen in GF.Compile.GeneratePMCFG instead of
GF.Compile.Optimize. This is implemented by testing the flag optNewComp in
both modules, to omit calls to the old partial evaluator from GF.Compile.Optimize
and add calls to the new partial evaluator in GF.Compile.GeneratePMCFG.
This also means that -new-comp effectively implies -noexpand.
In GF.Compile.CheckGrammar, there is a check that restricted inheritance is used
correctly. However, when -noexpand is used, this check causes unexpected errors,
so it has been converted to generate warnings, for now.
-new-comp no longer enables the new type checker in
GF.Compile.Typeckeck.ConcreteNew.
The GF version number has been bumped to 3.3.10-darcs
This commit is contained in:
hallgren
@@ -1,108 +1,338 @@
|
||||
-- | Functions for computing the values of terms in the concrete syntax, in
|
||||
-- | preparation for PMCFG generation.
|
||||
module GF.Compile.Compute.ConcreteNew
|
||||
( normalForm
|
||||
, Value(..), Env, eval, apply, value2term
|
||||
) where
|
||||
|
||||
import GF.Grammar hiding (Env, VGen, VApp, VRecType)
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Grammar.Predef
|
||||
import GF.Data.Operations
|
||||
import Data.List (intersect)
|
||||
import GF.Grammar.Lookup(lookupResDef,allParamValues)
|
||||
import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr)
|
||||
import GF.Grammar.PatternMatch(matchPattern)
|
||||
import GF.Grammar.Lockfield(unlockRecord,lockLabel,isLockLabel)
|
||||
import GF.Compile.Compute.Value
|
||||
import GF.Compile.Compute.Predef(predefs)
|
||||
import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok)
|
||||
import GF.Data.Operations(Err,err,maybeErr,combinations)
|
||||
import GF.Data.Utilities(mapSnd,mapBoth,apBoth,apSnd)
|
||||
import Control.Monad(liftM,liftM2,mplus)
|
||||
import Data.List (findIndex,intersect,isInfixOf,nub)
|
||||
import Data.Char (isUpper,toUpper,toLower)
|
||||
import Text.PrettyPrint
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.Map as Map
|
||||
import Debug.Trace(trace)
|
||||
|
||||
-- * Main entry points
|
||||
|
||||
normalForm :: SourceGrammar -> Term -> Term
|
||||
normalForm gr t = value2term gr [] (eval gr [] t)
|
||||
|
||||
data Value
|
||||
= VApp QIdent [Value]
|
||||
| VGen Int [Value]
|
||||
| VMeta MetaId Env [Value]
|
||||
| VClosure Env Term
|
||||
| VInt Int
|
||||
| VFloat Double
|
||||
| VString String
|
||||
| VSort Ident
|
||||
| VImplArg Value
|
||||
| VTblType Value Value
|
||||
| VRecType [(Label,Value)]
|
||||
| VRec [(Label,Value)]
|
||||
| VTbl Type [Value]
|
||||
-- | VC Value Value
|
||||
| VPatt Patt
|
||||
| VPattType Value
|
||||
| VFV [Value]
|
||||
| VAlts Value [(Value, Value)]
|
||||
| VError String
|
||||
deriving Show
|
||||
|
||||
type Env = [(Ident,Value)]
|
||||
normalForm gr = nfx gr []
|
||||
nfx gr env = value2term gr [] . eval gr env
|
||||
|
||||
eval :: SourceGrammar -> Env -> Term -> Value
|
||||
eval gr env (Vr x) = case lookup x env of
|
||||
Just v -> v
|
||||
Nothing -> error ("Unknown variable "++showIdent x)
|
||||
eval gr env (Q x)
|
||||
| x == (cPredef,cErrorType) -- to be removed
|
||||
= let varP = identC (BS.pack "P")
|
||||
in eval gr [] (mkProd [(Implicit,varP,typeType)] (Vr varP) [])
|
||||
| fst x == cPredef = VApp x []
|
||||
| otherwise = case lookupResDef gr x of
|
||||
Ok t -> eval gr [] t
|
||||
Bad err -> error err
|
||||
eval gr env (QC x) = VApp x []
|
||||
eval gr env (App e1 e2) = apply gr env e1 [eval gr env e2]
|
||||
eval gr env (Meta i) = VMeta i env []
|
||||
eval gr env t@(Prod _ _ _ _) = VClosure env t
|
||||
eval gr env t@(Abs _ _ _) = VClosure env t
|
||||
eval gr env (EInt n) = VInt n
|
||||
eval gr env (EFloat f) = VFloat f
|
||||
eval gr env (K s) = VString s
|
||||
eval gr env Empty = VString ""
|
||||
eval gr env (Sort s)
|
||||
| s == cTok = VSort cStr -- to be removed
|
||||
| otherwise = VSort s
|
||||
eval gr env (ImplArg t) = VImplArg (eval gr env t)
|
||||
eval gr env (Table p res) = VTblType (eval gr env p) (eval gr env res)
|
||||
eval gr env (RecType rs) = VRecType [(l,eval gr env ty) | (l,ty) <- rs]
|
||||
eval gr env t@(ExtR t1 t2) =
|
||||
let error = VError (show (text "The term" <+> ppTerm Unqualified 0 t <+> text "is not reducible"))
|
||||
in case (eval gr env t1, eval gr env t2) of
|
||||
(VRecType rs1, VRecType rs2) -> case intersect (map fst rs1) (map fst rs2) of
|
||||
[] -> VRecType (rs1 ++ rs2)
|
||||
_ -> error
|
||||
(VRec rs1, VRec rs2) -> case intersect (map fst rs1) (map fst rs2) of
|
||||
[] -> VRec (rs1 ++ rs2)
|
||||
_ -> error
|
||||
_ -> error
|
||||
eval gr env (FV ts) = VFV (map (eval gr env) ts)
|
||||
eval gr env t = error ("unimplemented: eval "++show t)
|
||||
eval gr env t = value (gr,env) t
|
||||
|
||||
apply gr env t [] = eval gr env t
|
||||
apply gr env (Q x) vs
|
||||
| fst x == cPredef = VApp x vs -- hmm
|
||||
| otherwise = case lookupResDef gr x of
|
||||
Ok t -> apply gr [] t vs
|
||||
Bad err -> error err
|
||||
apply gr env (App t1 t2) vs = apply gr env t1 (eval gr env t2 : vs)
|
||||
apply gr env (Abs b x t) (v:vs) = case (b,v) of
|
||||
(Implicit,VImplArg v) -> apply gr ((x,v):env) t vs
|
||||
(Explicit, v) -> apply gr ((x,v):env) t vs
|
||||
apply gr env t vs = error ("apply "++show t)
|
||||
apply gr env = apply' (gr,env)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- * Environments
|
||||
|
||||
type CompleteEnv = (SourceGrammar,Env)
|
||||
|
||||
ext b (gr,env) = (gr,b:env)
|
||||
|
||||
var env x = maybe unbound id (lookup x (snd env))
|
||||
where unbound = bug ("Unknown variable: "++showIdent x)
|
||||
|
||||
-- * Computing values
|
||||
|
||||
-- | Computing the value of a top-level term
|
||||
value0 gr t = eval gr [] t
|
||||
|
||||
-- | Computing the value of a term
|
||||
value :: CompleteEnv -> Term -> Value
|
||||
value env t0 =
|
||||
case t0 of
|
||||
Vr x -> var env x
|
||||
Q x@(m,f)
|
||||
| m == cPredef -> if f==cErrorType -- to be removed
|
||||
then let p = identC (BS.pack "P")
|
||||
in value0 (fst env) (mkProd [(Implicit,p,typeType)] (Vr p) [])
|
||||
else VApp x []
|
||||
| otherwise -> err bug (value0 (fst env)) (lookupResDef (fst env) x)
|
||||
QC x -> VCApp x []
|
||||
App e1 e2 -> apply' env e1 [value env e2]
|
||||
Let (x,(oty,t)) body -> value (ext (x,value env t) env) body
|
||||
Meta i -> VMeta i (snd env) []
|
||||
Prod bt x t1 t2 -> VProd bt (value env t1) x (Bind $ \ vx -> value (ext (x,vx) env) t2)
|
||||
Abs bt x t -> VAbs bt x (Bind $ \ vx -> value (ext (x,vx) env) t)
|
||||
EInt n -> VInt n
|
||||
EFloat f -> VFloat f
|
||||
K s -> VString s
|
||||
Empty -> VString ""
|
||||
Sort s | s == cTok -> VSort cStr -- to be removed
|
||||
| otherwise -> VSort s
|
||||
ImplArg t -> VImplArg (value env t)
|
||||
Table p res -> VTblType (value env p) (value env res)
|
||||
RecType rs -> VRecType [(l,value env ty) | (l,ty) <- rs]
|
||||
t@(ExtR t1 t2) -> extR t (both (value env) (t1,t2))
|
||||
FV ts -> vfv (map (value env) ts)
|
||||
R as -> VRec [(lbl,value env t)|(lbl,(oty,t))<-as]
|
||||
T i cs -> valueTable env i cs
|
||||
V ty ts -> VV ty (map (value env) ts)
|
||||
C t1 t2 -> vconcat (both (value env) (t1,t2))
|
||||
S t1 t2 -> select (fst env) (both (value env) (t1,t2))
|
||||
P t l -> --maybe (bug $ "project "++show l++" from "++show v) id $
|
||||
maybe (VP v l) id $
|
||||
proj l v where v = (value env t)
|
||||
Alts t tts -> VAlts (value env t) (mapBoth (value env) tts)
|
||||
Strs ts -> VStrs (map (value env) ts)
|
||||
Glue t1 t2 -> glue (both (value env) (t1,t2))
|
||||
ELin c r -> unlockVRec c (value env r)
|
||||
t -> ppbug (text "value"<+>ppTerm Unqualified 10 t $$ text (show t))
|
||||
|
||||
vconcat vv@(v1,v2) =
|
||||
case vv of
|
||||
(VError _,_) -> v1
|
||||
(VString "",_) -> v2
|
||||
(_,VError _) -> v2
|
||||
(_,VString "") -> v1
|
||||
_ -> VC v1 v2
|
||||
|
||||
proj l v | isLockLabel l = return (VRec [])
|
||||
---- a workaround 18/2/2005: take this away and find the reason
|
||||
---- why earlier compilation destroys the lock field
|
||||
proj l v =
|
||||
case v of
|
||||
VFV vs -> liftM vfv (mapM (proj l) vs)
|
||||
VRec rs -> lookup l rs
|
||||
VExtR v1 v2 -> proj l v2 `mplus` proj l v1 -- hmm
|
||||
_ -> return (ok1 VP v l)
|
||||
|
||||
ok1 f v1@(VError {}) _ = v1
|
||||
ok1 f v1 v2 = f v1 v2
|
||||
|
||||
ok2 f v1@(VError {}) _ = v1
|
||||
ok2 f _ v2@(VError {}) = v2
|
||||
ok2 f v1 v2 = f v1 v2
|
||||
|
||||
unlockVRec ::Ident -> Value -> Value
|
||||
unlockVRec c v =
|
||||
case v of
|
||||
-- VClosure env t -> err bug (VClosure env) (unlockRecord c t)
|
||||
VAbs bt x (Bind f) -> VAbs bt x (Bind $ \ v -> unlockVRec c (f v))
|
||||
VRec rs -> plusVRec rs lock
|
||||
_ -> VExtR v (VRec lock) -- hmm
|
||||
-- _ -> bug $ "unlock non-record "++show v
|
||||
where
|
||||
lock = [(lockLabel c,VRec [])]
|
||||
|
||||
-- suspicious, but backwards compatible
|
||||
plusVRec rs1 rs2 = VRec ([(l,v)|(l,v)<-rs1,l `notElem` ls2] ++ rs2)
|
||||
where ls2 = map fst rs2
|
||||
|
||||
extR t vv =
|
||||
case vv of
|
||||
(VFV vs,v2) -> vfv [extR t (v1,v2)|v1<-vs]
|
||||
(v1,VFV vs) -> vfv [extR t (v1,v2)|v2<-vs]
|
||||
(VRecType rs1, VRecType rs2) ->
|
||||
case intersect (map fst rs1) (map fst rs2) of
|
||||
[] -> VRecType (rs1 ++ rs2)
|
||||
ls -> error $ text "clash"<+>text (show ls)
|
||||
(VRec rs1, VRec rs2) -> plusVRec rs1 rs2
|
||||
(v1 , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm
|
||||
(VS (VV t vs) s,v2) -> VS (VV t [extR t (v1,v2)|v1<-vs]) s
|
||||
(v1,v2) -> ok2 VExtR v1 v2 -- hmm
|
||||
-- (v1,v2) -> error $ text "not records" $$ text (show v1) $$ text (show v2)
|
||||
where
|
||||
error explain = ppbug $ text "The term" <+> ppTerm Unqualified 0 t
|
||||
<+> text "is not reducible" $$ explain
|
||||
|
||||
glue vv = case vv of
|
||||
(VFV vs,v2) -> vfv [glue (v1,v2)|v1<-vs]
|
||||
(v1,VFV vs) -> vfv [glue (v1,v2)|v2<-vs]
|
||||
(VString s1,VString s2) -> VString (s1++s2)
|
||||
(v1,VAlts d vs) -> VAlts (glx d) [(glx v,c) | (v,c) <- vs]
|
||||
where glx v2 = glue (v1,v2)
|
||||
(v1@(VAlts {}),v2) ->
|
||||
--err (const (ok2 VGlue v1 v2)) id $
|
||||
err bug id $
|
||||
do y' <- strsFromValue v2
|
||||
x' <- strsFromValue v1
|
||||
return $ vfv [foldr1 VC (map VString (str2strings (glueStr v u))) | v <- x', u <- y']
|
||||
(VC va vb,v2) -> VC va (glue (vb,v2))
|
||||
(v1,VC va vb) -> VC (glue (va,va)) vb
|
||||
(VS (VV ty vs) vb,v2) -> VS (VV ty [glue (v,v2)|v<-vs]) vb
|
||||
(v1,VS (VV ty vs) vb) -> VS (VV ty [glue (v1,v)|v<-vs]) vb
|
||||
-- (v1,v2) -> ok2 VGlue v1 v2
|
||||
(v1,v2) -> bug vv
|
||||
where
|
||||
bug vv = ppbug $ text "glue"<+>text (show vv)
|
||||
|
||||
-- | to get a string from a value that represents a sequence of terminals
|
||||
strsFromValue :: Value -> Err [Str]
|
||||
strsFromValue t = case t of
|
||||
VString s -> return [str s]
|
||||
VC s t -> do
|
||||
s' <- strsFromValue s
|
||||
t' <- strsFromValue t
|
||||
return [plusStr x y | x <- s', y <- t']
|
||||
{-
|
||||
VGlue s t -> do
|
||||
s' <- strsFromValue s
|
||||
t' <- strsFromValue t
|
||||
return [glueStr x y | x <- s', y <- t']
|
||||
-}
|
||||
VAlts d vs -> do
|
||||
d0 <- strsFromValue d
|
||||
v0 <- mapM (strsFromValue . fst) vs
|
||||
c0 <- mapM (strsFromValue . snd) vs
|
||||
let vs' = zip v0 c0
|
||||
return [strTok (str2strings def) vars |
|
||||
def <- d0,
|
||||
vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
|
||||
vv <- combinations v0]
|
||||
]
|
||||
VFV ts -> mapM strsFromValue ts >>= return . concat
|
||||
VStrs ts -> mapM strsFromValue ts >>= return . concat
|
||||
_ -> fail "cannot get Str from value"
|
||||
|
||||
vfv vs = case nub vs of
|
||||
[v] -> v
|
||||
vs -> VFV vs
|
||||
|
||||
select gr vv =
|
||||
case vv of
|
||||
(v1,VFV vs) -> vfv [select gr (v1,v2)|v2<-vs]
|
||||
(VFV vs,v2) -> vfv [select gr (v1,v2)|v1<-vs]
|
||||
(v1@(VV pty rs),v2) ->
|
||||
err (const (VS v1 v2)) id $
|
||||
do ats <- allParamValues gr pty
|
||||
let vs = map (value0 gr) ats
|
||||
i <- maybeErr "no match" $ findIndex (==v2) vs
|
||||
return (rs!!i)
|
||||
(v1@(VT i cs),v2) ->
|
||||
err bug (valueMatch gr) $ matchPattern cs (value2term gr [] v2)
|
||||
(VS (VV pty rs) v12,v2) -> VS (VV pty [select gr (v11,v2)|v11<-rs]) v12
|
||||
(v1,v2) -> ok2 VS v1 v2
|
||||
|
||||
valueMatch gr (Bind f,env') = f (mapSnd (value0 gr) env')
|
||||
|
||||
valueTable env@(gr,bs) i cs =
|
||||
case i of
|
||||
TComp ty -> VV ty (map (value env.snd) cs)
|
||||
_ -> err keep id convert
|
||||
where
|
||||
keep _ = VT i (err bug id $ mapM valueCase cs)
|
||||
|
||||
valueCase (p,t) = do p' <- inlinePattMacro p
|
||||
return (p',Bind $ \ bs' -> value (gr,bs'++bs) t)
|
||||
|
||||
convert = do ty <- getTableType i
|
||||
let pty = nfx gr bs ty
|
||||
vs <- allParamValues gr pty
|
||||
cs' <- mapM valueCase cs
|
||||
sts <- mapM (matchPattern cs') vs
|
||||
return $ VV pty (map (valueMatch gr) sts)
|
||||
|
||||
inlinePattMacro p = case p of
|
||||
PM qc -> do EPatt p' <- lookupResDef gr qc
|
||||
inlinePattMacro p'
|
||||
_ -> composPattOp inlinePattMacro p
|
||||
|
||||
apply' env t [] = value env t
|
||||
apply' env t vs =
|
||||
case t of
|
||||
QC x -> VCApp x vs
|
||||
Q x@(m,f) | m==cPredef -> let constr = --trace ("predef "++show x) .
|
||||
VApp x
|
||||
in maybe constr id (Map.lookup f predefs) vs
|
||||
| otherwise -> err bug (\t->apply' (fst env,[]) t vs)
|
||||
(lookupResDef (fst env) x)
|
||||
App t1 t2 -> apply' env t1 (value env t2 : vs)
|
||||
-- Abs b x t -> beta env b x t vs
|
||||
_ -> vapply (value env t) vs
|
||||
|
||||
vapply v [] = v
|
||||
vapply v vs =
|
||||
case v of
|
||||
VError {} -> v
|
||||
-- VClosure env (Abs b x t) -> beta gr env b x t vs
|
||||
VAbs bt _ (Bind f) -> vbeta bt f vs
|
||||
VS (VV t fs) s -> VS (VV t [vapply f vs|f<-fs]) s
|
||||
v -> bug $ "vapply "++show v++" "++show vs
|
||||
|
||||
vbeta bt f (v:vs) =
|
||||
case (bt,v) of
|
||||
(Implicit,VImplArg v) -> vapply (f v) vs
|
||||
(Explicit, v) -> vapply (f v) vs
|
||||
{-
|
||||
beta env b x t (v:vs) =
|
||||
case (b,v) of
|
||||
(Implicit,VImplArg v) -> apply' (ext (x,v) env) t vs
|
||||
(Explicit, v) -> apply' (ext (x,v) env) t vs
|
||||
-}
|
||||
|
||||
-- tr s f vs = trace (s++" "++show vs++" = "++show r) r where r = f vs
|
||||
|
||||
-- | Convert a value back to a term
|
||||
value2term :: SourceGrammar -> [Ident] -> Value -> Term
|
||||
value2term gr xs (VApp f vs) = foldl App (Q f) (map (value2term gr xs) vs)
|
||||
value2term gr xs (VGen j vs) = foldl App (Vr (reverse xs !! j)) (map (value2term gr xs) vs)
|
||||
value2term gr xs (VMeta j env vs) = foldl App (Meta j) (map (value2term gr xs) vs)
|
||||
value2term gr xs (VClosure env (Prod bt x t1 t2)) = Prod bt x (value2term gr xs (eval gr env t1))
|
||||
(value2term gr (x:xs) (eval gr ((x,VGen (length xs) []) : env) t2))
|
||||
value2term gr xs (VClosure env (Abs bt x t)) = Abs bt x (value2term gr (x:xs) (eval gr ((x,VGen (length xs) []) : env) t))
|
||||
value2term gr xs (VInt n) = EInt n
|
||||
value2term gr xs (VFloat f) = EFloat f
|
||||
value2term gr xs (VString s) = if null s then Empty else K s
|
||||
value2term gr xs (VSort s) = Sort s
|
||||
value2term gr xs (VImplArg v) = ImplArg (value2term gr xs v)
|
||||
value2term gr xs (VTblType p res) = Table (value2term gr xs p) (value2term gr xs res)
|
||||
value2term gr xs (VRecType rs) = RecType [(l,value2term gr xs v) | (l,v) <- rs]
|
||||
value2term gr xs (VFV vs) = FV (map (value2term gr xs) vs)
|
||||
value2term gr xs v = error ("unimplemented: value2term "++show v)
|
||||
value2term gr xs v0 =
|
||||
case v0 of
|
||||
VApp f vs -> foldl App (Q f) (map v2t vs)
|
||||
VCApp f vs -> foldl App (QC f) (map v2t vs)
|
||||
VGen j vs -> foldl App (Vr (reverse xs !! j)) (map v2t vs)
|
||||
VMeta j env vs -> foldl App (Meta j) (map v2t vs)
|
||||
-- VClosure env (Prod bt x t1 t2) -> Prod bt x (v2t (eval gr env t1))
|
||||
-- (nf gr (push x (env,xs)) t2)
|
||||
-- VClosure env (Abs bt x t) -> Abs bt x (nf gr (push x (env,xs)) t)
|
||||
VProd bt v x (Bind f) -> Prod bt x (v2t v) (v2t' x f)
|
||||
VAbs bt x (Bind f) -> Abs bt x (v2t' x f)
|
||||
VInt n -> EInt n
|
||||
VFloat f -> EFloat f
|
||||
VString s -> if null s then Empty else K s
|
||||
VSort s -> Sort s
|
||||
VImplArg v -> ImplArg (v2t v)
|
||||
VTblType p res -> Table (v2t p) (v2t res)
|
||||
VRecType rs -> RecType [(l,v2t v) | (l,v) <- rs]
|
||||
VRec as -> R [(l,(Nothing,v2t v))|(l,v) <- as]
|
||||
VV t vs -> V t (map v2t vs)
|
||||
VT i cs -> T i (map nfcase cs)
|
||||
VFV vs -> FV (map v2t vs)
|
||||
VC v1 v2 -> C (v2t v1) (v2t v2)
|
||||
VS v1 v2 -> S (v2t v1) (v2t v2)
|
||||
VP v l -> P (v2t v) l
|
||||
VAlts v vvs -> Alts (v2t v) (mapBoth v2t vvs)
|
||||
VStrs vs -> Strs (map v2t vs)
|
||||
-- VGlue v1 v2 -> Glue (v2t v1) (v2t v2)
|
||||
VExtR v1 v2 -> ExtR (v2t v1) (v2t v2)
|
||||
VError err -> Error err
|
||||
_ -> bug ("value2term "++show v0)
|
||||
where
|
||||
v2t = value2term gr xs
|
||||
v2t' x f = value2term gr (x:xs) (f (gen xs))
|
||||
|
||||
pushs xs e = foldr push e xs
|
||||
push x (env,xs) = ((x,gen xs):env,x:xs)
|
||||
gen xs = VGen (length xs) []
|
||||
|
||||
nfcase (p,Bind f) = (p,value2term gr xs' (f env'))
|
||||
where (env',xs') = pushs (pattVars p) ([],xs)
|
||||
|
||||
-- nf gr (env,xs) = value2term gr xs . eval gr env
|
||||
|
||||
pattVars = nub . pv
|
||||
where
|
||||
pv p = case p of
|
||||
PV i -> [i]
|
||||
PAs i p -> i:pv p
|
||||
_ -> collectPattOp pv p
|
||||
|
||||
---
|
||||
|
||||
both = apBoth
|
||||
|
||||
bug msg = ppbug (text msg)
|
||||
ppbug doc = error $ render $
|
||||
hang (text "Internal error in Compute.ConcreteNew2:") 4 doc
|
||||
|
||||
Reference in New Issue
Block a user