change the library root namespace from GF.GFCC to PGF

src-3.0/PGF.hs

@@ -0,0 +1,181 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GFCCAPI
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 
+-- > CVS $Author: 
+-- > CVS $Revision: 
+--
+-- Reduced Application Programmer's Interface to GF, meant for
+-- embedded GF systems. AR 19/9/2007
+-----------------------------------------------------------------------------
+
+module PGF where
+
+import PGF.CId
+import PGF.Linearize
+import PGF.Generate
+import PGF.Macros
+import PGF.Data
+import PGF.Raw.Convert
+import PGF.Raw.Parse
+import PGF.Parsing.FCFG
+
+import GF.Data.ErrM
+
+import Data.Char
+import qualified Data.Map as Map
+import Control.Monad
+import System.Random (newStdGen)
+import System.Directory (doesFileExist)
+import qualified Text.PrettyPrint as PP
+import qualified Text.ParserCombinators.ReadP as RP
+
+
+-- This API is meant to be used when embedding GF grammars in Haskell 
+-- programs. The embedded system is supposed to use the
+-- .gfcc grammar format, which is first produced by the gf program.
+
+---------------------------------------------------
+-- Interface
+---------------------------------------------------
+
+data MultiGrammar = MultiGrammar {gfcc :: GFCC}
+type Language     = String
+type Category     = String
+type Tree         = Exp
+
+file2grammar :: FilePath -> IO MultiGrammar
+
+linearize    :: MultiGrammar -> Language -> Tree -> String
+parse        :: MultiGrammar -> Language -> Category -> String -> [Tree]
+
+linearizeAll     :: MultiGrammar -> Tree -> [String]
+linearizeAllLang :: MultiGrammar -> Tree -> [(Language,String)]
+
+parseAll     :: MultiGrammar -> Category -> String -> [[Tree]]
+parseAllLang :: MultiGrammar -> Category -> String -> [(Language,[Tree])]
+
+generateAll      :: MultiGrammar -> Category -> [Tree]
+generateRandom   :: MultiGrammar -> Category -> IO [Tree]
+generateAllDepth :: MultiGrammar -> Category -> Maybe Int -> [Tree]
+
+readTree   :: String -> Tree
+showTree   :: Tree -> String
+
+languages  :: MultiGrammar -> [Language]
+categories :: MultiGrammar -> [Category]
+
+startCat   :: MultiGrammar -> Category
+
+---------------------------------------------------
+-- Implementation
+---------------------------------------------------
+
+file2grammar f = do
+  gfcc <- file2gfcc f
+  return (MultiGrammar gfcc)
+
+file2gfcc f = do
+  s <- readFileIf f
+  g <- parseGrammar s
+  return $ toGFCC g
+
+linearize mgr lang = PGF.Linearize.linearize (gfcc mgr) (mkCId lang)
+
+parse mgr lang cat s = 
+  case lookParser (gfcc mgr) (mkCId lang) of
+    Nothing    -> error "no parser"
+    Just pinfo -> case parseFCF "bottomup" pinfo (mkCId cat) (words s) of
+                    Ok x -> x
+                    Bad s -> error s
+
+linearizeAll mgr = map snd . linearizeAllLang mgr
+linearizeAllLang mgr t = 
+  [(lang,PGF.linearize mgr lang t) | lang <- languages mgr]
+
+parseAll mgr cat = map snd . parseAllLang mgr cat
+
+parseAllLang mgr cat s = 
+  [(lang,ts) | lang <- languages mgr, let ts = parse mgr lang cat s, not (null ts)]
+
+generateRandom mgr cat = do
+  gen <- newStdGen
+  return $ genRandom gen (gfcc mgr) (mkCId cat)
+
+generateAll mgr cat = generate (gfcc mgr) (mkCId cat) Nothing
+generateAllDepth mgr cat = generate (gfcc mgr) (mkCId cat)
+
+readTree s = case RP.readP_to_S (pExp 0) s of
+               [(x,"")] -> x
+               _        -> error "no parse"
+
+pExps :: RP.ReadP [Exp]
+pExps = liftM2 (:) (pExp 1) pExps RP.<++ (RP.skipSpaces >> return [])
+
+pExp :: Int -> RP.ReadP Exp
+pExp n = RP.skipSpaces >> (pParen RP.<++ pApp RP.<++ pNum RP.<++ pStr RP.<++ pMeta)
+  where 
+        pParen = RP.between (RP.char '(') (RP.char ')') (pExp 0)
+        pApp = do xs <- RP.option [] (RP.between (RP.char '\\') (RP.string "->") (RP.sepBy1 pIdent (RP.char ',')))
+                  f  <- pIdent
+                  ts <- (if n == 0 then pExps else return [])
+                  return (DTr xs (AC f) ts)
+        pStr = RP.char '"' >> liftM (\s -> DTr [] (AS s) []) (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"'))
+        pEsc = RP.char '\\' >> RP.get
+        pNum = do x <- RP.munch1 isDigit
+                  ((RP.char '.' >> RP.munch1 isDigit >>= \y -> return (DTr [] (AF (read (x++"."++y))) []))
+                   RP.<++
+                   (return (DTr [] (AI (read x)) [])))
+        pMeta = do RP.char '?'
+                   x <- RP.munch1 isDigit
+                   return (DTr [] (AM (read x)) [])
+
+        pIdent = fmap mkCId (liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest))
+        isIdentFirst c = c == '_' || isLetter c
+        isIdentRest c = c == '_' || c == '\'' || isAlphaNum c
+
+
+showTree = PP.render . ppExp False
+
+ppExp isNested (DTr [] at []) = ppAtom at
+ppExp isNested (DTr xs at ts) = ppParens isNested (ppLambdas xs PP.<+> ppAtom at PP.<+> PP.hsep (map (ppExp True) ts))
+                                where
+                                  ppLambdas [] = PP.empty
+                                  ppLambdas xs = PP.char '\\' PP.<>
+                                                 PP.hsep (PP.punctuate PP.comma (map (PP.text . prCId) xs)) PP.<+>
+                                                 PP.text "->"
+
+                                  ppParens True  = PP.parens
+                                  ppParens False = id
+
+ppAtom (AC id) = PP.text (prCId id)
+ppAtom (AS s)  = PP.text (show s)
+ppAtom (AI n)  = PP.integer n
+ppAtom (AF d)  = PP.double d
+ppAtom (AM n)  = PP.char '?' PP.<> PP.integer n
+ppAtom (AV id) = PP.text (prCId id)
+
+abstractName mgr = prCId (absname (gfcc mgr))
+
+languages mgr = [prCId l | l <- cncnames (gfcc mgr)]
+
+categories mgr = [prCId c | c <- Map.keys (cats (abstract (gfcc mgr)))]
+
+startCat mgr = lookStartCat (gfcc mgr)
+
+emptyMultiGrammar = MultiGrammar emptyGFCC
+
+------------ for internal use only
+
+err f g ex = case ex of
+  Ok x -> g x
+  Bad s -> f s
+
+readFileIf f = do
+  b <- doesFileExist f
+  if b then readFile f 
+       else putStrLn ("file " ++ f ++ " not found") >> return ""