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 +-}