summaryrefslogtreecommitdiff
path: root/src/GF/UseGrammar/Editing.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/UseGrammar/Editing.hs')
-rw-r--r--src/GF/UseGrammar/Editing.hs435
1 files changed, 0 insertions, 435 deletions
diff --git a/src/GF/UseGrammar/Editing.hs b/src/GF/UseGrammar/Editing.hs
deleted file mode 100644
index 762562eb0..000000000
--- a/src/GF/UseGrammar/Editing.hs
+++ /dev/null
@@ -1,435 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Editing
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:23:45 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.14 $
---
--- generic tree editing, with some grammar notions assumed. AR 18\/8\/2001.
--- 19\/6\/2003 for GFC
------------------------------------------------------------------------------
-
-module GF.UseGrammar.Editing where
-
-import GF.Grammar.Abstract
-import qualified GF.Canon.GFC as GFC
-import GF.Grammar.TypeCheck
-import GF.Grammar.LookAbs
-import GF.Grammar.AbsCompute
-import GF.Grammar.Macros (errorCat)
-
-import GF.Data.Operations
-import GF.Data.Zipper
-
--- generic tree editing, with some grammar notions assumed. AR 18/8/2001
--- 19/6/2003 for GFC
-
-type CGrammar = GFC.CanonGrammar
-
-type State = Loc TrNode
-
--- | the "empty" state
-initState :: State
-initState = tree2loc uTree
-
-isRootState :: State -> Bool
-isRootState s = case actPath s of
- Top -> True
- _ -> False
-
-actTree :: State -> Tree
-actTree (Loc (t,_)) = t
-
-actPath :: State -> Path TrNode
-actPath (Loc (_,p)) = p
-
-actVal :: State -> Val
-actVal = valNode . nodeTree . actTree
-
-actCat :: State -> Cat
-actCat = errVal errorCat . val2cat . actVal ---- undef
-
-actAtom :: State -> Atom
-actAtom = atomTree . actTree
-
-actFun :: State -> Err Fun
-actFun s = case actAtom s of
- AtC f -> return f
- t -> prtBad "active atom: expected function, found" t
-
-actExp :: State -> Exp
-actExp = tree2exp . actTree
-
--- | current local bindings
-actBinds :: State -> Binds
-actBinds = bindsNode . nodeTree . actTree
-
--- | constraints in current subtree
-actConstrs :: State -> Constraints
-actConstrs = allConstrsTree . actTree
-
--- | constraints in the whole tree
-allConstrs :: State -> Constraints
-allConstrs = allConstrsTree . loc2tree
-
--- | metas in current subtree
-actMetas :: State -> [Meta]
-actMetas = metasTree . actTree
-
--- | metas in the whole tree
-allMetas :: State -> [Meta]
-allMetas = metasTree . loc2tree
-
-actTreeBody :: State -> Tree
-actTreeBody = bodyTree . actTree
-
-allPrevBinds :: State -> Binds
-allPrevBinds = concatMap bindsNode . traverseCollect . actPath
-
-allBinds :: State -> Binds
-allBinds s = actBinds s ++ allPrevBinds s
-
-actGen :: State -> Int
-actGen = length . allBinds -- symbol generator for VGen
-
-allPrevVars :: State -> [Var]
-allPrevVars = map fst . allPrevBinds
-
-allVars :: State -> [Var]
-allVars = map fst . allBinds
-
-vGenIndex :: State -> Int
-vGenIndex = length . allBinds
-
-actIsMeta :: State -> Bool
-actIsMeta = atomIsMeta . actAtom
-
-actMeta :: State -> Err Meta
-actMeta = getMetaAtom . actAtom
-
--- | meta substs are not only on the actual path...
-entireMetaSubst :: State -> MetaSubst
-entireMetaSubst = concatMap metaSubstsNode . scanTree . loc2tree
-
-isCompleteTree :: Tree -> Bool
-isCompleteTree = null . filter atomIsMeta . map atomNode . scanTree
-
-isCompleteState :: State -> Bool
-isCompleteState = isCompleteTree . loc2tree
-
-initStateCat :: Context -> Cat -> Err State
-initStateCat cont cat = do
- return $ tree2loc (Tr (mkNode [] mAtom (cat2val cont cat) ([],[]), []))
-
--- | this function only concerns the body of an expression...
-annotateInState :: CGrammar -> Exp -> State -> Err Tree
-annotateInState gr exp state = do
- let binds = allBinds state
- val = actVal state
- annotateIn gr binds exp (Just val)
-
--- | ...whereas this one works with lambda abstractions
-annotateExpInState :: CGrammar -> Exp -> State -> Err Tree
-annotateExpInState gr exp state = do
- let cont = allPrevBinds state
- binds = actBinds state
- val = actVal state
- typ <- mkProdVal binds val
- annotateIn gr binds exp (Just typ)
-
-treeByExp :: (Exp -> Err Exp) -> CGrammar -> Exp -> State -> Err Tree
-treeByExp trans gr exp0 state = do
- exp <- trans exp0
- annotateExpInState gr exp state
-
--- * actions
-
-type Action = State -> Err State
-
-newCat :: CGrammar -> Cat -> Action
-newCat gr cat@(m,c) _ = do
- cont <- lookupCatContext gr m c
- testErr (null cont) "start cat must have null context" -- for easier meta refresh
- initStateCat cont cat
-
-newFun :: CGrammar -> Fun -> Action
-newFun gr fun@(m,c) _ = do
- typ <- lookupFunType gr m c
- cat <- valCat typ
- st1 <- newCat gr cat initState
- refineWithAtom True gr (qq fun) st1
-
-newTree :: Tree -> Action
-newTree t _ = return $ tree2loc t
-
-newExpTC :: CGrammar -> Exp -> Action
-newExpTC gr t s = annotate gr (refreshMetas [] t) >>= flip newTree s
-
-goNextMeta, goPrevMeta, goNextNewMeta, goPrevNewMeta, goNextMetaIfCan :: Action
-
-goNextMeta = repeatUntilErr actIsMeta goAhead -- can be the location itself
-goPrevMeta = repeatUntilErr actIsMeta goBack
-
-goNextNewMeta s = goAhead s >>= goNextMeta -- always goes away from location
-goPrevNewMeta s = goBack s >>= goPrevMeta
-
-goNextMetaIfCan = actionIfPossible goNextMeta
-
-actionIfPossible :: Action -> Action
-actionIfPossible a s = return $ errVal s (a s)
-
-goFirstMeta, goLastMeta :: Action
-goFirstMeta s = goNextMeta $ goRoot s
-goLastMeta s = goLast s >>= goPrevMeta
-
-noMoreMetas :: State -> Bool
-noMoreMetas = err (const True) (const False) . goNextMeta
-
-replaceSubTree :: Tree -> Action
-replaceSubTree tree state = changeLoc state tree
-
-refineOrReplaceWithTree :: Bool -> CGrammar -> Tree -> Action
-refineOrReplaceWithTree der gr tree state = case actMeta state of
- Ok m -> refineWithTreeReal der gr tree m state
- _ -> do
- let tree1 = addBinds (actBinds state) $ tree
- state' <- replaceSubTree tree1 state
- reCheckState gr state'
-
-refineWithTree :: Bool -> CGrammar -> Tree -> Action
-refineWithTree der gr tree state = do
- m <- errIn "move pointer to meta" $ actMeta state
- refineWithTreeReal der gr tree m state
-
-refineWithTreeReal :: Bool -> CGrammar -> Tree -> Meta -> Action
-refineWithTreeReal der gr tree m state = do
- state' <- replaceSubTree tree state
- let cs0 = allConstrs state'
- (cs,ms) = splitConstraints gr cs0
- v = vClos $ tree2exp (bodyTree tree)
- msubst = (m,v) : ms
- metaSubstRefinements gr msubst $
- mapLoc (reduceConstraintsNode gr . performMetaSubstNode msubst) state'
-
- -- without dep. types, no constraints, no grammar needed - simply: do
- -- testErr (actIsMeta state) "move pointer to meta"
- -- replaceSubTree tree state
-
-refineAllNodes :: Action -> Action
-refineAllNodes act state = do
- let estate0 = goFirstMeta state
- case estate0 of
- Bad _ -> return state
- Ok state0 -> do
- (state',n) <- tryRefine 0 state0
- if n==0
- then return state
- else actionIfPossible goFirstMeta state'
- where
- tryRefine n state = err (const $ return (state,n)) return $ do
- state' <- goNextMeta state
- meta <- actMeta state'
- case act state' of
- Ok state2 -> tryRefine (n+1) state2
- _ -> err (const $ return (state',n)) return $ do
- state2 <- goNextNewMeta state'
- tryRefine n state2
-
-uniqueRefinements :: CGrammar -> Action
-uniqueRefinements = refineAllNodes . uniqueRefine
-
-metaSubstRefinements :: CGrammar -> MetaSubst -> Action
-metaSubstRefinements gr = refineAllNodes . metaSubstRefine gr
-
-contextRefinements :: CGrammar -> Action
-contextRefinements gr = refineAllNodes contextRefine where
- contextRefine state = case varRefinementsState state of
- [(e,_)] -> refineWithAtom False gr e state
- _ -> Bad "no unique refinement in context"
- varRefinementsState state =
- [r | r@(e,_) <- refinementsState gr state, isVariable e]
-
-uniqueRefine :: CGrammar -> Action
-uniqueRefine gr state = case refinementsState gr state of
- [(e,(_,True))] -> Bad "only circular refinement"
- [(e,_)] -> refineWithAtom False gr e state
- _ -> Bad "no unique refinement"
-
-metaSubstRefine :: CGrammar -> MetaSubst -> Action
-metaSubstRefine gr msubst state = do
- m <- errIn "move pointer to meta" $ actMeta state
- case lookup m msubst of
- Just v -> do
- e <- val2expSafe v
- refineWithExpTC False gr e state
- _ -> Bad "no metavariable substitution available"
-
-refineWithExpTC :: Bool -> CGrammar -> Exp -> Action
-refineWithExpTC der gr exp0 state = do
- let oldmetas = allMetas state
- exp = refreshMetas oldmetas exp0
- tree0 <- annotateInState gr exp state
- let tree = addBinds (actBinds state) $ tree0
- refineWithTree der gr tree state
-
-refineWithAtom :: Bool -> CGrammar -> Ref -> Action -- function or variable
-refineWithAtom der gr at state = do
- val <- lookupRef gr (allBinds state) at
- typ <- val2exp val
- let oldvars = allVars state
- exp <- ref2exp oldvars typ at
- refineWithExpTC der gr exp state
-
--- | in this command, we know that the result is well-typed, since computation
--- rules have been type checked and the result is equal
-computeSubTree :: CGrammar -> Action
-computeSubTree gr state = do
- let exp = tree2exp (actTree state)
- tree <- treeByExp (compute gr) gr exp state
- replaceSubTree tree state
-
--- | but here we don't, since the transfer flag isn't type checked,
--- and computing the transfer function is not checked to preserve equality
-transferSubTree :: Maybe Fun -> CGrammar -> Action
-transferSubTree Nothing _ s = return s
-transferSubTree (Just fun) gr state = do
- let exp = mkApp (qq fun) [tree2exp $ actTree state]
- tree <- treeByExp (compute gr) gr exp state
- state' <- replaceSubTree tree state
- reCheckState gr state'
-
-deleteSubTree :: CGrammar -> Action
-deleteSubTree gr state =
- if isRootState state
- then do
- let cat = actCat state
- newCat gr cat state
- else do
- let metas = allMetas state
- binds = actBinds state
- exp = refreshMetas metas mExp0
- tree <- annotateInState gr exp state
- state' <- replaceSubTree (addBinds binds tree) state
- reCheckState gr state' --- must be unfortunately done. 20/11/2001
-
-wrapWithFun :: CGrammar -> (Fun,Int) -> Action
-wrapWithFun gr (f@(m,c),i) state = do
- typ <- lookupFunType gr m c
- let olds = allPrevVars state
- oldmetas = allMetas state
- exp0 <- fun2wrap olds ((f,i),typ) (tree2exp (actTreeBody state))
- let exp = refreshMetas oldmetas exp0
- tree0 <- annotateInState gr exp state
- let tree = addBinds (actBinds state) $ tree0
- state' <- replaceSubTree tree state
- reCheckState gr state' --- must be unfortunately done. 20/11/2001
-
-alphaConvert :: CGrammar -> (Var,Var) -> Action
-alphaConvert gr (x,x') state = do
- let oldvars = allPrevVars state
- testErr (notElem x' oldvars) ("clash with previous bindings" +++ show x')
- let binds0 = actBinds state
- vars0 = map fst binds0
- testErr (notElem x' vars0) ("clash with other bindings" +++ show x')
- let binds = [(if z==x then x' else z, t) | (z,t) <- binds0]
- vars = map fst binds
- exp' <- alphaConv (vars ++ oldvars) (x,x') (tree2exp (actTreeBody state))
- let exp = mkAbs vars exp'
- tree <- annotateExpInState gr exp state
- replaceSubTree tree state
-
-changeFunHead :: CGrammar -> Fun -> Action
-changeFunHead gr f state = do
- let state' = changeNode (changeAtom (const (atomC f))) state
- reCheckState gr state' --- must be done because of constraints elsewhere
-
-peelFunHead :: CGrammar -> (Fun,Int) -> Action
-peelFunHead gr (f@(m,c),i) state = do
- tree0 <- nthSubtree i $ actTree state
- let tree = addBinds (actBinds state) $ tree0
- state' <- replaceSubTree tree state
- reCheckState gr state' --- must be unfortunately done. 20/11/2001
-
--- | an expensive operation
-reCheckState :: CGrammar -> State -> Err State
-reCheckState gr st = annotate gr (tree2exp (loc2tree st)) >>= return . tree2loc
-
--- | a variant that returns Bad instead of a tree with unsolvable constraints
-reCheckStateReject :: CGrammar -> State -> Err State
-reCheckStateReject gr st = do
- st' <- reCheckState gr st
- rejectUnsolvable st'
-
-rejectUnsolvable :: State -> Err State
-rejectUnsolvable st = case (constrsNode $ nodeTree $ actTree st) of
- [] -> return st
- cs -> Bad $ "Unsolvable constraints:" +++ prConstraints cs
-
--- | extract metasubstitutions from constraints and solve them
-solveAll :: CGrammar -> State -> Err State
-solveAll gr st = solve st >>= solve where
- solve st0 = do ---- why need twice?
- st <- reCheckState gr st0
- let cs0 = allConstrs st
- (cs,ms) = splitConstraints gr cs0
- metaSubstRefinements gr ms $
- mapLoc (reduceConstraintsNode gr . performMetaSubstNode ms) st
-
--- * active refinements
-
-refinementsState :: CGrammar -> State -> [(Term,(Val,Bool))]
-refinementsState gr state =
- let filt = possibleRefVal gr state in
- if actIsMeta state
- then refsForType filt gr (allBinds state) (actVal state)
- else []
-
-wrappingsState :: CGrammar -> State -> [((Fun,Int),Type)]
-wrappingsState gr state
- | actIsMeta state = []
- | isRootState state = funs
- | otherwise = [rule | rule@(_,typ) <- funs, possibleRefVal gr state aval typ]
- where
- funs = funsOnType (possibleRefVal gr state) gr aval
- aval = actVal state
-
-peelingsState :: CGrammar -> State -> [(Fun,Int)]
-peelingsState gr state
- | actIsMeta state = []
- | isRootState state =
- err (const []) (\f -> [(f,i) | i <- [0 .. arityTree tree - 1]]) $ actFun state
- | otherwise =
- err (const [])
- (\f -> [fi | (fi@(g,_),typ) <- funs,
- possibleRefVal gr state aval typ,g==f]) $ actFun state
- where
- funs = funsOnType (possibleRefVal gr state) gr aval
- aval = actVal state
- tree = actTree state
-
-headChangesState :: CGrammar -> State -> [Fun]
-headChangesState gr state = errVal [] $ do
- f@(m,c) <- funAtom (actAtom state)
- typ0 <- lookupFunType gr m c
- return [fun | (fun,typ) <- funRulesOf gr, fun /= f, typ == typ0]
- --- alpha-conv !
-
-possibleRefVal :: CGrammar -> State -> Val -> Type -> Bool
-possibleRefVal gr state val typ = errVal True $ do --- was False
- vtyp <- valType typ
- let gen = actGen state
- cs <- return [(val, vClos vtyp)] --- eqVal gen val (vClos vtyp) --- only poss cs
- return $ possibleConstraints gr cs --- a simple heuristic
-
-possibleTreeVal :: CGrammar -> State -> Tree -> Bool
-possibleTreeVal gr state tree = errVal True $ do --- was False
- let aval = actVal state
- let gval = valTree tree
- let gen = actGen state
- cs <- return [(aval, gval)] --- eqVal gen val (vClos vtyp) --- only poss cs
- return $ possibleConstraints gr cs --- a simple heuristic
-
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 05:15:20 +0000