GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

src-3.0/GF/API/BatchTranslate.hs

@@ -0,0 +1,43 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : BatchTranslate
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:05 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- translate OCL, etc, files in batch mode
+-----------------------------------------------------------------------------
+
+module GF.API.BatchTranslate (translate) where
+
+import GF.API
+import GetMyTree (file2tree)
+
+translate :: FilePath -> FilePath -> IO ()
+translate fgr txt = do
+  gr <- file2grammar fgr
+  s  <- file2tree txt
+  putStrLn $ linearize gr s
+
+
+{- headers for model-specific grammars:
+
+abstract userDefined = oclLibrary ** {
+
+--# -path=.:abstract:prelude:English:ExtraEng
+concrete userDefinedEng of userDefined = oclLibraryEng ** open externalOperEng in {
+
+--# -path=.:abstract:prelude:German:ExtraGer
+concrete userDefinedGer of userDefined = oclLibraryGer ** open
+externalOperGer in {
+
+
+It seems we should add open 
+
+   ParadigmsX, ResourceExtX, PredicationX
+
+-}

src-3.0/GF/API/GrammarToHaskell.hs

@@ -0,0 +1,271 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GrammarToHaskell
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/17 12:39:07 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- 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
+-----------------------------------------------------------------------------
+
+module GF.API.GrammarToHaskell (grammar2haskell, grammar2haskellGADT) where
+
+import qualified GF.Canon.GFC as GFC
+import GF.Grammar.Macros
+
+import GF.Infra.Modules
+import GF.Data.Operations
+
+import Data.List (isPrefixOf, find, intersperse)
+import Data.Maybe (fromMaybe)
+
+-- | the main function
+grammar2haskell :: GFC.CanonGrammar -> String
+grammar2haskell gr = foldr (++++) [] $  
+  haskPreamble ++ [datatypes gr', gfinstances gr', fginstances gr']
+    where gr' = hSkeleton gr
+
+grammar2haskellGADT :: GFC.CanonGrammar -> String
+grammar2haskellGADT gr = foldr (++++) [] $  
+  ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ 
+  haskPreamble ++ [datatypesGADT gr', composInstance gr', showInstanceGADT 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 GF.Infra.Ident",
+  "import GF.Grammar.Grammar",
+  "import GF.Grammar.PrGrammar",
+  "import GF.Grammar.Macros",
+  "import GF.Data.Compos",
+  "import GF.Data.Operations",
+  "",
+  "import Control.Applicative (pure,(<*>))",
+  "import Data.Traversable (traverse)",
+  "----------------------------------------------------",
+  "-- automatic translation from GF to Haskell",
+  "----------------------------------------------------",
+  "", 
+  "class Gf a where gf :: a -> Trm",
+  "class Fg a where fg :: Trm -> a",
+  "",
+  predefInst "GString" "String" "K s",
+  "",
+  predefInst "GInt" "Integer" "EInt s",
+  "",
+  predefInst "GFloat" "Double" "EFloat s",
+  "",
+  "----------------------------------------------------",
+  "-- below this line machine-generated",
+  "----------------------------------------------------",
+  ""
+ ]
+
+predefInst gtyp typ patt = 
+  "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) | isListCat (cat,rules) = 
+ "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" 
+  +++ "deriving Show"
+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"
+
+-- GADT version of data types
+datatypesGADT :: (String,HSkeleton) -> String
+datatypesGADT (_,skel) = 
+    unlines (concatMap hCatTypeGADT skel)
+    +++++
+    "data Tree :: * -> * where" ++++ unlines (concatMap (map ("  "++) . hDatatypeGADT) skel)
+
+hCatTypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String]
+hCatTypeGADT (cat,rules)
+    = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_",
+       "data"+++gId cat++"_"]
+
+hDatatypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String]
+hDatatypeGADT (cat, rules) 
+    | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
+    | otherwise =
+        [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ]
+  where t = "Tree" +++ gId cat ++ "_"
+
+
+----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
+hInstance m (cat,[]) = "" 
+hInstance m (cat,rules) 
+ | isListCat (cat,rules) =
+  "instance Gf" +++ gId cat +++ "where" ++++
+     " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" 
+           +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
+     " gf (" ++ gId cat +++ "(x:xs)) = " 
+           ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] 
+-- no show for GADTs
+--     ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" 
+ | otherwise =
+  "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
+   ec = elemCat cat
+   baseVars = mkVars (baseSize (cat,rules))
+   mkInst f xx = let xx' = mkVars (length xx) in "gf " ++
+     (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
+     "=" +++ mkRHS f xx'
+   mkVars n = ["x" ++ show i | i <- [1..n]]
+   mkRHS f vars = "appqc \"" ++ m ++ "\" \"" ++ f ++ "\"" +++ 
+		   "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
+
+
+----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' ++ "])" +++
+     "->" +++ mkRHS f xx'
+       where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
+	     mkRHS f vars 
+		 | isListCat (cat,rules) =
+		     if "Base" `isPrefixOf` f then
+			gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
+		      else
+                       let (i,t) = (init vars,last vars)
+                        in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++ 
+                          gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"]))
+		 | otherwise = 
+		     gId f +++  
+		     prTList " " [prParenth ("fg" +++ x) | x <- vars]
+
+composInstance :: (String,HSkeleton) -> String
+composInstance (_,skel) = unlines $
+    ["instance Compos Tree where",
+     "  compos f t = case t of"]
+    ++ map ("      "++) (concatMap prComposCat skel
+                         ++ if not allRecursive then ["_ -> pure t"] else [])
+    where
+    prComposCat c@(cat, fs) 
+        | isListCat c = [gId cat +++ "xs" +++ "->" 
+                         +++ "pure" +++ gId cat +++ "<*> traverse f" +++ "xs"]
+        | otherwise = concatMap (prComposFun cat) fs
+    prComposFun :: OIdent -> (OIdent,[OIdent]) -> [String]
+    prComposFun cat c@(fun,args) 
+	| any isTreeType args = [gId fun +++ unwords vars +++ "->" +++ rhs]
+        | otherwise = []
+      where vars = ["x" ++ show n | n <- [1..length args]]
+            rhs = "pure" +++ gId fun +++ unwords (zipWith prRec vars args)
+	        where prRec var typ
+                          | not (isTreeType typ) = "<*>" +++ "pure" +++ var
+			  | otherwise = "<*>" +++ "f" +++ var
+    allRecursive = and [any isTreeType args | (_,fs) <- skel, (_,args) <- fs] 
+    isTreeType cat = cat `elem` (map fst skel ++ builtin)
+    isList cat = case filter ((==cat) . fst) skel of
+                   [] -> error $ "Unknown cat " ++ show cat
+                   x:_ -> isListCat x
+    builtin = ["GString", "GInt", "GFloat"]
+
+showInstanceGADT :: (String,HSkeleton) -> String
+showInstanceGADT (_,skel) = unlines $
+            ["instance Show (Tree c) where",
+	     "  showsPrec n t = case t of"]
+	     ++ map ("    "++) (concatMap prShowCat skel)
+	     ++ ["   where opar n = if n > 0 then showChar '(' else id",
+	         "         cpar n = if n > 0 then showChar ')' else id"]
+  where 
+  prShowCat c@(cat, fs)
+      | isListCat c = [gId cat +++ "xs" +++ "->" +++ "showList" +++ "xs"]
+      | otherwise = map (prShowFun cat) fs
+  prShowFun :: OIdent -> (OIdent,[OIdent]) -> String
+  prShowFun cat (fun,args) 
+      | null vars = gId fun +++ "->" +++ "showString" +++ show fun
+      | otherwise = gId fun +++ unwords vars +++ "->" 
+			     +++ "opar n . showString" +++ show fun
+			     +++ unwords [". showChar ' ' . showsPrec 1 " ++ x | x <- vars]
+			     +++ ". cpar n"
+      where vars = ["x" ++ show n | n <- [1..length args]]
+
+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
+   _ -> error $ cat ++ ": updating empty skeleton with" +++ show rule
+
+isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
+isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
+		    && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
+    where c = elemCat cat
+	  fs = map fst rules
+
+-- | Gets the element category of a list category.
+elemCat :: OIdent -> OIdent
+elemCat = drop 4
+
+isBaseFun :: OIdent -> Bool
+isBaseFun f = "Base" `isPrefixOf` f
+
+isConsFun :: OIdent -> Bool
+isConsFun f = "Cons" `isPrefixOf` f
+
+baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int
+baseSize (_,rules) = length bs
+    where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules

src-3.0/GF/API/GrammarToTransfer.hs

@@ -0,0 +1,94 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : GrammarToTransfer
+-- Maintainer  : Björn Bringert
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/17 12:39:07 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- Creates a data type definition in the transfer language
+-- for an abstract module.
+-----------------------------------------------------------------------------
+
+module GF.API.GrammarToTransfer (grammar2transfer) where
+
+import qualified GF.Canon.GFC as GFC
+import qualified GF.Grammar.Abstract as A
+import GF.Grammar.Macros
+
+import GF.Infra.Modules
+import GF.Data.Operations
+
+import Transfer.Syntax.Abs as S
+import Transfer.Syntax.Print
+
+
+-- | the main function
+grammar2transfer :: GFC.CanonGrammar -> String
+grammar2transfer gr = printTree $ S.Module imports decls
+  where
+  cat = S.Ident "Cat" -- FIXME
+  tree = S.Ident "Tree" -- FIXME
+  defs = concat [tree2list (jments m) | im@(_,ModMod m) <- modules gr, isModAbs m]
+  -- get category name and context
+  cats = [(cat, c) | (cat,GFC.AbsCat c _) <- defs]
+  -- get function name and type
+  funs = [(fun, typ) | (fun,GFC.AbsFun typ _) <- defs]
+  name = ifNull "UnknownModule" (symid . last) [n | (n,ModMod m) <- modules gr, isModAbs m]
+  imports = [Import (S.Ident "prelude")]
+  decls = [cats2cat cat tree cats, funs2tree cat tree funs] ++ instances tree
+
+
+-- | Create a declaration of the type of categories given a list
+--   of category names and their contexts.
+cats2cat :: S.Ident -- ^ the name of the Cat type
+         -> S.Ident -- ^ the name of the Tree type
+         -> [(A.Ident,A.Context)] -> Decl
+cats2cat cat tree = S.DataDecl cat S.EType . map (uncurry catCons)
+  where
+  catCons i c = S.ConsDecl (id2id i) (catConsType c)
+  catConsType = foldr pi (S.EVar cat)
+  pi (i,x) t = mkPi (id2pv i) (addTree tree $ term2exp x) t
+
+funs2tree :: S.Ident -- ^ the name of the Cat type
+          -> S.Ident -- ^ the name of the Tree type
+          -> [(A.Ident,A.Type)] -> Decl
+funs2tree cat tree = 
+    S.DataDecl tree (S.EPiNoVar (S.EVar cat) S.EType) . map (uncurry funCons)
+  where 
+  funCons i t = S.ConsDecl (id2id i) (addTree tree $ term2exp t)
+
+term2exp :: A.Term -> S.Exp
+term2exp t = case t of
+  A.Vr i         -> S.EVar (id2id i)
+  A.App t1 t2    -> S.EApp (term2exp t1) (term2exp t2)
+  A.Abs i t1     -> S.EAbs (id2pv i) (term2exp t1)
+  A.Prod i t1 t2 -> mkPi (id2pv i) (term2exp t1) (term2exp t2)
+  A.Q m i        -> S.EVar (id2id i)
+  _ -> error $ "term2exp: can't handle " ++ show t
+
+mkPi :: S.VarOrWild -> S.Exp -> S.Exp -> S.Exp 
+mkPi VWild t e = S.EPiNoVar t e
+mkPi v     t e = S.EPi v t e
+
+id2id :: A.Ident -> S.Ident
+id2id = S.Ident . symid
+
+id2pv :: A.Ident -> S.VarOrWild
+id2pv i = case symid i of
+                       "h_" -> S.VWild -- FIXME: hacky?
+                       x    -> S.VVar (S.Ident x)
+
+-- FIXME: I think this is not general enoguh.
+addTree :: S.Ident -> S.Exp -> S.Exp
+addTree tree x = case x of
+  S.EPi i t e -> S.EPi i (addTree tree t) (addTree tree e)
+  S.EPiNoVar t e -> S.EPiNoVar (addTree tree t) (addTree tree e)
+  e -> S.EApp (S.EVar tree) e
+
+instances :: S.Ident -> [S.Decl]
+instances tree = [DeriveDecl (S.Ident "Eq") tree, 
+                  DeriveDecl (S.Ident "Compos") tree]

src-3.0/GF/API/IOGrammar.hs

@@ -0,0 +1,96 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : IOGrammar
+-- Maintainer  : Aarne Ranta
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/14 16:03:40 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.20 $
+--
+-- for reading grammars and terms from strings and files
+-----------------------------------------------------------------------------
+
+module GF.API.IOGrammar (shellStateFromFiles,
+		  getShellStateFromFiles) where
+
+import GF.Grammar.Abstract
+import qualified GF.Canon.GFC as GFC
+import GF.Compile.PGrammar
+import GF.Grammar.TypeCheck
+import GF.Compile.Compile
+import GF.Compile.ShellState
+import GF.Compile.NoParse
+import GF.Probabilistic.Probabilistic
+import GF.UseGrammar.Treebank
+
+import GF.Infra.Modules
+import GF.Infra.ReadFiles (isOldFile)
+import GF.Infra.Option
+import GF.Data.Operations
+import GF.Infra.UseIO
+import GF.System.Arch
+
+import qualified Transfer.InterpreterAPI as T
+
+import Control.Monad (liftM)
+import System.FilePath
+
+-- | a heuristic way of renaming constants is used
+string2absTerm :: String -> String -> Term 
+string2absTerm m = renameTermIn m . pTrm
+
+renameTermIn :: String -> Term -> Term
+renameTermIn m = refreshMetas [] . rename [] where
+  rename vs t = case t of
+    Abs x b -> Abs x (rename (x:vs) b)
+    Vr c    -> if elem c vs then t else Q (zIdent m) c
+    App f a -> App (rename vs f) (rename vs a)
+    _ -> t
+
+string2annotTree :: GFC.CanonGrammar -> Ident -> String -> Err Tree
+string2annotTree gr m = annotate gr . string2absTerm (prt m) ---- prt
+
+----string2paramList :: ConcreteST -> String -> [Term]
+---string2paramList st = map (renameTrm (lookupConcrete st) . patt2term) . pPattList
+
+shellStateFromFiles :: Options -> ShellState -> FilePath -> IOE ShellState
+shellStateFromFiles opts st file = do
+ ign <- ioeIO $ getNoparseFromFile opts file
+ let top = identC $ justModuleName file
+ sh <- case takeExtensions file of
+  ".trc" -> do
+     env <- ioeIO $ T.loadFile file
+     return $ addTransfer (top,env) st
+  ".gfcm" -> do
+     cenv <- compileOne opts (compileEnvShSt st []) file
+     ioeErr $ updateShellState opts ign Nothing st cenv
+  s | elem s [".cf",".ebnf"] -> do
+     let osb = addOptions (options []) opts
+     grts <- compileModule osb st file
+     ioeErr $ updateShellState opts ign Nothing st grts
+  s | oElem (iOpt "treebank") opts -> do
+     tbs <- ioeIO $ readUniTreebanks file
+     return $ addTreebanks tbs st
+  _ -> do
+     b <- ioeIO $ isOldFile file
+     let opts' = if b then (addOption showOld opts) else opts
+
+     let osb = if oElem showOld opts' 
+                 then addOptions (options []) opts' -- for old no emit
+                 else addOptions (options [emitCode]) opts'
+     grts <- compileModule osb st file
+     let mtop = if oElem showOld opts' then Nothing else Just top
+     ioeErr $ updateShellState opts' ign mtop st grts
+ if (isSetFlag opts probFile || oElem (iOpt "prob") opts)
+       then do 
+         probs <- ioeIO $ getProbsFromFile opts file
+         let lang = maybe top id $ concrete sh --- to work with cf, too
+         ioeErr $ addProbs (lang,probs) sh
+       else return sh
+
+getShellStateFromFiles :: Options -> FilePath -> IO ShellState
+getShellStateFromFiles os = 
+  useIOE emptyShellState . 
+  shellStateFromFiles os emptyShellState

src-3.0/GF/API/MyParser.hs

@@ -0,0 +1,25 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MyParser
+-- Maintainer  : Peter Ljunglöf
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:07 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.6 $
+--
+-- template to define your own parser (obsolete?)
+-----------------------------------------------------------------------------
+
+module GF.API.MyParser (myParser) where
+
+import GF.Compile.ShellState
+import GF.CF.CFIdent
+import GF.CF.CF
+import GF.Data.Operations
+
+-- type CFParser = [CFTok] -> ([(CFTree,[CFTok])],String)
+
+myParser :: StateGrammar -> CFCat -> CFParser
+myParser gr cat toks = ([],"Would you like to add your own parser?")