peel head i ; gt nometas ; gf2hs

3 files changed, 35 insertions, 17 deletions

diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index 71bbfab58..7770386ec 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -31,7 +31,7 @@ import CFtoSRG
 import Zipper
 
 import Morphology
------import GrammarToHaskell
+import GrammarToHaskell
 -----import GrammarToCanon (showCanon, showCanonOpt)
 -----import qualified GrammarToGFC as GFC
 
@@ -156,6 +156,7 @@ customGrammarPrinter =
   ,(strCI "old",     printGrammarOld . stateGrammarST)
   ,(strCI "srg",     prSRG . stateCF)
   ,(strCI "lbnf",    prLBNF . stateCF)
+  ,(strCI "haskell", grammar2haskell . stateGrammarST)
   ,(strCI "morpho",  prMorpho . stateMorpho)
   ,(strCI "fullform",prFullForm . stateMorpho)
   ,(strCI "opts",    prOpts . stateOptions)
@@ -208,7 +209,7 @@ customTermCommand =
   ,(strCI "generate",   \g t -> let gr = grammar g
                                     cat = actCat $ tree2loc t --- not needed
                                 in
-                         [tr | t <- generateTrees gr cat 2 Nothing (Just t), 
+                         [tr | t <- generateTrees gr False cat 2 Nothing (Just t), 
                                Ok tr <- [annotate gr $ MM.qualifTerm (absId g) t]])
 
   ,(strCI "typecheck",  \g t -> let gr = grammar g in
diff --git a/src/GF/UseGrammar/Editing.hs b/src/GF/UseGrammar/Editing.hs
index 3c3567394..6f444efe8 100644
--- a/src/GF/UseGrammar/Editing.hs
+++ b/src/GF/UseGrammar/Editing.hs
@@ -40,6 +40,11 @@ actCat = errVal undefined . 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 = tree2exp . actTree
 
 -- current local bindings
@@ -319,10 +324,12 @@ 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 -> Action
-peelFunHead gr state = do
-  state' <- forgetNode 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
@@ -355,6 +362,20 @@ wrappingsState gr state
    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)
@@ -362,12 +383,6 @@ headChangesState gr state = errVal [] $ do
   return [fun | (fun,typ) <- funRulesOf gr, fun /= f, typ == typ0] 
                                                           --- alpha-conv !
 
-canPeelState :: CGrammar -> State -> Bool
-canPeelState gr state = errVal False $ do
-  f@(m,c) <-  funAtom (actAtom state)
-  typ <- lookupFunType gr m c
-  return $ isInOneType typ
-
 possibleRefVal :: CGrammar -> State -> Val -> Type -> Bool
 possibleRefVal gr state val typ = errVal True $ do --- was False
   vtyp <- valType typ
diff --git a/src/GF/UseGrammar/Generate.hs b/src/GF/UseGrammar/Generate.hs
index ad15287b9..85af4e8aa 100644
--- a/src/GF/UseGrammar/Generate.hs
+++ b/src/GF/UseGrammar/Generate.hs
@@ -22,8 +22,8 @@ import List
 
 --- if type were shown more modules should be imported
 -- generateTrees :: 
--- GFCGrammar -> Cat -> Int -> Maybe Int -> Maybe Tree -> [Exp]
-generateTrees gr cat n mn mt = map str2tr $ generate gr' cat' n mn mt'
+-- GFCGrammar -> Bool -> Cat -> Int -> Maybe Int -> Maybe Tree -> [Exp]
+generateTrees gr ifm cat n mn mt = map str2tr $ generate gr' ifm cat' n mn mt'
   where
     gr' = gr2sgr gr
     cat' = prt $ snd cat
@@ -63,8 +63,8 @@ tr2str (Tr (N (_,at,val,_,_),ts)) = case (at,val) of
 -- if the depth is large (more than 3)
 -- If a tree is given as argument, generation concerns its metavariables.
 
-generate :: SGrammar -> SCat -> Int -> Maybe Int -> Maybe STree -> [STree]
-generate gr cat i mn mt = case mt of
+generate :: SGrammar -> Bool -> SCat -> Int -> Maybe Int -> Maybe STree -> [STree]
+generate gr ifm cat i mn mt = case mt of
   Nothing -> [t | (c,t) <- gen 0 [], c == cat] 
 
   Just t -> genM t
@@ -77,10 +77,12 @@ generate gr cat i mn mt = case mt of
 
   args :: [SCat] -> [(SCat,STree)] -> [[STree]]
   args cs cts = combinations 
-    [constr (SMeta c : [t | (k,t) <- cts, k == c]) | c <- cs]
+    [constr (ifmetas c [t | (k,t) <- cts, k == c]) | c <- cs]
 
   constr = maybe id take mn
 
+  ifmetas c = if ifm then (SMeta c :) else id
+
   genM t = case t of
     SApp (f,ts) -> [SApp (f,ts') | ts' <- combinations (map genM ts)]
     SMeta k -> [t | (c,t) <- gen 0 [], c == k]