peel head i ; gt nometas ; gf2hs

14 files changed, 208 insertions, 35 deletions

diff --git a/src/GF/API.hs b/src/GF/API.hs
index d748a5517..42101706d 100644
--- a/src/GF/API.hs
+++ b/src/GF/API.hs
@@ -160,13 +160,14 @@ randomTreesIO opts gr n = do
 generateTrees :: Options -> GFGrammar -> Maybe Tree -> [Tree]
 generateTrees opts gr mt =
   optIntOrAll opts flagNumber  
-    [tr | t <- Gen.generateTrees gr' cat dpt mn mt, Ok tr <- [mkTr t]]
+    [tr | t <- Gen.generateTrees gr' ifm cat dpt mn mt, Ok tr <- [mkTr t]]
   where
     mkTr = annotate gr' . qualifTerm (absId gr) 
     gr' = grammar gr
     cat = firstAbsCat opts gr
     dpt = maybe 3 id $ getOptInt opts flagDepth
     mn  = getOptInt opts flagAlts
+    ifm = not $ oElem noMetas opts
 
 speechGenerate :: Options -> String -> IO ()
 speechGenerate opts str = do
@@ -296,11 +297,14 @@ optTermCommand opts st =
 {-
 -- wraps term in a function and optionally computes the result
 
-wrapByFun :: Options -> StateGrammar -> Ident -> Term -> Term
-wrapByFun opts g f t = 
+wrapByFun :: Options -> GFGrammar -> Ident -> Tree -> Tree
+wrapByFun opts gr f t = 
   if oElem doCompute opts 
-  then err (const t) id $ computeAbsTerm (stateAbstract g) (appCons f [t])
-  else appCons f [t]
+  then err (const t) id $ computeAbsTerm (stateAbstract g) (appCons f' [t])
+  else appCons f' [t]
+ where
+   qualifTerm (absId gr) $ 
+
 
 optTransfer :: Options -> StateGrammar -> Term -> Term
 optTransfer opts g = case getOptVal opts transferFun of
diff --git a/src/GF/API/GrammarToHaskell.hs b/src/GF/API/GrammarToHaskell.hs
new file mode 100644
index 000000000..c7e3488ce
--- /dev/null
+++ b/src/GF/API/GrammarToHaskell.hs
@@ -0,0 +1,133 @@
+module GrammarToHaskell (grammar2haskell) where
+
+import qualified GFC
+import Macros
+
+import Modules
+import Operations
+
+-- to write a GF abstract grammar into a Haskell module with translations from
+-- data objects into GF trees. Example: GSyntax for Agda.
+-- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004
+
+-- the main function
+grammar2haskell :: GFC.CanonGrammar -> String
+grammar2haskell gr = foldr (++++) [] $  
+  haskPreamble ++ [datatypes gr', gfinstances gr', fginstances gr']
+    where gr' = hSkeleton gr
+
+-- by this you can prefix all identifiers with stg; the default is 'G'
+gId :: OIdent -> OIdent 
+gId i = 'G':i
+
+haskPreamble =
+ [
+  "module GSyntax where",
+  "",
+  "import Ident",
+  "import Grammar",
+  "import PrGrammar",
+  "import Macros",
+  "import Operations",
+  "----------------------------------------------------",
+  "-- automatic translation from GF to Haskell",
+  "----------------------------------------------------",
+  "", 
+  "class Gf a where gf :: a -> Trm",
+  "class Fg a where fg :: Trm -> a",
+  "",
+  predefInst "String" "K s",
+  "",
+  predefInst "Int" "EInt s",
+  "",
+  "----------------------------------------------------",
+  "-- below this line machine-generated",
+  "----------------------------------------------------",
+  ""
+ ]
+
+predefInst typ patt = let gtyp = gId typ in
+  "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++
+  "instance Gf" +++ gtyp +++ "where" ++++
+  "  gf (" ++ gtyp +++ "s) =" +++ patt +++++
+  "instance Fg" +++ gtyp +++ "where" ++++
+  "  fg t =" ++++
+  "    case termForm t of" ++++
+  "      Ok ([]," +++ patt +++ ",[]) ->" +++ gtyp +++ "s" ++++
+  "      _ -> error (\"no" +++ gtyp +++ "\" ++ prt t)"
+
+type OIdent = String
+
+type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
+
+datatypes, gfinstances, fginstances :: (String,HSkeleton) -> String
+datatypes   = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd
+gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (hInstance m)) g
+fginstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (fInstance m)) g
+
+hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String
+hInstance, fInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String
+
+hDatatype ("Cn",_) = "" ---
+hDatatype (cat,[]) = ""
+hDatatype (cat,rules) =
+ "data" +++ gId cat +++ "=" ++
+ (if length rules == 1 then "" else "\n  ") +++
+ foldr1 (\x y -> x ++ "\n |" +++ y) 
+        [gId f +++ foldr (+++) "" (map gId xx) | (f,xx) <- rules] ++++
+ "  deriving Show"
+
+----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
+hInstance m (cat,[]) = ""
+hInstance m (cat,rules) = 
+ "instance Gf" +++ gId cat +++ "where" ++
+ (if length rules == 1 then "" else "\n") +++
+ foldr1 (\x y -> x ++ "\n" +++ y) [mkInst f xx | (f,xx) <- rules]
+   where
+    mkInst f xx =
+     "gf " ++
+     (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
+     "=" +++
+     "appqc \"" ++ m ++ "\" \"" ++ f ++ "\"" +++ 
+     "[" ++ prTList ", " ["gf" +++ x | x <- xx'] ++ "]"
+       where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
+
+----fInstance m ("Cn",_) = "" ---
+fInstance m (cat,[]) = ""
+fInstance m (cat,rules) =
+ "instance Fg" +++ gId cat +++ "where" ++++
+ " fg t =" ++++
+ "  case termForm t of" ++++
+ foldr1 (\x y -> x ++ "\n" ++ y) [mkInst f xx | (f,xx) <- rules] ++++
+ "    _ -> error (\"no" +++ cat ++ " \" ++ prt t)"
+   where
+    mkInst f xx =
+     "    Ok ([], Q (IC \"" ++ m ++ "\") (IC \"" ++ f ++ "\")," ++
+     "[" ++ prTList "," xx' ++ "])" +++
+     "->" +++
+     gId f +++  
+     prTList " " [prParenth ("fg" +++ x) | x <- xx']
+       where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
+
+hSkeleton :: GFC.CanonGrammar -> (String,HSkeleton)
+hSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where
+  collectR rr hh =
+   case rr of
+     (fun,typ):rs -> case catSkeleton typ of
+        Ok (cats,cat) -> 
+             collectR rs (updateSkeleton (symid (snd cat)) hh (fun,
+	                                                    map (symid . snd) cats))
+        _ -> collectR rs hh
+     _ -> hh
+  cats =  [symid cat | (cat,GFC.AbsCat _ _) <- defs]
+  rules = [(symid fun, typ) | (fun,GFC.AbsFun typ _) <- defs]
+
+  defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m]
+  name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m]
+
+updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
+updateSkeleton cat skel rule =
+ case skel of
+   (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr
+   (cat0,rules):rr               -> (cat0, rules) : updateSkeleton cat rr rule
+
diff --git a/src/GF/Data/Zipper.hs b/src/GF/Data/Zipper.hs
index a696f1cae..e63743b06 100644
--- a/src/GF/Data/Zipper.hs
+++ b/src/GF/Data/Zipper.hs
@@ -180,3 +180,9 @@ changeRoot f loc = case loc of
    chPath pv = case pv of 
      (Top,a) -> (Top, f a)
      (Node (left,pv,right),v) -> (Node (left, chPath pv,right),v)
+
+nthSubtree :: Int -> Tr a -> Err (Tr a)
+nthSubtree n (Tr (a,ts)) = ts !? n
+
+arityTree :: Tr a -> Int
+arityTree (Tr (_,ts)) = length ts
\ No newline at end of file
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
index b74d02fd8..cdaea6734 100644
--- a/src/GF/Grammar/Macros.hs
+++ b/src/GF/Grammar/Macros.hs
@@ -192,6 +192,9 @@ appCons = mkApp . Cn
 appc :: String -> [Term] -> Term
 appc = appCons . zIdent
 
+appqc :: String -> String -> [Term] -> Term
+appqc q c = mkApp (Q (zIdent q) (zIdent c))
+
 mkLet :: [LocalDef] -> Term -> Term
 mkLet defs t = foldr Let t defs
 
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
index 7e273025f..b2a5902cc 100644
--- a/src/GF/Infra/Option.hs
+++ b/src/GF/Infra/Option.hs
@@ -140,6 +140,7 @@ tableLin    = iOpt "table"
 defaultLinOpts = [firstLin]
 useUTF8     = iOpt "utf8"
 showLang    = iOpt "lang"
+noMetas     = iOpt "nometas"
 
 -- other
 beVerbose    = iOpt "v"
diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
index 61fa7ce1e..f5692a398 100644
--- a/src/GF/Shell.hs
+++ b/src/GF/Shell.hs
@@ -200,7 +200,7 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
 
 
   CPutTerm -> changeArg (opTT2CommandArg (optTermCommand opts gro) . s2t) sa
------  CWrapTerm f -> changeArg (opTT2CommandArg (return . wrapByFun opts gro f)) sa
+----  CWrapTerm f -> changeArg (opTT2CommandArg (return . wrapByFun opts gro f)) sa
   CMorphoAnalyse -> changeArg (AString . morphoAnalyse opts gro . prCommandArg) sa
   CTestTokenizer -> changeArg (AString . optTokenizer opts gro . prCommandArg) sa
 
diff --git a/src/GF/Shell/CommandL.hs b/src/GF/Shell/CommandL.hs
index 3fd64dd00..5945dd271 100644
--- a/src/GF/Shell/CommandL.hs
+++ b/src/GF/Shell/CommandL.hs
@@ -68,7 +68,7 @@ pCommand = pCommandWords . words where
     "r" : f : _   -> CRefineWithAtom f
     "w" : f:i : _ -> CWrapWithFun (f, readIntArg i)
     "ch": f : _   -> CChangeHead f
-    "ph": _       -> CPeelHead
+    "ph": f:i : _ -> CPeelHead (f, readIntArg i)
     "x" : ws      -> CAlphaConvert $ unwords ws
     "s" : i : _   -> CSelectCand (readIntArg i)
     "f" : "unstructured" : _ -> CRemoveOption showStruct --- hmmm
diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs
index 345e5cd02..25ef5607f 100644
--- a/src/GF/Shell/Commands.hs
+++ b/src/GF/Shell/Commands.hs
@@ -63,7 +63,7 @@ data Command =
  | CRefineParse String
  | CWrapWithFun (String,Int)
  | CChangeHead String
- | CPeelHead
+ | CPeelHead (String,Int)
  | CAlphaConvert String
  | CRefineRandom
  | CSelectCand Int
@@ -206,7 +206,7 @@ execECommand env c = case c of
                           uniqueRefinements cgr s'
   CWrapWithFun (f,i) -> action2commandNext $ wrapWithFun cgr (qualif f, i)
   CChangeHead f      -> action2commandNext $ changeFunHead cgr (qualif f)
-  CPeelHead          -> action2commandNext $ peelFunHead cgr
+  CPeelHead (f,i)    -> action2commandNext $ peelFunHead cgr (qualif f,i)
 
   CAlphaConvert s    -> action2commandNext $ \x ->
                           string2varPair s >>= \xy -> alphaConvert cgr xy x
@@ -285,12 +285,12 @@ mkRefineMenuAll :: CEnv -> SState -> [(Command,(String,String))]
 mkRefineMenuAll env sstate = 
   case (refinementsState cgr state, candsSState sstate, wrappingsState cgr state) of
     ([],[],wraps) -> 
-       [(CWrapWithFun (prQIdent_ f, i), prWrap fit)     
+       [(CWrapWithFun (prQIdent_ f, i), prWrap "w" "Wrap" fit)     
          | fit@((f,i),_) <- wraps] ++
        [(CChangeHead (prQIdent_ f),  prChangeHead f) 
          | f <- headChangesState cgr state] ++
-       [(CPeelHead,    (ifShort "ph" "PeelHead", "ph")) 
-         | canPeelState cgr state] ++
+       [(CPeelHead (prQIdent_ f, i), prPeel "ph" "PeelHead" fi)     
+         | fi@(f,i) <- peelingsState cgr state] ++
        [(CDelete,      (ifShort "d"  "Delete",   "d"))] ++
        [(CAddClip,     (ifShort "ac" "AddClip",  "ac"))]
     (refs,[],_)   -> 
@@ -309,10 +309,14 @@ mkRefineMenuAll env sstate =
   prChangeHead f = 
     (ifShort "ch" "ChangeHead" +++ prOrLinFun f,
      "ch" +++ prQIdent_ f)
-  prWrap ((f,i),t) = 
-    (ifShort "w" "Wrap"   +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++
+  prWrap sh lg ((f,i),t) = 
+    (ifShort sh lg   +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++
      ifShort (show i) (prBracket (show i)),
-     "w" +++ prQIdent_ f +++ show i)
+     sh +++ prQIdent_ f +++ show i)
+  prPeel sh lg (f,i) = 
+    (ifShort sh lg   +++ prOrLinFun f +++
+     ifShort (show i) (prBracket (show i)),
+     sh +++ prQIdent_ f +++ show i)
   prCand (t,i) = 
     (ifShort ("s" +++ prOrLinExp t) ("Select" +++ prOrLinExp t),"s" +++ show i)
 
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] 
diff --git a/src/HelpFile b/src/HelpFile
index fa49f89ef..8184b4603 100644
--- a/src/HelpFile
+++ b/src/HelpFile
@@ -168,6 +168,8 @@ gt, generate_trees: gt Tree?
       command completes the Tree with values to the metavariables in
       the tree.
   flags:
+      -nometas don't return trees that include metavariables
+  flags:
       -depth   generate to this depth (default 3)
       -alts    take this number of alternatives at each branch (default unlimited)
       -cat     generate in this category
@@ -368,7 +370,7 @@ q, quit: q
     -printer=cf             context-free grammar
    *-printer=happy          source file for Happy parser generator
     -printer=srg            speech recognition grammar
-   *-printer=haskell        abstract syntax in Haskell, with transl to/from GF
+    -printer=haskell        abstract syntax in Haskell, with transl to/from GF
     -printer=morpho         full-form lexicon, long format
    *-printer=latex          LaTeX file (for the tg command)
     -printer=fullform       full-form lexicon, short format
diff --git a/src/HelpFile.hs b/src/HelpFile.hs
index b6a2eadf2..1dda915d7 100644
--- a/src/HelpFile.hs
+++ b/src/HelpFile.hs
@@ -181,6 +181,8 @@ txtHelpFile =
   "\n      command completes the Tree with values to the metavariables in" ++
   "\n      the tree." ++
   "\n  flags:" ++
+  "\n      -nometas don't return trees that include metavariables" ++
+  "\n  flags:" ++
   "\n      -depth   generate to this depth (default 3)" ++
   "\n      -alts    take this number of alternatives at each branch (default unlimited)" ++
   "\n      -cat     generate in this category" ++
@@ -381,7 +383,7 @@ txtHelpFile =
   "\n    -printer=cf             context-free grammar" ++
   "\n   *-printer=happy          source file for Happy parser generator" ++
   "\n    -printer=srg            speech recognition grammar" ++
-  "\n   *-printer=haskell        abstract syntax in Haskell, with transl to/from GF" ++
+  "\n    -printer=haskell        abstract syntax in Haskell, with transl to/from GF" ++
   "\n    -printer=morpho         full-form lexicon, long format" ++
   "\n   *-printer=latex          LaTeX file (for the tg command)" ++
   "\n    -printer=fullform       full-form lexicon, short format" ++
diff --git a/src/Today.hs b/src/Today.hs
index 1175e0b6e..002cdf2bf 100644
--- a/src/Today.hs
+++ b/src/Today.hs
@@ -1 +1 @@
-module Today where today = "Mon May  3 10:59:20 CEST 2004"
+module Today where today = "Tue May 18 23:54:22 CEST 2004"