mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-22 11:19:32 -06:00
remove all files that aren't used in GF-3.0
This commit is contained in:
kr.angelov
@@ -1,157 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/09/01 09:53:18 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.14 $
|
||||
--
|
||||
-- All conversions from GFC
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Conversion.GFC
|
||||
(module GF.Conversion.GFC,
|
||||
SGrammar, EGrammar, MGrammar, CGrammar) where
|
||||
|
||||
import GF.Infra.Option
|
||||
import GF.Canon.GFC (CanonGrammar)
|
||||
import GF.Infra.Ident (Ident, identC)
|
||||
import qualified GF.Infra.Modules as M
|
||||
|
||||
import GF.Formalism.GCFG (Rule(..), Abstract(..))
|
||||
import GF.Formalism.SimpleGFC (decl2cat)
|
||||
import GF.Formalism.CFG (CFRule(..))
|
||||
import GF.Formalism.Utilities (symbol, name2fun)
|
||||
import GF.Conversion.Types
|
||||
|
||||
import qualified GF.Conversion.GFCtoSimple as G2S
|
||||
import qualified GF.Conversion.SimpleToFinite as S2Fin
|
||||
import qualified GF.Conversion.RemoveSingletons as RemSing
|
||||
import qualified GF.Conversion.RemoveErasing as RemEra
|
||||
import qualified GF.Conversion.RemoveEpsilon as RemEps
|
||||
import qualified GF.Conversion.SimpleToMCFG as S2M
|
||||
import qualified GF.Conversion.MCFGtoCFG as M2C
|
||||
|
||||
import GF.Infra.Print
|
||||
|
||||
import GF.System.Tracing
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * GFC -> MCFG & CFG, using options to decide which conversion is used
|
||||
|
||||
convertGFC :: Options -> (CanonGrammar, Ident)
|
||||
-> (SGrammar, (EGrammar, (MGrammar, CGrammar)))
|
||||
convertGFC opts = \g -> let s = g2s g
|
||||
e = s2e s
|
||||
m = e2m e
|
||||
in trace2 "Options" (show opts) (s, (e, (m, e2c e)))
|
||||
where e2c = M2C.convertGrammar
|
||||
e2m = case getOptVal opts firstCat of
|
||||
Just cat -> flip erasing [identC cat]
|
||||
Nothing -> flip erasing []
|
||||
s2e = case getOptVal opts gfcConversion of
|
||||
Just "strict" -> strict
|
||||
Just "finite-strict" -> strict
|
||||
Just "epsilon" -> epsilon . nondet
|
||||
_ -> nondet
|
||||
g2s = case getOptVal opts gfcConversion of
|
||||
Just "finite" -> finite . simple
|
||||
Just "finite2" -> finite . finite . simple
|
||||
Just "finite3" -> finite . finite . finite . simple
|
||||
Just "singletons" -> single . simple
|
||||
Just "finite-singletons" -> single . finite . simple
|
||||
Just "finite-strict" -> finite . simple
|
||||
_ -> simple
|
||||
|
||||
simple = G2S.convertGrammar
|
||||
strict = S2M.convertGrammarStrict
|
||||
nondet = S2M.convertGrammarNondet
|
||||
epsilon = RemEps.convertGrammar
|
||||
finite = S2Fin.convertGrammar
|
||||
single = RemSing.convertGrammar
|
||||
erasing = RemEra.convertGrammar
|
||||
|
||||
gfc2simple :: Options -> (CanonGrammar, Ident) -> SGrammar
|
||||
gfc2simple opts = fst . convertGFC opts
|
||||
|
||||
gfc2mcfg :: Options -> (CanonGrammar, Ident) -> MGrammar
|
||||
gfc2mcfg opts g = mcfg
|
||||
where
|
||||
(mcfg, _) = snd (snd (convertGFC opts g))
|
||||
|
||||
gfc2cfg :: Options -> (CanonGrammar, Ident) -> CGrammar
|
||||
gfc2cfg opts g = cfg
|
||||
where
|
||||
(_, cfg) = snd (snd (convertGFC opts g))
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * single step conversions
|
||||
|
||||
{-
|
||||
gfc2simple :: (CanonGrammar, Ident) -> SGrammar
|
||||
gfc2simple = G2S.convertGrammar
|
||||
|
||||
simple2finite :: SGrammar -> SGrammar
|
||||
simple2finite = S2Fin.convertGrammar
|
||||
|
||||
removeSingletons :: SGrammar -> SGrammar
|
||||
removeSingletons = RemSing.convertGrammar
|
||||
|
||||
simple2mcfg_nondet :: SGrammar -> EGrammar
|
||||
simple2mcfg_nondet =
|
||||
|
||||
simple2mcfg_strict :: SGrammar -> EGrammar
|
||||
simple2mcfg_strict = S2M.convertGrammarStrict
|
||||
|
||||
mcfg2cfg :: EGrammar -> CGrammar
|
||||
mcfg2cfg = M2C.convertGrammar
|
||||
|
||||
removeErasing :: EGrammar -> [SCat] -> MGrammar
|
||||
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) _ <- G2S.convertGrammar gr ]
|
||||
|
||||
abstract2skvatt :: [Abstract SCat Fun] -> String
|
||||
abstract2skvatt gr = skvatt_hdr ++ concatMap abs2pl gr
|
||||
where abs2pl (Abs cat [] fun) = prtQuoted cat ++ " ---> " ++
|
||||
"\"" ++ prt fun ++ "\".\n"
|
||||
abs2pl (Abs cat cats fun) =
|
||||
prtQuoted cat ++ " ---> " ++
|
||||
"\"(" ++ prt fun ++ "\"" ++
|
||||
prtBefore ", \" \", " (map prtQuoted cats) ++ ", \")\".\n"
|
||||
|
||||
cfg2skvatt :: CGrammar -> String
|
||||
cfg2skvatt gr = skvatt_hdr ++ concatMap cfg2pl gr
|
||||
where cfg2pl (CFRule cat syms _name) =
|
||||
prtQuoted cat ++ " ---> " ++
|
||||
if null syms then "\"\".\n" else
|
||||
prtSep ", " (map (symbol prtQuoted prTok) syms) ++ ".\n"
|
||||
prTok tok = "\"" ++ tok ++ " \""
|
||||
|
||||
skvatt_hdr = ":- use_module(library(skvatt)).\n" ++
|
||||
":- use_module(library(utils), [repeat/1]).\n" ++
|
||||
"corpus(File, StartCat, Depth, Size) :- \n" ++
|
||||
" set_flag(gendepth, Depth),\n" ++
|
||||
" tell(File), repeat(Size),\n" ++
|
||||
" generate_words(StartCat, String), format('~s~n~n', [String]),\n" ++
|
||||
" write(user_error, '.'),\n" ++
|
||||
" fail ; told.\n\n"
|
||||
|
||||
prtQuoted :: Print a => a -> String
|
||||
prtQuoted a = "'" ++ prt a ++ "'"
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -1,175 +0,0 @@
|
||||
---------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/07 11:24:51 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.15 $
|
||||
--
|
||||
-- Converting GFC to SimpleGFC
|
||||
--
|
||||
-- the conversion might fail if the GFC grammar has dependent or higher-order types,
|
||||
-- or if the grammar contains bound pattern variables
|
||||
-- (use -optimize=values/share/none when importing)
|
||||
--
|
||||
-- TODO: lift all functions to the 'Err' monad
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Conversion.GFCtoSimple
|
||||
(convertGrammar) where
|
||||
|
||||
import qualified GF.Canon.AbsGFC as A
|
||||
import qualified GF.Infra.Ident as I
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.SimpleGFC
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Conversion.Types
|
||||
|
||||
import GF.UseGrammar.Linear (expandLinTables)
|
||||
import GF.Canon.GFC (CanonGrammar)
|
||||
import GF.Canon.MkGFC (grammar2canon)
|
||||
import GF.Canon.Subexpressions (unSubelimCanon)
|
||||
import qualified GF.Canon.Look as Look (lookupLin, allParamValues, lookupLincat)
|
||||
import qualified GF.Canon.CMacros as CMacros (defLinType)
|
||||
import GF.Data.Operations (err, errVal)
|
||||
--import qualified Modules as M
|
||||
|
||||
import GF.System.Tracing
|
||||
import GF.Infra.Print
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
type Env = (CanonGrammar, I.Ident)
|
||||
|
||||
convertGrammar :: Env -> SGrammar
|
||||
convertGrammar (g,i) = trace2 "GFCtoSimple - concrete language" (prt (snd gram)) $
|
||||
tracePrt "GFCtoSimple - simpleGFC rules" (prt . length) $
|
||||
[ convertAbsFun gram fun typing |
|
||||
A.Mod (A.MTAbs modname) _ _ _ defs <- modules,
|
||||
A.AbsDFun fun typing _ <- defs ]
|
||||
where A.Gr modules = grammar2canon (fst gram)
|
||||
gram = (unSubelimCanon g,i)
|
||||
|
||||
convertAbsFun :: Env -> I.Ident -> A.Exp -> SRule
|
||||
convertAbsFun gram fun typing = -- trace2 "GFCtoSimple - converting function" (prt fun) $
|
||||
Rule abs cnc
|
||||
where abs = convertAbstract [] fun typing
|
||||
cnc = convertConcrete gram abs
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- abstract definitions
|
||||
|
||||
convertAbstract :: [SDecl] -> Fun -> A.Exp -> Abstract SDecl Name
|
||||
convertAbstract env fun (A.EProd x a b)
|
||||
= convertAbstract (convertAbsType x' [] a : env) fun b
|
||||
where x' = if x==I.identC "h_" then anyVar else x
|
||||
convertAbstract env fun a
|
||||
= Abs (convertAbsType anyVar [] a) (reverse env) name
|
||||
where name = Name fun [ Unify [n] | n <- [0 .. length env-1] ]
|
||||
|
||||
convertAbsType :: Var -> [FOType SCat] -> A.Exp -> SDecl
|
||||
convertAbsType x args (A.EProd _ a b) = convertAbsType x (convertType [] a : args) b
|
||||
convertAbsType x args a = Decl x (reverse args ::--> convertType [] a)
|
||||
|
||||
convertType :: [TTerm] -> A.Exp -> FOType SCat
|
||||
convertType args (A.EApp a b) = convertType (convertExp [] b : args) a
|
||||
convertType args (A.EAtom at) = convertCat at ::@ reverse args
|
||||
convertType args (A.EProd _ _ b) = convertType args b ---- AR 7/10 workaround
|
||||
convertType args exp = error $ "GFCtoSimple.convertType: " ++ prt exp
|
||||
|
||||
{- Exp from GF/Canon/GFC.cf:
|
||||
EApp. Exp1 ::= Exp1 Exp2 ;
|
||||
EProd. Exp ::= "(" Ident ":" Exp ")" "->" Exp ;
|
||||
EAbs. Exp ::= "\\" Ident "->" Exp ;
|
||||
EAtom. Exp2 ::= Atom ;
|
||||
EData. Exp2 ::= "data" ;
|
||||
-}
|
||||
|
||||
convertExp :: [TTerm] -> A.Exp -> TTerm
|
||||
convertExp args (A.EAtom at) = convertAtom args at
|
||||
convertExp args (A.EApp a b) = convertExp (convertExp [] b : args) a
|
||||
convertExp args exp = error $ "GFCtoSimple.convertExp: " ++ prt exp
|
||||
|
||||
convertAtom :: [TTerm] -> A.Atom -> TTerm
|
||||
convertAtom args (A.AC con) = con :@ reverse args
|
||||
-- A.AD: is this correct???
|
||||
convertAtom args (A.AD con) = con :@ args
|
||||
convertAtom [] (A.AV var) = TVar var
|
||||
convertAtom args atom = error $ "GFCtoSimple.convertAtom: " ++ prt args ++ " " ++ show atom
|
||||
|
||||
convertCat :: A.Atom -> SCat
|
||||
convertCat (A.AC (A.CIQ _ cat)) = cat
|
||||
convertCat atom = error $ "GFCtoSimple.convertCat: " ++ show atom
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- concrete definitions
|
||||
|
||||
convertConcrete :: Env -> Abstract SDecl Name -> Concrete SLinType (Maybe STerm)
|
||||
convertConcrete gram (Abs decl args name) = Cnc ltyp largs term
|
||||
where term = fmap (convertTerm gram . expandTerm gram) $ lookupLin gram $ name2fun name
|
||||
ltyp : largs = map (convertCType gram . lookupCType gram) (decl : args)
|
||||
|
||||
expandTerm :: Env -> A.Term -> A.Term
|
||||
expandTerm gram term = -- tracePrt "expanded term" prt $
|
||||
err error id $ expandLinTables (fst gram) $
|
||||
-- tracePrt "initial term" prt $
|
||||
term
|
||||
|
||||
convertCType :: Env -> A.CType -> SLinType
|
||||
convertCType gram (A.RecType rec) = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ]
|
||||
convertCType gram (A.Table pt vt) = TblT (enumerateTerms Nothing (convertCType gram pt)) (convertCType gram vt)
|
||||
convertCType gram ct@(A.Cn con) = ConT $ map (convertTerm gram) $ groundTerms gram ct
|
||||
convertCType gram (A.TStr) = StrT
|
||||
convertCType gram (A.TInts n) = error "GFCtoSimple.convertCType: cannot handle 'TInts' constructor"
|
||||
|
||||
convertTerm :: Env -> A.Term -> STerm
|
||||
convertTerm gram (A.Arg arg) = convertArgVar arg
|
||||
convertTerm gram (A.Par con terms) = con :^ map (convertTerm gram) terms
|
||||
-- convertTerm gram (A.LI var) = Var var
|
||||
convertTerm gram (A.R rec) = Rec [ (lbl, convertTerm gram term) | A.Ass lbl term <- rec ]
|
||||
convertTerm gram (A.P term lbl) = convertTerm gram term +. lbl
|
||||
convertTerm gram (A.V ctype terms) = Tbl [ (convertTerm gram pat, convertTerm gram term) |
|
||||
(pat, term) <- zip (groundTerms gram ctype) terms ]
|
||||
convertTerm gram (A.T ctype tbl) = Tbl [ (convertPatt pat, convertTerm gram term) |
|
||||
A.Cas pats term <- tbl, pat <- pats ]
|
||||
convertTerm gram (A.S term sel) = convertTerm gram term :! convertTerm gram sel
|
||||
convertTerm gram (A.C term1 term2) = convertTerm gram term1 ?++ convertTerm gram term2
|
||||
convertTerm gram (A.FV terms) = variants (map (convertTerm gram) terms)
|
||||
convertTerm gram (A.E) = Empty
|
||||
convertTerm gram (A.K (A.KS tok)) = Token tok
|
||||
-- 'pre' tokens are converted to variants (over-generating):
|
||||
convertTerm gram (A.K (A.KP strs vars))
|
||||
= variants $ map conc $ strs : [ vs | A.Var vs _ <- vars ]
|
||||
where conc [] = Empty
|
||||
conc ts = foldr1 (?++) $ map Token ts
|
||||
convertTerm gram (A.I con) = error "GFCtoSimple.convertTerm: cannot handle 'I' constructor"
|
||||
convertTerm gram (A.EInt int) = error "GFCtoSimple.convertTerm: cannot handle 'EInt' constructor"
|
||||
|
||||
convertArgVar :: A.ArgVar -> STerm
|
||||
convertArgVar (A.A cat nr) = Arg (fromInteger nr) cat emptyPath
|
||||
convertArgVar (A.AB cat bindings nr) = Arg (fromInteger nr) cat emptyPath
|
||||
|
||||
convertPatt (A.PC con pats) = con :^ map convertPatt pats
|
||||
-- convertPatt (A.PV x) = Var x
|
||||
-- convertPatt (A.PW) = Wildcard
|
||||
convertPatt (A.PR rec) = Rec [ (lbl, convertPatt pat) | A.PAss lbl pat <- rec ]
|
||||
convertPatt (A.PI n) = error "GFCtoSimple.convertPatt: cannot handle 'PI' constructor"
|
||||
convertPatt p = error $ "GFCtoSimple.convertPatt: cannot handle " ++ show p
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
lookupLin :: Env -> Fun -> Maybe A.Term
|
||||
lookupLin gram fun = err fail Just $
|
||||
Look.lookupLin (fst gram) (A.CIQ (snd gram) fun)
|
||||
|
||||
lookupCType :: Env -> SDecl -> A.CType
|
||||
lookupCType env decl
|
||||
= errVal CMacros.defLinType $
|
||||
Look.lookupLincat (fst env) (A.CIQ (snd env) (decl2cat decl))
|
||||
|
||||
groundTerms :: Env -> A.CType -> [A.Term]
|
||||
groundTerms gram ctype = err error id $
|
||||
Look.allParamValues (fst gram) ctype
|
||||
|
||||
@@ -1,71 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/08/11 14:11:46 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.1 $
|
||||
--
|
||||
-- Converting/Printing different grammar formalisms in Haskell-readable format
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Conversion.Haskell where
|
||||
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.SimpleGFC
|
||||
import GF.Formalism.MCFG
|
||||
import GF.Formalism.CFG
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Conversion.Types
|
||||
import GF.Data.Operations ((++++), (+++++))
|
||||
import GF.Infra.Print
|
||||
|
||||
import Data.List (intersperse)
|
||||
|
||||
-- | SimpleGFC to Haskell
|
||||
prtSGrammar :: SGrammar -> String
|
||||
prtSGrammar rules = "-- Simple GFC grammar as a Haskell file" ++++
|
||||
"-- Autogenerated from the Grammatical Framework" +++++
|
||||
"import GF.Formalism.GCFG" ++++
|
||||
"import GF.Formalism.SimpleGFC" ++++
|
||||
"import GF.Formalism.Utilities" ++++
|
||||
"import GF.Canon.AbsGFC (CIdent(..), Label(..))" ++++
|
||||
"import GF.Infra.Ident (Ident(..))" +++++
|
||||
"grammar :: SimpleGrammar Ident (NameProfile Ident) String" ++++
|
||||
"grammar = \n\t[ " ++
|
||||
concat (intersperse "\n\t, " (map show rules)) ++ "\n\t]\n\n"
|
||||
|
||||
-- | MCFG to Haskell
|
||||
prtMGrammar :: MGrammar -> String
|
||||
prtMGrammar rules = "-- Multiple context-free grammar as a Haskell file" ++++
|
||||
"-- Autogenerated from the Grammatical Framework" +++++
|
||||
"import GF.Formalism.GCFG" ++++
|
||||
"import GF.Formalism.MCFG" ++++
|
||||
"import GF.Formalism.Utilities" +++++
|
||||
"grammar :: MCFGrammar String (NameProfile String) String String" ++++
|
||||
"grammar = \n\t[ " ++
|
||||
concat (intersperse "\n\t, " (map prtMRule rules)) ++ "\n\t]\n\n"
|
||||
where prtMRule (Rule (Abs cat cats (Name fun profiles)) (Cnc lcat lcats lins))
|
||||
= show (Rule (Abs (prt cat) (map prt cats) (Name (prt fun) (map cnvProfile profiles)))
|
||||
(Cnc (map prt lcat) (map (map prt) lcats) (map cnvLin lins)))
|
||||
cnvLin (Lin lbl syms) = Lin (prt lbl) (map (mapSymbol prtMArg id) syms)
|
||||
prtMArg (cat, lbl, nr) = (prt cat, prt lbl, nr)
|
||||
|
||||
-- | CFG to Haskell
|
||||
prtCGrammar :: CGrammar -> String
|
||||
prtCGrammar rules = "-- Context-free grammar as a Haskell file" ++++
|
||||
"-- autogenerated from the Grammatical Framework" +++++
|
||||
"import GF.Formalism.CFG" ++++
|
||||
"import GF.Formalism.Utilities" ++++
|
||||
"\ngrammar :: CFGrammar String (NameProfile String) String" ++++
|
||||
"grammar = \n\t[ " ++
|
||||
concat (intersperse "\n\t, " (map prtCRule rules)) ++ "\n\t]\n\n"
|
||||
where prtCRule (CFRule cat syms (Name fun profiles))
|
||||
= show (CFRule (prt cat) (map (mapSymbol prt id) syms)
|
||||
(Name (prt fun) (map cnvProfile profiles)))
|
||||
|
||||
cnvProfile (Unify args) = Unify args
|
||||
cnvProfile (Constant forest) = Constant (fmap prt forest)
|
||||
@@ -1,53 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/09 09:28:43 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.6 $
|
||||
--
|
||||
-- Converting MCFG grammars to (possibly overgenerating) CFG
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Conversion.MCFGtoCFG
|
||||
(convertGrammar) where
|
||||
|
||||
import GF.System.Tracing
|
||||
import GF.Infra.Print
|
||||
|
||||
import Control.Monad
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.MCFG
|
||||
import GF.Formalism.CFG
|
||||
import GF.Conversion.Types
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * converting (possibly erasing) MCFG grammars
|
||||
|
||||
convertGrammar :: EGrammar -> CGrammar
|
||||
convertGrammar gram = tracePrt "MCFGtoCFG - context-free rules" (prt.length) $
|
||||
concatMap convertRule gram
|
||||
|
||||
convertRule :: ERule -> [CRule]
|
||||
convertRule (Rule (Abs cat args (Name fun mprofile)) (Cnc _ _ record))
|
||||
= [ CFRule (CCat cat lbl) rhs (Name fun profile) |
|
||||
Lin lbl lin <- record,
|
||||
let rhs = map (mapSymbol convertArg id) lin,
|
||||
let cprofile = map (Unify . argPlaces lin) [0 .. length args-1],
|
||||
let profile = mprofile `composeProfiles` cprofile
|
||||
]
|
||||
|
||||
convertArg :: (ECat, ELabel, Int) -> CCat
|
||||
convertArg (cat, lbl, _) = CCat cat lbl
|
||||
|
||||
argPlaces :: [Symbol (cat, lbl, Int) tok] -> Int -> [Int]
|
||||
argPlaces lin nr = [ place | (nr', place) <- zip linArgs [0..], nr == nr' ]
|
||||
where linArgs = [ nr' | (_, _, nr') <- filterCats lin ]
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -1,51 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/09 09:28:43 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.6 $
|
||||
--
|
||||
-- Converting MCFG grammars to equivalent optimized FCFG
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Conversion.MCFGtoFCFG
|
||||
(convertGrammar) where
|
||||
|
||||
import Control.Monad
|
||||
import List (elemIndex)
|
||||
import Array
|
||||
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.MCFG
|
||||
import GF.Formalism.FCFG
|
||||
import GF.Conversion.Types
|
||||
import GF.Data.SortedList (nubsort)
|
||||
|
||||
import GF.Infra.Print
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * converting MCFG to optimized FCFG
|
||||
|
||||
convertGrammar :: MGrammar -> FGrammar
|
||||
convertGrammar gram = [ FRule (Abs (fcat cat) (map fcat cats) name) (fcnc cnc) |
|
||||
Rule (Abs cat cats name) cnc <- gram ]
|
||||
where mcats = nubsort [ mc | Rule (Abs mcat mcats _) _ <- gram, mc <- mcat:mcats ]
|
||||
|
||||
fcat mcat@(MCat (ECat scat ecns) mlbls)
|
||||
= case elemIndex mcat mcats of
|
||||
Just catid -> FCat catid scat mlbls ecns
|
||||
Nothing -> error ("MCFGtoFCFG.fcat " ++ prt mcat)
|
||||
|
||||
fcnc (Cnc _ arglbls lins) = listArray (0, length lins-1) (map flin lins)
|
||||
where flin (Lin _ syms) = listArray (0, length syms-1) (map fsym syms)
|
||||
fsym (Tok tok) = FSymTok tok
|
||||
fsym (Cat (cat,lbl,arg)) = FSymCat (fcat cat) (flbl arg lbl) arg
|
||||
flbl arg lbl = case elemIndex lbl (arglbls !! arg) of
|
||||
Just lblid -> lblid
|
||||
Nothing -> error ("MCFGtoFCFG.flbl " ++ prt arg ++ " " ++ prt lbl)
|
||||
|
||||
@@ -1,205 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/09/14 09:51:18 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
--
|
||||
-- Converting/Printing different grammar formalisms in Prolog-readable format
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Conversion.Prolog (prtSGrammar, prtSMulti, prtSHeader, prtSRule,
|
||||
prtMGrammar, prtMMulti, prtMHeader, prtMRule,
|
||||
prtCGrammar, prtCMulti, prtCHeader, prtCRule) where
|
||||
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.SimpleGFC
|
||||
import GF.Formalism.MCFG
|
||||
import GF.Formalism.CFG
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Conversion.Types
|
||||
import qualified GF.Conversion.GFC as Cnv
|
||||
|
||||
import GF.Data.Operations ((++++), (+++++))
|
||||
import GF.Infra.Print
|
||||
import qualified GF.Infra.Modules as Mod
|
||||
import qualified GF.Infra.Option as Option
|
||||
import GF.Data.Operations (okError)
|
||||
import GF.Canon.AbsGFC (Flag(..))
|
||||
import GF.Canon.GFC (CanonGrammar)
|
||||
import GF.Infra.Ident (Ident(..))
|
||||
|
||||
import Data.Maybe (maybeToList, listToMaybe)
|
||||
import Data.Char (isLower, isAlphaNum)
|
||||
|
||||
import GF.System.Tracing
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- | printing multiple languages at the same time
|
||||
|
||||
prtSMulti, prtMMulti, prtCMulti :: Option.Options -> CanonGrammar -> String
|
||||
prtSMulti = prtMulti prtSHeader prtSRule Cnv.gfc2simple "gfc_"
|
||||
prtMMulti = prtMulti prtMHeader prtMRule Cnv.gfc2mcfg "mcfg_"
|
||||
prtCMulti = prtMulti prtCHeader prtCRule Cnv.gfc2cfg "cfg_"
|
||||
|
||||
-- code and ideas stolen from GF.CFGM.PrintCFGrammar
|
||||
|
||||
prtMulti prtHeader prtRule conversion prefix opts gr
|
||||
= prtHeader ++++ unlines
|
||||
[ "\n\n" ++ prtLine ++++
|
||||
"%% Language module: " ++ prtQ langmod +++++
|
||||
unlines (map (prtRule langmod) rules) |
|
||||
lang <- maybe [] (Mod.allConcretes gr) (Mod.greatestAbstract gr),
|
||||
let Mod.ModMod (Mod.Module{Mod.flags=fs}) = okError (Mod.lookupModule gr lang),
|
||||
let cnvopts = Option.Opts $ map Option.gfcConversion $ getFlag fs "conversion",
|
||||
let rules = conversion cnvopts (gr, lang),
|
||||
let langmod = (let IC lg = lang in prefix ++ lg) ]
|
||||
|
||||
getFlag :: [Flag] -> String -> [String]
|
||||
getFlag fs x = [v | Flg (IC k) (IC v) <- fs, k == x]
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- | SimpleGFC to Prolog
|
||||
--
|
||||
-- assumes that the profiles in the Simple GFC names are trivial
|
||||
prtSGrammar :: SGrammar -> String
|
||||
prtSGrammar rules = prtSHeader +++++ unlines (map (prtSRule "") rules)
|
||||
|
||||
prtSHeader :: String
|
||||
prtSHeader = prtLine ++++
|
||||
"%% Simple GFC grammar in Prolog-readable format" ++++
|
||||
"%% Autogenerated from the Grammatical Framework" +++++
|
||||
"%% The following predicate is defined:" ++++
|
||||
"%% \t rule(Fun, Cat, c(Cat,...), LinTerm)"
|
||||
|
||||
prtSRule :: String -> SRule -> String
|
||||
prtSRule lang (Rule (Abs cat cats (Name fun _prof)) (Cnc _ _ mterm))
|
||||
= (if null lang then "" else prtQ lang ++ " : ") ++
|
||||
prtFunctor "rule" [plfun, plcat, plcats, plcnc] ++ "."
|
||||
where plfun = prtQ fun
|
||||
plcat = prtSDecl cat
|
||||
plcats = prtFunctor "c" (map prtSDecl cats)
|
||||
plcnc = "\n\t" ++ prtSTerm (maybe Empty id mterm)
|
||||
|
||||
prtSTerm (Arg n c p) = prtFunctor "arg" [prtQ c, prt (n+1), prtSPath p]
|
||||
-- prtSTerm (c :^ []) = prtQ c
|
||||
prtSTerm (c :^ ts) = prtOper "^" (prtQ c) (prtPList (map prtSTerm ts))
|
||||
prtSTerm (Rec rec) = prtFunctor "rec" [prtPList [ prtOper "=" (prtQ l) (prtSTerm t) | (l, t) <- rec ]]
|
||||
prtSTerm (Tbl tbl) = prtFunctor "tbl" [prtPList [ prtOper "=" (prtSTerm p) (prtSTerm t) | (p, t) <- tbl ]]
|
||||
prtSTerm (Variants ts) = prtFunctor "variants" [prtPList (map prtSTerm ts)]
|
||||
prtSTerm (t1 :++ t2) = prtOper "+" (prtSTerm t1) (prtSTerm t2)
|
||||
prtSTerm (Token t) = prtFunctor "tok" [prtQ t]
|
||||
prtSTerm (Empty) = "empty"
|
||||
prtSTerm (term :. lbl) = prtOper "*" (prtSTerm term) (prtQ lbl)
|
||||
prtSTerm (term :! sel) = prtOper "/" (prtSTerm term) (prtSTerm sel)
|
||||
-- prtSTerm (Wildcard) = "wildcard"
|
||||
-- prtSTerm (Var var) = prtFunctor "var" [prtQ var]
|
||||
|
||||
prtSPath (Path path) = prtPList (map (either prtQ prtSTerm) path)
|
||||
|
||||
prtSDecl (Decl var typ) | var == anyVar = prtSAbsType typ
|
||||
| otherwise = "_" ++ prtVar var ++ ":" ++ prtSAbsType typ
|
||||
|
||||
|
||||
prtSAbsType ([] ::--> typ) = prtSFOType typ
|
||||
prtSAbsType (args ::--> typ) = prtOper ":->" (prtPList (map prtSFOType args)) (prtSFOType typ)
|
||||
|
||||
prtSFOType (cat ::@ args) = prtFunctor (prtQ cat) (map prtSTTerm args)
|
||||
|
||||
prtSTTerm (con :@ args) = prtFunctor (prtQ con) (map prtSTTerm args)
|
||||
prtSTTerm (TVar var) = "_" ++ prtVar var
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- | MCFG to Prolog
|
||||
prtMGrammar :: MGrammar -> String
|
||||
prtMGrammar rules = prtMHeader +++++ unlines (map (prtMRule "") rules)
|
||||
|
||||
prtMHeader :: String
|
||||
prtMHeader = prtLine ++++
|
||||
"%% Multiple context-free grammar in Prolog-readable format" ++++
|
||||
"%% Autogenerated from the Grammatical Framework" +++++
|
||||
"%% The following predicate is defined:" ++++
|
||||
"%% \t rule(Profile, Cat, c(Cat,...), [Lbl=Symbols,...])"
|
||||
|
||||
prtMRule :: String -> MRule -> String
|
||||
prtMRule lang (Rule (Abs cat cats name) (Cnc _lcat _lcats lins))
|
||||
= (if null lang then "" else prtQ lang ++ " : ") ++
|
||||
prtFunctor "rule" [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) ++ " ]"
|
||||
|
||||
prtMLin (Lin lbl lin) = prtOper "=" (prtQ lbl) (prtPList (map prtMSymbol lin))
|
||||
|
||||
prtMSymbol (Cat (cat, lbl, nr)) = prtFunctor "arg" [prtQ cat, show (nr+1), prtQ lbl]
|
||||
prtMSymbol (Tok tok) = prtFunctor "tok" [prtQ tok]
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- | CFG to Prolog
|
||||
prtCGrammar :: CGrammar -> String
|
||||
prtCGrammar rules = prtCHeader +++++ unlines (map (prtCRule "") rules)
|
||||
|
||||
prtCHeader :: String
|
||||
prtCHeader = prtLine ++++
|
||||
"%% Context-free grammar in Prolog-readable format" ++++
|
||||
"%% Autogenerated from the Grammatical Framework" +++++
|
||||
"%% The following predicate is defined:" ++++
|
||||
"%% \t rule(Profile, Cat, [Symbol,...])"
|
||||
|
||||
prtCRule :: String -> CRule -> String
|
||||
prtCRule lang (CFRule cat syms name)
|
||||
= (if null lang then "" else prtQ lang ++ " : ") ++
|
||||
prtFunctor "cfgrule" [plname, plcat, plsyms] ++ "."
|
||||
where plname = prtName name
|
||||
plcat = prtQ cat
|
||||
plsyms = prtPList (map prtCSymbol syms)
|
||||
|
||||
prtCSymbol (Cat cat) = prtFunctor "cat" [prtQ cat]
|
||||
prtCSymbol (Tok tok) = prtFunctor "tok" [prtQ tok]
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- profiles, quoted strings and more
|
||||
|
||||
prtFunctor f xs = f ++ if null xs then "" else "(" ++ prtSep ", " xs ++ ")"
|
||||
prtPList xs = "[" ++ prtSep ", " xs ++ "]"
|
||||
prtOper f x y = "(" ++ x ++ " " ++ f ++ " " ++ y ++ ")"
|
||||
|
||||
prtName name@(Name fun profiles)
|
||||
| name == coercionName = "1"
|
||||
| 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) = " ? "
|
||||
prtForest (FNode fun [fs]) = prtFunctor (prtQ fun) (map prtForest fs)
|
||||
prtForest (FNode fun fss) = prtPList [ prtFunctor (prtQ fun) (map prtForest fs) |
|
||||
fs <- fss ]
|
||||
|
||||
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"
|
||||
esc c = [c]
|
||||
|
||||
prtVar var = reprime (prt var)
|
||||
where reprime "" = ""
|
||||
reprime ('\'' : cs) = "_0" ++ reprime cs
|
||||
reprime (c:cs) = c : reprime cs
|
||||
|
||||
prtLine = replicate 70 '%'
|
||||
|
||||
|
||||
@@ -1,46 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/30 08:11:32 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.3 $
|
||||
--
|
||||
-- Removing epsilon linearizations from MCF grammars
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Conversion.RemoveEpsilon where
|
||||
-- (convertGrammar) where
|
||||
|
||||
import GF.System.Tracing
|
||||
import GF.Infra.Print
|
||||
|
||||
import Control.Monad
|
||||
import Data.List (mapAccumL)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.MCFG
|
||||
import GF.Conversion.Types
|
||||
import GF.Data.Assoc
|
||||
import GF.Data.SortedList
|
||||
import GF.Data.GeneralDeduction
|
||||
|
||||
convertGrammar :: EGrammar -> EGrammar
|
||||
convertGrammar grammar = trace2 "RemoveEpsilon: initialEmpties" (prt initialEmpties) $
|
||||
trace2 "RemoveEpsilon: emptyCats" (prt emptyCats) $
|
||||
grammar
|
||||
where initialEmpties = nubsort [ (cat, lbl) |
|
||||
Rule (Abs cat _ _) (Cnc _ _ lins) <- grammar,
|
||||
Lin lbl [] <- lins ]
|
||||
emptyCats = limitEmpties initialEmpties
|
||||
limitEmpties es = if es==es' then es else limitEmpties es'
|
||||
where es' = nubsort [ (cat, lbl) | Rule (Abs cat _ _) (Cnc _ _ lins) <- grammar,
|
||||
Lin lbl rhs <- lins,
|
||||
all (symbol (\(c,l,n) -> (c,l) `elem` es) (const False)) rhs ]
|
||||
|
||||
|
||||
|
||||
@@ -1,113 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.3 $
|
||||
--
|
||||
-- Removing erasingness from MCFG grammars (as in Ljunglöf 2004, sec 4.5.1)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Conversion.RemoveErasing
|
||||
(convertGrammar) where
|
||||
|
||||
import GF.System.Tracing
|
||||
import GF.Infra.Print
|
||||
|
||||
import Control.Monad
|
||||
import Data.List (mapAccumL)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.MCFG
|
||||
import GF.Conversion.Types
|
||||
import GF.Data.Assoc
|
||||
import GF.Data.SortedList
|
||||
import GF.Data.GeneralDeduction
|
||||
|
||||
convertGrammar :: EGrammar -> [SCat] -> MGrammar
|
||||
convertGrammar grammar starts = newGrammar
|
||||
where newGrammar = tracePrt "RemoveErasing - nonerasing rules" (prt . length) $
|
||||
[ rule | NR rule <- chartLookup finalChart True ]
|
||||
finalChart = tracePrt "RemoveErasing - nonerasing cats"
|
||||
(prt . length . flip chartLookup False) $
|
||||
buildChart keyof [newRules rulesByCat] $
|
||||
tracePrt "RemoveErasing - initial ne-cats" (prt . length) $
|
||||
initialCats
|
||||
initialCats = trace2 "RemoveErasing - starting categories" (prt starts) $
|
||||
if null starts
|
||||
then trace2 "RemoveErasing" "initialCatsBU" $
|
||||
initialCatsBU rulesByCat
|
||||
else trace2 "RemoveErasing" ("initialCatsTD: " ++ prt starts) $
|
||||
initialCatsTD rulesByCat starts
|
||||
rulesByCat = trace2 "RemoveErasing - erasing rules" (prt $ length grammar) $
|
||||
accumAssoc id [ (cat, rule) | rule@(Rule (Abs cat _ _) _) <- grammar ]
|
||||
|
||||
data Item r c = NR r | NC c deriving (Eq, Ord, Show)
|
||||
|
||||
keyof (NR _) = True
|
||||
keyof (NC _) = False
|
||||
|
||||
newRules grammar chart (NR (Rule (Abs _ cats _) _))
|
||||
= [ NC cat | cat@(MCat _ lbls) <- cats, not (null lbls) ]
|
||||
newRules grammar chart (NC newCat@(MCat cat lbls))
|
||||
= do Rule (Abs _ args (Name fun profile)) (Cnc _ _ lins0) <- grammar ? cat
|
||||
|
||||
lins <- selectLins lins0 lbls
|
||||
-- let lins = [ lin | lin@(Lin lbl _) <- lins0,
|
||||
-- lbl `elem` lbls ]
|
||||
|
||||
let argsInLin = listAssoc $
|
||||
map (\((n,c),l) -> (n, MCat c l)) $
|
||||
groupPairs $ nubsort $
|
||||
[ ((nr, cat), lbl) |
|
||||
Lin _ lin <- lins,
|
||||
Cat (cat, lbl, nr) <- lin ]
|
||||
|
||||
newArgs = mapMaybe (lookupAssoc argsInLin) [0 .. length args-1]
|
||||
argLbls = [ lbls | MCat _ lbls <- newArgs ]
|
||||
|
||||
newLins = [ Lin lbl newLin | Lin lbl lin <- lins,
|
||||
let newLin = map (mapSymbol cnvCat id) lin ]
|
||||
cnvCat (cat, lbl, nr) = (mcat, lbl, nr')
|
||||
where Just mcat = lookupAssoc argsInLin nr
|
||||
Unify [nr'] = newProfile !! nr
|
||||
nonEmptyCat (Cat (MCat _ [], _, _)) = False
|
||||
nonEmptyCat _ = True
|
||||
|
||||
newProfile = snd $ mapAccumL accumProf 0 $
|
||||
map (lookupAssoc argsInLin) [0 .. length args-1]
|
||||
accumProf nr = maybe (nr, Unify []) $ const (nr+1, Unify [nr])
|
||||
newName = -- tracePrt "newName" (prtNewName profile newProfile) $
|
||||
Name fun (profile `composeProfiles` newProfile)
|
||||
|
||||
guard $ all (not . null) argLbls
|
||||
return $ NR (Rule (Abs newCat newArgs newName) (Cnc lbls argLbls newLins))
|
||||
|
||||
selectLins lins0 = mapM selectLbl
|
||||
where selectLbl lbl = [ lin | lin@(Lin lbl' _) <- lins0, lbl == lbl' ]
|
||||
|
||||
|
||||
prtNewName :: [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)] -> Name -> String
|
||||
prtNewName p p' n = prt p ++ " .o. " ++ prt p' ++ " : " ++ prt n
|
||||
|
||||
|
||||
initialCatsTD grammar starts =
|
||||
[ cat | cat@(NC (MCat (ECat start _) _)) <- initialCatsBU grammar,
|
||||
start `elem` starts ]
|
||||
|
||||
initialCatsBU grammar
|
||||
= [ NC (MCat cat [lbl]) | (cat, rules) <- aAssocs grammar,
|
||||
let Rule _ (Cnc lbls _ _) = head rules,
|
||||
lbl <- lbls ]
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -1,82 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/11 10:28:16 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
--
|
||||
-- Instantiating all types which only have one single element.
|
||||
--
|
||||
-- Should be merged into 'GF.Conversion.FiniteToSimple'
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Conversion.RemoveSingletons where
|
||||
|
||||
import GF.System.Tracing
|
||||
import GF.Infra.Print
|
||||
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.SimpleGFC
|
||||
import GF.Conversion.Types
|
||||
|
||||
import GF.Data.SortedList
|
||||
import GF.Data.Assoc
|
||||
|
||||
import Data.List (mapAccumL)
|
||||
|
||||
convertGrammar :: SGrammar -> SGrammar
|
||||
convertGrammar grammar = if singles == emptyAssoc then grammar
|
||||
else tracePrt "RemoveSingletons - non-singleton rules" (prt . length) $
|
||||
map (convertRule singles) grammar
|
||||
where singles = calcSingletons grammar
|
||||
|
||||
convertRule :: Assoc SCat (SyntaxForest Fun, Maybe STerm) -> SRule -> SRule
|
||||
convertRule singles rule@(Rule (Abs _ decls _) _)
|
||||
= if all (Nothing ==) singleArgs then rule
|
||||
else instantiateSingles singleArgs rule
|
||||
where singleArgs = map (lookupAssoc singles . decl2cat) decls
|
||||
|
||||
instantiateSingles :: [Maybe (SyntaxForest Fun, Maybe STerm)] -> SRule -> SRule
|
||||
instantiateSingles singleArgs (Rule (Abs decl decls (Name fun profile)) (Cnc lcat lcats lterm))
|
||||
= Rule (Abs decl decls' (Name fun profile')) (Cnc lcat lcats' lterm')
|
||||
where (decls', lcats') = unzip [ (d, l) | (Nothing, d, l) <- zip3 singleArgs decls lcats ]
|
||||
profile' = map (fmap fst) exProfile `composeProfiles` profile
|
||||
newArgs = map (fmap snd) exProfile
|
||||
lterm' = fmap (instantiateLin newArgs) lterm
|
||||
exProfile = snd $ mapAccumL mkProfile 0 singleArgs
|
||||
mkProfile nr (Just trm) = (nr, Constant trm)
|
||||
mkProfile nr (Nothing) = (nr+1, Unify [nr])
|
||||
|
||||
instantiateLin :: [Profile (Maybe STerm)] -> STerm -> STerm
|
||||
instantiateLin newArgs = inst
|
||||
where inst (Arg nr cat path)
|
||||
= case newArgs !! nr of
|
||||
Unify [nr'] -> Arg nr' cat path
|
||||
Constant (Just term) -> termFollowPath path term
|
||||
Constant Nothing -> error "RemoveSingletons.instantiateLin: This should not happen (argument has no linearization)"
|
||||
inst (cn :^ terms) = cn :^ map inst terms
|
||||
inst (Rec rec) = Rec [ (lbl, inst term) | (lbl, term) <- rec ]
|
||||
inst (term :. lbl) = inst term +. lbl
|
||||
inst (Tbl tbl) = Tbl [ (pat, inst term) | (pat, term) <- tbl ]
|
||||
inst (term :! sel) = inst term +! inst sel
|
||||
inst (Variants ts) = variants (map inst ts)
|
||||
inst (t1 :++ t2) = inst t1 ?++ inst t2
|
||||
inst term = term
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
calcSingletons :: SGrammar -> Assoc SCat (SyntaxForest Fun, Maybe STerm)
|
||||
calcSingletons rules = listAssoc singleCats
|
||||
where singleCats = tracePrt "RemoveSingletons - singleton cats" (prtSep " ") $
|
||||
[ (cat, (constantNameToForest name, lin)) |
|
||||
(cat, [([], name, lin)]) <- rulesByCat ]
|
||||
rulesByCat = groupPairs $ nubsort
|
||||
[ (decl2cat cat, (args, name, lin)) |
|
||||
Rule (Abs cat args name) (Cnc _ _ lin) <- rules ]
|
||||
|
||||
|
||||
|
||||
@@ -1,178 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/09/01 09:53:19 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.7 $
|
||||
--
|
||||
-- Calculating the finiteness of each type in a grammar
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Conversion.SimpleToFinite
|
||||
(convertGrammar) where
|
||||
|
||||
import GF.System.Tracing
|
||||
import GF.Infra.Print
|
||||
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.SimpleGFC
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Conversion.Types
|
||||
|
||||
import GF.Data.SortedList
|
||||
import GF.Data.Assoc
|
||||
import GF.Data.BacktrackM
|
||||
import GF.Data.Utilities (lookupList)
|
||||
|
||||
import GF.Infra.Ident (Ident(..))
|
||||
|
||||
type CnvMonad a = BacktrackM () a
|
||||
|
||||
convertGrammar :: SGrammar -> SGrammar
|
||||
convertGrammar rules = tracePrt "SimpleToFinie - nr. 'finite' rules" (prt . length) $
|
||||
solutions cnvMonad ()
|
||||
where split = calcSplitable rules
|
||||
cnvMonad = member rules >>= convertRule split
|
||||
|
||||
convertRule :: Splitable -> SRule -> CnvMonad SRule
|
||||
convertRule split (Rule abs cnc)
|
||||
= do newAbs <- convertAbstract split abs
|
||||
return $ Rule newAbs cnc
|
||||
|
||||
{-
|
||||
-- old code
|
||||
convertAbstract :: Splitable -> Abstract SDecl Name
|
||||
-> CnvMonad (Abstract SDecl Name)
|
||||
convertAbstract split (Abs decl decls name)
|
||||
= case splitableFun split (name2fun name) of
|
||||
Just cat' -> return $ Abs (Decl anyVar (mergeFun (name2fun name) cat') []) decls name
|
||||
Nothing -> expandTyping split name [] decl decls []
|
||||
|
||||
|
||||
expandTyping :: Splitable -> Name -> [(Var, SCat)] -> SDecl -> [SDecl] -> [SDecl]
|
||||
-> CnvMonad (Abstract SDecl Name)
|
||||
expandTyping split name env (Decl x cat args) [] decls
|
||||
= return $ Abs decl (reverse decls) name
|
||||
where decl = substArgs split x env cat args []
|
||||
expandTyping split name env typ (Decl x xcat xargs : declsToDo) declsDone
|
||||
= do (x', xcat', env') <- calcNewEnv
|
||||
let decl = substArgs split x' env xcat' xargs []
|
||||
expandTyping split name env' typ declsToDo (decl : declsDone)
|
||||
where calcNewEnv = case splitableCat split xcat of
|
||||
Just newFuns -> do newFun <- member newFuns
|
||||
let newCat = mergeFun newFun xcat
|
||||
-- Just newCats -> do newCat <- member newCats
|
||||
return (anyVar, newCat, (x,newCat) : env)
|
||||
Nothing -> return (x, xcat, env)
|
||||
-}
|
||||
|
||||
-- new code
|
||||
convertAbstract :: Splitable -> Abstract SDecl Name
|
||||
-> CnvMonad (Abstract SDecl Name)
|
||||
convertAbstract split (Abs decl decls name)
|
||||
= case splitableFun split fun of
|
||||
Just cat' -> return $ Abs (Decl anyVar ([] ::--> (mergeFun fun cat' ::@ []))) decls name
|
||||
Nothing -> expandTyping split [] fun profiles [] decl decls []
|
||||
where Name fun profiles = name
|
||||
|
||||
expandTyping :: Splitable -> [(Var, SCat)]
|
||||
-> Fun -> [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)]
|
||||
-> SDecl -> [SDecl] -> [SDecl]
|
||||
-> CnvMonad (Abstract SDecl Name)
|
||||
expandTyping split env fun [] profiles (Decl x (typargs ::--> (cat ::@ args))) [] decls
|
||||
= return $ Abs decl (reverse decls) (Name fun (reverse profiles))
|
||||
where decl = substArgs split x env typargs cat args []
|
||||
expandTyping split env fun (prof:profiles) profsDone typ
|
||||
(Decl x (xtypargs ::--> (xcat ::@ xargs)) : declsToDo) declsDone
|
||||
= do (x', xcat', env', prof') <- calcNewEnv
|
||||
let decl = substArgs split x' env xtypargs xcat' xargs []
|
||||
expandTyping split env' fun profiles (prof' : profsDone) typ declsToDo (decl : declsDone)
|
||||
where calcNewEnv = case splitableCat split xcat of
|
||||
Nothing -> return (x, xcat, env, prof)
|
||||
Just newFuns -> do newFun <- member newFuns
|
||||
let newCat = mergeFun newFun xcat
|
||||
newProf = Constant (FNode newFun [[]])
|
||||
-- should really be using some kind of
|
||||
-- "profile unification"
|
||||
return (anyVar, newCat, (x,newCat) : env, newProf)
|
||||
|
||||
substArgs :: Splitable -> Var -> [(Var, SCat)] -> [FOType SCat]
|
||||
-> SCat -> [TTerm] -> [TTerm] -> SDecl
|
||||
substArgs split x env typargs cat [] args = Decl x (typargs ::--> (cat ::@ reverse args))
|
||||
substArgs split x env typargs cat (arg:argsToDo) argsDone
|
||||
= case argLookup split env arg of
|
||||
Just newCat -> substArgs split x env typargs (mergeArg cat newCat) argsToDo argsDone
|
||||
Nothing -> substArgs split x env typargs cat argsToDo (arg : argsDone)
|
||||
|
||||
argLookup split env (TVar x) = lookup x env
|
||||
argLookup split env (con :@ _) = fmap (mergeFun fun) (splitableFun split fun)
|
||||
where fun = constr2fun con
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- splitable categories (finite, no dependencies)
|
||||
-- they should also be used as some dependency
|
||||
|
||||
type Splitable = (Assoc SCat [Fun], Assoc Fun SCat)
|
||||
|
||||
splitableCat :: Splitable -> SCat -> Maybe [Fun]
|
||||
splitableCat = lookupAssoc . fst
|
||||
|
||||
splitableFun :: Splitable -> Fun -> Maybe SCat
|
||||
splitableFun = lookupAssoc . snd
|
||||
|
||||
calcSplitable :: [SRule] -> Splitable
|
||||
calcSplitable rules = (listAssoc splitableCat2Funs, listAssoc splitableFun2Cat)
|
||||
where splitableCat2Funs = groupPairs $ nubsort splitableCatFuns
|
||||
|
||||
splitableFun2Cat = nubsort
|
||||
[ (fun, cat) | (cat, fun) <- splitableCatFuns ]
|
||||
|
||||
-- cat-fun pairs that are splitable
|
||||
splitableCatFuns = tracePrt "SimpleToFinite - splitable functions" prt $
|
||||
[ (cat, name2fun name) |
|
||||
Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] name) _ <- rules,
|
||||
splitableCats ?= cat ]
|
||||
|
||||
-- all cats that are splitable
|
||||
splitableCats = listSet $
|
||||
tracePrt "SimpleToFinite - finite categories to split" prt $
|
||||
(nondepCats <**> depCats) <\\> resultCats
|
||||
|
||||
-- all result cats for some pure function
|
||||
resultCats = tracePrt "SimpleToFinite - result cats" prt $
|
||||
nubsort [ cat | Rule (Abs (Decl _ (_ ::--> (cat ::@ _))) decls _) _ <- rules,
|
||||
not (null decls) ]
|
||||
|
||||
-- all cats in constants without dependencies
|
||||
nondepCats = tracePrt "SimpleToFinite - nondep cats" prt $
|
||||
nubsort [ cat | Rule (Abs (Decl _ ([] ::--> (cat ::@ []))) [] _) _ <- rules ]
|
||||
|
||||
-- all cats occurring as some dependency of another cat
|
||||
depCats = tracePrt "SimpleToFinite - dep cats" prt $
|
||||
nubsort [ cat | Rule (Abs decl decls _) _ <- rules,
|
||||
cat <- varCats [] (decls ++ [decl]) ]
|
||||
|
||||
varCats _ [] = []
|
||||
varCats env (Decl x (xargs ::--> xtyp@(xcat ::@ _)) : decls)
|
||||
= varCats ((x,xcat) : env) decls ++
|
||||
[ cat | (_::@args) <- (xtyp:xargs), arg <- args,
|
||||
y <- varsInTTerm arg, cat <- lookupList y env ]
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- utilities
|
||||
-- mergeing categories
|
||||
|
||||
mergeCats :: String -> String -> String -> SCat -> SCat -> SCat
|
||||
mergeCats before middle after (IC cat) (IC arg)
|
||||
= IC (before ++ cat ++ middle ++ arg ++ after)
|
||||
|
||||
mergeFun, mergeArg :: SCat -> SCat -> SCat
|
||||
mergeFun = mergeCats "{" ":" "}"
|
||||
mergeArg = mergeCats "" "" ""
|
||||
|
||||
|
||||
@@ -1,26 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/18 14:55:32 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.3 $
|
||||
--
|
||||
-- All different conversions from SimpleGFC to MCFG
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Conversion.SimpleToMCFG where
|
||||
|
||||
import GF.Formalism.SimpleGFC
|
||||
import GF.Conversion.Types
|
||||
|
||||
import qualified GF.Conversion.SimpleToMCFG.Strict as Strict
|
||||
import qualified GF.Conversion.SimpleToMCFG.Nondet as Nondet
|
||||
import qualified GF.Conversion.SimpleToMCFG.Coercions as Coerce
|
||||
|
||||
convertGrammarNondet, convertGrammarStrict :: SGrammar -> EGrammar
|
||||
convertGrammarNondet = Coerce.addCoercions . Nondet.convertGrammar
|
||||
convertGrammarStrict = Strict.convertGrammar
|
||||
|
||||
@@ -1,63 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
--
|
||||
-- Adding coercion functions to a MCFG if necessary.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Conversion.SimpleToMCFG.Coercions
|
||||
(addCoercions) where
|
||||
|
||||
import GF.System.Tracing
|
||||
import GF.Infra.Print
|
||||
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.MCFG
|
||||
import GF.Conversion.Types
|
||||
import GF.Data.SortedList
|
||||
import Data.List (groupBy)
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
addCoercions :: EGrammar -> EGrammar
|
||||
addCoercions rules = coercions ++ rules
|
||||
where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) |
|
||||
Rule (Abs head args _) (Cnc lbls _ _) <- rules ]
|
||||
allHeadSet = nubsort allHeads
|
||||
allArgSet = union allArgs <\\> map fst allHeadSet
|
||||
coercions = tracePrt "SimpleToMCFG.Coercions - MCFG coercions" (prt . length) $
|
||||
concat $
|
||||
tracePrt "SimpleToMCFG.Coercions - MCFG coercions per category"
|
||||
(prtList . map length) $
|
||||
combineCoercions
|
||||
(groupBy sameECatFst allHeadSet)
|
||||
(groupBy sameECat allArgSet)
|
||||
sameECatFst a b = sameECat (fst a) (fst b)
|
||||
|
||||
|
||||
combineCoercions [] _ = []
|
||||
combineCoercions _ [] = []
|
||||
combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs)
|
||||
= case compare (ecat2scat $ fst $ head heads) (ecat2scat $ head args) of
|
||||
LT -> combineCoercions allHeads allArgs'
|
||||
GT -> combineCoercions allHeads' allArgs
|
||||
EQ -> makeCoercion heads args : combineCoercions allHeads allArgs
|
||||
|
||||
|
||||
makeCoercion heads args
|
||||
= [ Rule (Abs arg [head] coercionName) (Cnc lbls [lbls] lins) |
|
||||
(head@(ECat _ headCns), lbls) <- heads,
|
||||
let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ],
|
||||
arg@(ECat _ argCns) <- args,
|
||||
argCns `subset` headCns ]
|
||||
|
||||
|
||||
|
||||
@@ -1,256 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/08/17 08:27:29 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.7 $
|
||||
--
|
||||
-- Converting SimpleGFC grammars to MCFG grammars, nondeterministically.
|
||||
-- Afterwards, the grammar has to be extended with coercion functions,
|
||||
-- from the module 'GF.Conversion.SimpleToMCFG.Coercions'
|
||||
--
|
||||
-- the resulting grammars might be /very large/
|
||||
--
|
||||
-- the conversion is only equivalent if the GFC grammar has a context-free backbone.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Conversion.SimpleToMCFG.Nondet
|
||||
(convertGrammar) where
|
||||
|
||||
import GF.System.Tracing
|
||||
import GF.Infra.Print
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.MCFG
|
||||
import GF.Formalism.SimpleGFC
|
||||
import GF.Conversion.Types
|
||||
|
||||
import GF.Data.BacktrackM
|
||||
import GF.Data.Utilities (notLongerThan, updateNthM)
|
||||
|
||||
------------------------------------------------------------
|
||||
-- type declarations
|
||||
|
||||
type CnvMonad a = BacktrackM Env a
|
||||
|
||||
type Env = (ECat, [ECat], LinRec, [SLinType]) -- variable bindings: [(Var, STerm)]
|
||||
type LinRec = [Lin SCat MLabel Token]
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- main conversion function
|
||||
|
||||
maxNrRules :: Int
|
||||
maxNrRules = 5000
|
||||
|
||||
convertGrammar :: SGrammar -> EGrammar
|
||||
convertGrammar rules = traceCalcFirst rules' $
|
||||
tracePrt "SimpleToMCFG.Nondet - MCFG rules" (prt . length) $
|
||||
rules'
|
||||
where rules' = rules >>= convertRule
|
||||
-- solutions conversion undefined
|
||||
-- where conversion = member rules >>= convertRule
|
||||
|
||||
convertRule :: SRule -> [ERule] -- CnvMonad ERule
|
||||
convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) =
|
||||
-- | prt(name2fun fun) `elem`
|
||||
-- words "UseCl PosTP TPast ASimul SPredV IndefOneNP DefOneNP UseN2 mother_N2 jump_V" =
|
||||
if notLongerThan maxNrRules rules
|
||||
then tracePrt ("SimpeToMCFG.Nondet - MCFG rules for " ++ prt fun) (prt . length) $
|
||||
rules
|
||||
else trace2 "SimpeToMCFG.Nondet - TOO MANY RULES, function not converted"
|
||||
("More than " ++ show maxNrRules ++ " MCFG rules for " ++ prt fun) $
|
||||
[]
|
||||
where rules = flip solutions undefined $
|
||||
do let cat : args = map decl2cat (decl : decls)
|
||||
writeState (initialECat cat, map initialECat args, [], ctypes)
|
||||
rterm <- simplifyTerm term
|
||||
reduceTerm ctype emptyPath rterm
|
||||
(newCat, newArgs, linRec, _) <- readState
|
||||
let newLinRec = map (instantiateArgs newArgs) linRec
|
||||
catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes)
|
||||
-- checkLinRec argsPaths catPaths newLinRec
|
||||
return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec)
|
||||
convertRule _ = [] -- failure
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- "type-checking" the resulting linearization
|
||||
-- should not be necessary, if the algorithms (type-checking and conversion) are correct
|
||||
|
||||
checkLinRec args lbls = mapM (checkLin args lbls)
|
||||
|
||||
checkLin args lbls (Lin lbl lin)
|
||||
| lbl `elem` lbls = mapM (symbol (checkArg args) (const (return ()))) lin
|
||||
| otherwise = trace2 "SimpleToMCFG.Nondet - ERROR" "Label mismatch" $
|
||||
failure
|
||||
|
||||
checkArg args (_cat, lbl, nr)
|
||||
| lbl `elem` (args !! nr) = return ()
|
||||
-- | otherwise = trace2 "SimpleToMCFG.Nondet - ERROR" ("Label mismatch in arg " ++ prt nr) $
|
||||
-- failure
|
||||
| otherwise = trace2 ("SimpleToMCFG.Nondet - ERROR: Label mismatch in arg " ++ prt nr)
|
||||
(prt lbl ++ " `notElem` " ++ prt (args!!nr)) $
|
||||
failure
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- term simplification
|
||||
|
||||
simplifyTerm :: STerm -> CnvMonad STerm
|
||||
simplifyTerm (term :! sel)
|
||||
= do sterm <- simplifyTerm term
|
||||
ssel <- simplifyTerm sel
|
||||
case sterm of
|
||||
Tbl table -> do (pat, val) <- member table
|
||||
pat =?= ssel
|
||||
return val
|
||||
_ -> do sel' <- expandTerm ssel
|
||||
return (sterm +! sel')
|
||||
-- simplifyTerm (Var x) = readBinding x
|
||||
simplifyTerm (con :^ terms) = liftM (con :^) $ mapM simplifyTerm terms
|
||||
simplifyTerm (Rec record) = liftM Rec $ mapM simplifyAssign record
|
||||
simplifyTerm (term :. lbl) = liftM (+. lbl) $ simplifyTerm term
|
||||
simplifyTerm (Tbl table) = liftM Tbl $ mapM simplifyCase table
|
||||
simplifyTerm (Variants terms) = liftM Variants $ mapM simplifyTerm terms
|
||||
simplifyTerm (term1 :++ term2) = liftM2 (:++) (simplifyTerm term1) (simplifyTerm term2)
|
||||
simplifyTerm term = return term
|
||||
|
||||
simplifyAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
|
||||
simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term
|
||||
|
||||
simplifyCase :: (STerm, STerm) -> CnvMonad (STerm, STerm)
|
||||
simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term)
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- reducing simplified terms, collecting MCF rules
|
||||
|
||||
reduceTerm :: SLinType -> SPath -> STerm -> CnvMonad ()
|
||||
--reduceTerm ctype path (Variants terms)
|
||||
-- = member terms >>= reduceTerm ctype path
|
||||
reduceTerm (StrT) path term = updateLin (path, term)
|
||||
reduceTerm (ConT _) path term = do pat <- expandTerm term
|
||||
updateHead (path, pat)
|
||||
reduceTerm (RecT rtype) path term
|
||||
= sequence_ [ reduceTerm ctype (path ++. lbl) (term +. lbl) | (lbl, ctype) <- rtype ]
|
||||
reduceTerm (TblT pats vtype) path table
|
||||
= sequence_ [ reduceTerm vtype (path ++! pat) (table +! pat) | pat <- pats ]
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- expanding a term to ground terms
|
||||
|
||||
expandTerm :: STerm -> CnvMonad STerm
|
||||
expandTerm arg@(Arg nr _ path)
|
||||
= do ctypes <- readArgCTypes
|
||||
unifyPType arg $ lintypeFollowPath path $ ctypes !! nr
|
||||
-- expandTerm arg@(Arg nr _ path)
|
||||
-- = do ctypes <- readArgCTypes
|
||||
-- pat <- member $ enumeratePatterns $ lintypeFollowPath path $ ctypes !! nr
|
||||
-- pat =?= arg
|
||||
-- return pat
|
||||
expandTerm (con :^ terms) = liftM (con :^) $ mapM expandTerm terms
|
||||
expandTerm (Rec record) = liftM Rec $ mapM expandAssign record
|
||||
--expandTerm (Variants terms) = liftM Variants $ mapM expandTerm terms
|
||||
expandTerm (Variants terms) = member terms >>= expandTerm
|
||||
expandTerm term = error $ "expandTerm: " ++ prt term
|
||||
|
||||
expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
|
||||
expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term
|
||||
|
||||
unifyPType :: STerm -> SLinType -> CnvMonad STerm
|
||||
unifyPType arg (RecT prec) =
|
||||
liftM Rec $
|
||||
sequence [ liftM ((,) lbl) $
|
||||
unifyPType (arg +. lbl) ptype |
|
||||
(lbl, ptype) <- prec ]
|
||||
unifyPType (Arg nr _ path) (ConT terms) =
|
||||
do (_, args, _, _) <- readState
|
||||
case lookup path (ecatConstraints (args !! nr)) of
|
||||
Just term -> return term
|
||||
Nothing -> do term <- member terms
|
||||
updateArg nr (path, term)
|
||||
return term
|
||||
|
||||
------------------------------------------------------------
|
||||
-- unification of patterns and selection terms
|
||||
|
||||
(=?=) :: STerm -> STerm -> CnvMonad ()
|
||||
-- Wildcard =?= _ = return ()
|
||||
-- Var x =?= term = addBinding x term
|
||||
Rec precord =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) |
|
||||
(lbl, pat) <- precord ]
|
||||
pat =?= Arg nr _ path = updateArg nr (path, pat)
|
||||
(con :^ pats) =?= (con' :^ terms) = do guard (con==con' && length pats==length terms)
|
||||
sequence_ $ zipWith (=?=) pats terms
|
||||
Rec precord =?= Rec record = sequence_ [ maybe mzero (pat =?=) mterm |
|
||||
(lbl, pat) <- precord,
|
||||
let mterm = lookup lbl record ]
|
||||
-- variants are not allowed in patterns, but in selection terms:
|
||||
term =?= Variants terms = member terms >>= (term =?=)
|
||||
pat =?= term = error $ "(=?=): " ++ prt pat ++ " =?= " ++ prt term
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- variable bindings (does not work correctly)
|
||||
{-
|
||||
addBinding x term = do (a, b, c, d, bindings) <- readState
|
||||
writeState (a, b, c, d, (x,term):bindings)
|
||||
|
||||
readBinding x = do (_, _, _, _, bindings) <- readState
|
||||
return $ maybe (Var x) id $ lookup x bindings
|
||||
-}
|
||||
|
||||
------------------------------------------------------------
|
||||
-- updating the MCF rule
|
||||
|
||||
readArgCTypes :: CnvMonad [SLinType]
|
||||
readArgCTypes = do (_, _, _, env) <- readState
|
||||
return env
|
||||
|
||||
updateArg :: Int -> Constraint -> CnvMonad ()
|
||||
updateArg arg cn
|
||||
= do (head, args, lins, env) <- readState
|
||||
args' <- updateNthM (addToECat cn) arg args
|
||||
writeState (head, args', lins, env)
|
||||
|
||||
updateHead :: Constraint -> CnvMonad ()
|
||||
updateHead cn
|
||||
= do (head, args, lins, env) <- readState
|
||||
head' <- addToECat cn head
|
||||
writeState (head', args, lins, env)
|
||||
|
||||
updateLin :: Constraint -> CnvMonad ()
|
||||
updateLin (path, term)
|
||||
= do let newLins = term2lins term
|
||||
(head, args, lins, env) <- readState
|
||||
let lins' = lins ++ map (Lin path) newLins
|
||||
writeState (head, args, lins', env)
|
||||
|
||||
term2lins :: STerm -> [[Symbol (SCat, SPath, Int) Token]]
|
||||
term2lins (Arg nr cat path) = return [Cat (cat, path, nr)]
|
||||
term2lins (Token str) = return [Tok str]
|
||||
term2lins (t1 :++ t2) = liftM2 (++) (term2lins t1) (term2lins t2)
|
||||
term2lins (Empty) = return []
|
||||
term2lins (Variants terms) = terms >>= term2lins
|
||||
term2lins term = error $ "term2lins: " ++ show term
|
||||
|
||||
addToECat :: Constraint -> ECat -> CnvMonad ECat
|
||||
addToECat cn (ECat cat cns) = liftM (ECat cat) $ addConstraint cn cns
|
||||
|
||||
addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint]
|
||||
addConstraint cn0 (cn : cns)
|
||||
| fst cn0 > fst cn = liftM (cn:) (addConstraint cn0 cns)
|
||||
| fst cn0 == fst cn = guard (snd cn0 == snd cn) >>
|
||||
return (cn : cns)
|
||||
addConstraint cn0 cns = return (cn0 : cns)
|
||||
|
||||
|
||||
|
||||
@@ -1,129 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
--
|
||||
-- Converting SimpleGFC grammars to MCFG grammars, deterministic.
|
||||
--
|
||||
-- the resulting grammars might be /very large/
|
||||
--
|
||||
-- the conversion is only equivalent if the GFC grammar has a context-free backbone.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Conversion.SimpleToMCFG.Strict
|
||||
(convertGrammar) where
|
||||
|
||||
import GF.System.Tracing
|
||||
import GF.Infra.Print
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.MCFG
|
||||
import GF.Formalism.SimpleGFC
|
||||
import GF.Conversion.Types
|
||||
|
||||
import GF.Data.BacktrackM
|
||||
import GF.Data.SortedList
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- main conversion function
|
||||
|
||||
type CnvMonad a = BacktrackM () a
|
||||
|
||||
convertGrammar :: SGrammar -> EGrammar
|
||||
convertGrammar rules = tracePrt "SimpleToMCFG.Strict - MCFG rules" (prt . length) $
|
||||
solutions conversion undefined
|
||||
where conversion = member rules >>= convertRule
|
||||
|
||||
convertRule :: SRule -> CnvMonad ERule
|
||||
convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term)))
|
||||
= do let cat : args = map decl2cat (decl : decls)
|
||||
args_ctypes = zip3 [0..] args ctypes
|
||||
instArgs <- mapM enumerateArg args_ctypes
|
||||
let instTerm = substitutePaths instArgs term
|
||||
newCat <- extractECat cat ctype instTerm
|
||||
newArgs <- mapM (extractArg instArgs) args_ctypes
|
||||
let linRec = strPaths ctype instTerm >>= extractLin newArgs
|
||||
let newLinRec = map (instantiateArgs newArgs) linRec
|
||||
catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes)
|
||||
return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec)
|
||||
convertRule _ = failure
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- category extraction
|
||||
|
||||
extractArg :: [STerm] -> (Int, SCat, SLinType) -> CnvMonad ECat
|
||||
extractArg args (nr, cat, ctype) = extractECat cat ctype (args !! nr)
|
||||
|
||||
extractECat :: SCat -> SLinType -> STerm -> CnvMonad ECat
|
||||
extractECat cat ctype term = member $ map (ECat cat) $ parPaths ctype term
|
||||
|
||||
enumerateArg :: (Int, SCat, SLinType) -> CnvMonad STerm
|
||||
enumerateArg (nr, cat, ctype) = member $ enumerateTerms (Just (Arg nr cat emptyPath)) ctype
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- Substitute each instantiated parameter path for its instantiation
|
||||
|
||||
substitutePaths :: [STerm] -> STerm -> STerm
|
||||
substitutePaths arguments = subst
|
||||
where subst (Arg nr _ path) = termFollowPath path (arguments !! nr)
|
||||
subst (con :^ terms) = con :^ map subst terms
|
||||
subst (Rec record) = Rec [ (lbl, subst term) | (lbl, term) <- record ]
|
||||
subst (term :. lbl) = subst term +. lbl
|
||||
subst (Tbl table) = Tbl [ (pat, subst term) |
|
||||
(pat, term) <- table ]
|
||||
subst (term :! select) = subst term +! subst select
|
||||
subst (term :++ term') = subst term ?++ subst term'
|
||||
subst (Variants terms) = Variants $ map subst terms
|
||||
subst term = term
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- term paths extaction
|
||||
|
||||
termPaths :: SLinType -> STerm -> [(SPath, (SLinType, STerm))]
|
||||
termPaths ctype (Variants terms) = terms >>= termPaths ctype
|
||||
termPaths (RecT rtype) (Rec record)
|
||||
= [ (path ++. lbl, value) |
|
||||
(lbl, term) <- record,
|
||||
let Just ctype = lookup lbl rtype,
|
||||
(path, value) <- termPaths ctype term ]
|
||||
termPaths (TblT _ ctype) (Tbl table)
|
||||
= [ (path ++! pat, value) |
|
||||
(pat, term) <- table,
|
||||
(path, value) <- termPaths ctype term ]
|
||||
termPaths ctype term | isBaseType ctype = [ (emptyPath, (ctype, term)) ]
|
||||
|
||||
{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt):
|
||||
{a=a1; b=b1} | {a=a2; b=b2} ==> {a=a1|a2; b=b1|b2}
|
||||
[p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2]
|
||||
-}
|
||||
|
||||
parPaths :: SLinType -> STerm -> [[(SPath, STerm)]]
|
||||
parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $
|
||||
nubsort [ (path, value) |
|
||||
(path, (ConT _, value)) <- termPaths ctype term ]
|
||||
|
||||
strPaths :: SLinType -> STerm -> [(SPath, STerm)]
|
||||
strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs paths ]
|
||||
where paths = nubsort [ (path, value) | (path, (StrT, value)) <- termPaths ctype term ]
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- linearization extraction
|
||||
|
||||
extractLin :: [ECat] -> (SPath, STerm) -> [Lin ECat MLabel Token]
|
||||
extractLin args (path, term) = map (Lin path) (convertLin term)
|
||||
where convertLin (t1 :++ t2) = liftM2 (++) (convertLin t1) (convertLin t2)
|
||||
convertLin (Empty) = [[]]
|
||||
convertLin (Token tok) = [[Tok tok]]
|
||||
convertLin (Variants terms) = concatMap convertLin terms
|
||||
convertLin (Arg nr _ path) = [[Cat (args !! nr, path, nr)]]
|
||||
convertLin t = error $ "convertLin: " ++ prt t ++ " " ++ prt (args, path)
|
||||
|
||||
@@ -1,58 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/16 10:21:21 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.2 $
|
||||
--
|
||||
-- Printing the type hierarchy of an abstract module in GraphViz format
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Conversion.TypeGraph (prtTypeGraph, prtFunctionGraph) where
|
||||
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.SimpleGFC
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Conversion.Types
|
||||
|
||||
import GF.Data.Operations ((++++), (+++++))
|
||||
import GF.Infra.Print
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- | SimpleGFC to TypeGraph
|
||||
--
|
||||
-- assumes that the profiles in the Simple GFC names are trivial
|
||||
|
||||
prtTypeGraph :: SGrammar -> String
|
||||
prtTypeGraph rules = "digraph TypeGraph {" ++++
|
||||
"concentrate=true;" ++++
|
||||
"node [shape=ellipse];" +++++
|
||||
unlines (map prtTypeGraphRule rules) +++++
|
||||
"}"
|
||||
|
||||
prtTypeGraphRule :: SRule -> String
|
||||
prtTypeGraphRule (Rule abs@(Abs cat cats (Name fun _prof)) _)
|
||||
= "// " ++ prt abs ++++
|
||||
unlines [ prtSCat c ++ " -> " ++ prtSCat cat ++ ";" | c <- cats ]
|
||||
|
||||
prtFunctionGraph :: SGrammar -> String
|
||||
prtFunctionGraph rules = "digraph FunctionGraph {" ++++
|
||||
"node [shape=ellipse];" +++++
|
||||
unlines (map prtFunctionGraphRule rules) +++++
|
||||
"}"
|
||||
|
||||
prtFunctionGraphRule :: SRule -> String
|
||||
prtFunctionGraphRule (Rule abs@(Abs cat cats (Name fun _prof)) _)
|
||||
= "// " ++ prt abs ++++
|
||||
pfun ++ " [label=\"" ++ prt fun ++ "\", shape=box, style=dashed];" ++++
|
||||
pfun ++ " -> " ++ prtSCat cat ++ ";" ++++
|
||||
unlines [ prtSCat c ++ " -> " ++ pfun ++ ";" | c <- cats ]
|
||||
where pfun = "GF_FUNCTION_" ++ prt fun
|
||||
|
||||
prtSCat decl = prt (decl2cat decl)
|
||||
|
||||
|
||||
@@ -1,146 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/08/11 14:11:46 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.10 $
|
||||
--
|
||||
-- All possible instantiations of different grammar formats used in conversion from GFC
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Conversion.Types where
|
||||
|
||||
---import GF.Conversion.FTypes
|
||||
|
||||
import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent)
|
||||
import qualified GF.Canon.AbsGFC as AbsGFC (CIdent(..), Label(..))
|
||||
import qualified GF.GFCC.CId
|
||||
import qualified GF.Grammar.Grammar as Grammar (Term)
|
||||
|
||||
import GF.Formalism.GCFG
|
||||
import GF.Formalism.SimpleGFC
|
||||
import GF.Formalism.MCFG
|
||||
import GF.Formalism.FCFG
|
||||
import GF.Formalism.CFG
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Infra.Print
|
||||
import GF.Data.Assoc
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Data.Array
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * basic (leaf) types
|
||||
|
||||
-- ** input tokens
|
||||
|
||||
type Token = String
|
||||
|
||||
-- ** function names
|
||||
|
||||
type Fun = Ident.Ident
|
||||
type Name = NameProfile Fun
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * Simple GFC
|
||||
|
||||
type SCat = Ident.Ident
|
||||
|
||||
constr2fun :: Constr -> Fun
|
||||
constr2fun (AbsGFC.CIQ _ fun) = fun
|
||||
|
||||
-- ** grammar types
|
||||
|
||||
type SGrammar = SimpleGrammar SCat Name Token
|
||||
type SRule = SimpleRule SCat Name Token
|
||||
|
||||
type SPath = Path SCat Token
|
||||
type STerm = Term SCat Token
|
||||
type SLinType = LinType SCat Token
|
||||
type SDecl = Decl SCat
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * erasing MCFG
|
||||
|
||||
type EGrammar = MCFGrammar ECat Name ELabel Token
|
||||
type ERule = MCFRule ECat Name ELabel Token
|
||||
data ECat = ECat SCat [Constraint] deriving (Eq, Ord, Show)
|
||||
type ELabel = SPath
|
||||
|
||||
type Constraint = (SPath, STerm)
|
||||
|
||||
-- ** type coercions etc
|
||||
|
||||
initialECat :: SCat -> ECat
|
||||
initialECat cat = ECat cat []
|
||||
|
||||
ecat2scat :: ECat -> SCat
|
||||
ecat2scat (ECat cat _) = cat
|
||||
|
||||
ecatConstraints :: ECat -> [Constraint]
|
||||
ecatConstraints (ECat _ cns) = cns
|
||||
|
||||
sameECat :: ECat -> ECat -> Bool
|
||||
sameECat ec1 ec2 = ecat2scat ec1 == ecat2scat ec2
|
||||
|
||||
coercionName :: Name
|
||||
coercionName = Name Ident.identW [Unify [0]]
|
||||
|
||||
isCoercion :: Name -> Bool
|
||||
isCoercion (Name fun [Unify [0]]) = Ident.isWildIdent fun
|
||||
isCoercion _ = False
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * nonerasing MCFG
|
||||
|
||||
type MGrammar = MCFGrammar MCat Name MLabel Token
|
||||
type MRule = MCFRule MCat Name MLabel Token
|
||||
data MCat = MCat ECat [ELabel] deriving (Eq, Ord, Show)
|
||||
type MLabel = ELabel
|
||||
|
||||
mcat2ecat :: MCat -> ECat
|
||||
mcat2ecat (MCat cat _) = cat
|
||||
|
||||
mcat2scat :: MCat -> SCat
|
||||
mcat2scat = ecat2scat . mcat2ecat
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * fast nonerasing MCFG
|
||||
|
||||
---- moved to FTypes by AR 20/9/2007
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * CFG
|
||||
|
||||
type CGrammar = CFGrammar CCat Name Token
|
||||
type CRule = CFRule CCat Name Token
|
||||
data CCat = CCat ECat ELabel deriving (Eq, Ord, Show)
|
||||
|
||||
ccat2ecat :: CCat -> ECat
|
||||
ccat2ecat (CCat cat _) = cat
|
||||
|
||||
ccat2scat :: CCat -> SCat
|
||||
ccat2scat = ecat2scat . ccat2ecat
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * pretty-printing
|
||||
|
||||
instance Print ECat where
|
||||
prt (ECat cat constrs) = prt cat ++ "{" ++
|
||||
concat [ prt path ++ "=" ++ prt term ++ ";" |
|
||||
(path, term) <- constrs ] ++ "}"
|
||||
|
||||
instance Print MCat where
|
||||
prt (MCat cat labels) = prt cat ++ prt labels
|
||||
|
||||
instance Print CCat where
|
||||
prt (CCat cat label) = prt cat ++ prt label
|
||||
|
||||
---- instance Print FCat where ---- FCat
|
||||
|
||||
Reference in New Issue
Block a user