RunGHCC for testing

4 files changed, 73 insertions, 10 deletions

diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs
index 38b58b4c8..9a02f7f25 100644
--- a/src/GF/Canon/GFCC/DataGFCC.hs
+++ b/src/GF/Canon/GFCC/DataGFCC.hs
@@ -1,4 +1,4 @@
-module GF.Canon.GFCC.DataGFCM where
+module GF.Canon.GFCC.DataGFCC where
 
 import GF.Canon.GFCC.AbsGFCC
 import Data.Map
@@ -28,6 +28,8 @@ realize trm = case trm of
   S ss     -> unwords $ Prelude.map realize ss
   K (KS s) -> s
   K (KP s _) -> unwords s ---- prefix choice TODO
+  W s t    -> s ++ " " ++ realize t
+  _ -> "ERROR " ++ show trm ---- debug
 
 linExp :: GFCC -> CId -> Exp -> Term
 linExp mcfg lang tree@(Tr at trees) = 
@@ -46,10 +48,13 @@ kks = K . KS
 compute :: GFCC -> CId -> [Term] -> Term -> Term
 compute mcfg lang args trm = case trm of
   P r p -> case (comp r, comp p) of 
-    (W s (R ss), C i) -> case comp $ ss !! (fromInteger i) of
-      K (KS u) -> kks (s ++ u)      -- the only case where W occurs 
+    (W s t, C i) -> case comp t of
+      R ss -> case comp $ ss !! (fromInteger i) of
+        K (KS u) -> kks (s ++ u)      -- the only case where W occurs 
     (R rs, C i) -> comp $ rs !! (fromInteger i)
     (r',p') -> P r' p'
+  W s t -> W s (comp t)
+  R ts  -> R $ Prelude.map comp ts
   V i   -> args !! (fromInteger i)  -- already computed
   S ts  -> S (Prelude.map comp ts)
   F c   -> comp $ look c  -- global constant: not yet comp'd (if contains argvar)
@@ -68,5 +73,6 @@ mkGFCC (Grm (Hdr a cs) ab@(Abs funs) ccs) = GFCC {
   concretes = fromAscList [(lang, mkCnc lins) | Cnc lang lins <- ccs]
   }
  where
-   mkCnc lins = fromAscList [(fun,lin) | Lin fun lin <- lins]
+   mkCnc lins = fromList [(fun,lin) | Lin fun lin <- lins] ---- Asc
+
 
diff --git a/src/GF/Canon/GFCC/LexGFCC.hs b/src/GF/Canon/GFCC/LexGFCC.hs
index f05a9a3c6..850034117 100644
--- a/src/GF/Canon/GFCC/LexGFCC.hs
+++ b/src/GF/Canon/GFCC/LexGFCC.hs
@@ -1,7 +1,7 @@
 {-# OPTIONS -fglasgow-exts -cpp #-}
 {-# LINE 3 "LexGFCC.x" #-}
 {-# OPTIONS -fno-warn-incomplete-patterns #-}
-module LexGFCC where
+module GF.Canon.GFCC.LexGFCC where
 
 
 
diff --git a/src/GF/Canon/GFCC/ParGFCC.hs b/src/GF/Canon/GFCC/ParGFCC.hs
index 6e137e4c9..b0f15dc5d 100644
--- a/src/GF/Canon/GFCC/ParGFCC.hs
+++ b/src/GF/Canon/GFCC/ParGFCC.hs
@@ -1,10 +1,10 @@
 {-# OPTIONS -fglasgow-exts -cpp #-}
 {-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}
-module ParGFCC where
-import AbsGFCC
-import LexGFCC
-import ErrM
-import Array
+module GF.Canon.GFCC.ParGFCC where
+import GF.Canon.GFCC.AbsGFCC
+import GF.Canon.GFCC.LexGFCC
+import GF.Data.Operations
+import Data.Array
 #if __GLASGOW_HASKELL__ >= 503
 import GHC.Exts
 #else
diff --git a/src/GF/Canon/GFCC/RunGFCC.hs b/src/GF/Canon/GFCC/RunGFCC.hs
new file mode 100644
index 000000000..be2ed3358
--- /dev/null
+++ b/src/GF/Canon/GFCC/RunGFCC.hs
@@ -0,0 +1,57 @@
+module Main where
+
+import GF.Canon.GFCC.DataGFCC
+import GF.Canon.GFCC.AbsGFCC
+import GF.Canon.GFCC.ParGFCC
+import GF.Canon.GFCC.PrintGFCC
+import GF.Data.Operations
+import Data.Map
+import System
+
+-- Simple translation application built on GFCC. AR 7/9/2006
+
+main :: IO ()
+main = do
+  file  <- getLine ----getArgs
+  grammar <- file2gfcc file
+  loop grammar
+
+loop :: GFCC -> IO ()
+loop grammar = do
+  s <- getLine
+  if s == "quit" then return () else do
+    treat grammar s
+    loop grammar
+
+treat :: GFCC -> String -> IO ()
+treat grammar s = do 
+  let t = readExp s
+  putStrLn $ printTree $ linExp grammar lang t 
+  putStrLn $ linearize grammar lang t
+ where
+  lang = head $ cncnames grammar
+
+--- should be in an API
+
+file2gfcc :: FilePath -> IO GFCC
+file2gfcc f = 
+  readFile f >>= err (error "no parse") (return . mkGFCC) . pGrammar . myLexer
+
+readExp :: String -> Exp
+readExp = err (error "no parse") id . (pExp . myLexer)
+
+
+{-
+treat grammar s = putStrLn $ case comm of
+  ["lin"]        -> unlines $ linearizeAll grammar $ readTree grammar rest 
+  ["lin",lang]   -> linearize grammar lang $ readTree grammar rest 
+  ["parse",cat]  -> unlines $ map showTree $ concat $ parseAll grammar cat rest
+  ["parse",lang,cat] -> unlines $ map showTree $ parse grammar lang cat rest
+  ["langs"]      -> unwords $ languages grammar
+  ["cats"]       -> unwords $ categories grammar
+  ["help"]       -> helpMsg
+  _ -> "command not interpreted: " ++ s
+ where
+   (comm,rest) = (words c,drop 1 r) where
+      (c,r) = span (/=':') s
+-}