diff --git a/src/GF/Canon/GFCC/FCFGParsing.hs b/src/GF/Canon/GFCC/FCFGParsing.hs index dfedc6622..eeea653d2 100644 --- a/src/GF/Canon/GFCC/FCFGParsing.hs +++ b/src/GF/Canon/GFCC/FCFGParsing.hs @@ -118,13 +118,11 @@ cnv_forests2 (FFloat x) = FFloat x tree2term :: SyntaxTree Fun -> Exp tree2term (TNode f ts) = Tr (AC f) (map tree2term ts) -{- ---- -tree2term (TString s) = Macros.string2term s -tree2term (TInt n) = Macros.int2term n -tree2term (TFloat f) = Macros.float2term f -tree2term (TMeta) = Macros.mkMeta 0 --} +tree2term (TString s) = Tr (AS s) [] +tree2term (TInt n) = Tr (AI n) [] +tree2term (TFloat f) = Tr (AF f) [] +tree2term (TMeta) = Tr AM [] ---------------------------------------------------------------------- -- conversion and unification of forests diff --git a/src/GF/Canon/GFCC/GFCCAPI.hs b/src/GF/Canon/GFCC/GFCCAPI.hs index 211f9f67b..9c3978442 100644 --- a/src/GF/Canon/GFCC/GFCCAPI.hs +++ b/src/GF/Canon/GFCC/GFCCAPI.hs @@ -22,7 +22,8 @@ import GF.Canon.GFCC.ParGFCC import GF.Canon.GFCC.PrintGFCC import GF.Canon.GFCC.ErrM import GF.Canon.GFCC.FCFGParsing -import GF.Conversion.SimpleToFCFG (convertGrammarCId,FCat(..)) +import qualified GF.Canon.GFCC.GenGFCC as G +import GF.Conversion.SimpleToFCFG (convertGrammarCId,FCat(..)) ---- --import GF.Data.Operations --import GF.Infra.UseIO @@ -52,8 +53,11 @@ 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])] +parseAll :: MultiGrammar -> Category -> String -> [[Tree]] +parseAllLang :: MultiGrammar -> Category -> String -> [(Language,[Tree])] + +generateAll :: MultiGrammar -> Category -> [Tree] +generateRandom :: MultiGrammar -> Category -> IO [Tree] readTree :: MultiGrammar -> String -> Tree showTree :: Tree -> String @@ -80,26 +84,20 @@ linearize mgr lang = GF.Canon.GFCC.DataGFCC.linearize (gfcc mgr) (CId lang) parse mgr lang cat s = err error id $ parserLang (gfcc mgr) (CId lang) (CId cat) (words s) -{- - map tree2exp . - errVal [] . - parseString (stateOptions sgr) sgr cfcat - where - sgr = stateGrammarOfLang mgr (zIdent lang) - cfcat = string2CFCat abs cat - abs = maybe (error "no abstract syntax") prIdent $ abstract mgr --} - linearizeAll mgr = map snd . linearizeAllLang mgr linearizeAllLang mgr t = [(lang,linearThis 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 $ G.generateRandom gen (gfcc mgr) (CId cat) + +generateAll mgr cat = G.generate (gfcc mgr) (CId cat) readTree _ = err (const exp0) id . (pExp . myLexer) diff --git a/src/GF/Canon/GFCC/GFCCToHaskell.hs b/src/GF/Canon/GFCC/GFCCToHaskell.hs new file mode 100644 index 000000000..890c1a76f --- /dev/null +++ b/src/GF/Canon/GFCC/GFCCToHaskell.hs @@ -0,0 +1,212 @@ +---------------------------------------------------------------------- +-- | +-- 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.Canon.GFCC.GFCCToHaskell (grammar2haskell, grammar2haskellGADT) where + +import GF.Canon.GFCC.AbsGFCC +import GF.Canon.GFCC.DataGFCC +import GF.Data.Operations + +import Data.List --(isPrefixOf, find, intersperse) +import qualified Data.Map as Map + +-- | the main function +grammar2haskell :: GFCC -> String +grammar2haskell gr = foldr (++++) [] $ + haskPreamble ++ [datatypes gr', gfinstances gr', fginstances gr'] + where gr' = hSkeleton gr + +grammar2haskellGADT :: GFCC -> String +grammar2haskellGADT gr = foldr (++++) [] $ + ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ + haskPreamble ++ [datatypesGADT 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.Canon.GFCC.AbsGFCC", + "import GF.Canon.GFCC.DataGFCC", + "import GF.Data.Operations", + "----------------------------------------------------", + "-- automatic translation from GF to Haskell", + "----------------------------------------------------", + "", + "class Gf a where gf :: a -> Exp", + "class Fg a where fg :: Exp -> a", + "", + predefInst "GString" "String" "Tr (AS s) []", + "", + predefInst "GInt" "Integer" "Tr (AI s) []", + "", + predefInst "GFloat" "Double" "Tr (AF 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 t of" ++++ + " " +++ patt +++ " ->" +++ gtyp +++ "s" ++++ + " _ -> error (\"no" +++ gtyp +++ "\" ++ show 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 = "Tr (AC (CId \"" ++ f ++ "\"))" +++ + "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" + + +----fInstance m ("Cn",_) = "" --- +fInstance m (cat,[]) = "" +fInstance m (cat,rules) = + "instance Fg" +++ gId cat +++ "where" ++++ + " fg t =" ++++ + " case t of" ++++ + foldr1 (\x y -> x ++ "\n" ++ y) [mkInst f xx | (f,xx) <- rules] ++++ + " _ -> error (\"no" +++ cat ++ " \" ++ show t)" + where + mkInst f xx = + " Tr (AC (CId \"" ++ 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] + + +--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] +hSkeleton :: GFCC -> (String,HSkeleton) +hSkeleton gr = + (pr (absname gr), + [(pr c, [(pr f, map pr cs) | (f, Typ cs _) <- fs]) | + fs@((_, Typ _ c):_) <- fs] + ) + where + fs = groupBy valtypg (sortBy valtyps (Map.assocs (funs (abstract gr)))) + valtyps (_, Typ _ x) (_, Typ _ y) = compare x y + valtypg (_, Typ _ x) (_, Typ _ y) = x == y + pr (CId c) = c + +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 + +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/GF/Canon/GFCC/Shell.hs b/src/GF/Canon/GFCC/Shell.hs index 2bee4a300..5285b89a8 100644 --- a/src/GF/Canon/GFCC/Shell.hs +++ b/src/GF/Canon/GFCC/Shell.hs @@ -5,7 +5,7 @@ import qualified GF.Canon.GFCC.GenGFCC as G --- import GF.Canon.GFCC.AbsGFCC (CId(CId)) --- import System.Random (newStdGen) import System (getArgs) - +import Data.Char (isDigit) -- Simple translation application built on GFCC. AR 7/9/2006 -- 19/9/2007 @@ -13,29 +13,37 @@ main :: IO () main = do file:_ <- getArgs grammar <- file2grammar file - putStrLn $ "languages: " ++ unwords (languages grammar) - putStrLn $ "categories: " ++ unwords (categories grammar) + printHelp grammar loop grammar loop :: MultiGrammar -> IO () loop grammar = do s <- getLine - if s == "quit" then return () else do + if s == "q" then return () else do treat grammar s loop grammar +printHelp grammar = do + putStrLn $ "languages: " ++ unwords (languages grammar) + putStrLn $ "categories: " ++ unwords (categories grammar) + putStrLn commands + + +commands = unlines [ + "Commands:", + " (gt | gtt | gr | grt) Cat Num - generate all or random", + " p Lang Cat String - parse (unquoted) string", + " l Tree - linearize in all languages", + " h - help", + " q - quit" + ] + treat :: MultiGrammar -> String -> IO () treat mgr s = case words s of - "gt":cat:n:_ -> do - mapM_ prlinonly $ take (read n) $ G.generate grammar (CId cat) - "gtt":cat:n:_ -> do - mapM_ prlin $ take (read n) $ G.generate grammar (CId cat) - "gr":cat:n:_ -> do - gen <- newStdGen - mapM_ prlinonly $ take (read n) $ G.generateRandom gen grammar (CId cat) - "grt":cat:n:_ -> do - gen <- newStdGen - mapM_ prlin $ take (read n) $ G.generateRandom gen grammar (CId cat) + "gt" :cat:n:_ -> mapM_ prlinonly $ take (read1 n) $ generateAll mgr cat + "gtt":cat:n:_ -> mapM_ prlin $ generateAll mgr cat + "gr" :cat:n:_ -> generateRandom mgr cat >>= mapM_ prlinonly . take (read1 n) + "grt":cat:n:_ -> generateRandom mgr cat >>= mapM_ prlin . take (read1 n) "p":lang:cat:ws -> do let ts = parse mgr lang cat $ unwords ws mapM_ (putStrLn . showTree) ts @@ -43,6 +51,7 @@ treat mgr s = case words s of case G.parse (read n) grammar (CId cat) ws of t:_ -> prlin t _ -> putStrLn "no parse found" + "h":_ -> printHelp mgr _ -> lins $ readTree mgr s where grammar = gfcc mgr @@ -60,4 +69,6 @@ treat mgr s = case words s of putStrLn $ showTree t prlinonly t prlinonly t = mapM_ (lin t) $ langs + read1 s = if all isDigit s then read s else 1 + diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index 6737247ef..ea115b207 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -35,6 +35,8 @@ import qualified GF.Grammar.Grammar as G import qualified GF.Canon.AbsGFC as A import qualified GF.Canon.GFC as C import qualified GF.Canon.CanonToGFCC as GFCC +import qualified GF.Canon.GFCC.GFCCToHaskell as CCH +import qualified GF.Canon.GFCC.DataGFCC as DataGFCC import qualified GF.Canon.CanonToJS as JS (prCanon2js) import qualified GF.Source.AbsGF as GF import qualified GF.Grammar.MMacros as MM @@ -273,6 +275,8 @@ customGrammarPrinter = ,(strCI "bnf", \_ -> prBNF False) ,(strCI "absbnf", \_ -> abstract2bnf . stateGrammarST) ,(strCI "haskell", \_ -> grammar2haskell . stateGrammarST) + ,(strCI "gfcc_haskell", \_ -> CCH.grammar2haskell . DataGFCC.mkGFCC . + GFCC.mkCanon2gfcc . stateGrammarST) ,(strCI "haskell_gadt", \_ -> grammar2haskellGADT . stateGrammarST) ,(strCI "transfer", \_ -> grammar2transfer . stateGrammarST) ,(strCI "morpho", \_ -> prMorpho . stateMorpho)