mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-27 21:42:50 -06:00
196 lines
7.4 KiB
Haskell
196 lines
7.4 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : ConvertGFCtoMCFG.Strict
|
|
-- Maintainer : PL
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/03/29 11:17:55 $
|
|
-- > CVS $Author: peb $
|
|
-- > CVS $Revision: 1.2 $
|
|
--
|
|
-- Converting GFC grammars to MCFG grammars, nondeterministically.
|
|
--
|
|
-- the resulting grammars might be /very large/
|
|
--
|
|
-- the conversion is only equivalent if the GFC grammar has a context-free backbone.
|
|
-- (also, the conversion might fail if the GFC grammar has dependent or higher-order types)
|
|
-----------------------------------------------------------------------------
|
|
|
|
|
|
module GF.Parsing.ConvertGFCtoMCFG.Strict (convertGrammar) where
|
|
|
|
import GF.System.Tracing
|
|
-- import IOExts (unsafePerformIO)
|
|
import GF.Printing.PrintParser
|
|
import GF.Printing.PrintSimplifiedTerm
|
|
-- import PrintGFC
|
|
-- import qualified PrGrammar as PG
|
|
|
|
import Monad
|
|
import Ident (Ident(..))
|
|
import AbsGFC
|
|
import GFC
|
|
import Look
|
|
import Operations
|
|
import qualified Modules as M
|
|
import CMacros (defLinType)
|
|
import MkGFC (grammar2canon)
|
|
import GF.Parsing.Utilities
|
|
import GF.Parsing.GrammarTypes
|
|
import GF.Parsing.MCFGrammar (Grammar, Rule(..), Lin(..))
|
|
import GF.Data.SortedList
|
|
-- import Maybe (listToMaybe)
|
|
import List (groupBy) -- , transpose)
|
|
|
|
import GF.Data.BacktrackM
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
type GrammarEnv = (CanonGrammar, Ident)
|
|
|
|
convertGrammar :: GrammarEnv -- ^ the canonical grammar, together with the selected language
|
|
-> MCFGrammar -- ^ the resulting MCF grammar
|
|
convertGrammar gram = trace2 "language" (prt (snd gram)) $
|
|
trace2 "modules" (prtSep " " modnames) $
|
|
tracePrt "#mcf-rules total" (prt . length) $
|
|
solutions conversion gram undefined
|
|
where Gr modules = grammar2canon (fst gram)
|
|
modnames = uncurry M.allExtends gram
|
|
conversion = member modules >>= convertModule
|
|
convertModule (Mod (MTCnc modname _) _ _ _ defs)
|
|
| modname `elem` modnames = member defs >>= convertDef
|
|
convertModule _ = failure
|
|
|
|
convertDef :: Def -> CnvMonad MCFRule
|
|
convertDef (CncDFun fun (CIQ _ cat) args term _)
|
|
| trace2 "converting function" (prt fun) True
|
|
= do env <- readEnv
|
|
let ctype = lookupCType env cat
|
|
instArgs <- mapM enumerateArg args
|
|
let instTerm = substitutePaths env instArgs term
|
|
newCat <- emcfCat cat instTerm
|
|
newArgs <- mapM (extractArg instArgs) args
|
|
let newTerm = strPaths env ctype instTerm >>= extractLin newArgs
|
|
traceDot $
|
|
return (Rule newCat newArgs newTerm fun)
|
|
convertDef _ = failure
|
|
|
|
------------------------------------------------------------
|
|
|
|
type CnvMonad a = BacktrackM GrammarEnv () a
|
|
|
|
----------------------------------------------------------------------
|
|
-- strict conversion
|
|
|
|
extractArg :: [STerm] -> ArgVar -> CnvMonad MCFCat
|
|
extractArg args (A cat nr) = emcfCat cat (args !! fromInteger nr)
|
|
|
|
emcfCat :: Cat -> STerm -> CnvMonad MCFCat
|
|
emcfCat cat term = do env <- readEnv
|
|
member $ map (MCFCat cat) $ parPaths env (lookupCType env cat) term
|
|
|
|
enumerateArg :: ArgVar -> CnvMonad STerm
|
|
enumerateArg (A cat nr) = do env <- readEnv
|
|
let ctype = lookupCType env cat
|
|
enumerate (SArg (fromInteger nr) cat emptyPath) ctype
|
|
where enumerate arg (TStr) = return arg
|
|
enumerate arg ctype@(Cn _) = do env <- readEnv
|
|
member $ groundTerms env ctype
|
|
enumerate arg (RecType rtype)
|
|
= liftM SRec $ sequence [ liftM ((,) lbl) $
|
|
enumerate (arg +. lbl) ctype |
|
|
lbl `Lbg` ctype <- rtype ]
|
|
enumerate arg (Table stype ctype)
|
|
= do env <- readEnv
|
|
state <- readState
|
|
liftM STbl $ sequence [ liftM ((,) sel) $
|
|
enumerate (arg +! sel) ctype |
|
|
sel <- solutions (enumerate err stype) env state ]
|
|
where err = error "enumerate: parameter type should not be string"
|
|
|
|
-- Substitute each instantiated parameter path for its instantiation
|
|
substitutePaths :: GrammarEnv -> [STerm] -> Term -> STerm
|
|
substitutePaths env arguments trm = subst trm
|
|
where subst (con `Con` terms) = con `SCon` map subst terms
|
|
subst (R record) = SRec [ (lbl, subst term) | lbl `Ass` term <- record ]
|
|
subst (term `P` lbl) = subst term +. lbl
|
|
subst (T ptype table) = STbl [ (pattern2sterm pat, subst term) |
|
|
pats `Cas` term <- table, pat <- pats ]
|
|
subst (V ptype table) = STbl [ (pat, subst term) |
|
|
(pat, term) <- zip (groundTerms env ptype) table ]
|
|
subst (term `S` select) = subst term +! subst select
|
|
subst (term `C` term') = subst term `SConcat` subst term'
|
|
subst (K str) = SToken str
|
|
subst (E) = SEmpty
|
|
subst (FV terms) = evalFV $ map subst terms
|
|
subst (Arg (A _ arg)) = arguments !! fromInteger arg
|
|
|
|
|
|
termPaths :: GrammarEnv -> CType -> STerm -> [(Path, (CType, STerm))]
|
|
termPaths env (TStr) term = [ (emptyPath, (TStr, term)) ]
|
|
termPaths env (RecType rtype) (SRec record)
|
|
= [ (path ++. lbl, value) |
|
|
(lbl, term) <- record,
|
|
let ctype = lookupLabelling lbl rtype,
|
|
(path, value) <- termPaths env ctype term ]
|
|
termPaths env (Table _ ctype) (STbl table)
|
|
= [ (path ++! pat, value) |
|
|
(pat, term) <- table,
|
|
(path, value) <- termPaths env ctype term ]
|
|
termPaths env ctype (SVariants terms)
|
|
= terms >>= termPaths env ctype
|
|
termPaths env (Cn pc) term = [ (emptyPath, (Cn pc, 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 :: GrammarEnv -> CType -> STerm -> [[(Path, STerm)]]
|
|
parPaths env ctype term = mapM (uncurry (map . (,))) (groupPairs paths)
|
|
where paths = nubsort [ (path, value) | (path, (Cn _, value)) <- termPaths env ctype term ]
|
|
|
|
strPaths :: GrammarEnv -> CType -> STerm -> [(Path, STerm)]
|
|
strPaths env ctype term = [ (path, evalFV values) | (path, values) <- groupPairs paths ]
|
|
where paths = nubsort [ (path, value) | (path, (TStr, value)) <- termPaths env ctype term ]
|
|
|
|
extractLin :: [MCFCat] -> (Path, STerm) -> [Lin MCFCat MCFLabel Tokn]
|
|
extractLin args (path, term) = map (Lin path) (convertLin term)
|
|
where convertLin (t1 `SConcat` t2) = liftM2 (++) (convertLin t1) (convertLin t2)
|
|
convertLin (SEmpty) = [[]]
|
|
convertLin (SToken tok) = [[Tok tok]]
|
|
convertLin (SVariants terms) = concatMap convertLin terms
|
|
convertLin (SArg nr _ path) = [[Cat (args !! nr, path, nr)]]
|
|
|
|
evalFV terms0 = case nubsort (concatMap flattenFV terms0) of
|
|
[term] -> term
|
|
terms -> SVariants terms
|
|
where flattenFV (SVariants ts) = ts
|
|
flattenFV t = [t]
|
|
|
|
----------------------------------------------------------------------
|
|
-- utilities
|
|
|
|
lookupCType :: GrammarEnv -> Cat -> CType
|
|
lookupCType env cat = errVal defLinType $
|
|
lookupLincat (fst env) (CIQ (snd env) cat)
|
|
|
|
lookupLabelling :: Label -> [Labelling] -> CType
|
|
lookupLabelling lbl rtyp = case [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ] of
|
|
[ctyp] -> ctyp
|
|
err -> error $ "lookupLabelling:" ++ show err
|
|
|
|
groundTerms :: GrammarEnv -> CType -> [STerm]
|
|
groundTerms env ctype = err error (map term2spattern) $
|
|
allParamValues (fst env) ctype
|
|
|
|
term2spattern (R rec) = SRec [ (lbl, term2spattern term) | Ass lbl term <- rec ]
|
|
term2spattern (Con con terms) = SCon con $ map term2spattern terms
|
|
|
|
pattern2sterm :: Patt -> STerm
|
|
pattern2sterm (con `PC` patterns) = con `SCon` map pattern2sterm patterns
|
|
pattern2sterm (PR record) = SRec [ (lbl, pattern2sterm pattern) |
|
|
lbl `PAss` pattern <- record ]
|
|
|