From 394050d9f7d90f5b7a5905175bd51733048bf481 Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Sun, 5 Oct 2008 19:49:26 +0000
Subject: [PATCH] added a command for tree operations and started a module for
 defining them

---
 src/GF/Command/Commands.hs       | 24 +++++++++++++
 src/GF/Command/TreeOperations.hs | 58 ++++++++++++++++++++++++++++++++
 2 files changed, 82 insertions(+)
 create mode 100644 src/GF/Command/TreeOperations.hs

diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs
index baeb6ba41..27ac61c81 100644
--- a/src/GF/Command/Commands.hs
+++ b/src/GF/Command/Commands.hs
@@ -27,6 +27,8 @@ import GF.Command.Messages
 import GF.Text.Lexing
 import GF.Text.Transliterations
 
+import GF.Command.TreeOperations ---- temporary place for typecheck and compute
+
 import GF.Data.Operations
 import GF.Text.Coding
 
@@ -367,6 +369,23 @@ allCommands cod pgf = Map.fromList [
      exec = \opts -> return . fromString . stringOps (map prOpt opts) . toString,
      options = stringOpOptions
      }),
+  ("pt", emptyCommandInfo {
+     longname = "put_tree",
+     syntax = "ps OPT? TREE",
+     synopsis = "return a tree, possibly processed with a function",
+     explanation = unlines [
+       "Returns a tree obtained from its argument tree by applying",
+       "tree processing functions in the order given in the command line",
+       "option list. Thus 'pt -f -g s' returns g (f s). Typical tree processors",
+       "are type checking and semantic computation."
+       ], 
+     examples = [
+       "pt -compute (plus one two)   -- compute value",
+       "p \"foo\" | pt -typecheck      -- type check parse results"
+       ],
+     exec = \opts -> return . fromTrees . treeOps (map prOpt opts),
+     options = treeOpOptions
+     }),
   ("q",  emptyCommandInfo {
      longname = "quit",
      synopsis = "exit GF interpreter"
@@ -588,6 +607,9 @@ allCommands cod pgf = Map.fromList [
    stringOps opts s = foldr app s (reverse opts) where
      app f = maybe id id (stringOp f) 
 
+   treeOps opts s = foldr app s (reverse opts) where
+     app f = maybe id id (treeOp f) 
+
    showAsString t = case t of
      Lit (LStr s) -> s
      _ -> "\n" ++ showTree t  --- newline needed in other cases than the first
@@ -619,6 +641,8 @@ stringOpOptions = [
        ("words","lexer that assumes tokens separated by spaces (default)")
        ]
 
+treeOpOptions = [(op,expl) | (op,(expl,_)) <- allTreeOps]
+
 translationQuiz :: String -> PGF -> Language -> Language -> Category -> IO ()
 translationQuiz cod pgf ig og cat = do
   tts <- translationList pgf ig og cat infinity
diff --git a/src/GF/Command/TreeOperations.hs b/src/GF/Command/TreeOperations.hs
new file mode 100644
index 000000000..88b962bdc
--- /dev/null
+++ b/src/GF/Command/TreeOperations.hs
@@ -0,0 +1,58 @@
+module GF.Command.TreeOperations (
+  treeOp,
+  allTreeOps
+  --typeCheck,
+  --compute
+  ) where
+
+import GF.Compile.TypeCheck
+import GF.Compile.AbsCompute
+
+-- for conversions
+import PGF.Data
+--import GF.Compile.GrammarToGFCC (mkType,mkExp)
+import GF.Grammar.Grammar
+
+
+type TreeOp = [Tree] -> [Tree]
+
+treeOp :: String -> Maybe TreeOp
+treeOp f = fmap snd $ lookup f allTreeOps
+
+allTreeOps :: [(String,(String,TreeOp))]
+allTreeOps = [
+   ("compute",("compute by using semantic definitions (def)",
+      id)),
+   ("smallest",("sort trees from smallest to largest, in number of nodes",
+      id)),
+   ("typecheck",("type check and solve metavariables; reject if incorrect",
+      id))
+  ]
+
+typeCheck :: PGF -> Tree -> (Tree,(Bool,[String]))
+typeCheck pgf t = (t,(True,[]))
+
+compute :: PGF -> Tree -> Tree
+compute pgf t = t
+
+
+
+{-
+data Tree = 
+   Abs [CId] Tree                   -- ^ lambda abstraction. The list of variables is non-empty
+ | Var CId                          -- ^ variable
+ | Fun CId [Tree]                   -- ^ function application
+ | Lit Literal                      -- ^ literal
+ | Meta Int                         -- ^ meta variable
+
+data Literal = 
+   LStr String                      -- ^ string constant
+ | LInt Integer                     -- ^ integer constant
+ | LFlt Double                      -- ^ floating point constant
+
+mkType :: A.Type -> C.Type
+mkType t = case GM.typeForm t of
+  Ok (hyps,(_,cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args)
+
+mkExp :: A.Term -> C.Expr
+-}