From df0c4f81fa9c620d7c63af79c0b183a6beccf0bd Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Thu, 22 May 2008 11:59:31 +0000 Subject: remove all files that aren't used in GF-3.0 --- src-3.0/GF/API/BatchTranslate.hs | 43 ------ src-3.0/GF/API/GrammarToHaskell.hs | 271 ------------------------------------ src-3.0/GF/API/GrammarToTransfer.hs | 94 ------------- src-3.0/GF/API/IOGrammar.hs | 96 ------------- src-3.0/GF/API/MyParser.hs | 25 ---- 5 files changed, 529 deletions(-) delete mode 100644 src-3.0/GF/API/BatchTranslate.hs delete mode 100644 src-3.0/GF/API/GrammarToHaskell.hs delete mode 100644 src-3.0/GF/API/GrammarToTransfer.hs delete mode 100644 src-3.0/GF/API/IOGrammar.hs delete mode 100644 src-3.0/GF/API/MyParser.hs (limited to 'src-3.0/GF/API') diff --git a/src-3.0/GF/API/BatchTranslate.hs b/src-3.0/GF/API/BatchTranslate.hs deleted file mode 100644 index c1b124526..000000000 --- a/src-3.0/GF/API/BatchTranslate.hs +++ /dev/null @@ -1,43 +0,0 @@ ----------------------------------------------------------------------- --- | --- 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 - --} diff --git a/src-3.0/GF/API/GrammarToHaskell.hs b/src-3.0/GF/API/GrammarToHaskell.hs deleted file mode 100644 index c57cfed42..000000000 --- a/src-3.0/GF/API/GrammarToHaskell.hs +++ /dev/null @@ -1,271 +0,0 @@ ----------------------------------------------------------------------- --- | --- 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 diff --git a/src-3.0/GF/API/GrammarToTransfer.hs b/src-3.0/GF/API/GrammarToTransfer.hs deleted file mode 100644 index 658c15184..000000000 --- a/src-3.0/GF/API/GrammarToTransfer.hs +++ /dev/null @@ -1,94 +0,0 @@ ----------------------------------------------------------------------- --- | --- 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] diff --git a/src-3.0/GF/API/IOGrammar.hs b/src-3.0/GF/API/IOGrammar.hs deleted file mode 100644 index bd7fc5648..000000000 --- a/src-3.0/GF/API/IOGrammar.hs +++ /dev/null @@ -1,96 +0,0 @@ ----------------------------------------------------------------------- --- | --- 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 diff --git a/src-3.0/GF/API/MyParser.hs b/src-3.0/GF/API/MyParser.hs deleted file mode 100644 index c926fe865..000000000 --- a/src-3.0/GF/API/MyParser.hs +++ /dev/null @@ -1,25 +0,0 @@ ----------------------------------------------------------------------- --- | --- 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?") -- cgit v1.2.3