diff options
Diffstat (limited to 'src-3.0/GF/API')
| -rw-r--r-- | src-3.0/GF/API/BatchTranslate.hs | 43 | ||||
| -rw-r--r-- | src-3.0/GF/API/GrammarToHaskell.hs | 271 | ||||
| -rw-r--r-- | src-3.0/GF/API/GrammarToTransfer.hs | 94 | ||||
| -rw-r--r-- | src-3.0/GF/API/IOGrammar.hs | 96 | ||||
| -rw-r--r-- | src-3.0/GF/API/MyParser.hs | 25 |
5 files changed, 529 insertions, 0 deletions
diff --git a/src-3.0/GF/API/BatchTranslate.hs b/src-3.0/GF/API/BatchTranslate.hs new file mode 100644 index 000000000..c1b124526 --- /dev/null +++ b/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 + +-} diff --git a/src-3.0/GF/API/GrammarToHaskell.hs b/src-3.0/GF/API/GrammarToHaskell.hs new file mode 100644 index 000000000..c57cfed42 --- /dev/null +++ b/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 diff --git a/src-3.0/GF/API/GrammarToTransfer.hs b/src-3.0/GF/API/GrammarToTransfer.hs new file mode 100644 index 000000000..658c15184 --- /dev/null +++ b/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] diff --git a/src-3.0/GF/API/IOGrammar.hs b/src-3.0/GF/API/IOGrammar.hs new file mode 100644 index 000000000..bd7fc5648 --- /dev/null +++ b/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 diff --git a/src-3.0/GF/API/MyParser.hs b/src-3.0/GF/API/MyParser.hs new file mode 100644 index 000000000..c926fe865 --- /dev/null +++ b/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?") |