forked from GitHub/gf-core
"Committed_by_peb"
This commit is contained in:
peb
70
src/GF/Parsing/ConvertGFCtoMCFG/Coercions.hs
Normal file
70
src/GF/Parsing/ConvertGFCtoMCFG/Coercions.hs
Normal file
@@ -0,0 +1,70 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : AddCoercions
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/03/21 22:31:53 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.1 $
|
||||
--
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Parsing.ConvertGFCtoMCFG.Coercions (addCoercions) where
|
||||
|
||||
import Tracing
|
||||
import GF.Printing.PrintParser
|
||||
import GF.Printing.PrintSimplifiedTerm
|
||||
-- import PrintGFC
|
||||
-- import qualified PrGrammar as PG
|
||||
|
||||
import qualified Ident
|
||||
import GF.Parsing.Utilities
|
||||
import GF.Parsing.GrammarTypes
|
||||
import GF.Parsing.MCFGrammar (Rule(..), Lin(..))
|
||||
import GF.Data.SortedList
|
||||
import List (groupBy) -- , transpose)
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
addCoercions :: MCFGrammar -> MCFGrammar
|
||||
addCoercions rules = coercions ++ rules
|
||||
where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) |
|
||||
Rule head args lins _ <- rules,
|
||||
let lbls = [ lbl | Lin lbl _ <- lins ] ]
|
||||
allHeadSet = nubsort allHeads
|
||||
allArgSet = union allArgs <\\> map fst allHeadSet
|
||||
coercions = tracePrt "#coercions total" (prt . length) $
|
||||
concat $
|
||||
tracePrt "#coercions per cat" (prtList . map length) $
|
||||
combineCoercions
|
||||
(groupBy sameCatFst allHeadSet)
|
||||
(groupBy sameCat allArgSet)
|
||||
sameCatFst a b = sameCat (fst a) (fst b)
|
||||
|
||||
|
||||
combineCoercions [] _ = []
|
||||
combineCoercions _ [] = []
|
||||
combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs)
|
||||
= case compare (mainCat $ fst $ head heads) (mainCat $ head args) of
|
||||
LT -> combineCoercions allHeads allArgs'
|
||||
GT -> combineCoercions allHeads' allArgs
|
||||
EQ -> makeCoercion heads args : combineCoercions allHeads allArgs
|
||||
|
||||
|
||||
makeCoercion heads args = [ Rule arg [head] lins coercionName |
|
||||
(head@(MCFCat _ headCns), lbls) <- heads,
|
||||
let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ],
|
||||
arg@(MCFCat _ argCns) <- args,
|
||||
argCns `subset` headCns ]
|
||||
|
||||
|
||||
coercionName = Ident.IW
|
||||
|
||||
mainCat (MCFCat c _) = c
|
||||
|
||||
sameCat mc1 mc2 = mainCat mc1 == mainCat mc2
|
||||
|
||||
|
||||
281
src/GF/Parsing/ConvertGFCtoMCFG/Nondet.hs
Normal file
281
src/GF/Parsing/ConvertGFCtoMCFG/Nondet.hs
Normal file
@@ -0,0 +1,281 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : ConvertGFCtoMCFG.Nondet
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/03/21 22:31:53 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.1 $
|
||||
--
|
||||
-- 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.Nondet (convertGrammar) where
|
||||
|
||||
import 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 let iCat : iArgs = map initialMCat (cat : map catOfArg args)
|
||||
writeState (iCat, iArgs, [])
|
||||
convertTerm cat term
|
||||
(newCat, newArgs, linRec) <- readState
|
||||
let newTerm = map (instLin newArgs) linRec
|
||||
traceDot $
|
||||
return (Rule newCat newArgs newTerm fun)
|
||||
convertDef _ = failure
|
||||
|
||||
instLin newArgs (Lin lbl lin) = Lin lbl (map instSym lin)
|
||||
where instSym = mapSymbol instCat id
|
||||
instCat (_, lbl, arg) = (newArgs !! arg, lbl, arg)
|
||||
|
||||
convertTerm :: Cat -> Term -> CnvMonad ()
|
||||
convertTerm cat term = do rterm <- simplifyTerm term
|
||||
env <- readEnv
|
||||
let ctype = lookupCType env cat
|
||||
reduce ctype rterm emptyPath
|
||||
|
||||
------------------------------------------------------------
|
||||
|
||||
type CnvMonad a = BacktrackM GrammarEnv CMRule a
|
||||
|
||||
type CMRule = (MCFCat, [MCFCat], LinRec)
|
||||
type LinRec = [Lin Cat Path Tokn]
|
||||
|
||||
initialMCat :: Cat -> MCFCat
|
||||
initialMCat cat = MCFCat cat []
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
simplifyTerm :: Term -> CnvMonad STerm
|
||||
simplifyTerm (Arg (A cat nr)) = return (SArg (fromInteger nr) cat emptyPath)
|
||||
simplifyTerm (Con con terms) = liftM (SCon con) $ mapM simplifyTerm terms
|
||||
simplifyTerm (R record) = liftM SRec $ mapM simplifyAssign record
|
||||
simplifyTerm (P term lbl) = liftM (+. lbl) $ simplifyTerm term
|
||||
simplifyTerm (T ct table) = liftM STbl $ sequence $ concatMap simplifyCase table
|
||||
simplifyTerm (V ct terms)
|
||||
= do env <- readEnv
|
||||
liftM STbl $ sequence [ liftM ((,) pat) (simplifyTerm term) |
|
||||
(pat, term) <- zip (groundTerms env ct) terms ]
|
||||
simplifyTerm (S term sel)
|
||||
= do sterm <- simplifyTerm term
|
||||
ssel <- simplifyTerm sel
|
||||
case sterm of
|
||||
STbl table -> do (pat, val) <- member table
|
||||
pat =?= ssel
|
||||
return val
|
||||
_ -> do sel' <- expandTerm ssel
|
||||
return (sterm +! sel')
|
||||
simplifyTerm (FV terms) = liftM SVariants $ mapM simplifyTerm terms
|
||||
simplifyTerm (term1 `C` term2) = liftM2 (SConcat) (simplifyTerm term1) (simplifyTerm term2)
|
||||
simplifyTerm (K tokn) = return $ SToken tokn
|
||||
simplifyTerm (E) = return $ SEmpty
|
||||
simplifyTerm x = error $ "simplifyTerm: " ++ show x
|
||||
-- error constructors:
|
||||
-- (I CIdent) - from resource
|
||||
-- (LI Ident) - pattern variable
|
||||
-- (EInt Integer) - integer
|
||||
|
||||
simplifyAssign :: Assign -> CnvMonad (Label, STerm)
|
||||
simplifyAssign (Ass lbl term) = liftM ((,) lbl) $ simplifyTerm term
|
||||
|
||||
simplifyCase :: Case -> [CnvMonad (STerm, STerm)]
|
||||
simplifyCase (Cas pats term) = [ liftM2 (,) (simplifyPattern pat) (simplifyTerm term) |
|
||||
pat <- pats ]
|
||||
|
||||
simplifyPattern :: Patt -> CnvMonad STerm
|
||||
simplifyPattern (PC con pats) = liftM (SCon con) $ mapM simplifyPattern pats
|
||||
simplifyPattern (PW) = return SWildcard
|
||||
simplifyPattern (PR record) = do record' <- mapM simplifyPattAssign record
|
||||
case filter (\row -> snd row /= SWildcard) record' of
|
||||
[] -> return SWildcard
|
||||
record'' -> return (SRec record')
|
||||
simplifyPattern x = error $ "simplifyPattern: " ++ show x
|
||||
-- error constructors:
|
||||
-- (PV Ident) - pattern variable
|
||||
|
||||
simplifyPattAssign :: PattAssign -> CnvMonad (Label, STerm)
|
||||
simplifyPattAssign (PAss lbl pat) = liftM ((,) lbl) $ simplifyPattern pat
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- reducing simplified terms, collecting mcf rules
|
||||
|
||||
reduce :: CType -> STerm -> Path -> CnvMonad ()
|
||||
reduce TStr term path = updateLin (path, term)
|
||||
reduce (Cn _) term path
|
||||
= do pat <- expandTerm term
|
||||
updateHead (path, pat)
|
||||
reduce ctype (SVariants terms) path
|
||||
= do term <- member terms
|
||||
reduce ctype term path
|
||||
reduce (RecType rtype) term path
|
||||
= sequence_ [ reduce ctype (term +. lbl) (path ++. lbl) |
|
||||
Lbg lbl ctype <- rtype ]
|
||||
reduce (Table _ ctype) (STbl table) path
|
||||
= sequence_ [ reduce ctype term (path ++! pat) |
|
||||
(pat, term) <- table ]
|
||||
reduce (Table ptype vtype) arg@(SArg _ _ _) path
|
||||
= do env <- readEnv
|
||||
sequence_ [ reduce vtype (arg +! pat) (path ++! pat) |
|
||||
pat <- groundTerms env ptype ]
|
||||
reduce ctype term path = error ("reduce:\n ctype = (" ++ show ctype ++
|
||||
")\n term = (" ++ show term ++
|
||||
")\n path = (" ++ show path ++ ")\n")
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- expanding a term to ground terms
|
||||
|
||||
expandTerm :: STerm -> CnvMonad STerm
|
||||
expandTerm arg@(SArg _ _ _)
|
||||
= do env <- readEnv
|
||||
pat <- member $ groundTerms env $ cTypeForArg env arg
|
||||
pat =?= arg
|
||||
return pat
|
||||
expandTerm (SCon con terms) = liftM (SCon con) $ mapM expandTerm terms
|
||||
expandTerm (SRec record) = liftM SRec $ mapM expandAssign record
|
||||
expandTerm (SVariants terms) = member terms >>= expandTerm
|
||||
expandTerm term = error $ "expandTerm: " ++ show term
|
||||
|
||||
expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
|
||||
expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term
|
||||
|
||||
------------------------------------------------------------
|
||||
-- unification of patterns and selection terms
|
||||
|
||||
(=?=) :: STerm -> STerm -> CnvMonad ()
|
||||
SWildcard =?= _ = return ()
|
||||
SRec precord =?= arg@(SArg _ _ _) = sequence_ [ pat =?= (arg +. lbl) |
|
||||
(lbl, pat) <- precord ]
|
||||
pat =?= SArg arg _ path = updateArg arg (path, pat)
|
||||
SCon con pats =?= SCon con' terms = do guard (con==con' && length pats==length terms)
|
||||
sequence_ $ zipWith (=?=) pats terms
|
||||
SRec precord =?= SRec record = sequence_ [ maybe mzero (pat =?=) mterm |
|
||||
(lbl, pat) <- precord,
|
||||
let mterm = lookup lbl record ]
|
||||
pat =?= term = error $ "(=?=): " ++ show pat ++ " =?= " ++ show term
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- updating the mcf rule
|
||||
|
||||
updateArg :: Int -> Constraint -> CnvMonad ()
|
||||
updateArg arg cn
|
||||
= do (head, args, lins) <- readState
|
||||
args' <- updateNth (addToMCFCat cn) arg args
|
||||
writeState (head, args', lins)
|
||||
|
||||
updateHead :: Constraint -> CnvMonad ()
|
||||
updateHead cn
|
||||
= do (head, args, lins) <- readState
|
||||
head' <- addToMCFCat cn head
|
||||
writeState (head', args, lins)
|
||||
|
||||
updateLin :: Constraint -> CnvMonad ()
|
||||
updateLin (path, term)
|
||||
= do let newLins = term2lins term
|
||||
(head, args, lins) <- readState
|
||||
let lins' = lins ++ map (Lin path) newLins
|
||||
writeState (head, args, lins')
|
||||
|
||||
term2lins :: STerm -> [[Symbol (Cat, Path, Int) Tokn]]
|
||||
term2lins (SArg arg cat path) = return [Cat (cat, path, arg)]
|
||||
term2lins (SToken str) = return [Tok str]
|
||||
term2lins (SConcat t1 t2) = liftM2 (++) (term2lins t1) (term2lins t2)
|
||||
term2lins (SEmpty) = return []
|
||||
term2lins (SVariants terms) = terms >>= term2lins
|
||||
term2lins term = error $ "term2lins: " ++ show term
|
||||
|
||||
addToMCFCat :: Constraint -> MCFCat -> CnvMonad MCFCat
|
||||
addToMCFCat cn (MCFCat cat cns) = liftM (MCFCat 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)
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- utilities
|
||||
|
||||
updateNth :: Monad m => (a -> m a) -> Int -> [a] -> m [a]
|
||||
updateNth update 0 (a : as) = liftM (:as) (update a)
|
||||
updateNth update n (a : as) = liftM (a:) (updateNth update (n-1) as)
|
||||
|
||||
catOfArg (A aCat _) = aCat
|
||||
catOfArg (AB aCat _ _) = aCat
|
||||
|
||||
lookupCType :: GrammarEnv -> Cat -> CType
|
||||
lookupCType env cat = errVal defLinType $
|
||||
lookupLincat (fst env) (CIQ (snd env) cat)
|
||||
|
||||
groundTerms :: GrammarEnv -> CType -> [STerm]
|
||||
groundTerms env ctype = err error (map term2spattern) $
|
||||
allParamValues (fst env) ctype
|
||||
|
||||
cTypeForArg :: GrammarEnv -> STerm -> CType
|
||||
cTypeForArg env (SArg nr cat (Path path))
|
||||
= follow path $ lookupCType env cat
|
||||
where follow [] ctype = ctype
|
||||
follow (Right pat : path) (Table _ ctype) = follow path ctype
|
||||
follow (Left lbl : path) (RecType rec)
|
||||
= case [ ctype | Lbg lbl' ctype <- rec, lbl == lbl' ] of
|
||||
[ctype] -> follow path ctype
|
||||
err -> error $ "follow: " ++ show rec ++ " . " ++ show lbl ++
|
||||
" results in " ++ show err
|
||||
|
||||
term2spattern (R rec) = SRec [ (lbl, term2spattern term) | Ass lbl term <- rec ]
|
||||
term2spattern (Con con terms) = SCon con $ map term2spattern terms
|
||||
|
||||
277
src/GF/Parsing/ConvertGFCtoMCFG/Old.hs
Normal file
277
src/GF/Parsing/ConvertGFCtoMCFG/Old.hs
Normal file
@@ -0,0 +1,277 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : ConvertGFCtoMCFG
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/03/21 22:31:53 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.1 $
|
||||
--
|
||||
-- Converting GFC grammars to MCFG grammars.
|
||||
--
|
||||
-- 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.Old (convertGrammar) where
|
||||
|
||||
import Tracing
|
||||
import GF.Printing.PrintParser
|
||||
import GF.Printing.PrintSimplifiedTerm
|
||||
--import PrintGFC
|
||||
import qualified PrGrammar as PG
|
||||
|
||||
import Monad (liftM, liftM2, guard)
|
||||
-- import Maybe (listToMaybe)
|
||||
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 (Rule(..), Lin(..))
|
||||
import SortedList (nubsort, groupPairs)
|
||||
import Maybe (listToMaybe)
|
||||
import List (groupBy, transpose)
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- old style types
|
||||
|
||||
data XMCFCat = XMCFCat Cat [(XPath, Term)] deriving (Eq, Ord, Show)
|
||||
type XMCFLabel = XPath
|
||||
|
||||
cnvXMCFCat :: XMCFCat -> MCFCat
|
||||
cnvXMCFCat (XMCFCat cat constrs) = MCFCat cat [ (cnvXPath path, cnvTerm term) |
|
||||
(path, term) <- constrs ]
|
||||
|
||||
cnvXMCFLabel :: XMCFLabel -> MCFLabel
|
||||
cnvXMCFLabel = cnvXPath
|
||||
|
||||
cnvXMCFLin :: Lin XMCFCat XMCFLabel Tokn -> Lin MCFCat MCFLabel Tokn
|
||||
cnvXMCFLin (Lin lbl lin) = Lin (cnvXMCFLabel lbl) $
|
||||
map (mapSymbol cnvSym id) lin
|
||||
where cnvSym (cat, lbl, nr) = (cnvXMCFCat cat, cnvXMCFLabel lbl, nr)
|
||||
|
||||
-- Term -> STerm
|
||||
|
||||
cnvTerm (R rec) = SRec [ (lbl, cnvTerm term) | Ass lbl term <- rec ]
|
||||
cnvTerm (T _ tbl) = STbl [ (cnvPattern pat, cnvTerm term) |
|
||||
Cas pats term <- tbl, pat <- pats ]
|
||||
cnvTerm (Con con terms) = SCon con $ map cnvTerm terms
|
||||
cnvTerm term
|
||||
| isArgPath term = cnvArgPath term
|
||||
|
||||
cnvPattern (PR rec) = SRec [ (lbl, cnvPattern term) | PAss lbl term <- rec ]
|
||||
cnvPattern (PC con pats) = SCon con $ map cnvPattern pats
|
||||
cnvPattern (PW) = SWildcard
|
||||
|
||||
isArgPath (Arg _) = True
|
||||
isArgPath (P _ _) = True
|
||||
isArgPath (S _ _) = True
|
||||
isArgPath _ = False
|
||||
|
||||
cnvArgPath (Arg (A cat nr)) = SArg (fromInteger nr) cat emptyPath
|
||||
cnvArgPath (term `P` lbl) = cnvArgPath term +. lbl
|
||||
cnvArgPath (term `S` sel) = cnvArgPath term +! cnvTerm sel
|
||||
|
||||
-- old style paths
|
||||
|
||||
newtype XPath = XPath [Either Label Term] deriving (Eq, Ord, Show)
|
||||
|
||||
cnvXPath :: XPath -> Path
|
||||
cnvXPath (XPath path) = Path (map (either Left (Right . cnvTerm)) (reverse path))
|
||||
|
||||
emptyXPath :: XPath
|
||||
emptyXPath = XPath []
|
||||
|
||||
(++..) :: XPath -> Label -> XPath
|
||||
XPath path ++.. lbl = XPath (Left lbl : path)
|
||||
|
||||
(++!!) :: XPath -> Term -> XPath
|
||||
XPath path ++!! sel = XPath (Right sel : path)
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
-- | combining alg. 1 and alg. 2 from Ljunglöf's PhD thesis
|
||||
convertGrammar :: (CanonGrammar, Ident) -> MCFGrammar
|
||||
convertGrammar (gram, lng) = trace2 "language" (prt lng) $
|
||||
trace2 "modules" (prtSep " " modnames) $
|
||||
trace2 "#lin-terms" (prt (length cncdefs)) $
|
||||
tracePrt "#mcf-rules total" (prt.length) $
|
||||
concat $
|
||||
tracePrt "#mcf-rules per fun"
|
||||
(\rs -> concat [" "++show n++"="++show (length r) |
|
||||
(n, r) <- zip [1..] rs]) $
|
||||
map (convertDef gram lng) cncdefs
|
||||
where Gr mods = grammar2canon gram
|
||||
cncdefs = [ def | Mod (MTCnc modname _) _ _ _ defs <- mods,
|
||||
modname `elem` modnames,
|
||||
def@(CncDFun _ _ _ _ _) <- defs ]
|
||||
modnames = M.allExtends gram lng
|
||||
|
||||
|
||||
convertDef :: CanonGrammar -> Ident -> Def -> [MCFRule]
|
||||
convertDef gram lng (CncDFun fun (CIQ _ cat) args term _)
|
||||
= [ Rule (cnvXMCFCat newCat) (map cnvXMCFCat newArgs) (map cnvXMCFLin newTerm) fun |
|
||||
let ctype = lookupCType gram lng cat,
|
||||
instArgs <- mapM (enumerateInsts gram lng) args,
|
||||
let instTerm = substitutePaths gram lng instArgs term,
|
||||
newCat <- emcfCat gram lng cat instTerm,
|
||||
newArgs <- mapM (extractArg gram lng instArgs) args,
|
||||
let newTerm = concatMap (extractLin newArgs) $ strPaths gram lng ctype instTerm
|
||||
]
|
||||
|
||||
|
||||
-- gammalt skräp:
|
||||
-- mergeArgs = zipWith mergeRec
|
||||
-- mergeRec (R r1) (R r2) = R (r1 ++ r2)
|
||||
|
||||
extractArg :: CanonGrammar -> Ident -> [Term] -> ArgVar -> [XMCFCat]
|
||||
extractArg gram lng args (A cat nr) = emcfCat gram lng cat (args !!! nr)
|
||||
|
||||
|
||||
emcfCat :: CanonGrammar -> Ident -> Ident -> Term -> [XMCFCat]
|
||||
emcfCat gram lng cat = map (XMCFCat cat) . parPaths gram lng (lookupCType gram lng cat)
|
||||
|
||||
|
||||
extractLin :: [XMCFCat] -> (XPath, Term) -> [Lin XMCFCat XMCFLabel Tokn]
|
||||
extractLin args (path, term) = map (Lin path) (convertLin term)
|
||||
where convertLin (t1 `C` t2) = liftM2 (++) (convertLin t1) (convertLin t2)
|
||||
convertLin (E) = [[]]
|
||||
convertLin (K tok) = [[Tok tok]]
|
||||
convertLin (FV terms) = concatMap convertLin terms
|
||||
convertLin term = map (return . Cat) $ flattenTerm emptyXPath term
|
||||
flattenTerm path (Arg (A _ nr)) = [(args !!! nr, path, fromInteger nr)]
|
||||
flattenTerm path (term `P` lbl) = flattenTerm (path ++.. lbl) term
|
||||
flattenTerm path (term `S` sel) = flattenTerm (path ++!! sel) term
|
||||
flattenTerm path (FV terms) = concatMap (flattenTerm path) terms
|
||||
flattenTerm path term = error $ "flattenTerm: \n " ++ show path ++ "\n " ++ prt term
|
||||
|
||||
|
||||
enumerateInsts :: CanonGrammar -> Ident -> ArgVar -> [Term]
|
||||
enumerateInsts gram lng arg@(A argCat _) = enumerate (Arg arg) (lookupCType gram lng argCat)
|
||||
where enumerate path (TStr) = [ path ]
|
||||
enumerate path (Cn con) = okError $ lookupParamValues gram con
|
||||
enumerate path (RecType r)
|
||||
= map R $ sequence [ map (lbl `Ass`) $
|
||||
enumerate (path `P` lbl) ctype |
|
||||
lbl `Lbg` ctype <- r ]
|
||||
enumerate path (Table s t)
|
||||
= map (T s) $ sequence [ map ([term2pattern sel] `Cas`) $
|
||||
enumerate (path `S` sel) t |
|
||||
sel <- enumerate (error "enumerate") s ]
|
||||
|
||||
|
||||
|
||||
termPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, (CType, Term))]
|
||||
termPaths gr l (TStr) term = [ (emptyXPath, (TStr, term)) ]
|
||||
termPaths gr l (RecType rtype) (R record)
|
||||
= [ (path ++.. lbl, value) |
|
||||
lbl `Ass` term <- record,
|
||||
let ctype = okError $ maybeErr "termPaths/record" $ lookupLabelling lbl rtype,
|
||||
(path, value) <- termPaths gr l ctype term ]
|
||||
termPaths gr l (Table _ ctype) (T _ table)
|
||||
= [ (path ++!! pattern2term pat, value) |
|
||||
pats `Cas` term <- table, pat <- pats,
|
||||
(path, value) <- termPaths gr l ctype term ]
|
||||
termPaths gr l (Table _ ctype) (V ptype table)
|
||||
= [ (path ++!! pat, value) |
|
||||
(pat, term) <- zip (okError $ allParamValues gr ptype) table,
|
||||
(path, value) <- termPaths gr l ctype term ]
|
||||
termPaths gr l ctype (FV terms)
|
||||
= concatMap (termPaths gr l ctype) terms
|
||||
termPaths gr l (Cn pc) term = [ (emptyXPath, (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 :: CanonGrammar -> Ident -> CType -> Term -> [[(XPath, Term)]]
|
||||
parPaths gr l ctype term = mapM (uncurry (map . (,))) (groupPairs paths)
|
||||
where paths = nubsort [ (path, value) | (path, (Cn _, value)) <- termPaths gr l ctype term ]
|
||||
|
||||
strPaths :: CanonGrammar -> Ident -> CType -> Term -> [(XPath, Term)]
|
||||
strPaths gr l ctype term = [ (path, evalFV values) | (path, values) <- groupPairs paths ]
|
||||
where paths = nubsort [ (path, value) | (path, (TStr, value)) <- termPaths gr l ctype term ]
|
||||
|
||||
|
||||
-- Substitute each instantiated parameter path for its instantiation
|
||||
substitutePaths :: CanonGrammar -> Ident -> [Term] -> Term -> Term
|
||||
substitutePaths gr l arguments trm = subst trm
|
||||
where subst (con `Con` terms) = con `Con` map subst terms
|
||||
subst (R record) = R $ map substAss record
|
||||
subst (term `P` lbl) = subst term `evalP` lbl
|
||||
subst (T ptype table) = T ptype $ map substCas table
|
||||
subst (V ptype table) = T ptype [ [term2pattern pat] `Cas` subst term |
|
||||
(pat, term) <- zip (okError $ allParamValues gr ptype) table ]
|
||||
subst (term `S` select) = subst term `evalS` subst select
|
||||
subst (term `C` term') = subst term `C` subst term'
|
||||
subst (FV terms) = evalFV $ map subst terms
|
||||
subst (Arg (A _ arg)) = arguments !!! arg
|
||||
subst term = term
|
||||
|
||||
substAss (l `Ass` term) = l `Ass` subst term
|
||||
substCas (p `Cas` term) = p `Cas` subst term
|
||||
|
||||
|
||||
evalP (R record) lbl = okError $ maybeErr errStr $ lookupAssign lbl record
|
||||
where errStr = "evalP: " ++ prt (R record `P` lbl)
|
||||
evalP (FV terms) lbl = evalFV [ evalP term lbl | term <- terms ]
|
||||
evalP term lbl = term `P` lbl
|
||||
|
||||
evalS t@(T _ tbl) sel = maybe (t `S` sel) id $ lookupCase sel tbl
|
||||
evalS (FV terms) sel = evalFV [ term `evalS` sel | term <- terms ]
|
||||
evalS term (FV sels)= evalFV [ term `evalS` sel | sel <- sels ]
|
||||
evalS term sel = term `S` sel
|
||||
|
||||
evalFV terms0 = case nubsort (concatMap flattenFV terms0) of
|
||||
[term] -> term
|
||||
terms -> FV terms
|
||||
where flattenFV (FV ts) = ts
|
||||
flattenFV t = [t]
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- utilities
|
||||
|
||||
-- lookup a CType for an Ident
|
||||
lookupCType :: CanonGrammar -> Ident -> Ident -> CType
|
||||
lookupCType gr lng c = errVal defLinType $ lookupLincat gr (CIQ lng c)
|
||||
|
||||
-- lookup a label in a (record / record ctype / table)
|
||||
lookupAssign :: Label -> [Assign] -> Maybe Term
|
||||
lookupLabelling :: Label -> [Labelling] -> Maybe CType
|
||||
lookupCase :: Term -> [Case] -> Maybe Term
|
||||
|
||||
lookupAssign lbl rec = listToMaybe [ term | lbl' `Ass` term <- rec, lbl == lbl' ]
|
||||
lookupLabelling lbl rtyp = listToMaybe [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ]
|
||||
lookupCase sel tbl = listToMaybe [ term | pats `Cas` term <- tbl, sel `matchesPats` pats ]
|
||||
|
||||
matchesPats :: Term -> [Patt] -> Bool
|
||||
matchesPats term patterns = or [ term == pattern2term pattern | pattern <- patterns ]
|
||||
|
||||
-- converting between patterns and terms
|
||||
pattern2term :: Patt -> Term
|
||||
term2pattern :: Term -> Patt
|
||||
|
||||
pattern2term (con `PC` patterns) = con `Con` map pattern2term patterns
|
||||
pattern2term (PR record) = R [ lbl `Ass` pattern2term pattern |
|
||||
lbl `PAss` pattern <- record ]
|
||||
|
||||
term2pattern (con `Con` terms) = con `PC` map term2pattern terms
|
||||
term2pattern (R record) = PR [ lbl `PAss` term2pattern term |
|
||||
lbl `Ass` term <- record ]
|
||||
|
||||
-- list lookup for Integers instead of Ints
|
||||
(!!!) :: [a] -> Integer -> a
|
||||
xs !!! n = xs !! fromInteger n
|
||||
195
src/GF/Parsing/ConvertGFCtoMCFG/Strict.hs
Normal file
195
src/GF/Parsing/ConvertGFCtoMCFG/Strict.hs
Normal file
@@ -0,0 +1,195 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : ConvertGFCtoMCFG.Strict
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/03/21 22:31:54 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.1 $
|
||||
--
|
||||
-- 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 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 ]
|
||||
|
||||
237
src/GF/Parsing/ConvertGFCtoMCFG/Utils.hs
Normal file
237
src/GF/Parsing/ConvertGFCtoMCFG/Utils.hs
Normal file
@@ -0,0 +1,237 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : ConvertGFCtoMCFGnondet
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/03/21 22:31:54 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.1 $
|
||||
--
|
||||
-- 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.Conversion.ConvertGFCtoMCFG.Utils where
|
||||
|
||||
import 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.Parser
|
||||
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)
|
||||
|
||||
buildConversion :: (Def -> BacktrackM GrammarEnv state MCFRule)
|
||||
-> GrammarEnv -> MCFGrammar
|
||||
buildConversion cnvDef env = trace2 "language" (prt (snd gram)) $
|
||||
trace2 "modules" (prtSep " " modnames) $
|
||||
tracePrt "#mcf-rules total" (prt . length) $
|
||||
solutions conversion env 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 >>= cnvDef cnvtype
|
||||
convertModule _ = failure
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- 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]
|
||||
|
||||
lookupLabelling :: Label -> [Labelling] -> CType
|
||||
lookupLabelling lbl rtyp = case [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ] of
|
||||
[ctyp] -> ctyp
|
||||
err -> error $ "lookupLabelling:" ++ show err
|
||||
|
||||
pattern2sterm :: Patt -> STerm
|
||||
pattern2sterm (con `PC` patterns) = con `SCon` map pattern2sterm patterns
|
||||
pattern2sterm (PR record) = SRec [ (lbl, pattern2sterm pattern) |
|
||||
lbl `PAss` pattern <- record ]
|
||||
|
||||
------------------------------------------------------------
|
||||
-- updating the mcf rule
|
||||
|
||||
updateArg :: Int -> Constraint -> CnvMonad ()
|
||||
updateArg arg cn
|
||||
= do (head, args, lins) <- readState
|
||||
args' <- updateNth (addToMCFCat cn) arg args
|
||||
writeState (head, args', lins)
|
||||
|
||||
updateHead :: Constraint -> CnvMonad ()
|
||||
updateHead cn
|
||||
= do (head, args, lins) <- readState
|
||||
head' <- addToMCFCat cn head
|
||||
writeState (head', args, lins)
|
||||
|
||||
updateLin :: Constraint -> CnvMonad ()
|
||||
updateLin (path, term)
|
||||
= do let newLins = term2lins term
|
||||
(head, args, lins) <- readState
|
||||
let lins' = lins ++ map (Lin path) newLins
|
||||
writeState (head, args, lins')
|
||||
|
||||
term2lins :: STerm -> [[Symbol (Cat, Path, Int) Tokn]]
|
||||
term2lins (SArg arg cat path) = return [Cat (cat, path, arg)]
|
||||
term2lins (SToken str) = return [Tok str]
|
||||
term2lins (SConcat t1 t2) = liftM2 (++) (term2lins t1) (term2lins t2)
|
||||
term2lins (SEmpty) = return []
|
||||
term2lins (SVariants terms) = terms >>= term2lins
|
||||
term2lins term = error $ "term2lins: " ++ show term
|
||||
|
||||
addToMCFCat :: Constraint -> MCFCat -> CnvMonad MCFCat
|
||||
addToMCFCat cn (MCFCat cat cns) = liftM (MCFCat 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)
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- utilities
|
||||
|
||||
updateNth :: Monad m => (a -> m a) -> Int -> [a] -> m [a]
|
||||
updateNth update 0 (a : as) = liftM (:as) (update a)
|
||||
updateNth update n (a : as) = liftM (a:) (updateNth update (n-1) as)
|
||||
|
||||
catOfArg (A aCat _) = aCat
|
||||
catOfArg (AB aCat _ _) = aCat
|
||||
|
||||
lookupCType :: GrammarEnv -> Cat -> CType
|
||||
lookupCType env cat = errVal defLinType $
|
||||
lookupLincat (fst env) (CIQ (snd env) cat)
|
||||
|
||||
groundTerms :: GrammarEnv -> CType -> [STerm]
|
||||
groundTerms env ctype = err error (map term2spattern) $
|
||||
allParamValues (fst env) ctype
|
||||
|
||||
cTypeForArg :: GrammarEnv -> STerm -> CType
|
||||
cTypeForArg env (SArg nr cat (Path path))
|
||||
= follow path $ lookupCType env cat
|
||||
where follow [] ctype = ctype
|
||||
follow (Right pat : path) (Table _ ctype) = follow path ctype
|
||||
follow (Left lbl : path) (RecType rec)
|
||||
= case [ ctype | Lbg lbl' ctype <- rec, lbl == lbl' ] of
|
||||
[ctype] -> follow path ctype
|
||||
err -> error $ "follow: " ++ show rec ++ " . " ++ show lbl ++
|
||||
" results in " ++ show err
|
||||
|
||||
term2spattern (R rec) = SRec [ (lbl, term2spattern term) | Ass lbl term <- rec ]
|
||||
term2spattern (Con con terms) = SCon con $ map term2spattern terms
|
||||
|
||||
Reference in New Issue
Block a user