forked from GitHub/gf-core
GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3
This commit is contained in:
aarne
341
src-3.0/GF/Grammar/MMacros.hs
Normal file
341
src-3.0/GF/Grammar/MMacros.hs
Normal file
@@ -0,0 +1,341 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : MMacros
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/10 12:49:13 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.9 $
|
||||
--
|
||||
-- some more abstractions on grammars, esp. for Edit
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Grammar.MMacros where
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Data.Zipper
|
||||
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.PrGrammar
|
||||
import GF.Infra.Ident
|
||||
import GF.Grammar.Refresh
|
||||
import GF.Grammar.Values
|
||||
----import GrammarST
|
||||
import GF.Grammar.Macros
|
||||
|
||||
import Control.Monad
|
||||
|
||||
nodeTree :: Tree -> TrNode
|
||||
argsTree :: Tree -> [Tree]
|
||||
|
||||
nodeTree (Tr (n,_)) = n
|
||||
argsTree (Tr (_,ts)) = ts
|
||||
|
||||
isFocusNode :: TrNode -> Bool
|
||||
bindsNode :: TrNode -> Binds
|
||||
atomNode :: TrNode -> Atom
|
||||
valNode :: TrNode -> Val
|
||||
constrsNode :: TrNode -> Constraints
|
||||
metaSubstsNode :: TrNode -> MetaSubst
|
||||
|
||||
isFocusNode (N (_,_,_,_,b)) = b
|
||||
bindsNode (N (b,_,_,_,_)) = b
|
||||
atomNode (N (_,a,_,_,_)) = a
|
||||
valNode (N (_,_,v,_,_)) = v
|
||||
constrsNode (N (_,_,_,(c,_),_)) = c
|
||||
metaSubstsNode (N (_,_,_,(_,m),_)) = m
|
||||
|
||||
atomTree :: Tree -> Atom
|
||||
valTree :: Tree -> Val
|
||||
|
||||
atomTree = atomNode . nodeTree
|
||||
valTree = valNode . nodeTree
|
||||
|
||||
mkNode :: Binds -> Atom -> Val -> (Constraints, MetaSubst) -> TrNode
|
||||
mkNode binds atom vtyp cs = N (binds,atom,vtyp,cs,False)
|
||||
|
||||
type Var = Ident
|
||||
type Meta = MetaSymb
|
||||
|
||||
metasTree :: Tree -> [Meta]
|
||||
metasTree = concatMap metasNode . scanTree where
|
||||
metasNode n = [m | AtM m <- [atomNode n]] ++ map fst (metaSubstsNode n)
|
||||
|
||||
varsTree :: Tree -> [(Var,Val)]
|
||||
varsTree t = [(x,v) | N (_,AtV x,v,_,_) <- scanTree t]
|
||||
|
||||
constrsTree :: Tree -> Constraints
|
||||
constrsTree = constrsNode . nodeTree
|
||||
|
||||
allConstrsTree :: Tree -> Constraints
|
||||
allConstrsTree = concatMap constrsNode . scanTree
|
||||
|
||||
changeConstrs :: (Constraints -> Constraints) -> TrNode -> TrNode
|
||||
changeConstrs f (N (b,a,v,(c,m),x)) = N (b,a,v,(f c, m),x)
|
||||
|
||||
changeMetaSubst :: (MetaSubst -> MetaSubst) -> TrNode -> TrNode
|
||||
changeMetaSubst f (N (b,a,v,(c,m),x)) = N (b,a,v,(c, f m),x)
|
||||
|
||||
changeAtom :: (Atom -> Atom) -> TrNode -> TrNode
|
||||
changeAtom f (N (b,a,v,(c,m),x)) = N (b,f a,v,(c, m),x)
|
||||
|
||||
-- * on the way to Edit
|
||||
|
||||
uTree :: Tree
|
||||
uTree = Tr (uNode, []) -- unknown tree
|
||||
|
||||
uNode :: TrNode
|
||||
uNode = mkNode [] uAtom uVal ([],[])
|
||||
|
||||
|
||||
uAtom :: Atom
|
||||
uAtom = AtM meta0
|
||||
|
||||
mAtom :: Atom
|
||||
mAtom = AtM meta0
|
||||
|
||||
uVal :: Val
|
||||
uVal = vClos uExp
|
||||
|
||||
vClos :: Exp -> Val
|
||||
vClos = VClos []
|
||||
|
||||
uExp :: Exp
|
||||
uExp = Meta meta0
|
||||
|
||||
mExp, mExp0 :: Exp
|
||||
mExp = Meta meta0
|
||||
mExp0 = mExp
|
||||
|
||||
meta2exp :: MetaSymb -> Exp
|
||||
meta2exp = Meta
|
||||
|
||||
atomC :: Fun -> Atom
|
||||
atomC = AtC
|
||||
|
||||
funAtom :: Atom -> Err Fun
|
||||
funAtom a = case a of
|
||||
AtC f -> return f
|
||||
_ -> prtBad "not function head" a
|
||||
|
||||
uBoundVar :: Ident
|
||||
uBoundVar = zIdent "#h" -- used for suppressed bindings
|
||||
|
||||
atomIsMeta :: Atom -> Bool
|
||||
atomIsMeta atom = case atom of
|
||||
AtM _ -> True
|
||||
_ -> False
|
||||
|
||||
getMetaAtom :: Atom -> Err Meta
|
||||
getMetaAtom a = case a of
|
||||
AtM m -> return m
|
||||
_ -> Bad "the active node is not meta"
|
||||
|
||||
cat2val :: Context -> Cat -> Val
|
||||
cat2val cont cat = vClos $ mkApp (qq cat) [mkMeta i | i <- [1..length cont]]
|
||||
|
||||
val2cat :: Val -> Err Cat
|
||||
val2cat v = val2exp v >>= valCat
|
||||
|
||||
substTerm :: [Ident] -> Substitution -> Term -> Term
|
||||
substTerm ss g c = case c of
|
||||
Vr x -> maybe c id $ lookup x g
|
||||
App f a -> App (substTerm ss g f) (substTerm ss g a)
|
||||
Abs x b -> let y = mkFreshVarX ss x in
|
||||
Abs y (substTerm (y:ss) ((x, Vr y):g) b)
|
||||
Prod x a b -> let y = mkFreshVarX ss x in
|
||||
Prod y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) b)
|
||||
_ -> c
|
||||
|
||||
metaSubstExp :: MetaSubst -> [(Meta,Exp)]
|
||||
metaSubstExp msubst = [(m, errVal (meta2exp m) (val2expSafe v)) | (m,v) <- msubst]
|
||||
|
||||
-- * belong here rather than to computation
|
||||
|
||||
substitute :: [Var] -> Substitution -> Exp -> Err Exp
|
||||
substitute v s = return . substTerm v s
|
||||
|
||||
alphaConv :: [Var] -> (Var,Var) -> Exp -> Err Exp ---
|
||||
alphaConv oldvars (x,x') = substitute (x:x':oldvars) [(x,Vr x')]
|
||||
|
||||
alphaFresh :: [Var] -> Exp -> Err Exp
|
||||
alphaFresh vs = refreshTermN $ maxVarIndex vs
|
||||
|
||||
-- | done in a state monad
|
||||
alphaFreshAll :: [Var] -> [Exp] -> Err [Exp]
|
||||
alphaFreshAll vs = mapM $ alphaFresh vs
|
||||
|
||||
-- | for display
|
||||
val2exp :: Val -> Err Exp
|
||||
val2exp = val2expP False
|
||||
|
||||
-- | for type checking
|
||||
val2expSafe :: Val -> Err Exp
|
||||
val2expSafe = val2expP True
|
||||
|
||||
val2expP :: Bool -> Val -> Err Exp
|
||||
val2expP safe v = case v of
|
||||
|
||||
VClos g@(_:_) e@(Meta _) -> if safe
|
||||
then prtBad "unsafe value substitution" v
|
||||
else substVal g e
|
||||
VClos g e -> substVal g e
|
||||
VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c)
|
||||
VCn c -> return $ qq c
|
||||
VGen i x -> if safe
|
||||
then prtBad "unsafe val2exp" v
|
||||
else return $ vr $ x --- in editing, no alpha conversions presentv
|
||||
where
|
||||
substVal g e = mapPairsM (val2expP safe) g >>= return . (\s -> substTerm [] s e)
|
||||
|
||||
isConstVal :: Val -> Bool
|
||||
isConstVal v = case v of
|
||||
VApp f c -> isConstVal f && isConstVal c
|
||||
VCn _ -> True
|
||||
VClos [] e -> null $ freeVarsExp e
|
||||
_ -> False --- could be more liberal
|
||||
|
||||
mkProdVal :: Binds -> Val -> Err Val ---
|
||||
mkProdVal bs v = do
|
||||
bs' <- mapPairsM val2exp bs
|
||||
v' <- val2exp v
|
||||
return $ vClos $ foldr (uncurry Prod) v' bs'
|
||||
|
||||
freeVarsExp :: Exp -> [Ident]
|
||||
freeVarsExp e = case e of
|
||||
Vr x -> [x]
|
||||
App f c -> freeVarsExp f ++ freeVarsExp c
|
||||
Abs x b -> filter (/=x) (freeVarsExp b)
|
||||
Prod x a b -> freeVarsExp a ++ filter (/=x) (freeVarsExp b)
|
||||
_ -> [] --- thus applies to abstract syntax only
|
||||
|
||||
ident2string :: Ident -> String
|
||||
ident2string = prIdent
|
||||
|
||||
tree :: (TrNode,[Tree]) -> Tree
|
||||
tree = Tr
|
||||
|
||||
eqCat :: Cat -> Cat -> Bool
|
||||
eqCat = (==)
|
||||
|
||||
addBinds :: Binds -> Tree -> Tree
|
||||
addBinds b (Tr (N (b0,at,t,c,x),ts)) = Tr (N (b ++ b0,at,t,c,x),ts)
|
||||
|
||||
bodyTree :: Tree -> Tree
|
||||
bodyTree (Tr (N (_,a,t,c,x),ts)) = Tr (N ([],a,t,c,x),ts)
|
||||
|
||||
refreshMetas :: [Meta] -> Exp -> Exp
|
||||
refreshMetas metas = fst . rms minMeta where
|
||||
rms meta trm = case trm of
|
||||
Meta m -> (Meta meta, nextMeta meta)
|
||||
App f a -> let (f',msf) = rms meta f
|
||||
(a',msa) = rms msf a
|
||||
in (App f' a', msa)
|
||||
Prod x a b ->
|
||||
let (a',msa) = rms meta a
|
||||
(b',msb) = rms msa b
|
||||
in (Prod x a' b', msb)
|
||||
Abs x b -> let (b',msb) = rms meta b in (Abs x b', msb)
|
||||
_ -> (trm,meta)
|
||||
minMeta = int2meta $
|
||||
if null metas then 0 else (maximum (map metaSymbInt metas) + 1)
|
||||
|
||||
ref2exp :: [Var] -> Type -> Ref -> Err Exp
|
||||
ref2exp bounds typ ref = do
|
||||
cont <- contextOfType typ
|
||||
xx0 <- mapM (typeSkeleton . snd) cont
|
||||
let (xxs,cs) = unzip [(length hs, c) | (hs,c) <- xx0]
|
||||
args = [mkAbs xs mExp | i <- xxs, let xs = mkFreshVars i bounds]
|
||||
return $ mkApp ref args
|
||||
-- no refreshment of metas
|
||||
|
||||
-- | invariant: only 'Con' or 'Var'
|
||||
type Ref = Exp
|
||||
|
||||
fun2wrap :: [Var] -> ((Fun,Int),Type) -> Exp -> Err Exp
|
||||
fun2wrap oldvars ((fun,i),typ) exp = do
|
||||
cont <- contextOfType typ
|
||||
args <- mapM mkArg (zip [0..] (map snd cont))
|
||||
return $ mkApp (qq fun) args
|
||||
where
|
||||
mkArg (n,c) = do
|
||||
cont <- contextOfType c
|
||||
let vars = mkFreshVars (length cont) oldvars
|
||||
return $ mkAbs vars $ if n==i then exp else mExp
|
||||
|
||||
-- | weak heuristics: sameness of value category
|
||||
compatType :: Val -> Type -> Bool
|
||||
compatType v t = errVal True $ do
|
||||
cat1 <- val2cat v
|
||||
cat2 <- valCat t
|
||||
return $ cat1 == cat2
|
||||
|
||||
---
|
||||
|
||||
mkJustProd :: Context -> Term -> Term
|
||||
mkJustProd cont typ = mkProd (cont,typ,[])
|
||||
|
||||
int2var :: Int -> Ident
|
||||
int2var = zIdent . ('$':) . show
|
||||
|
||||
meta0 :: Meta
|
||||
meta0 = int2meta 0
|
||||
|
||||
termMeta0 :: Term
|
||||
termMeta0 = Meta meta0
|
||||
|
||||
identVar :: Term -> Err Ident
|
||||
identVar (Vr x) = return x
|
||||
identVar _ = Bad "not a variable"
|
||||
|
||||
|
||||
-- | light-weight rename for user interaction; also change names of internal vars
|
||||
qualifTerm :: Ident -> Term -> Term
|
||||
qualifTerm m = qualif [] where
|
||||
qualif xs t = case t of
|
||||
Abs x b -> let x' = chV x in Abs x' $ qualif (x':xs) b
|
||||
Prod x a b -> Prod x (qualif xs a) $ qualif (x:xs) b
|
||||
Vr x -> let x' = chV x in if (elem x' xs) then (Vr x') else (Q m x)
|
||||
Cn c -> Q m c
|
||||
Con c -> QC m c
|
||||
_ -> composSafeOp (qualif xs) t
|
||||
chV x = string2var $ prIdent x
|
||||
|
||||
string2var :: String -> Ident
|
||||
string2var s = case s of
|
||||
c:'_':i -> identV (readIntArg i,[c]) ---
|
||||
_ -> zIdent s
|
||||
|
||||
-- | reindex variables so that they tell nesting depth level
|
||||
reindexTerm :: Term -> Term
|
||||
reindexTerm = qualif (0,[]) where
|
||||
qualif dg@(d,g) t = case t of
|
||||
Abs x b -> let x' = ind x d in Abs x' $ qualif (d+1, (x,x'):g) b
|
||||
Prod x a b -> let x' = ind x d in Prod x' (qualif dg a) $ qualif (d+1, (x,x'):g) b
|
||||
Vr x -> Vr $ look x g
|
||||
_ -> composSafeOp (qualif dg) t
|
||||
look x = maybe x id . lookup x --- if x is not in scope it is unchanged
|
||||
ind x d = identC $ prIdent x ++ "_" ++ show d
|
||||
|
||||
|
||||
-- this method works for context-free abstract syntax
|
||||
-- and is meant to be used in simple embedded GF applications
|
||||
|
||||
exp2tree :: Exp -> Err Tree
|
||||
exp2tree e = do
|
||||
(bs,f,xs) <- termForm e
|
||||
cont <- case bs of
|
||||
[] -> return []
|
||||
_ -> prtBad "cannot convert bindings in" e
|
||||
at <- case f of
|
||||
Q m c -> return $ AtC (m,c)
|
||||
QC m c -> return $ AtC (m,c)
|
||||
Meta m -> return $ AtM m
|
||||
K s -> return $ AtL s
|
||||
EInt n -> return $ AtI n
|
||||
EFloat n -> return $ AtF n
|
||||
_ -> prtBad "cannot convert to atom" f
|
||||
ts <- mapM exp2tree xs
|
||||
return $ Tr (N (cont,at,uVal,([],[]),True),ts)
|
||||
Reference in New Issue
Block a user