mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
More work on the new partial evaluator
The work done by the partial evaluator is now divied in two stages: - A static "term traversal" stage that happens only once per term and uses only statically known information. In particular, the values of lambda bound variables are unknown during this stage. Some tables are transformed to reduce the cost of pattern matching. - A dynamic "function application" stage, where function bodies can be evaluated repeatedly with different arguments, without the term traversal overhead and without recomputing statically known information. Also the treatment of predefined functions has been reworked to take advantage of the staging and better handle partial applications.
This commit is contained in:
hallgren
@@ -218,7 +218,7 @@ checkInfo opts sgr (m,mo) c info = do
|
||||
(Just (L loct ty), Just (L locd de)) -> do
|
||||
ty' <- chIn loct "operation" $
|
||||
(if False --flag optNewComp opts
|
||||
then CN.checkLType gr ty typeType >>= return . CN.normalForm (CN.resourceValues gr) . fst -- !!
|
||||
then CN.checkLType gr ty typeType >>= return . CN.normalForm (CN.resourceValues gr) (L loct c) . fst -- !!
|
||||
else checkLType gr [] ty typeType >>= computeLType gr [] . fst)
|
||||
(de',_) <- chIn locd "operation" $
|
||||
(if False -- flag optNewComp opts
|
||||
|
||||
@@ -1,9 +1,8 @@
|
||||
-- | Functions for computing the values of terms in the concrete syntax, in
|
||||
-- | preparation for PMCFG generation.
|
||||
module GF.Compile.Compute.ConcreteNew
|
||||
( normalForm
|
||||
, GlobalEnv, resourceValues
|
||||
, Value(..), Env, eval, apply, value2term
|
||||
(GlobalEnv, resourceValues, normalForm
|
||||
--, Value(..), Env, value2term, eval, apply
|
||||
) where
|
||||
|
||||
import GF.Grammar hiding (Env, VGen, VApp, VRecType)
|
||||
@@ -11,27 +10,30 @@ 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,lockRecType)
|
||||
import GF.Compile.Compute.Value
|
||||
import GF.Compile.Compute.Predef(predefs)
|
||||
import GF.Compile.Compute.Value hiding (Predefined(..))
|
||||
import GF.Compile.Compute.Predef(predef,predefName,delta)
|
||||
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 GF.Data.Operations(Err,err,maybeErr,combinations,mapPairsM)
|
||||
import GF.Data.Utilities(mapFst,mapSnd,mapBoth,apBoth,apSnd)
|
||||
import Control.Monad(ap,liftM,liftM2,mplus)
|
||||
import Data.List (findIndex,intersect,isInfixOf,nub,elemIndex)
|
||||
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)
|
||||
--import Debug.Trace(trace)
|
||||
|
||||
-- * Main entry points
|
||||
|
||||
normalForm :: GlobalEnv -> Term -> Term
|
||||
normalForm = nfx . toplevel
|
||||
nfx env = value2term (srcgr env) [] . value env
|
||||
normalForm :: GlobalEnv -> L Ident -> Term -> Term
|
||||
normalForm (GE gr rv _) loc = err bugloc id . nfx (GE gr rv loc)
|
||||
where
|
||||
bugloc s = ppbug $ hang (text "In"<+>ppL loc<>text ":") 4 (text s)
|
||||
|
||||
eval :: GlobalEnv -> Term -> Value
|
||||
eval = value . toplevel
|
||||
nfx env@(GE gr _ loc) t = value2term loc gr [] # eval env t
|
||||
|
||||
eval :: GlobalEnv -> Term -> Err Value
|
||||
eval ge t = ($[]) # value (toplevel ge) t
|
||||
|
||||
apply env = apply' env
|
||||
|
||||
@@ -41,21 +43,36 @@ apply env = apply' env
|
||||
|
||||
type ResourceValues = Map.Map Ident (Map.Map Ident (Err Value))
|
||||
|
||||
data GlobalEnv = GE SourceGrammar ResourceValues
|
||||
data CompleteEnv = CE {srcgr::SourceGrammar,rvs::ResourceValues,local::Env}
|
||||
|
||||
data GlobalEnv = GE SourceGrammar ResourceValues (L Ident)
|
||||
data CompleteEnv = CE {srcgr::SourceGrammar,rvs::ResourceValues,
|
||||
gloc::L Ident,local::LocalScope}
|
||||
type LocalScope = [Ident]
|
||||
type Stack = [Value]
|
||||
type OpenValue = Stack->Value
|
||||
|
||||
ext b env = env{local=b:local env}
|
||||
extend bs env = env{local=bs++local env}
|
||||
global env = GE (srcgr env) (rvs env)
|
||||
toplevel (GE gr rvs) = CE gr rvs []
|
||||
global env = GE (srcgr env) (rvs env) (gloc env)
|
||||
toplevel (GE gr rvs loc) = CE gr rvs loc []
|
||||
|
||||
var env x = maybe unbound id (lookup x (local env))
|
||||
where unbound = bug ("Unknown variable: "++showIdent x)
|
||||
var :: CompleteEnv -> Ident -> Err OpenValue
|
||||
var env x = maybe unbound pick' (elemIndex x (local env))
|
||||
where
|
||||
unbound = fail ("Unknown variable: "++showIdent x)
|
||||
pick' i = return $ \ vs -> maybe (err i vs) id (pick i vs)
|
||||
err i vs = bug $ "Stack problem: "++showIdent x++": "
|
||||
++unwords (map showIdent (local env))
|
||||
++" => "++show (i,length vs)
|
||||
|
||||
pick :: Int -> Stack -> Maybe Value
|
||||
pick 0 (v:_) = Just v
|
||||
pick i (_:vs) = pick (i-1) vs
|
||||
pick i vs = Nothing -- bug $ "pick "++show (i,vs)
|
||||
|
||||
resource env (m,c) =
|
||||
err bug id $
|
||||
-- err bug id $
|
||||
if isPredefCat c
|
||||
then fmap (value0 env) (lockRecType c defLinType) -- hmm
|
||||
then value0 env =<< lockRecType c defLinType -- hmm
|
||||
else maybe e id $ Map.lookup c =<< Map.lookup m (rvs env)
|
||||
where e = fail $ "Not found: "++showIdent m++"."++showIdent c
|
||||
|
||||
@@ -63,64 +80,90 @@ resource env (m,c) =
|
||||
resourceValues :: SourceGrammar -> GlobalEnv
|
||||
resourceValues gr = env
|
||||
where
|
||||
env = GE gr rvs
|
||||
env = GE gr rvs (L NoLoc IW)
|
||||
rvs = Map.mapWithKey moduleResources (moduleMap gr)
|
||||
moduleResources m = Map.mapWithKey (moduleResource m) . jments
|
||||
moduleResource m c _info = fmap (eval env) (lookupResDef gr (m,c))
|
||||
moduleResource m c _info = eval (GE gr rvs (L NoLoc c)) =<< lookupResDef gr (m,c)
|
||||
|
||||
-- * Computing values
|
||||
|
||||
-- | Computing the value of a top-level term
|
||||
value0 :: CompleteEnv -> Term -> Err Value
|
||||
value0 = eval . global
|
||||
|
||||
-- | Computing the value of a term
|
||||
value :: CompleteEnv -> Term -> Value
|
||||
value :: CompleteEnv -> Term -> Err OpenValue
|
||||
value env t0 =
|
||||
-- Each terms is traversed only once by this function, using only statically
|
||||
-- available information. Notably, the values of lambda bound variables
|
||||
-- will be unknown during the term traversal phase.
|
||||
-- The result is an OpenValue, which is a function that may be applied many
|
||||
-- times to different dynamic values, but without the term traversal overhead
|
||||
-- and without recomputing other statically known information.
|
||||
-- For this to work, there should be no recursive calls under lambdas here.
|
||||
-- Whenever we need to construct the OpenValue function with an explicit
|
||||
-- lambda, we have to lift the recursive calls outside the lambda.
|
||||
-- (See e.g. the rules for Let, Prod and Abs)
|
||||
{-
|
||||
trace (render $ text "value"<+>sep [ppL (gloc env)<>text ":",
|
||||
brackets (fsep (map ppIdent (local env))),
|
||||
ppTerm Unqualified 10 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 env (mkProd [(Implicit,p,typeType)] (Vr p) [])
|
||||
else VApp x []
|
||||
| otherwise -> resource env x --valueResDef (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 (local 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]
|
||||
in const # value0 env (mkProd [(Implicit,p,typeType)] (Vr p) [])
|
||||
else const . flip VApp [] # predef f
|
||||
| otherwise -> const # resource env x --valueResDef (fst env) x
|
||||
QC x -> return $ const (VCApp x [])
|
||||
App e1 e2 -> apply' env e1 . (:[]) =<< value env e2
|
||||
Let (x,(oty,t)) body -> do vb <- value (ext x env) body
|
||||
vt <- value env t
|
||||
return $ \ vs -> vb (vt vs:vs)
|
||||
Meta i -> return $ \ vs -> VMeta i (zip (local env) vs) []
|
||||
Prod bt x t1 t2 ->
|
||||
do vt1 <- value env t1
|
||||
vt2 <- value (ext x env) t2
|
||||
return $ \ vs -> VProd bt (vt1 vs) x $ Bind $ \ vx -> vt2 (vx:vs)
|
||||
Abs bt x t -> do vt <- value (ext x env) t
|
||||
return $ VAbs bt x . Bind . \ vs vx -> vt (vx:vs)
|
||||
EInt n -> return $ const (VInt n)
|
||||
EFloat f -> return $ const (VFloat f)
|
||||
K s -> return $ const (VString s)
|
||||
Empty -> return $ const (VString "")
|
||||
Sort s | s == cTok -> return $ const (VSort cStr) -- to be removed
|
||||
| otherwise -> return $ const (VSort s)
|
||||
ImplArg t -> (VImplArg.) # value env t
|
||||
Table p res -> liftM2 VTblType # value env p <# value env res
|
||||
RecType rs -> do lovs <- mapPairsM (value env) rs
|
||||
return $ \vs->VRecType $ mapSnd ($vs) lovs
|
||||
t@(ExtR t1 t2) -> ((extR t.)# both id) # both (value env) (t1,t2)
|
||||
FV ts -> ((vfv .) # sequence) # mapM (value env) ts
|
||||
R as -> do lovs <- mapPairsM (value env.snd) as
|
||||
return $ \ vs->VRec $ mapSnd ($vs) lovs
|
||||
T i cs -> valueTable env i cs
|
||||
V ty ts -> VV ty (paramValues env ty) (map (value env) ts)
|
||||
C t1 t2 -> vconcat (both (value env) (t1,t2))
|
||||
S t1 t2 -> select env (both (value env) (t1,t2))
|
||||
V ty ts -> do pvs <- paramValues env ty
|
||||
((VV ty pvs .) . sequence) # mapM (value env) ts
|
||||
C t1 t2 -> ((vconcat.) # both id) # both (value env) (t1,t2)
|
||||
S t1 t2 -> ((select env.) # both id) # 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)
|
||||
EPatt p -> VPatt p -- hmm
|
||||
t -> ppbug (text "value"<+>ppTerm Unqualified 10 t $$ text (show t))
|
||||
do ov <- value env t
|
||||
return $ \ vs -> let v = ov vs
|
||||
in maybe (VP v l) id (proj l v)
|
||||
Alts t tts -> (\v vts -> VAlts # v <# mapM (both id) vts) # value env t <# mapM (both (value env)) tts
|
||||
Strs ts -> ((VStrs.) # sequence) # mapM (value env) ts
|
||||
Glue t1 t2 -> ((glue.) # both id) # both (value env) (t1,t2)
|
||||
ELin c r -> (unlockVRec c.) # value env r
|
||||
EPatt p -> return $ const (VPatt p) -- hmm
|
||||
t -> fail.render $ text "value"<+>ppTerm Unqualified 10 t $$ text (show t)
|
||||
|
||||
--valueResDef gr = err bug (value0 gr) . lookupResDef gr
|
||||
|
||||
paramValues env ty = let pty = nfx env ty
|
||||
ats = err bug id $ allParamValues (srcgr env) pty
|
||||
in map (value0 env) ats
|
||||
paramValues env ty = do let ge = global env
|
||||
ats <- allParamValues (srcgr env) =<< nfx ge ty
|
||||
mapM (eval ge) ats
|
||||
|
||||
vconcat vv@(v1,v2) =
|
||||
case vv of
|
||||
@@ -242,57 +285,90 @@ select env vv =
|
||||
--let vs = map (value0 env) ats
|
||||
i <- maybeErr "no match" $ findIndex (==v2) vs
|
||||
return (rs!!i)
|
||||
(v1@(VT i cs),v2) ->
|
||||
err bug (valueMatch env) $ matchPattern cs (value2term (srcgr env) [] v2)
|
||||
(v1@(VT _ _ cs),v2) ->
|
||||
err bug id $ valueMatch env =<< matchPattern cs (value2term (gloc env) (srcgr env) [] v2)
|
||||
(VS (VV pty pvs rs) v12,v2) -> VS (VV pty pvs [select env (v11,v2)|v11<-rs]) v12
|
||||
(v1,v2) -> ok2 VS v1 v2
|
||||
|
||||
valueMatch env (Bind f,env') = f (mapSnd (value0 env) env')
|
||||
|
||||
valueMatch :: CompleteEnv -> (Bind Env,Substitution) -> Err Value
|
||||
valueMatch env (Bind f,env') = f # mapPairsM (value0 env) env'
|
||||
--{-
|
||||
valueTable :: CompleteEnv -> TInfo -> [Case] -> Err OpenValue
|
||||
valueTable env i cs =
|
||||
case i of
|
||||
TComp ty -> VV ty (paramValues env ty) (map (value env.snd) cs)
|
||||
_ -> err keep id convert
|
||||
TComp ty -> do pvs <- paramValues env ty
|
||||
((VV ty pvs .) # sequence) # mapM (value env.snd) cs
|
||||
_ -> do vty <- value env =<< getTableType i
|
||||
err (keep vty) return convert
|
||||
where
|
||||
keep _ = VT i (err bug id $ mapM valueCase cs)
|
||||
keep vty _ = cases vty # mapM valueCase cs
|
||||
cases vty cs vs = VT wild (vty vs) (mapSnd ($vs) cs)
|
||||
wild = case i of
|
||||
TWild _ -> True
|
||||
_ -> False
|
||||
|
||||
valueCase (p,t) = do p' <- inlinePattMacro p
|
||||
return (p',Bind $ \ bs' -> value (extend bs' env) t)
|
||||
let pvs = pattVars p'
|
||||
vt <- value (extend pvs env) t
|
||||
return (p', \ vs -> Bind $ \ bs -> vt (push' p' bs pvs vs))
|
||||
--{-
|
||||
convert = do ty <- getTableType i
|
||||
let pty = nfx env ty
|
||||
convert :: Err OpenValue
|
||||
convert = do ty <- getTableType i
|
||||
pty <- nfx (global env) ty
|
||||
vs <- allParamValues (srcgr env) pty
|
||||
let pvs = map (value0 env) vs
|
||||
pvs <- mapM (value0 env) vs
|
||||
cs' <- mapM valueCase cs
|
||||
sts <- mapM (matchPattern cs') vs
|
||||
return $ VV pty pvs (map (valueMatch env) sts)
|
||||
return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env) (mapFst ($vs) sts)
|
||||
--}
|
||||
inlinePattMacro p =
|
||||
case p of
|
||||
PM qc -> case resource env qc of
|
||||
VPatt p' -> inlinePattMacro p'
|
||||
r -> ppbug $ hang (text "Expected pattern macro:") 4
|
||||
(text (show r))
|
||||
PM qc -> do r <- resource env qc
|
||||
case r of
|
||||
VPatt p' -> inlinePattMacro p'
|
||||
_ -> ppbug $ hang (text "Expected pattern macro:") 4
|
||||
(text (show r))
|
||||
_ -> composPattOp inlinePattMacro p
|
||||
--}
|
||||
|
||||
apply' env t [] = value env t
|
||||
push' p bs xs = if length bs/=length xs
|
||||
then bug $ "push "++show (p,bs,xs)
|
||||
else push bs xs
|
||||
|
||||
push :: Env -> LocalScope -> Stack -> Stack
|
||||
push bs [] vs = vs
|
||||
push bs (x:xs) vs = maybe err id (lookup x bs):push bs xs vs
|
||||
where err = bug $ "Unbound pattern variable "++showIdent x
|
||||
|
||||
apply' :: CompleteEnv -> Term -> [OpenValue] -> Err OpenValue
|
||||
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) .
|
||||
QC x -> return $ \ svs -> VCApp x (map ($svs) vs)
|
||||
{-
|
||||
Q x@(m,f) | m==cPredef -> return $
|
||||
let constr = --trace ("predef "++show x) .
|
||||
VApp x
|
||||
in maybe constr id (Map.lookup f predefs) vs
|
||||
| otherwise -> vapply (resource env x) vs
|
||||
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
|
||||
in \ svs -> maybe constr id (Map.lookup f predefs)
|
||||
$ map ($svs) vs
|
||||
| otherwise -> do r <- resource env x
|
||||
return $ \ svs -> vapply r (map ($svs) vs)
|
||||
-}
|
||||
App t1 t2 -> apply' env t1 . (:vs) =<< value env t2
|
||||
_ -> do fv <- value env t
|
||||
return $ \ svs -> vapply (fv svs) (map ($svs) vs)
|
||||
|
||||
vapply :: Value -> [Value] -> Value
|
||||
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
|
||||
VApp pre vs1 -> err msg id $ delta pre (vs1++vs)
|
||||
where
|
||||
--msg = const (VApp pre (vs1++vs))
|
||||
msg = bug . (("Applying Predef."++showIdent (predefName pre)++": ")++)
|
||||
VS (VV t pvs fs) s -> VS (VV t pvs [vapply f vs|f<-fs]) s
|
||||
VFV fs -> vfv [vapply f vs|f<-fs]
|
||||
v -> bug $ "vapply "++show v++" "++show vs
|
||||
@@ -315,10 +391,10 @@ beta env b x t (v: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 v0 =
|
||||
value2term :: L Ident -> SourceGrammar -> [Ident] -> Value -> Term
|
||||
value2term loc gr xs v0 =
|
||||
case v0 of
|
||||
VApp f vs -> foldl App (Q f) (map v2t vs)
|
||||
VApp pre vs -> foldl App (Q (cPredef,predefName pre)) (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)
|
||||
@@ -336,7 +412,8 @@ value2term gr xs v0 =
|
||||
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)
|
||||
VT wild v cs -> T ((if wild then TWild else TTyped) (v2t v))
|
||||
(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)
|
||||
@@ -346,30 +423,38 @@ value2term gr xs v0 =
|
||||
-- VGlue v1 v2 -> Glue (v2t v1) (v2t v2)
|
||||
VExtR v1 v2 -> ExtR (v2t v1) (v2t v2)
|
||||
VError err -> Error err
|
||||
_ -> bug ("value2term "++show v0)
|
||||
_ -> bug ("value2term "++show loc++" "++show v0)
|
||||
where
|
||||
v2t = value2term gr xs
|
||||
v2t' x f = value2term gr (x:xs) (f (gen xs))
|
||||
v2t = value2term loc gr xs
|
||||
v2t' x f = value2term loc 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'))
|
||||
nfcase (p,Bind f) = (p,value2term loc 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
|
||||
pattVars = nub . allPattVars
|
||||
allPattVars p =
|
||||
case p of
|
||||
PV i -> [i]
|
||||
PAs i p -> i:allPattVars p
|
||||
_ -> collectPattOp allPattVars p
|
||||
|
||||
---
|
||||
|
||||
both = apBoth
|
||||
infixl 1 #,<#,@@
|
||||
|
||||
f # x = fmap f x
|
||||
mf <# mx = ap mf mx
|
||||
m1 @@ m2 = (m1 =<<) . m2
|
||||
|
||||
both f (x,y) = (,) # f x <# f y
|
||||
|
||||
ppL (L loc x) = ppLocation "" loc<>text ":"<>ppIdent x
|
||||
|
||||
bug msg = ppbug (text msg)
|
||||
ppbug doc = error $ render $
|
||||
|
||||
@@ -1,93 +1,142 @@
|
||||
-- | Implementations of predefined functions
|
||||
module GF.Compile.Compute.Predef where
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module GF.Compile.Compute.Predef(predef,predefName,delta) where
|
||||
|
||||
import Text.PrettyPrint(render,hang,text)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Array(array,(!))
|
||||
import Data.List (isInfixOf)
|
||||
import Data.Char (isUpper,toLower,toUpper)
|
||||
import Control.Monad(ap)
|
||||
|
||||
import GF.Data.Utilities (mapSnd,apBoth)
|
||||
|
||||
import GF.Compile.Compute.Value
|
||||
import GF.Infra.Ident (Ident,varX)
|
||||
import GF.Infra.Ident (Ident,varX,showIdent)
|
||||
import GF.Data.Operations(Err,err)
|
||||
import GF.Grammar.Predef
|
||||
import PGF.Data(BindType(..))
|
||||
|
||||
predefs :: Map.Map Ident ([Value]->Value)
|
||||
predefs = Map.fromList $ mapSnd strictf
|
||||
[(cDrop,apISS drop),(cTake,apISS take),(cTk,apISS tk),(cDp,apISS dp),
|
||||
(cEqStr,apSSB (==)),(cOccur,apSSB occur),(cOccurs,apSSB occurs),
|
||||
(cToUpper,apSS (map toUpper)),(cToLower,apSS (map toLower)),
|
||||
(cIsUpper,apSB (all isUpper)),(cLength,apSS' (VInt . length)),
|
||||
(cPlus,apIII (+)),(cEqInt,apIIB (==)),(cLessInt,apIIB (<)),
|
||||
(cShow,unimpl),(cRead,unimpl),(cToStr,unimpl),(cMapStr,unimpl),
|
||||
(cEqVal,unimpl),(cError,apSS' VError)]
|
||||
--- add more functions!!!
|
||||
--------------------------------------------------------------------------------
|
||||
class Predef a where
|
||||
toValue :: a -> Value
|
||||
fromValue :: Value -> Err a
|
||||
|
||||
instance Predef Int where
|
||||
toValue = VInt
|
||||
fromValue (VInt i) = return i
|
||||
fromValue v = verror "Int" v
|
||||
|
||||
instance Predef Bool where
|
||||
toValue = boolV
|
||||
|
||||
instance Predef String where
|
||||
toValue = string
|
||||
fromValue v = case norm v of
|
||||
VString s -> return s
|
||||
_ -> verror "String" v
|
||||
|
||||
instance Predef Value where
|
||||
toValue = id
|
||||
fromValue = return
|
||||
{-
|
||||
instance (Predef a,Predef b) => Predef (a->b) where
|
||||
toValue f = VAbs Explicit (varX 0) $ Bind $ err bug (toValue . f) . fromValue
|
||||
-}
|
||||
verror t v =
|
||||
case v of
|
||||
VError e -> fail e
|
||||
VGen {} -> fail $ "Expected a static value of type "++t
|
||||
++", got a dynamic value"
|
||||
_ -> fail $ "Expected a value of type "++t++", got "++show v
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
predef f = maybe undef return (Map.lookup f predefs)
|
||||
where
|
||||
unimpl = bug "unimplemented predefined function"
|
||||
undef = fail $ "Unimplemented predfined operator: Predef."++showIdent f
|
||||
|
||||
tk i s = take (max 0 (length s - i)) s
|
||||
dp i s = drop (max 0 (length s - i)) s
|
||||
occur s t = isInfixOf s t
|
||||
occurs s t = any (`elem` t) s
|
||||
predefs :: Map.Map Ident Predefined
|
||||
predefs = Map.fromList predefList
|
||||
|
||||
apIII f vs = case vs of
|
||||
[VInt i1, VInt i2] -> VInt (f i1 i2)
|
||||
_ -> bug $ "f::Int->Int->Int got "++show vs
|
||||
predefName pre = predefNames ! pre
|
||||
predefNames = array (minBound,maxBound) (map swap predefList)
|
||||
|
||||
apIIB f vs = case vs of
|
||||
[VInt i1, VInt i2] -> boolV (f i1 i2)
|
||||
_ -> bug $ "f::Int->Int->Bool got "++show vs
|
||||
predefList =
|
||||
[(cDrop,Drop),(cTake,Take),(cTk,Tk),(cDp,Dp),(cEqStr,EqStr),
|
||||
(cOccur,Occur),(cOccurs,Occurs),(cToUpper,ToUpper),(cToLower,ToLower),
|
||||
(cIsUpper,IsUpper),(cLength,Length),(cPlus,Plus),(cEqInt,EqInt),
|
||||
(cLessInt,LessInt),
|
||||
-- cShow, cRead, cMapStr, cEqVal
|
||||
(cError,Error),
|
||||
-- Canonical values:
|
||||
(cPBool,PBool),(cPFalse,PFalse),(cPTrue,PTrue),(cInts,Ints)]
|
||||
--- add more functions!!!
|
||||
|
||||
apISS f vs = case vs of
|
||||
[VInt i, VString s] -> string (f i s)
|
||||
[VInt i] -> VAbs Explicit (varX 0) $ Bind $ \ v ->
|
||||
case norm v of
|
||||
VString s -> string (f i s)
|
||||
_ -> bug $ "f::Int->Str->Str got "++show (vs++[v])
|
||||
_ -> bug $ "f::Int->Str->Str got "++show vs
|
||||
delta f vs =
|
||||
case f of
|
||||
Drop -> ap2 (drop::Int->String->String)
|
||||
Take -> ap2 (take::Int->String->String)
|
||||
Tk -> ap2 tk
|
||||
Dp -> ap2 dp
|
||||
EqStr -> ap2 ((==)::String->String->Bool)
|
||||
Occur -> ap2 occur
|
||||
Occurs -> ap2 occurs
|
||||
ToUpper -> ap1 (map toUpper)
|
||||
ToLower -> ap1 (map toLower)
|
||||
IsUpper -> ap1 (all isUpper)
|
||||
Length -> ap1 (length::String->Int)
|
||||
Plus -> ap2 ((+)::Int->Int->Int)
|
||||
EqInt -> ap2 ((==)::Int->Int->Bool)
|
||||
LessInt -> ap2 ((<)::Int->Int->Bool)
|
||||
{- | Show | Read | ToStr | MapStr | EqVal -}
|
||||
Error -> ap1 VError
|
||||
-- Canonical values:
|
||||
PBool -> canonical
|
||||
Ints -> canonical
|
||||
PFalse -> canonical
|
||||
PTrue -> canonical
|
||||
where
|
||||
canonical = delay
|
||||
delay = return (VApp f vs) -- wrong number of arguments
|
||||
|
||||
apSSB f vs = case vs of
|
||||
[VString s1, VString s2] -> boolV (f s1 s2)
|
||||
_ -> bug $ "f::Str->Str->Bool got "++show vs
|
||||
ap1 f = case vs of
|
||||
[v1] -> (toValue . f) `fmap` fromValue v1
|
||||
_ -> delay
|
||||
|
||||
apSB f vs = case vs of
|
||||
[VString s] -> boolV (f s)
|
||||
_ -> bug $ "f::Str->Bool got "++show vs
|
||||
ap2 f = case vs of
|
||||
[v1,v2] -> toValue `fmap` (f `fmap` fromValue v1 `ap` fromValue v2)
|
||||
_ -> delay
|
||||
|
||||
apSS f vs = case vs of
|
||||
[VString s] -> string (f s)
|
||||
_ -> bug $ "f::Str->Str got "++show vs
|
||||
unimpl id = bug $ "unimplemented predefined function: "++showIdent id
|
||||
-- problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs
|
||||
|
||||
apSS' f vs = case vs of
|
||||
[VString s] -> f s
|
||||
_ -> bug $ "f::Str->_ got "++show vs
|
||||
tk i s = take (max 0 (length s - i)) s :: String
|
||||
dp i s = drop (max 0 (length s - i)) s :: String
|
||||
occur s t = isInfixOf (s::String) t
|
||||
occurs s t = any (`elem` t) (s::String)
|
||||
|
||||
boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) []
|
||||
boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) []
|
||||
|
||||
strictf f vs = case normvs vs of
|
||||
Left err -> VError err
|
||||
Right vs -> f vs
|
||||
norm v =
|
||||
case v of
|
||||
VC v1 v2 -> case apBoth norm (v1,v2) of
|
||||
(VString s1,VString s2) -> VString (s1++" "++s2)
|
||||
(v1,v2) -> VC v1 v2
|
||||
_ -> v
|
||||
|
||||
normvs = mapM (strict . norm)
|
||||
strict v = case v of
|
||||
VError err -> Left err
|
||||
_ -> Right v
|
||||
|
||||
norm v =
|
||||
case v of
|
||||
VC v1 v2 -> case apBoth norm (v1,v2) of
|
||||
(VString s1,VString s2) -> VString (s1++" "++s2)
|
||||
(v1,v2) -> VC v1 v2
|
||||
_ -> v
|
||||
|
||||
strict v = case v of
|
||||
VError err -> Left err
|
||||
_ -> Right v
|
||||
|
||||
string s = case words s of
|
||||
[] -> VString ""
|
||||
ss -> foldr1 VC (map VString ss)
|
||||
string s = case words s of
|
||||
[] -> VString ""
|
||||
ss -> foldr1 VC (map VString ss)
|
||||
|
||||
---
|
||||
|
||||
swap (x,y) = (y,x)
|
||||
|
||||
bug msg = ppbug (text msg)
|
||||
ppbug doc = error $ render $
|
||||
hang (text "Internal error in Compute.Predef:") 4 doc
|
||||
|
||||
@@ -3,10 +3,11 @@ import GF.Grammar.Grammar(Label,Type,TInfo,MetaId,Patt,QIdent)
|
||||
import PGF.Data(BindType)
|
||||
import GF.Infra.Ident(Ident)
|
||||
import Text.Show.Functions
|
||||
import Data.Ix(Ix)
|
||||
|
||||
-- | Self-contained (not quite) representation of values
|
||||
data Value
|
||||
= VApp QIdent [Value] -- from Q, always Predef.x, has a built-in value
|
||||
= VApp Predefined [Value] -- from Q, always Predef.x, has a built-in value
|
||||
| VCApp QIdent [Value] -- from QC, constructors
|
||||
| VGen Int [Value] -- for lambda bound variables, possibly applied
|
||||
| VMeta MetaId Env [Value]
|
||||
@@ -22,7 +23,7 @@ data Value
|
||||
| VRecType [(Label,Value)]
|
||||
| VRec [(Label,Value)]
|
||||
| VV Type [Value] [Value] -- preserve type for conversion back to Term
|
||||
| VT TInfo [(Patt,Bind Env)]
|
||||
| VT Wild Value [(Patt,Bind Env)]
|
||||
| VC Value Value
|
||||
| VS Value Value
|
||||
| VP Value Label
|
||||
@@ -36,9 +37,19 @@ data Value
|
||||
| VError String
|
||||
deriving (Eq,Show)
|
||||
|
||||
type Wild = Bool
|
||||
type Binding = Bind Value
|
||||
data Bind a = Bind (a->Value) deriving Show
|
||||
|
||||
instance Eq (Bind a) where x==y = False
|
||||
|
||||
type Env = [(Ident,Value)]
|
||||
|
||||
-- | Predefined functions
|
||||
data Predefined = Drop | Take | Tk | Dp | EqStr | Occur | Occurs | ToUpper
|
||||
| ToLower | IsUpper | Length | Plus | EqInt | LessInt
|
||||
{- | Show | Read | ToStr | MapStr | EqVal -}
|
||||
| Error
|
||||
-- Canonical values below:
|
||||
| PBool | PFalse | PTrue | Ints
|
||||
deriving (Show,Eq,Ord,Ix,Bounded,Enum)
|
||||
|
||||
@@ -66,13 +66,13 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
|
||||
|
||||
|
||||
addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Ident -> Ident -> SeqSet -> Ident -> Info -> IO (SeqSet, Info)
|
||||
addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L _ term)) mprn Nothing) = do
|
||||
addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
|
||||
let pres = protoFCat gr res val
|
||||
pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
|
||||
|
||||
pmcfgEnv0 = emptyPMCFGEnv
|
||||
|
||||
b = convert opts gr cenv term val pargs
|
||||
b = convert opts gr cenv (L loc id) term val pargs
|
||||
(seqs1,b1) = addSequencesB seqs b
|
||||
pmcfgEnv1 = foldBM addRule
|
||||
pmcfgEnv0
|
||||
@@ -99,13 +99,13 @@ addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val))
|
||||
newArgs = map getFIds newArgs'
|
||||
in addFunction env0 newCat fun newArgs
|
||||
|
||||
addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L _ term)) mprn Nothing) = do
|
||||
addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L loc term)) mprn Nothing) = do
|
||||
let pres = protoFCat gr (am,id) lincat
|
||||
parg = protoFCat gr (identW,cVar) typeStr
|
||||
|
||||
pmcfgEnv0 = emptyPMCFGEnv
|
||||
|
||||
b = convert opts gr cenv term lincat [parg]
|
||||
b = convert opts gr cenv (L loc id) term lincat [parg]
|
||||
(seqs1,b1) = addSequencesB seqs b
|
||||
pmcfgEnv1 = foldBM addRule
|
||||
pmcfgEnv0
|
||||
@@ -122,12 +122,12 @@ addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) m
|
||||
|
||||
addPMCFG opts gr cenv am cm seqs id info = return (seqs, info)
|
||||
|
||||
convert opts gr cenv term val pargs =
|
||||
convert opts gr cenv loc term val pargs =
|
||||
runCnvMonad gr conv (pargs,[])
|
||||
where
|
||||
conv = convertTerm opts CNil val =<< unfactor cenv term'
|
||||
conv = convertTerm opts CNil val =<< unfactor term'
|
||||
term' = if flag optNewComp opts
|
||||
then normalForm cenv (recordExpand val term) -- new evaluator
|
||||
then normalForm cenv loc (recordExpand val term) -- new evaluator
|
||||
else term -- old evaluator is invoked from GF.Compile.Optimize
|
||||
|
||||
recordExpand :: Type -> Term -> Term
|
||||
@@ -143,8 +143,8 @@ recordExpand typ trm =
|
||||
_ -> R [assign lab (P trm lab) | (lab,_) <- tys]
|
||||
_ -> trm
|
||||
|
||||
unfactor :: GlobalEnv -> Term -> CnvMonad Term
|
||||
unfactor cenv t = CM (\gr c -> c (unfac gr t))
|
||||
unfactor :: Term -> CnvMonad Term
|
||||
unfactor t = CM (\gr c -> c (unfac gr t))
|
||||
where
|
||||
unfac gr t =
|
||||
case t of
|
||||
|
||||
@@ -333,7 +333,7 @@ checkComputeTerm' new sgr t = do
|
||||
((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
|
||||
inferLType sgr [] t
|
||||
t1 <- if new
|
||||
then return (CN.normalForm (CN.resourceValues sgr) t)
|
||||
then return (CN.normalForm (CN.resourceValues sgr) (L NoLoc IW) t)
|
||||
else computeConcrete sgr t
|
||||
checkPredefError sgr t1
|
||||
|
||||
|
||||
Reference in New Issue
Block a user