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

1 files changed, 435 insertions, 0 deletions

diff --git a/src-3.0/GF/UseGrammar/Editing.hs b/src-3.0/GF/UseGrammar/Editing.hs
new file mode 100644
index 000000000..762562eb0
--- /dev/null
+++ b/src-3.0/GF/UseGrammar/Editing.hs
@@ -0,0 +1,435 @@
+----------------------------------------------------------------------
+-- |
+-- 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
+