mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 13:09:33 -06:00
made Devel versions of Compute, CheckGrammar, Optimize, etc, to leave GF 2.8 untouched when experimenting
This commit is contained in:
aarne
145
src/GF/Devel/AbsCompute.hs
Normal file
145
src/GF/Devel/AbsCompute.hs
Normal file
@@ -0,0 +1,145 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : AbsCompute
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/02 20:50:19 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.8 $
|
||||
--
|
||||
-- computation in abstract syntax w.r.t. explicit definitions.
|
||||
--
|
||||
-- old GF computation; to be updated
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Devel.AbsCompute (LookDef,
|
||||
compute,
|
||||
computeAbsTerm,
|
||||
computeAbsTermIn,
|
||||
beta
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import GF.Grammar.Abstract
|
||||
import GF.Grammar.PrGrammar
|
||||
import GF.Grammar.LookAbs
|
||||
import GF.Devel.Compute
|
||||
|
||||
import Debug.Trace
|
||||
import Data.List(intersperse)
|
||||
import Control.Monad (liftM, liftM2)
|
||||
|
||||
-- for debugging
|
||||
tracd m t = t
|
||||
-- tracd = trace
|
||||
|
||||
compute :: GFCGrammar -> Exp -> Err Exp
|
||||
compute = computeAbsTerm
|
||||
|
||||
computeAbsTerm :: GFCGrammar -> Exp -> Err Exp
|
||||
computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) []
|
||||
|
||||
-- | a hack to make compute work on source grammar as well
|
||||
type LookDef = Ident -> Ident -> Err (Maybe Term)
|
||||
|
||||
computeAbsTermIn :: LookDef -> [Ident] -> Exp -> Err Exp
|
||||
computeAbsTermIn lookd xs e = errIn ("computing" +++ prt e) $ compt xs e where
|
||||
compt vv t = case t of
|
||||
-- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
|
||||
-- Abs x b -> liftM (Abs x) (compt (x:vv) b)
|
||||
_ -> do
|
||||
let t' = beta vv t
|
||||
(yy,f,aa) <- termForm t'
|
||||
let vv' = yy ++ vv
|
||||
aa' <- mapM (compt vv') aa
|
||||
case look f of
|
||||
Just (Eqs eqs) -> tracd ("\nmatching" +++ prt f) $
|
||||
case findMatch eqs aa' of
|
||||
Ok (d,g) -> do
|
||||
--- let (xs,ts) = unzip g
|
||||
--- ts' <- alphaFreshAll vv' ts
|
||||
let g' = g --- zip xs ts'
|
||||
d' <- compt vv' $ substTerm vv' g' d
|
||||
tracd ("by Egs:" +++ prt d') $ return $ mkAbs yy $ d'
|
||||
_ -> tracd ("no match" +++ prt t') $
|
||||
do
|
||||
let v = mkApp f aa'
|
||||
return $ mkAbs yy $ v
|
||||
Just d -> tracd ("define" +++ prt t') $ do
|
||||
da <- compt vv' $ mkApp d aa'
|
||||
return $ mkAbs yy $ da
|
||||
_ -> do
|
||||
let t2 = mkAbs yy $ mkApp f aa'
|
||||
tracd ("not defined" +++ prt_ t2) $ return t2
|
||||
|
||||
look t = case t of
|
||||
(Q m f) -> case lookd m f of
|
||||
Ok (Just EData) -> Nothing -- canonical --- should always be QC
|
||||
Ok md -> md
|
||||
_ -> Nothing
|
||||
Eqs _ -> return t ---- for nested fn
|
||||
_ -> Nothing
|
||||
|
||||
beta :: [Ident] -> Exp -> Exp
|
||||
beta vv c = case c of
|
||||
Let (x,(_,a)) b -> beta vv $ substTerm vv [(x,beta vv a)] (beta (x:vv) b)
|
||||
App f a ->
|
||||
let (a',f') = (beta vv a, beta vv f) in
|
||||
case f' of
|
||||
Abs x b -> beta vv $ substTerm vv [(x,a')] (beta (x:vv) b)
|
||||
_ -> (if a'==a && f'==f then id else beta vv) $ App f' a'
|
||||
Prod x a b -> Prod x (beta vv a) (beta (x:vv) b)
|
||||
Abs x b -> Abs x (beta (x:vv) b)
|
||||
_ -> c
|
||||
|
||||
-- special version of pattern matching, to deal with comp under lambda
|
||||
|
||||
findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
|
||||
findMatch cases terms = case cases of
|
||||
[] -> Bad $"no applicable case for" +++ unwords (intersperse "," (map prt terms))
|
||||
(patts,_):_ | length patts /= length terms ->
|
||||
Bad ("wrong number of args for patterns :" +++
|
||||
unwords (map prt patts) +++ "cannot take" +++ unwords (map prt terms))
|
||||
(patts,val):cc -> case mapM tryMatch (zip patts terms) of
|
||||
Ok substs -> return (tracd ("value" +++ prt_ val) val, concat substs)
|
||||
_ -> findMatch cc terms
|
||||
|
||||
tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
|
||||
tryMatch (p,t) = do
|
||||
t' <- termForm t
|
||||
trym p t'
|
||||
where
|
||||
|
||||
trym p t' = err (\s -> tracd s (Bad s)) (\t -> tracd (prtm p t) (return t)) $ ----
|
||||
case (p,t') of
|
||||
(PV IW, _) | notMeta t -> return [] -- optimization with wildcard
|
||||
(PV x, _) | notMeta t -> return [(x,t)]
|
||||
(PString s, ([],K i,[])) | s==i -> return []
|
||||
(PInt s, ([],EInt i,[])) | s==i -> return []
|
||||
(PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
|
||||
(PP q p pp, ([], QC r f, tt)) |
|
||||
p `eqStrIdent` f && length pp == length tt -> do
|
||||
matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
(PP q p pp, ([], Q r f, tt)) |
|
||||
p `eqStrIdent` f && length pp == length tt -> do
|
||||
matches <- mapM tryMatch (zip pp tt)
|
||||
return (concat matches)
|
||||
(PT _ p',_) -> trym p' t'
|
||||
(_, ([],Alias _ _ d,[])) -> tryMatch (p,d)
|
||||
(PAs x p',_) -> do
|
||||
subst <- trym p' t'
|
||||
return $ (x,t) : subst
|
||||
_ -> Bad ("no match in pattern" +++ prt p +++ "for" +++ prt t)
|
||||
|
||||
notMeta e = case e of
|
||||
Meta _ -> False
|
||||
App f a -> notMeta f && notMeta a
|
||||
Abs _ b -> notMeta b
|
||||
_ -> True
|
||||
|
||||
prtm p g =
|
||||
prt p +++ ":" ++++ unwords [" " ++ prt_ x +++ "=" +++ prt_ y +++ ";" | (x,y) <- g]
|
||||
1079
src/GF/Devel/CheckGrammar.hs
Normal file
1079
src/GF/Devel/CheckGrammar.hs
Normal file
File diff suppressed because it is too large
Load Diff
@@ -6,9 +6,9 @@ import GF.Compile.Extend
|
||||
import GF.Compile.Rebuild
|
||||
import GF.Compile.Rename
|
||||
import GF.Grammar.Refresh
|
||||
import GF.Compile.CheckGrammar
|
||||
import GF.Compile.Optimize
|
||||
import GF.Compile.Evaluate ----
|
||||
import GF.Devel.CheckGrammar
|
||||
import GF.Devel.Optimize
|
||||
--import GF.Compile.Evaluate ----
|
||||
import GF.Devel.OptimizeGF
|
||||
--import GF.Canon.Share
|
||||
--import GF.Canon.Subexpressions (elimSubtermsMod,unSubelimModule)
|
||||
@@ -166,7 +166,7 @@ compileSourceModule opts env@(k,gr) mo@(i,mi) = do
|
||||
(k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3
|
||||
intermOut opts (iOpt "show_refresh") (prMod mo3r)
|
||||
|
||||
let eenv = emptyEEnv
|
||||
let eenv = () --- emptyEEnv
|
||||
(mo4,eenv') <-
|
||||
---- if oElem "check_only" opts
|
||||
putpp " optimizing " $ ioeErr $ optimizeModule opts (mos,eenv) mo3r
|
||||
|
||||
395
src/GF/Devel/Compute.hs
Normal file
395
src/GF/Devel/Compute.hs
Normal file
@@ -0,0 +1,395 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Compute
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/01 15:39:12 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.19 $
|
||||
--
|
||||
-- Computation of source terms. Used in compilation and in @cc@ command.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Devel.Compute (computeConcrete, computeTerm,computeConcreteRec) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
import GF.Data.Str
|
||||
import GF.Grammar.PrGrammar
|
||||
import GF.Infra.Modules
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Grammar.Refresh
|
||||
import GF.Grammar.PatternMatch
|
||||
import GF.Grammar.Lockfield (isLockLabel) ----
|
||||
|
||||
import GF.Grammar.AppPredefined
|
||||
|
||||
import Data.List (nub,intersperse)
|
||||
import Control.Monad (liftM2, liftM)
|
||||
|
||||
-- | computation of concrete syntax terms into normal form
|
||||
-- used mainly for partial evaluation
|
||||
computeConcrete :: SourceGrammar -> Term -> Err Term
|
||||
computeConcrete g t = {- refreshTerm t >>= -} computeTerm g [] t
|
||||
computeConcreteRec g t = {- refreshTerm t >>= -} computeTermOpt True g [] t
|
||||
|
||||
computeTerm :: SourceGrammar -> Substitution -> Term -> Err Term
|
||||
computeTerm = computeTermOpt False
|
||||
|
||||
-- rec=True is used if it cannot be assumed that looked-up constants
|
||||
-- have already been computed (mainly with -optimize=noexpand in .gfr)
|
||||
|
||||
computeTermOpt :: Bool -> SourceGrammar -> Substitution -> Term -> Err Term
|
||||
computeTermOpt rec gr = comp where
|
||||
|
||||
comp g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging
|
||||
case t of
|
||||
|
||||
Q (IC "Predef") _ -> return t
|
||||
Q p c -> look p c
|
||||
|
||||
-- if computed do nothing
|
||||
Computed t' -> return $ unComputed t'
|
||||
|
||||
Vr x -> do
|
||||
t' <- maybe (prtBad ("no value given to variable") x) return $ lookup x g
|
||||
case t' of
|
||||
_ | t == t' -> return t
|
||||
_ -> comp g t'
|
||||
|
||||
Abs x b -> do
|
||||
b' <- comp (ext x (Vr x) g) b
|
||||
return $ Abs x b'
|
||||
|
||||
Let (x,(_,a)) b -> do
|
||||
a' <- comp g a
|
||||
comp (ext x a' g) b
|
||||
|
||||
Prod x a b -> do
|
||||
a' <- comp g a
|
||||
b' <- comp (ext x (Vr x) g) b
|
||||
return $ Prod x a' b'
|
||||
|
||||
-- beta-convert
|
||||
App f a -> do
|
||||
f' <- comp g f
|
||||
a' <- comp g a
|
||||
case (f',a') of
|
||||
(Abs x b, FV as) ->
|
||||
mapM (\c -> comp (ext x c g) b) as >>= return . variants
|
||||
(_, FV as) -> mapM (\c -> comp g (App f' c)) as >>= return . variants
|
||||
(FV fs, _) -> mapM (\c -> comp g (App c a')) fs >>= return . variants
|
||||
(Abs x b,_) -> comp (ext x a' g) b
|
||||
(QC _ _,_) -> returnC $ App f' a'
|
||||
|
||||
(Alias _ _ d, _) -> comp g (App d a')
|
||||
|
||||
(S (T i cs) e,_) -> prawitz g i (flip App a') cs e
|
||||
(S (V i cs) e,_) -> prawitzV g i (flip App a') cs e
|
||||
|
||||
_ -> do
|
||||
(t',b) <- appPredefined (App f' a')
|
||||
if b then return t' else comp g t'
|
||||
|
||||
P t l | isLockLabel l -> return $ R []
|
||||
---- a workaround 18/2/2005: take this away and find the reason
|
||||
---- why earlier compilation destroys the lock field
|
||||
|
||||
|
||||
P t l -> do
|
||||
t' <- comp g t
|
||||
case t' of
|
||||
FV rs -> mapM (\c -> comp g (P c l)) rs >>= returnC . variants
|
||||
R r -> maybe (prtBad "no value for label" l) (comp g . snd) $
|
||||
lookup l $ reverse r
|
||||
|
||||
ExtR a (R b) ->
|
||||
case comp g (P (R b) l) of
|
||||
Ok v -> return v
|
||||
_ -> comp g (P a l)
|
||||
|
||||
--- { - --- this is incorrect, since b can contain the proper value
|
||||
ExtR (R a) b -> -- NOT POSSIBLE both a and b records!
|
||||
case comp g (P (R a) l) of
|
||||
Ok v -> return v
|
||||
_ -> comp g (P b l)
|
||||
--- - } ---
|
||||
|
||||
Alias _ _ r -> comp g (P r l)
|
||||
|
||||
S (T i cs) e -> prawitz g i (flip P l) cs e
|
||||
S (V i cs) e -> prawitzV g i (flip P l) cs e
|
||||
|
||||
_ -> returnC $ P t' l
|
||||
|
||||
PI t l i -> comp g $ P t l -----
|
||||
|
||||
S t@(T ti cc) v -> do
|
||||
v' <- comp g v
|
||||
case v' of
|
||||
FV vs -> do
|
||||
ts' <- mapM (comp g . S t) vs
|
||||
return $ variants ts'
|
||||
_ -> case ti of
|
||||
{-
|
||||
TComp _ -> do
|
||||
case term2patt v' of
|
||||
Ok p' -> case lookup p' cc of
|
||||
Just u -> comp g u
|
||||
_ -> do
|
||||
t' <- comp g t
|
||||
return $ S t' v' -- if v' is not canonical
|
||||
_ -> do
|
||||
t' <- comp g t
|
||||
return $ S t' v'
|
||||
-}
|
||||
_ -> case matchPattern cc v' of
|
||||
Ok (c,g') -> comp (g' ++ g) c
|
||||
_ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t
|
||||
_ -> do
|
||||
t' <- comp g t
|
||||
return $ S t' v' -- if v' is not canonical
|
||||
|
||||
|
||||
S t v -> do
|
||||
|
||||
t' <- case t of
|
||||
---- why not? ResFin.Agr "has no values"
|
||||
---- T (TComp _) _ -> return t
|
||||
---- V _ _ -> return t
|
||||
_ -> comp g t
|
||||
|
||||
v' <- comp g v
|
||||
|
||||
case v' of
|
||||
FV vs -> mapM (\c -> comp g (S t' c)) vs >>= returnC . variants
|
||||
_ -> case t' of
|
||||
FV ccs -> mapM (\c -> comp g (S c v')) ccs >>= returnC . variants
|
||||
|
||||
T _ [(PV IW,c)] -> comp g c --- an optimization
|
||||
T _ [(PT _ (PV IW),c)] -> comp g c
|
||||
|
||||
T _ [(PV z,c)] -> comp (ext z v' g) c --- another optimization
|
||||
T _ [(PT _ (PV z),c)] -> comp (ext z v' g) c
|
||||
|
||||
-- course-of-values table: look up by index, no pattern matching needed
|
||||
V ptyp ts -> do
|
||||
vs <- allParamValues gr ptyp
|
||||
case lookup v' (zip vs [0 .. length vs - 1]) of
|
||||
Just i -> comp g $ ts !! i
|
||||
----- _ -> prtBad "selection" $ S t' v' -- debug
|
||||
_ -> return $ S t' v' -- if v' is not canonical
|
||||
|
||||
T (TComp _) cs -> do
|
||||
case term2patt v' of
|
||||
Ok p' -> case lookup p' cs of
|
||||
Just u -> comp g u
|
||||
_ -> return $ S t' v' -- if v' is not canonical
|
||||
_ -> return $ S t' v'
|
||||
|
||||
T _ cc -> case matchPattern cc v' of
|
||||
Ok (c,g') -> comp (g' ++ g) c
|
||||
_ | isCan v' -> prtBad ("missing case" +++ prt v' +++ "in") t
|
||||
_ -> return $ S t' v' -- if v' is not canonical
|
||||
|
||||
Alias _ _ d -> comp g (S d v')
|
||||
|
||||
S (T i cs) e -> prawitz g i (flip S v') cs e
|
||||
S (V i cs) e -> prawitzV g i (flip S v') cs e
|
||||
_ -> returnC $ S t' v'
|
||||
|
||||
-- normalize away empty tokens
|
||||
K "" -> return Empty
|
||||
|
||||
-- glue if you can
|
||||
Glue x0 y0 -> do
|
||||
x <- comp g x0
|
||||
y <- comp g y0
|
||||
case (x,y) of
|
||||
(FV ks,_) -> do
|
||||
kys <- mapM (comp g . flip Glue y) ks
|
||||
return $ variants kys
|
||||
(_,FV ks) -> do
|
||||
xks <- mapM (comp g . Glue x) ks
|
||||
return $ variants xks
|
||||
|
||||
(Alias _ _ d, y) -> comp g $ Glue d y
|
||||
(x, Alias _ _ d) -> comp g $ Glue x d
|
||||
|
||||
(S (T i cs) e, s) -> prawitz g i (flip Glue s) cs e
|
||||
(s, S (T i cs) e) -> prawitz g i (Glue s) cs e
|
||||
(S (V i cs) e, s) -> prawitzV g i (flip Glue s) cs e
|
||||
(s, S (V i cs) e) -> prawitzV g i (Glue s) cs e
|
||||
(_,Empty) -> return x
|
||||
(Empty,_) -> return y
|
||||
(K a, K b) -> return $ K (a ++ b)
|
||||
(_, Alts (d,vs)) -> do
|
||||
---- (K a, Alts (d,vs)) -> do
|
||||
let glx = Glue x
|
||||
comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs])
|
||||
(Alts _, ka) -> checks [do
|
||||
y' <- strsFromTerm ka
|
||||
---- (Alts _, K a) -> checks [do
|
||||
x' <- strsFromTerm x -- this may fail when compiling opers
|
||||
return $ variants [
|
||||
foldr1 C (map K (str2strings (glueStr v u))) | v <- x', u <- y']
|
||||
---- foldr1 C (map K (str2strings (glueStr v (str a)))) | v <- x']
|
||||
,return $ Glue x y
|
||||
]
|
||||
(C u v,_) -> comp g $ C u (Glue v y)
|
||||
|
||||
_ -> do
|
||||
mapM_ checkNoArgVars [x,y]
|
||||
r <- composOp (comp g) t
|
||||
returnC r
|
||||
|
||||
Alts _ -> do
|
||||
r <- composOp (comp g) t
|
||||
returnC r
|
||||
|
||||
-- remove empty
|
||||
C a b -> do
|
||||
a' <- comp g a
|
||||
b' <- comp g b
|
||||
case (a',b') of
|
||||
(Alts _, K a) -> checks [do
|
||||
as <- strsFromTerm a' -- this may fail when compiling opers
|
||||
return $ variants [
|
||||
foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as]
|
||||
,
|
||||
return $ C a' b'
|
||||
]
|
||||
(Empty,_) -> returnC b'
|
||||
(_,Empty) -> returnC a'
|
||||
_ -> returnC $ C a' b'
|
||||
|
||||
-- reduce free variation as much as you can
|
||||
FV ts -> mapM (comp g) ts >>= returnC . variants
|
||||
|
||||
-- merge record extensions if you can
|
||||
ExtR r s -> do
|
||||
r' <- comp g r
|
||||
s' <- comp g s
|
||||
case (r',s') of
|
||||
(Alias _ _ d, _) -> comp g $ ExtR d s'
|
||||
(_, Alias _ _ d) -> comp g $ Glue r' d
|
||||
|
||||
(R rs, R ss) -> plusRecord r' s'
|
||||
(RecType rs, RecType ss) -> plusRecType r' s'
|
||||
_ -> return $ ExtR r' s'
|
||||
|
||||
-- case-expand tables
|
||||
-- if already expanded, don't expand again
|
||||
T i@(TComp ty) cs -> do
|
||||
-- if there are no variables, don't even go inside
|
||||
cs' <- if (null g) then return cs else mapPairsM (comp g) cs
|
||||
---- return $ V ty (map snd cs')
|
||||
return $ T i cs'
|
||||
--- this means some extra work; should implement TSh directly
|
||||
TSh i cs -> comp g $ T i [(p,v) | (ps,v) <- cs, p <- ps] --- OBSOLETE
|
||||
|
||||
T i cs -> do
|
||||
pty0 <- getTableType i
|
||||
ptyp <- comp g pty0
|
||||
case allParamValues gr ptyp of
|
||||
Ok vs -> do
|
||||
|
||||
cs' <- mapM (compBranchOpt g) cs ---- why is this needed??
|
||||
sts <- mapM (matchPattern cs') vs
|
||||
ts <- mapM (\ (c,g') -> comp (g' ++ g) c) sts
|
||||
ps <- mapM term2patt vs
|
||||
let ps' = ps --- PT ptyp (head ps) : tail ps
|
||||
---- return $ V ptyp ts -- to save space ---- why doesn't this work??
|
||||
return $ T (TComp ptyp) (zip ps' ts)
|
||||
_ -> do
|
||||
cs' <- mapM (compBranch g) cs
|
||||
return $ T i cs' -- happens with variable types
|
||||
|
||||
Alias c a d -> do --- OBSOLETE
|
||||
d' <- comp g d
|
||||
return $ Alias c a d' -- alias only disappears in certain redexes
|
||||
|
||||
-- otherwise go ahead
|
||||
_ -> composOp (comp g) t >>= returnC
|
||||
|
||||
where
|
||||
|
||||
look p c
|
||||
| rec = lookupResDef gr p c >>= comp []
|
||||
| otherwise = lookupResDef gr p c
|
||||
|
||||
{-
|
||||
look p c = case lookupResDefKind gr p c of
|
||||
Ok (t,_) | noExpand p || rec -> comp [] t
|
||||
Ok (t,_) -> return t
|
||||
Bad s -> raise s
|
||||
|
||||
noExpand p = errVal False $ do
|
||||
mo <- lookupModMod gr p
|
||||
return $ case getOptVal (iOpts (flags mo)) useOptimizer of
|
||||
Just "noexpand" -> True
|
||||
_ -> False
|
||||
-}
|
||||
|
||||
ext x a g = (x,a):g
|
||||
|
||||
returnC = return --- . computed
|
||||
|
||||
variants ts = case nub ts of
|
||||
[t] -> t
|
||||
ts -> FV ts
|
||||
|
||||
isCan v = case v of
|
||||
Con _ -> True
|
||||
QC _ _ -> True
|
||||
App f a -> isCan f && isCan a
|
||||
R rs -> all (isCan . snd . snd) rs
|
||||
_ -> False
|
||||
|
||||
compBranch g (p,v) = do
|
||||
let g' = contP p ++ g
|
||||
v' <- comp g' v
|
||||
return (p,v')
|
||||
|
||||
compBranchOpt g c@(p,v) = case contP p of
|
||||
[] -> return c
|
||||
_ -> err (const (return c)) return $ compBranch g c
|
||||
|
||||
contP p = case p of
|
||||
PV x -> [(x,Vr x)]
|
||||
PC _ ps -> concatMap contP ps
|
||||
PP _ _ ps -> concatMap contP ps
|
||||
PT _ p -> contP p
|
||||
PR rs -> concatMap (contP . snd) rs
|
||||
|
||||
PAs x p -> (x,Vr x) : contP p
|
||||
|
||||
PSeq p q -> concatMap contP [p,q]
|
||||
PAlt p q -> concatMap contP [p,q]
|
||||
PRep p -> contP p
|
||||
PNeg p -> contP p
|
||||
|
||||
_ -> []
|
||||
|
||||
prawitz g i f cs e = do
|
||||
cs' <- mapM (compBranch g) [(p, f v) | (p,v) <- cs]
|
||||
return $ S (T i cs') e
|
||||
prawitzV g i f cs e = do
|
||||
cs' <- mapM (comp g) [(f v) | v <- cs]
|
||||
return $ S (V i cs') e
|
||||
|
||||
-- | argument variables cannot be glued
|
||||
checkNoArgVars :: Term -> Err Term
|
||||
checkNoArgVars t = case t of
|
||||
Vr (IA _) -> Bad $ glueErrorMsg $ prt t
|
||||
Vr (IAV _) -> Bad $ glueErrorMsg $ prt t
|
||||
_ -> composOp checkNoArgVars t
|
||||
|
||||
glueErrorMsg s =
|
||||
"Cannot glue (+) term with run-time variable" +++ s ++ "." ++++
|
||||
"Use Prelude.bind instead."
|
||||
@@ -10,7 +10,7 @@ import qualified GF.GFCC.AbsGFCC as C
|
||||
import qualified GF.GFCC.DataGFCC as D
|
||||
import qualified GF.Grammar.Abstract as A
|
||||
import qualified GF.Grammar.Macros as GM
|
||||
import qualified GF.Grammar.Compute as Compute
|
||||
--import qualified GF.Grammar.Compute as Compute
|
||||
import qualified GF.Infra.Modules as M
|
||||
import qualified GF.Infra.Option as O
|
||||
|
||||
|
||||
298
src/GF/Devel/Optimize.hs
Normal file
298
src/GF/Devel/Optimize.hs
Normal file
@@ -0,0 +1,298 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Optimize
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/09/16 13:56:13 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.18 $
|
||||
--
|
||||
-- Top-level partial evaluation for GF source modules.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Devel.Optimize (optimizeModule) where
|
||||
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Modules
|
||||
import GF.Grammar.PrGrammar
|
||||
import GF.Grammar.Macros
|
||||
import GF.Grammar.Lookup
|
||||
import GF.Grammar.Refresh
|
||||
import GF.Devel.Compute
|
||||
import GF.Compile.BackOpt
|
||||
import GF.Devel.CheckGrammar
|
||||
import GF.Compile.Update
|
||||
--import GF.Compile.Evaluate
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Infra.CheckM
|
||||
import GF.Infra.Option
|
||||
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
|
||||
-- conditional trace
|
||||
|
||||
prtIf :: (Print a) => Bool -> a -> a
|
||||
prtIf b t = if b then trace (" " ++ prt t) t else t
|
||||
|
||||
-- experimental evaluation, option to import
|
||||
oEval = iOpt "eval"
|
||||
|
||||
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
|
||||
|
||||
type EEnv = () --- not used
|
||||
|
||||
-- only do this for resource: concrete is optimized in gfc form
|
||||
optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) ->
|
||||
(Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv)
|
||||
optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of
|
||||
ModMod m0@(Module mt st fs me ops js) |
|
||||
st == MSComplete && isModRes m0 && not (oElem oEval oopts)-> do
|
||||
(mo1,_) <- evalModule oopts mse mo
|
||||
let
|
||||
mo2 = case optim of
|
||||
"parametrize" -> shareModule paramOpt mo1 -- parametrization and sharing
|
||||
"values" -> shareModule valOpt mo1 -- tables as courses-of-values
|
||||
"share" -> shareModule shareOpt mo1 -- sharing of branches
|
||||
"all" -> shareModule allOpt mo1 -- first parametrize then values
|
||||
"none" -> mo1 -- no optimization
|
||||
_ -> mo1 -- none; default for src
|
||||
return (mo2,eenv)
|
||||
_ -> evalModule oopts mse mo
|
||||
where
|
||||
oopts = addOptions opts (iOpts (flagsModule mo))
|
||||
optim = maybe "all" id $ getOptVal oopts useOptimizer
|
||||
|
||||
evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) ->
|
||||
Err ((Ident,SourceModInfo),EEnv)
|
||||
evalModule oopts (ms,eenv) mo@(name,mod) = case mod of
|
||||
|
||||
ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt of
|
||||
_ | isModRes m0 && not (oElem oEval oopts) -> do
|
||||
let deps = allOperDependencies name js
|
||||
ids <- topoSortOpers deps
|
||||
MGrammar (mod' : _) <- foldM evalOp gr ids
|
||||
return $ (mod',eenv)
|
||||
|
||||
MTConcrete a -> do
|
||||
js' <- mapMTree (evalCncInfo oopts gr name a) js ---- <- gr0 6/12/2005
|
||||
return $ ((name, ModMod (Module mt st fs me ops js')),eenv)
|
||||
|
||||
_ -> return $ ((name,mod),eenv)
|
||||
_ -> return $ ((name,mod),eenv)
|
||||
where
|
||||
gr0 = MGrammar $ ms
|
||||
gr = MGrammar $ (name,mod) : ms
|
||||
|
||||
evalOp g@(MGrammar ((_, ModMod m) : _)) i = do
|
||||
info <- lookupTree prt i $ jments m
|
||||
info' <- evalResInfo oopts gr (i,info)
|
||||
return $ updateRes g name i info'
|
||||
|
||||
-- | only operations need be compiled in a resource, and this is local to each
|
||||
-- definition since the module is traversed in topological order
|
||||
evalResInfo :: Options -> SourceGrammar -> (Ident,Info) -> Err Info
|
||||
evalResInfo oopts gr (c,info) = case info of
|
||||
|
||||
ResOper pty pde -> eIn "operation" $ do
|
||||
pde' <- case pde of
|
||||
Yes de | optres -> liftM yes $ comp de
|
||||
_ -> return pde
|
||||
return $ ResOper pty pde'
|
||||
|
||||
_ -> return info
|
||||
where
|
||||
comp = if optres then computeConcrete gr else computeConcreteRec gr
|
||||
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
|
||||
optim = maybe "all" id $ getOptVal oopts useOptimizer
|
||||
optres = case optim of
|
||||
"noexpand" -> False
|
||||
_ -> True
|
||||
|
||||
|
||||
evalCncInfo ::
|
||||
Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
|
||||
evalCncInfo opts gr cnc abs (c,info) = do
|
||||
|
||||
seq (prtIf (oElem beVerbose opts) c) $ return ()
|
||||
|
||||
errIn ("optimizing" +++ prt c) $ case info of
|
||||
|
||||
CncCat ptyp pde ppr -> do
|
||||
pde' <- case (ptyp,pde) of
|
||||
(Yes typ, Yes de) ->
|
||||
liftM yes $ pEval ([(strVar, typeStr)], typ) de
|
||||
(Yes typ, Nope) ->
|
||||
liftM yes $ mkLinDefault gr typ >>= partEval noOptions gr ([(strVar, typeStr)],typ)
|
||||
(May b, Nope) ->
|
||||
return $ May b
|
||||
_ -> return pde -- indirection
|
||||
|
||||
ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c)
|
||||
|
||||
return (c, CncCat ptyp pde' ppr')
|
||||
|
||||
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr ->
|
||||
eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
|
||||
pde' <- case pde of
|
||||
Yes de | notNewEval -> do
|
||||
liftM yes $ pEval ty de
|
||||
|
||||
_ -> return pde
|
||||
ppr' <- liftM yes $ evalPrintname gr c ppr pde'
|
||||
return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed
|
||||
|
||||
_ -> return (c,info)
|
||||
where
|
||||
pEval = partEval opts gr
|
||||
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
|
||||
notNewEval = not (oElem oEval opts)
|
||||
|
||||
-- | the main function for compiling linearizations
|
||||
partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
|
||||
partEval opts gr (context, val) trm = errIn ("parteval" +++ prt_ trm) $ do
|
||||
let vars = map fst context
|
||||
args = map Vr vars
|
||||
subst = [(v, Vr v) | v <- vars]
|
||||
trm1 = mkApp trm args
|
||||
trm3 <- if globalTable
|
||||
then etaExpand subst trm1 >>= outCase subst
|
||||
else etaExpand subst trm1
|
||||
return $ mkAbs vars trm3
|
||||
|
||||
where
|
||||
|
||||
globalTable = oElem showAll opts --- i -all
|
||||
|
||||
comp g t = {- refreshTerm t >>= -} computeTerm gr g t
|
||||
|
||||
etaExpand su t = do
|
||||
t' <- comp su t
|
||||
case t' of
|
||||
R _ | rightType t' -> comp su t' --- return t' wo noexpand...
|
||||
_ -> recordExpand val t' >>= comp su
|
||||
-- don't eta expand records of right length (correct by type checking)
|
||||
rightType t = case (t,val) of
|
||||
(R rs, RecType ts) -> length rs == length ts
|
||||
_ -> False
|
||||
|
||||
outCase subst t = do
|
||||
pts <- getParams context
|
||||
let (args,ptyps) = unzip $ filter (flip occur t . fst) pts
|
||||
if null args
|
||||
then return t
|
||||
else do
|
||||
let argtyp = RecType $ tuple2recordType ptyps
|
||||
let pvars = map (Vr . zIdent . prt) args -- gets eliminated
|
||||
patt <- term2patt $ R $ tuple2record $ pvars
|
||||
let t' = replace (zip args pvars) t
|
||||
t1 <- comp subst $ T (TTyped argtyp) [(patt, t')]
|
||||
return $ S t1 $ R $ tuple2record args
|
||||
|
||||
--- notice: this assumes that all lin types follow the "old JFP style"
|
||||
getParams = liftM concat . mapM getParam
|
||||
getParam (argv,RecType rs) = return
|
||||
[(P (Vr argv) lab, ptyp) | (lab,ptyp) <- rs, not (isLinLabel lab)]
|
||||
---getParam (_,ty) | ty==typeStr = return [] --- in lindef
|
||||
getParam (av,ty) =
|
||||
Bad ("record type expected not" +++ prt ty +++ "for" +++ prt av)
|
||||
--- all lin types are rec types
|
||||
|
||||
replace :: [(Term,Term)] -> Term -> Term
|
||||
replace reps trm = case trm of
|
||||
-- this is the important case
|
||||
P _ _ -> maybe trm id $ lookup trm reps
|
||||
_ -> composSafeOp (replace reps) trm
|
||||
|
||||
occur t trm = case trm of
|
||||
|
||||
-- this is the important case
|
||||
P _ _ -> t == trm
|
||||
S x y -> occur t y || occur t x
|
||||
App f x -> occur t x || occur t f
|
||||
Abs _ f -> occur t f
|
||||
R rs -> any (occur t) (map (snd . snd) rs)
|
||||
T _ cs -> any (occur t) (map snd cs)
|
||||
C x y -> occur t x || occur t y
|
||||
Glue x y -> occur t x || occur t y
|
||||
ExtR x y -> occur t x || occur t y
|
||||
FV ts -> any (occur t) ts
|
||||
V _ ts -> any (occur t) ts
|
||||
Let (_,(_,x)) y -> occur t x || occur t y
|
||||
_ -> False
|
||||
|
||||
|
||||
-- here we must be careful not to reduce
|
||||
-- variants {{s = "Auto" ; g = N} ; {s = "Wagen" ; g = M}}
|
||||
-- {s = variants {"Auto" ; "Wagen"} ; g = variants {N ; M}} ;
|
||||
|
||||
recordExpand :: Type -> Term -> Err Term
|
||||
recordExpand typ trm = case unComputed typ of
|
||||
RecType tys -> case trm of
|
||||
FV rs -> return $ FV [R [assign lab (P r lab) | (lab,_) <- tys] | r <- rs]
|
||||
_ -> return $ R [assign lab (P trm lab) | (lab,_) <- tys]
|
||||
_ -> return trm
|
||||
|
||||
|
||||
-- | auxiliaries for compiling the resource
|
||||
|
||||
mkLinDefault :: SourceGrammar -> Type -> Err Term
|
||||
mkLinDefault gr typ = do
|
||||
case unComputed typ of
|
||||
RecType lts -> mapPairsM mkDefField lts >>= (return . Abs strVar . R . mkAssign)
|
||||
_ -> prtBad "linearization type must be a record type, not" typ
|
||||
where
|
||||
mkDefField typ = case unComputed typ of
|
||||
Table p t -> do
|
||||
t' <- mkDefField t
|
||||
let T _ cs = mkWildCases t'
|
||||
return $ T (TWild p) cs
|
||||
Sort "Str" -> return $ Vr strVar
|
||||
QC q p -> lookupFirstTag gr q p
|
||||
RecType r -> do
|
||||
let (ls,ts) = unzip r
|
||||
ts' <- mapM mkDefField ts
|
||||
return $ R $ [assign l t | (l,t) <- zip ls ts']
|
||||
_ | isTypeInts typ -> return $ EInt 0 -- exists in all as first val
|
||||
_ -> prtBad "linearization type field cannot be" typ
|
||||
|
||||
-- | Form the printname: if given, compute. If not, use the computed
|
||||
-- lin for functions, cat name for cats (dispatch made in evalCncDef above).
|
||||
--- We cannot use linearization at this stage, since we do not know the
|
||||
--- defaults we would need for question marks - and we're not yet in canon.
|
||||
evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term
|
||||
evalPrintname gr c ppr lin =
|
||||
case ppr of
|
||||
Yes pr -> comp pr
|
||||
_ -> case lin of
|
||||
Yes t -> return $ K $ clean $ prt $ oneBranch t ---- stringFromTerm
|
||||
_ -> return $ K $ prt c ----
|
||||
where
|
||||
comp = computeConcrete gr
|
||||
|
||||
oneBranch t = case t of
|
||||
Abs _ b -> oneBranch b
|
||||
R (r:_) -> oneBranch $ snd $ snd r
|
||||
T _ (c:_) -> oneBranch $ snd c
|
||||
V _ (c:_) -> oneBranch c
|
||||
FV (t:_) -> oneBranch t
|
||||
C x y -> C (oneBranch x) (oneBranch y)
|
||||
S x _ -> oneBranch x
|
||||
P x _ -> oneBranch x
|
||||
Alts (d,_) -> oneBranch d
|
||||
_ -> t
|
||||
|
||||
--- very unclean cleaner
|
||||
clean s = case s of
|
||||
'+':'+':' ':cs -> clean cs
|
||||
'"':cs -> clean cs
|
||||
c:cs -> c: clean cs
|
||||
_ -> s
|
||||
|
||||
@@ -116,7 +116,9 @@ values :: Term -> Term
|
||||
values t = case t of
|
||||
T ty [(ps,t)] -> T ty [(ps,values t)] -- don't destroy parametrization
|
||||
T (TComp ty) cs -> V ty [values t | (_, t) <- cs]
|
||||
T (TTyped ty) cs -> V ty [values t | (_, t) <- cs] ---- why are these left?
|
||||
T (TTyped ty) cs -> V ty [values t | (_, t) <- cs]
|
||||
---- why are these left?
|
||||
---- printing with GrammarToSource does not preserve the distinction
|
||||
_ -> C.composSafeOp values t
|
||||
|
||||
|
||||
|
||||
299
src/GF/Devel/TC.hs
Normal file
299
src/GF/Devel/TC.hs
Normal file
@@ -0,0 +1,299 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : TC
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/02 20:50:19 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.11 $
|
||||
--
|
||||
-- Thierry Coquand's type checking algorithm that creates a trace
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Devel.TC (AExp(..),
|
||||
Theory,
|
||||
checkExp,
|
||||
inferExp,
|
||||
checkEqs,
|
||||
eqVal,
|
||||
whnf
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Grammar.Abstract
|
||||
import GF.Devel.AbsCompute
|
||||
|
||||
import Control.Monad
|
||||
import Data.List (sortBy)
|
||||
|
||||
data AExp =
|
||||
AVr Ident Val
|
||||
| ACn QIdent Val
|
||||
| AType
|
||||
| AInt Integer
|
||||
| AFloat Double
|
||||
| AStr String
|
||||
| AMeta MetaSymb Val
|
||||
| AApp AExp AExp Val
|
||||
| AAbs Ident Val AExp
|
||||
| AProd Ident AExp AExp
|
||||
| AEqs [([Exp],AExp)] --- not used
|
||||
| AData Val
|
||||
deriving (Eq,Show)
|
||||
|
||||
type Theory = QIdent -> Err Val
|
||||
|
||||
lookupConst :: Theory -> QIdent -> Err Val
|
||||
lookupConst th f = th f
|
||||
|
||||
lookupVar :: Env -> Ident -> Err Val
|
||||
lookupVar g x = maybe (prtBad "unknown variable" x) return $ lookup x ((IW,uVal):g)
|
||||
-- wild card IW: no error produced, ?0 instead.
|
||||
|
||||
type TCEnv = (Int,Env,Env)
|
||||
|
||||
emptyTCEnv :: TCEnv
|
||||
emptyTCEnv = (0,[],[])
|
||||
|
||||
whnf :: Val -> Err Val
|
||||
whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
|
||||
case v of
|
||||
VApp u w -> do
|
||||
u' <- whnf u
|
||||
w' <- whnf w
|
||||
app u' w'
|
||||
VClos env e -> eval env e
|
||||
_ -> return v
|
||||
|
||||
app :: Val -> Val -> Err Val
|
||||
app u v = case u of
|
||||
VClos env (Abs x e) -> eval ((x,v):env) e
|
||||
_ -> return $ VApp u v
|
||||
|
||||
eval :: Env -> Exp -> Err Val
|
||||
eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
|
||||
case e of
|
||||
Vr x -> lookupVar env x
|
||||
Q m c -> return $ VCn (m,c)
|
||||
QC m c -> return $ VCn (m,c) ---- == Q ?
|
||||
Sort c -> return $ VType --- the only sort is Type
|
||||
App f a -> join $ liftM2 app (eval env f) (eval env a)
|
||||
_ -> return $ VClos env e
|
||||
|
||||
eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
|
||||
eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
|
||||
do
|
||||
w1 <- whnf u1
|
||||
w2 <- whnf u2
|
||||
let v = VGen k
|
||||
case (w1,w2) of
|
||||
(VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
|
||||
(VClos env1 (Abs x1 e1), VClos env2 (Abs x2 e2)) ->
|
||||
eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
|
||||
(VClos env1 (Prod x1 a1 e1), VClos env2 (Prod x2 a2 e2)) ->
|
||||
liftM2 (++)
|
||||
(eqVal k (VClos env1 a1) (VClos env2 a2))
|
||||
(eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
|
||||
(VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
|
||||
(VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
|
||||
--- thus ignore qualifications; valid because inheritance cannot
|
||||
--- be qualified. Simplifies annotation. AR 17/3/2005
|
||||
_ -> return [(w1,w2) | w1 /= w2]
|
||||
-- invariant: constraints are in whnf
|
||||
|
||||
checkType :: Theory -> TCEnv -> Exp -> Err (AExp,[(Val,Val)])
|
||||
checkType th tenv e = checkExp th tenv e vType
|
||||
|
||||
checkExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)])
|
||||
checkExp th tenv@(k,rho,gamma) e ty = do
|
||||
typ <- whnf ty
|
||||
let v = VGen k
|
||||
case e of
|
||||
Meta m -> return $ (AMeta m typ,[])
|
||||
EData -> return $ (AData typ,[])
|
||||
|
||||
Abs x t -> case typ of
|
||||
VClos env (Prod y a b) -> do
|
||||
a' <- whnf $ VClos env a ---
|
||||
(t',cs) <- checkExp th
|
||||
(k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
|
||||
return (AAbs x a' t', cs)
|
||||
_ -> prtBad ("function type expected for" +++ prt e +++ "instead of") typ
|
||||
|
||||
-- {- --- to get deprec when checkEqs works (15/9/2005)
|
||||
Eqs es -> do
|
||||
bcs <- mapM (\b -> checkBranch th tenv b typ) es
|
||||
let (bs,css) = unzip bcs
|
||||
return (AEqs bs, concat css)
|
||||
-- - }
|
||||
Prod x a b -> do
|
||||
testErr (typ == vType) "expected Type"
|
||||
(a',csa) <- checkType th tenv a
|
||||
(b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
|
||||
return (AProd x a' b', csa ++ csb)
|
||||
|
||||
_ -> checkInferExp th tenv e typ
|
||||
|
||||
checkInferExp :: Theory -> TCEnv -> Exp -> Val -> Err (AExp, [(Val,Val)])
|
||||
checkInferExp th tenv@(k,_,_) e typ = do
|
||||
(e',w,cs1) <- inferExp th tenv e
|
||||
cs2 <- eqVal k w typ
|
||||
return (e',cs1 ++ cs2)
|
||||
|
||||
inferExp :: Theory -> TCEnv -> Exp -> Err (AExp, Val, [(Val,Val)])
|
||||
inferExp th tenv@(k,rho,gamma) e = case e of
|
||||
Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
|
||||
Q m c
|
||||
| m == cPredefAbs && (elem c (map identC ["Int","String","Float"])) ->
|
||||
return (ACn (m,c) vType, vType, [])
|
||||
| otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c)
|
||||
QC m c -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) ----
|
||||
EInt i -> return (AInt i, valAbsInt, [])
|
||||
EFloat i -> return (AFloat i, valAbsFloat, [])
|
||||
K i -> return (AStr i, valAbsString, [])
|
||||
Sort _ -> return (AType, vType, [])
|
||||
App f t -> do
|
||||
(f',w,csf) <- inferExp th tenv f
|
||||
typ <- whnf w
|
||||
case typ of
|
||||
VClos env (Prod x a b) -> do
|
||||
(a',csa) <- checkExp th tenv t (VClos env a)
|
||||
b' <- whnf $ VClos ((x,VClos rho t):env) b
|
||||
return $ (AApp f' a' b', b', csf ++ csa)
|
||||
_ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ
|
||||
_ -> prtBad "cannot infer type of expression" e
|
||||
where
|
||||
predefAbs c s = case c of
|
||||
IC "Int" -> return $ const $ Q cPredefAbs cInt
|
||||
IC "Float" -> return $ const $ Q cPredefAbs cFloat
|
||||
IC "String" -> return $ const $ Q cPredefAbs cString
|
||||
_ -> Bad s
|
||||
|
||||
checkEqs :: Theory -> TCEnv -> (Fun,Trm) -> Val -> Err [(Val,Val)]
|
||||
checkEqs th tenv@(k,rho,gamma) (fun@(m,f),def) val = case def of
|
||||
Eqs es -> liftM concat $ mapM checkBranch es
|
||||
_ -> liftM snd $ checkExp th tenv def val
|
||||
where
|
||||
checkBranch (ps,df) =
|
||||
let
|
||||
(ps',_,vars) = foldr p2t ([],0,[]) ps
|
||||
fps = mkApp (Q m f) ps'
|
||||
in errIn ("branch" +++ prt fps) $ do
|
||||
(aexp, typ, cs1) <- inferExp th tenv fps
|
||||
let
|
||||
bds = binds vars aexp
|
||||
tenv' = (k, rho, bds ++ gamma)
|
||||
(_,cs2) <- errIn (show bds) $ checkExp th tenv' df typ
|
||||
return $ (cs1 ++ cs2)
|
||||
p2t p (ps,i,g) = case p of
|
||||
PW -> (meta (MetaSymb i) : ps, i+1, g)
|
||||
PV IW -> (meta (MetaSymb i) : ps, i+1, g)
|
||||
PV x -> (meta (MetaSymb i) : ps, i+1,upd x i g)
|
||||
PString s -> ( K s : ps, i, g)
|
||||
PInt n -> (EInt n : ps, i, g)
|
||||
PFloat n -> (EFloat n : ps, i, g)
|
||||
PP m c xs -> (mkApp (qq (m,c)) xss : ps, i', g')
|
||||
where (xss,i',g') = foldr p2t ([],i,g) xs
|
||||
_ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch"
|
||||
upd x i g = (x,i) : g --- to annotate pattern variables: treat as metas
|
||||
|
||||
-- notice: in vars, the sequence 0.. is sorted. In subst aexp, all
|
||||
-- this occurs and nothing else.
|
||||
binds vars aexp = [(x,v) | ((x,_),v) <- zip vars metas] where
|
||||
metas = map snd $ sortBy (\ (x,_) (y,_) -> compare x y) $ subst aexp
|
||||
subst aexp = case aexp of
|
||||
AMeta (MetaSymb i) v -> [(i,v)]
|
||||
AApp c a _ -> subst c ++ subst a
|
||||
_ -> [] -- never matter in patterns
|
||||
|
||||
checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Exp],AExp),[(Val,Val)])
|
||||
checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
|
||||
chB tenv' ps' ty
|
||||
where
|
||||
|
||||
(ps',_,rho2,k') = ps2ts k ps
|
||||
tenv' = (k, rho2++rho, gamma) ---- k' ?
|
||||
(k,rho,gamma) = tenv
|
||||
|
||||
chB tenv@(k,rho,gamma) ps ty = case ps of
|
||||
p:ps2 -> do
|
||||
typ <- whnf ty
|
||||
case typ of
|
||||
VClos env (Prod y a b) -> do
|
||||
a' <- whnf $ VClos env a
|
||||
(p', sigma, binds, cs1) <- checkP tenv p y a'
|
||||
let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
|
||||
((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
|
||||
return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
|
||||
_ -> prtBad ("Product expected for definiens" +++prt t +++ "instead of") typ
|
||||
[] -> do
|
||||
(e,cs) <- checkExp th tenv t ty
|
||||
return (([],e),cs)
|
||||
checkP env@(k,rho,gamma) t x a = do
|
||||
(delta,cs) <- checkPatt th env t a
|
||||
let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
|
||||
return (VClos sigma t, sigma, delta, cs)
|
||||
|
||||
ps2ts k = foldr p2t ([],0,[],k)
|
||||
p2t p (ps,i,g,k) = case p of
|
||||
PW -> (meta (MetaSymb i) : ps, i+1,g,k)
|
||||
PV IW -> (meta (MetaSymb i) : ps, i+1,g,k)
|
||||
PV x -> (vr x : ps, i, upd x k g,k+1)
|
||||
PString s -> (K s : ps, i, g, k)
|
||||
PInt n -> (EInt n : ps, i, g, k)
|
||||
PFloat n -> (EFloat n : ps, i, g, k)
|
||||
PP m c xs -> (mkApp (qq (m,c)) xss : ps, j, g',k')
|
||||
where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
|
||||
_ -> error $ "undefined p2t case" +++ prt p +++ "in checkBranch"
|
||||
|
||||
upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables
|
||||
|
||||
|
||||
checkPatt :: Theory -> TCEnv -> Exp -> Val -> Err (Binds,[(Val,Val)])
|
||||
checkPatt th tenv exp val = do
|
||||
(aexp,_,cs) <- checkExpP tenv exp val
|
||||
let binds = extrBinds aexp
|
||||
return (binds,cs)
|
||||
where
|
||||
extrBinds aexp = case aexp of
|
||||
AVr i v -> [(i,v)]
|
||||
AApp f a _ -> extrBinds f ++ extrBinds a
|
||||
_ -> [] -- no other cases are possible
|
||||
|
||||
--- ad hoc, to find types of variables
|
||||
checkExpP tenv@(k,rho,gamma) exp val = case exp of
|
||||
Meta m -> return $ (AMeta m val, val, [])
|
||||
Vr x -> return $ (AVr x val, val, [])
|
||||
EInt i -> return (AInt i, valAbsInt, [])
|
||||
EFloat i -> return (AFloat i, valAbsFloat, [])
|
||||
K s -> return (AStr s, valAbsString, [])
|
||||
|
||||
Q m c -> do
|
||||
typ <- lookupConst th (m,c)
|
||||
return $ (ACn (m,c) typ, typ, [])
|
||||
QC m c -> do
|
||||
typ <- lookupConst th (m,c)
|
||||
return $ (ACn (m,c) typ, typ, []) ----
|
||||
App f t -> do
|
||||
(f',w,csf) <- checkExpP tenv f val
|
||||
typ <- whnf w
|
||||
case typ of
|
||||
VClos env (Prod x a b) -> do
|
||||
(a',_,csa) <- checkExpP tenv t (VClos env a)
|
||||
b' <- whnf $ VClos ((x,VClos rho t):env) b
|
||||
return $ (AApp f' a' b', b', csf ++ csa)
|
||||
_ -> prtBad ("Prod expected for function" +++ prt f +++ "instead of") typ
|
||||
_ -> prtBad "cannot typecheck pattern" exp
|
||||
|
||||
-- auxiliaries
|
||||
|
||||
noConstr :: Err Val -> Err (Val,[(Val,Val)])
|
||||
noConstr er = er >>= (\v -> return (v,[]))
|
||||
|
||||
mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
|
||||
mkAnnot a ti = do
|
||||
(v,cs) <- ti
|
||||
return (a v, v, cs)
|
||||
|
||||
311
src/GF/Devel/TypeCheck.hs
Normal file
311
src/GF/Devel/TypeCheck.hs
Normal file
@@ -0,0 +1,311 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : TypeCheck
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/09/15 16:22:02 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.16 $
|
||||
--
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Devel.TypeCheck (-- * top-level type checking functions; TC should not be called directly.
|
||||
annotate, annotateIn,
|
||||
justTypeCheck, checkIfValidExp,
|
||||
reduceConstraints,
|
||||
splitConstraints,
|
||||
possibleConstraints,
|
||||
reduceConstraintsNode,
|
||||
performMetaSubstNode,
|
||||
-- * some top-level batch-mode checkers for the compiler
|
||||
justTypeCheckSrc,
|
||||
grammar2theorySrc,
|
||||
checkContext,
|
||||
checkTyp,
|
||||
checkEquation,
|
||||
checkConstrs,
|
||||
editAsTermCommand,
|
||||
exp2termCommand,
|
||||
exp2termlistCommand,
|
||||
tree2termlistCommand
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Data.Zipper
|
||||
|
||||
import GF.Grammar.Abstract
|
||||
import GF.Devel.AbsCompute
|
||||
import GF.Grammar.Refresh
|
||||
import GF.Grammar.LookAbs
|
||||
import qualified GF.Grammar.Lookup as Lookup ---
|
||||
|
||||
import GF.Devel.TC
|
||||
|
||||
import GF.Grammar.Unify ---
|
||||
|
||||
import Control.Monad (foldM, liftM, liftM2)
|
||||
import Data.List (nub) ---
|
||||
|
||||
-- top-level type checking functions; TC should not be called directly.
|
||||
|
||||
annotate :: GFCGrammar -> Exp -> Err Tree
|
||||
annotate gr exp = annotateIn gr [] exp Nothing
|
||||
|
||||
-- | type check in empty context, return a list of constraints
|
||||
justTypeCheck :: GFCGrammar -> Exp -> Val -> Err Constraints
|
||||
justTypeCheck gr e v = do
|
||||
(_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v
|
||||
constrs1 <- reduceConstraints (lookupAbsDef gr) 0 constrs0
|
||||
return $ fst $ splitConstraints gr constrs1
|
||||
|
||||
-- | type check in empty context, return the expression itself if valid
|
||||
checkIfValidExp :: GFCGrammar -> Exp -> Err Exp
|
||||
checkIfValidExp gr e = do
|
||||
(_,_,constrs0) <- inferExp (grammar2theory gr) (initTCEnv []) e
|
||||
constrs1 <- reduceConstraints (lookupAbsDef gr) 0 constrs0
|
||||
ifNull (return e) (Bad . unwords . prConstrs) constrs1
|
||||
|
||||
annotateIn :: GFCGrammar -> Binds -> Exp -> Maybe Val -> Err Tree
|
||||
annotateIn gr gamma exp = maybe (infer exp) (check exp) where
|
||||
infer e = do
|
||||
(a,_,cs) <- inferExp theory env e
|
||||
aexp2treeC (a,cs)
|
||||
check e v = do
|
||||
(a,cs) <- checkExp theory env e v
|
||||
aexp2treeC (a,cs)
|
||||
env = initTCEnv gamma
|
||||
theory = grammar2theory gr
|
||||
aexp2treeC (a,c) = do
|
||||
c' <- reduceConstraints (lookupAbsDef gr) (length gamma) c
|
||||
aexp2tree (a,c')
|
||||
|
||||
-- | invariant way of creating TCEnv from context
|
||||
initTCEnv gamma =
|
||||
(length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
|
||||
|
||||
-- | process constraints after eqVal by computing by defs
|
||||
reduceConstraints :: LookDef -> Int -> Constraints -> Err Constraints
|
||||
reduceConstraints look i = liftM concat . mapM redOne where
|
||||
redOne (u,v) = do
|
||||
u' <- computeVal look u
|
||||
v' <- computeVal look v
|
||||
eqVal i u' v'
|
||||
|
||||
computeVal :: LookDef -> Val -> Err Val
|
||||
computeVal look v = case v of
|
||||
VClos g@(_:_) e -> do
|
||||
e' <- compt (map fst g) e --- bindings of g in e?
|
||||
whnf $ VClos g e'
|
||||
{- ----
|
||||
_ -> do ---- how to compute a Val, really??
|
||||
e <- val2exp v
|
||||
e' <- compt [] e
|
||||
whnf $ vClos e'
|
||||
-}
|
||||
VApp f c -> liftM2 VApp (compv f) (compv c) >>= whnf
|
||||
_ -> whnf v
|
||||
where
|
||||
compt = computeAbsTermIn look
|
||||
compv = computeVal look
|
||||
|
||||
-- | take apart constraints that have the form (? <> t), usable as solutions
|
||||
splitConstraints :: GFCGrammar -> Constraints -> (Constraints,MetaSubst)
|
||||
splitConstraints gr = splitConstraintsGen (lookupAbsDef gr)
|
||||
|
||||
splitConstraintsSrc :: Grammar -> Constraints -> (Constraints,MetaSubst)
|
||||
splitConstraintsSrc gr = splitConstraintsGen (Lookup.lookupAbsDef gr)
|
||||
|
||||
splitConstraintsGen :: LookDef -> Constraints -> (Constraints,MetaSubst)
|
||||
splitConstraintsGen look cs = csmsu where
|
||||
|
||||
csmsu = (nub [(a,b) | (a,b) <- csf1,a /= b],msf1)
|
||||
(csf1,msf1) = unif (csf,msf) -- alternative: filter first
|
||||
(csf,msf) = foldr mkOne ([],[]) cs
|
||||
|
||||
csmsf = foldr mkOne ([],msu) csu
|
||||
(csu,msu) = unif (cs1,[]) -- alternative: unify first
|
||||
|
||||
cs1 = errVal cs $ reduceConstraints look 0 cs
|
||||
|
||||
mkOne (u,v) = case (u,v) of
|
||||
(VClos g (Meta m), v) | null g -> sub m v
|
||||
(v, VClos g (Meta m)) | null g -> sub m v
|
||||
-- do nothing if meta has nonempty closure; null g || isConstVal v WAS WRONG
|
||||
c -> con c
|
||||
con c (cs,ms) = (c:cs,ms)
|
||||
sub m v (cs,ms) = (cs,(m,v):ms)
|
||||
|
||||
unifo = id -- alternative: don't use unification
|
||||
|
||||
unif cm@(cs,ms) = errVal cm $ do --- alternative: use unification
|
||||
(cs',ms') <- unifyVal cs
|
||||
return (cs', ms' ++ ms)
|
||||
|
||||
performMetaSubstNode :: MetaSubst -> TrNode -> TrNode
|
||||
performMetaSubstNode subst n@(N (b,a,v,(c,m),s)) = let
|
||||
v' = metaSubstVal v
|
||||
b' = [(x,metaSubstVal v) | (x,v) <- b]
|
||||
c' = [(u',v') | (u,v) <- c,
|
||||
let (u',v') = (metaSubstVal u, metaSubstVal v), u' /= v']
|
||||
in N (b',a,v',(c',m),s)
|
||||
where
|
||||
metaSubstVal u = errVal u $ whnf $ case u of
|
||||
VApp f a -> VApp (metaSubstVal f) (metaSubstVal a)
|
||||
VClos g e -> VClos [(x,metaSubstVal v) | (x,v) <- g] (metaSubstExp e)
|
||||
_ -> u
|
||||
metaSubstExp e = case e of
|
||||
Meta m -> errVal e $ maybe (return e) val2expSafe $ lookup m subst
|
||||
_ -> composSafeOp metaSubstExp e
|
||||
|
||||
reduceConstraintsNode :: GFCGrammar -> TrNode -> TrNode
|
||||
reduceConstraintsNode gr = changeConstrs red where
|
||||
red cs = errVal cs $ reduceConstraints (lookupAbsDef gr) 0 cs
|
||||
|
||||
-- | weak heuristic to narrow down menus; not used for TC. 15\/11\/2001.
|
||||
-- the age-old method from GF 0.9
|
||||
possibleConstraints :: GFCGrammar -> Constraints -> Bool
|
||||
possibleConstraints gr = and . map (possibleConstraint gr)
|
||||
|
||||
possibleConstraint :: GFCGrammar -> (Val,Val) -> Bool
|
||||
possibleConstraint gr (u,v) = errVal True $ do
|
||||
u' <- val2exp u >>= compute gr
|
||||
v' <- val2exp v >>= compute gr
|
||||
return $ cts u' v'
|
||||
where
|
||||
cts t u = isUnknown t || isUnknown u || case (t,u) of
|
||||
(Q m c, Q n d) -> c == d || notCan (m,c) || notCan (n,d)
|
||||
(QC m c, QC n d) -> c == d
|
||||
(App f a, App g b) -> cts f g && cts a b
|
||||
(Abs x b, Abs y c) -> cts b c
|
||||
(Prod x a f, Prod y b g) -> cts a b && cts f g
|
||||
(_ , _) -> False
|
||||
|
||||
isUnknown t = case t of
|
||||
Vr _ -> True
|
||||
Meta _ -> True
|
||||
_ -> False
|
||||
|
||||
notCan = not . isPrimitiveFun gr
|
||||
|
||||
-- interface to TC type checker
|
||||
|
||||
type2val :: Type -> Val
|
||||
type2val = VClos []
|
||||
|
||||
aexp2tree :: (AExp,[(Val,Val)]) -> Err Tree
|
||||
aexp2tree (aexp,cs) = do
|
||||
(bi,at,vt,ts) <- treeForm aexp
|
||||
ts' <- mapM aexp2tree [(t,[]) | t <- ts]
|
||||
return $ Tr (N (bi,at,vt,(cs,[]),False),ts')
|
||||
where
|
||||
treeForm a = case a of
|
||||
AAbs x v b -> do
|
||||
(bi, at, vt, args) <- treeForm b
|
||||
v' <- whnf v ---- should not be needed...
|
||||
return ((x,v') : bi, at, vt, args)
|
||||
AApp c a v -> do
|
||||
(_,at,_,args) <- treeForm c
|
||||
v' <- whnf v ----
|
||||
return ([],at,v',args ++ [a])
|
||||
AVr x v -> do
|
||||
v' <- whnf v ----
|
||||
return ([],AtV x,v',[])
|
||||
ACn c v -> do
|
||||
v' <- whnf v ----
|
||||
return ([],AtC c,v',[])
|
||||
AInt i -> do
|
||||
return ([],AtI i,valAbsInt,[])
|
||||
AFloat i -> do
|
||||
return ([],AtF i,valAbsFloat,[])
|
||||
AStr s -> do
|
||||
return ([],AtL s,valAbsString,[])
|
||||
AMeta m v -> do
|
||||
v' <- whnf v ----
|
||||
return ([],AtM m,v',[])
|
||||
_ -> Bad "illegal tree" -- AProd
|
||||
|
||||
grammar2theory :: GFCGrammar -> Theory
|
||||
grammar2theory gr (m,f) = case lookupFunType gr m f of
|
||||
Ok t -> return $ type2val t
|
||||
Bad s -> case lookupCatContext gr m f of
|
||||
Ok cont -> return $ cont2val cont
|
||||
_ -> Bad s
|
||||
|
||||
cont2exp :: Context -> Exp
|
||||
cont2exp c = mkProd (c, eType, []) -- to check a context
|
||||
|
||||
cont2val :: Context -> Val
|
||||
cont2val = type2val . cont2exp
|
||||
|
||||
-- some top-level batch-mode checkers for the compiler
|
||||
|
||||
justTypeCheckSrc :: Grammar -> Exp -> Val -> Err Constraints
|
||||
justTypeCheckSrc gr e v = do
|
||||
(_,constrs0) <- checkExp (grammar2theorySrc gr) (initTCEnv []) e v
|
||||
return $ filter notJustMeta constrs0
|
||||
---- return $ fst $ splitConstraintsSrc gr constrs0
|
||||
---- this change was to force proper tc of abstract modules.
|
||||
---- May not be quite right. AR 13/9/2005
|
||||
|
||||
notJustMeta (c,k) = case (c,k) of
|
||||
(VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False
|
||||
_ -> True
|
||||
|
||||
grammar2theorySrc :: Grammar -> Theory
|
||||
grammar2theorySrc gr (m,f) = case lookupFunTypeSrc gr m f of
|
||||
Ok t -> return $ type2val t
|
||||
Bad s -> case lookupCatContextSrc gr m f of
|
||||
Ok cont -> return $ cont2val cont
|
||||
_ -> Bad s
|
||||
|
||||
checkContext :: Grammar -> Context -> [String]
|
||||
checkContext st = checkTyp st . cont2exp
|
||||
|
||||
checkTyp :: Grammar -> Type -> [String]
|
||||
checkTyp gr typ = err singleton prConstrs $ justTypeCheckSrc gr typ vType
|
||||
|
||||
checkEquation :: Grammar -> Fun -> Trm -> [String]
|
||||
checkEquation gr (m,fun) def = err singleton id $ do
|
||||
typ <- lookupFunTypeSrc gr m fun
|
||||
---- cs <- checkEqs (grammar2theorySrc gr) (initTCEnv []) ((m,fun),def) (vClos typ)
|
||||
cs <- justTypeCheckSrc gr def (vClos typ)
|
||||
let cs1 = filter notJustMeta cs ----- filter (not . possibleConstraint gr) cs ----
|
||||
return $ ifNull [] (singleton . prConstraints) cs1
|
||||
|
||||
checkConstrs :: Grammar -> Cat -> [Ident] -> [String]
|
||||
checkConstrs gr cat _ = [] ---- check constructors!
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
{- ----
|
||||
err singleton concat . mapM checkOne where
|
||||
checkOne con = do
|
||||
typ <- lookupFunType gr con
|
||||
typ' <- computeAbsTerm gr typ
|
||||
vcat <- valCat typ'
|
||||
return $ if (cat == vcat) then [] else ["wrong type in constructor" +++ prt con]
|
||||
-}
|
||||
|
||||
editAsTermCommand :: GFCGrammar -> (Loc TrNode -> Err (Loc TrNode)) -> Exp -> [Exp]
|
||||
editAsTermCommand gr c e = err (const []) singleton $ do
|
||||
t <- annotate gr $ refreshMetas [] e
|
||||
t' <- c $ tree2loc t
|
||||
return $ tree2exp $ loc2tree t'
|
||||
|
||||
exp2termCommand :: GFCGrammar -> (Exp -> Err Exp) -> Tree -> Err Tree
|
||||
exp2termCommand gr f t = errIn ("modifying term" +++ prt t) $ do
|
||||
let exp = tree2exp t
|
||||
exp2 <- f exp
|
||||
annotate gr exp2
|
||||
|
||||
exp2termlistCommand :: GFCGrammar -> (Exp -> [Exp]) -> Tree -> [Tree]
|
||||
exp2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f . tree2exp
|
||||
|
||||
tree2termlistCommand :: GFCGrammar -> (Tree -> [Exp]) -> Tree -> [Tree]
|
||||
tree2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f
|
||||
Reference in New Issue
Block a user