diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs index a8afb8a01..a484b50e8 100644 --- a/src/GF/Compile/ShellState.hs +++ b/src/GF/Compile/ShellState.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/21 16:46:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.45 $ +-- > CVS $Date: 2005/09/01 09:53:18 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.46 $ -- -- (Description of the module) ----------------------------------------------------------------------------- @@ -189,7 +189,7 @@ updateShellState opts mcnc sh ((_,sgr,gr),rts) = do let pinfosOld = map (CnvOld.pInfo opts cgr) concrs -- peb 18/6 (OBSOLETE) - let fromGFC = Cnv.gfc2mcfg2cfg opts + let fromGFC = snd . snd . Cnv.convertGFC opts (mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs pInfos = zipWith Prs.buildPInfo mcfgs cfgs diff --git a/src/GF/Conversion/GFC.hs b/src/GF/Conversion/GFC.hs index c0d1b68b2..0975d552a 100644 --- a/src/GF/Conversion/GFC.hs +++ b/src/GF/Conversion/GFC.hs @@ -4,16 +4,16 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/08/11 14:11:46 $ +-- > CVS $Date: 2005/09/01 09:53:18 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.13 $ +-- > CVS $Revision: 1.14 $ -- -- All conversions from GFC ----------------------------------------------------------------------------- module GF.Conversion.GFC (module GF.Conversion.GFC, - SGrammar, MGrammar, CGrammar) where + SGrammar, EGrammar, MGrammar, CGrammar) where import GF.Infra.Option import GF.Canon.GFC (CanonGrammar) @@ -40,30 +40,39 @@ import GF.System.Tracing ---------------------------------------------------------------------- -- * GFC -> MCFG & CFG, using options to decide which conversion is used -gfc2mcfg2cfg :: Options -> (CanonGrammar, Ident) -> (MGrammar, CGrammar) -gfc2mcfg2cfg opts = \g -> let e = g2e g in trace2 "Options" (show opts) (e2m e, e2c e) - where e2c = mcfg2cfg +convertGFC :: Options -> (CanonGrammar, Ident) -> (SGrammar, (EGrammar, (MGrammar, CGrammar))) +convertGFC opts = \g -> let s = g2s g + e = s2e s + in trace2 "Options" (show opts) (s, (e, (e2m e, e2c e))) + where e2c = M2C.convertGrammar e2m = case getOptVal opts firstCat of - Just cat -> flip removeErasing [identC cat] - Nothing -> flip removeErasing [] - g2e = case getOptVal opts gfcConversion of - Just "strict" -> simple2mcfg_strict . gfc2simple - Just "finite" -> simple2mcfg_nondet . simple2finite . gfc2simple - Just "singletons" -> simple2mcfg_nondet . removeSingletons . gfc2simple - Just "epsilon" -> removeEpsilon . simple2mcfg_nondet . gfc2simple - Just "finite-singletons" -> simple2mcfg_nondet . removeSingletons . simple2finite . gfc2simple - Just "finite-strict" -> simple2mcfg_strict . simple2finite . gfc2simple - _ -> simple2mcfg_nondet . gfc2simple + Just cat -> flip RemEra.convertGrammar [identC cat] + Nothing -> flip RemEra.convertGrammar [] + s2e = case getOptVal opts gfcConversion of + Just "strict" -> S2M.convertGrammarStrict + Just "finite-strict" -> S2M.convertGrammarStrict + Just "epsilon" -> RemEps.convertGrammar . S2M.convertGrammarNondet + _ -> S2M.convertGrammarNondet + g2s = case getOptVal opts gfcConversion of + Just "finite" -> S2Fin.convertGrammar . G2S.convertGrammar + Just "singletons" -> RemSing.convertGrammar . G2S.convertGrammar + Just "finite-singletons" -> RemSing.convertGrammar . S2Fin.convertGrammar . G2S.convertGrammar + Just "finite-strict" -> S2Fin.convertGrammar . G2S.convertGrammar + _ -> G2S.convertGrammar + +gfc2simple :: Options -> (CanonGrammar, Ident) -> SGrammar +gfc2simple opts = fst . convertGFC opts gfc2mcfg :: Options -> (CanonGrammar, Ident) -> MGrammar -gfc2mcfg opts = fst . gfc2mcfg2cfg opts +gfc2mcfg opts = fst . snd . snd . convertGFC opts gfc2cfg :: Options -> (CanonGrammar, Ident) -> CGrammar -gfc2cfg opts = snd . gfc2mcfg2cfg opts +gfc2cfg opts = snd . snd . snd . convertGFC opts ---------------------------------------------------------------------- -- * single step conversions +{- gfc2simple :: (CanonGrammar, Ident) -> SGrammar gfc2simple = G2S.convertGrammar @@ -74,7 +83,7 @@ removeSingletons :: SGrammar -> SGrammar removeSingletons = RemSing.convertGrammar simple2mcfg_nondet :: SGrammar -> EGrammar -simple2mcfg_nondet = S2M.convertGrammarNondet +simple2mcfg_nondet = simple2mcfg_strict :: SGrammar -> EGrammar simple2mcfg_strict = S2M.convertGrammarStrict @@ -87,13 +96,14 @@ removeErasing = RemEra.convertGrammar removeEpsilon :: EGrammar -> EGrammar removeEpsilon = RemEps.convertGrammar +-} ---------------------------------------------------------------------- -- * converting to some obscure formats gfc2abstract :: (CanonGrammar, Ident) -> [Abstract SCat Fun] gfc2abstract gr = [ Abs (decl2cat decl) (map decl2cat decls) (name2fun name) | - Rule (Abs decl decls name) _ <- gfc2simple gr ] + Rule (Abs decl decls name) _ <- G2S.convertGrammar gr ] abstract2skvatt :: [Abstract SCat Fun] -> String abstract2skvatt gr = skvatt_hdr ++ concatMap abs2pl gr diff --git a/src/GF/Conversion/Prolog.hs b/src/GF/Conversion/Prolog.hs index 281960048..eecc4ca55 100644 --- a/src/GF/Conversion/Prolog.hs +++ b/src/GF/Conversion/Prolog.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/08/18 13:18:10 $ +-- > CVS $Date: 2005/09/01 09:53:19 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ +-- > CVS $Revision: 1.3 $ -- -- Converting/Printing different grammar formalisms in Prolog-readable format ----------------------------------------------------------------------------- @@ -34,12 +34,13 @@ import GF.Canon.GFC (CanonGrammar) import GF.Infra.Ident (Ident(..)) import Data.Maybe (maybeToList, listToMaybe) +import Data.Char (isLower, isAlphaNum) ---------------------------------------------------------------------- -- | printing multiple languages at the same time prtSMulti, prtMMulti, prtCMulti :: Option.Options -> CanonGrammar -> String -prtSMulti = prtMulti prtSHeader prtSRule (const Cnv.gfc2simple) +prtSMulti = prtMulti prtSHeader prtSRule Cnv.gfc2simple prtMMulti = prtMulti prtMHeader prtMRule Cnv.gfc2mcfg prtCMulti = prtMulti prtCHeader prtCRule Cnv.gfc2cfg @@ -78,9 +79,9 @@ prtSRule lang (Rule (Abs cat cats (Name fun _prof)) (Cnc _ _ mterm)) = (if null lang then "" else prtQ lang ++ " : ") ++ prtFunctor "gfcrule" [plfun, plcat, plcats, plcnc] ++ "." where plfun = prtQ fun - plcat = prtQ cat - plcats = prtFunctor "c" (map prtQ cats) - plcnc = "\n\t" ++ prtSTerm (maybe (Variants []) id mterm) + plcat = prtSCat cat + plcats = prtFunctor "c" (map prtSCat cats) + plcnc = "\n\t" ++ prtSTerm (maybe Empty id mterm) prtSTerm (Arg n c p) = prtFunctor "arg" [prtQ c, prtSPath p, prt (n+1)] -- prtSTerm (c :^ []) = prtQ c @@ -98,6 +99,13 @@ prtSTerm (term :! sel) = prtOper "/" (prtSTerm term) (prtSTerm sel) prtSPath (Path path) = prtPList (map (either prtQ prtSTerm) path) +prtSCat (Decl var cat args) = prVar ++ prtFunctor (prtQ cat) (map prtSTTerm args) + where prVar | var == anyVar = "" + | otherwise = "_" ++ prt var ++ ":" + +prtSTTerm (con :@ args) = prtFunctor (prtQ con) (map prtSTTerm args) +prtSTTerm (TVar var) = "_" ++ prt var + ---------------------------------------------------------------------- -- | MCFG to Prolog prtMGrammar :: MGrammar -> String @@ -108,14 +116,13 @@ prtMHeader = prtLine ++++ "%% Multiple context-free grammar in Prolog-readable format" ++++ "%% Autogenerated from the Grammatical Framework" +++++ "%% The following predicate is defined:" ++++ - "%% \t mcfgrule(Fun, p(Profile,...), Cat, c(Cat,...), [Lbl=Symbols,...])" + "%% \t mcfgrule(Fun(Profile,...), Cat, c(Cat,...), [Lbl=Symbols,...])" prtMRule :: String -> MRule -> String -prtMRule lang (Rule (Abs cat cats (Name fun profiles)) (Cnc _lcat _lcats lins)) +prtMRule lang (Rule (Abs cat cats name) (Cnc _lcat _lcats lins)) = (if null lang then "" else prtQ lang ++ " : ") ++ - prtFunctor "mcfgrule" [plfun, plprof, plcat, plcats, pllins] ++ "." - where plfun = prtQ fun - plprof = prtFunctor "p" (map prtProfile profiles) + prtFunctor "mcfgrule" [plname, plcat, plcats, pllins] ++ "." + where plname = prtName name plcat = prtQ cat plcats = prtFunctor "c" (map prtQ cats) pllins = "\n\t[ " ++ prtSep "\n\t, " (map prtMLin lins) ++ " ]" @@ -135,14 +142,13 @@ prtCHeader = prtLine ++++ "%% Context-free grammar in Prolog-readable format" ++++ "%% Autogenerated from the Grammatical Framework" +++++ "%% The following predicate is defined:" ++++ - "%% \t cfgrule(Fun, p(Profile,...), Cat, [Symbol,...])" + "%% \t cfgrule(Fun(Profile,...), Cat, [Symbol,...])" prtCRule :: String -> CRule -> String -prtCRule lang (CFRule cat syms (Name fun profiles)) +prtCRule lang (CFRule cat syms name) = (if null lang then "" else prtQ lang ++ " : ") ++ - prtFunctor "cfgrule" [plfun, plprof, plcat, plsyms] ++ "." - where plfun = prtQ fun - plprof = prtFunctor "p" (map prtProfile profiles) + prtFunctor "cfgrule" [plname, plcat, plsyms] ++ "." + where plname = prtName name plcat = prtQ cat plsyms = prtPList (map prtCSymbol syms) @@ -156,16 +162,26 @@ prtFunctor f xs = f ++ if null xs then "" else "(" ++ prtSep ", " xs ++ ")" prtPList xs = "[" ++ prtSep ", " xs ++ "]" prtOper f x y = "(" ++ x ++ " " ++ f ++ " " ++ y ++ ")" -prtProfile (Unify [arg]) = show (succ arg) -prtProfile (Unify args) = show (map succ args) +prtName (Name fun profiles) + | and (zipWith (==) profiles (map (Unify . return) [0..])) = prtQ fun + | otherwise = prtFunctor (prtQ fun) (map prtProfile profiles) + +prtProfile (Unify []) = " ? " +prtProfile (Unify args) = foldr1 (prtOper "=") (map (show . succ) args) prtProfile (Constant forest) = prtForest forest -prtForest (FMeta) = "fmeta" -prtForest (FNode fun fss) = prtFunctor "fnode" [prtQ fun, prtFss fss] - where prtFss fss = prtPList (map prtFs fss) - prtFs fs = prtPList (map prtForest fs) +prtForest (FMeta) = " ? " +prtForest (FNode fun [fs]) = prtFunctor (prtQ fun) (prtPList (map prtForest fs)) +prtForest (FNode fun fss) = prtPList [ prtFunctor (prtQ fun) (prtPList (map prtForest fs)) | + fs <- fss ] -prtQ x = "'" ++ concatMap esc (prt x) ++ "'" +prtQ atom = prtQStr (prt atom) + +prtQStr atom@(x:xs) + | isLower x && all isAlphaNumUnder xs = atom + where isAlphaNumUnder '_' = True + isAlphaNumUnder x = isAlphaNum x +prtQStr atom = "'" ++ concatMap esc (prt atom) ++ "'" where esc '\'' = "\\'" esc '\n' = "\\n" esc '\t' = "\\t" diff --git a/src/GF/Conversion/SimpleToFinite.hs b/src/GF/Conversion/SimpleToFinite.hs index adc8afc78..b875a698e 100644 --- a/src/GF/Conversion/SimpleToFinite.hs +++ b/src/GF/Conversion/SimpleToFinite.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/05/13 12:40:19 $ +-- > CVS $Date: 2005/09/01 09:53:19 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.6 $ +-- > CVS $Revision: 1.7 $ -- -- Calculating the finiteness of each type in a grammar ----------------------------------------------------------------------------- @@ -56,13 +56,13 @@ expandTyping split fun env (Decl x cat args) [] decls = return $ Abs decl (reverse decls) fun where decl = substArgs split x env cat args [] expandTyping split fun env typ (Decl x xcat xargs : declsToDo) declsDone - = do (xcat', env') <- calcNewEnv - let decl = substArgs split x env xcat' xargs [] + = do (x', xcat', env') <- calcNewEnv + let decl = substArgs split x' env xcat' xargs [] expandTyping split fun env' typ declsToDo (decl : declsDone) where calcNewEnv = case splitableCat split xcat of Just newCats -> do newCat <- member newCats - return (newCat, (x,newCat) : env) - Nothing -> return (xcat, env) + return (anyVar, newCat, (x,newCat) : env) + Nothing -> return (x, xcat, env) substArgs :: Splitable -> Var -> [(Var, SCat)] -> SCat -> [TTerm] -> [TTerm] -> SDecl substArgs split x env cat [] args = Decl x cat (reverse args) @@ -96,7 +96,8 @@ calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat) [ (fun, mergeFun fun cat) | (cat, fun) <- splitableCatFuns ] -- cat-fun pairs that are splitable - splitableCatFuns = [ (cat, name2fun name) | + splitableCatFuns = tracePrt "SimpleToFinite - splitable functions" prt $ + [ (cat, name2fun name) | Rule (Abs (Decl _ cat []) [] name) _ <- rules, splitableCats ?= cat ] diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index 340db4187..2e54bcb18 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/08/18 13:18:10 $ +-- > CVS $Date: 2005/09/01 09:53:19 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.68 $ +-- > CVS $Revision: 1.69 $ -- -- A database for customizable GF shell commands. -- @@ -264,24 +264,23 @@ customGrammarPrinter = ,(strCI "pinfo", Prt.prt . statePInfo) ,(strCI "abstract", Prt.prtAfter "\n" . Cnv.gfc2abstract . stateGrammarLang) - ,(strCI "gfc-haskell", CnvHaskell.prtSGrammar . Cnv.gfc2simple . stateGrammarLang) + ,(strCI "gfc-haskell", CnvHaskell.prtSGrammar . uncurry Cnv.gfc2simple . stateGrammarLangOpts) ,(strCI "mcfg-haskell", CnvHaskell.prtMGrammar . stateMCFG) ,(strCI "cfg-haskell", CnvHaskell.prtCGrammar . stateCFG) - ,(strCI "gfc-prolog", CnvProlog.prtSGrammar . Cnv.gfc2simple . stateGrammarLang) + ,(strCI "gfc-prolog", CnvProlog.prtSGrammar . uncurry Cnv.gfc2simple . stateGrammarLangOpts) ,(strCI "mcfg-prolog", CnvProlog.prtMGrammar . stateMCFG) ,(strCI "cfg-prolog", CnvProlog.prtCGrammar . stateCFG) -- obsolete, or only for testing: ,(strCI "abs-skvatt", Cnv.abstract2skvatt . Cnv.gfc2abstract . stateGrammarLang) ,(strCI "cfg-skvatt", Cnv.cfg2skvatt . stateCFG) - ,(strCI "simple", Prt.prt . Cnv.gfc2simple . stateGrammarLang) - ,(strCI "mcfg-erasing", Prt.prt . Cnv.simple2mcfg_nondet . Cnv.gfc2simple . stateGrammarLang) - ,(strCI "finite", Prt.prt . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang) - ,(strCI "single", Prt.prt . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang) - ,(strCI "sg-sg", Prt.prt . Cnv.removeSingletons . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang) + ,(strCI "simple", Prt.prt . uncurry Cnv.gfc2simple . stateGrammarLangOpts) + ,(strCI "mcfg-erasing", Prt.prt . fst . snd . uncurry Cnv.convertGFC . stateGrammarLangOpts) ,(strCI "mcfg-old", PrtOld.prt . CnvOld.mcfg . statePInfoOld) ,(strCI "cfg-old", PrtOld.prt . CnvOld.cfg . statePInfoOld) ] + where stateGrammarLangOpts s = (stateOptions s, stateGrammarLang s) + customMultiGrammarPrinter = customData "Printers for multiple grammars, selected by option -printer=x" $