summaryrefslogtreecommitdiff
path: root/src/GF/Conversion/SimpleToFCFG.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Conversion/SimpleToFCFG.hs')
-rw-r--r--src/GF/Conversion/SimpleToFCFG.hs459
1 files changed, 459 insertions, 0 deletions
diff --git a/src/GF/Conversion/SimpleToFCFG.hs b/src/GF/Conversion/SimpleToFCFG.hs
new file mode 100644
index 000000000..a41c7e92f
--- /dev/null
+++ b/src/GF/Conversion/SimpleToFCFG.hs
@@ -0,0 +1,459 @@
+----------------------------------------------------------------------
+-- |
+-- 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 fast nonerasing MCFG grammar.
+--
+-- the resulting grammars might be /very large/
+--
+-- the conversion is only equivalent if the GFC grammar has a context-free backbone.
+-----------------------------------------------------------------------------
+
+
+module GF.Conversion.SimpleToFCFG
+ (convertGrammar) where
+
+import GF.System.Tracing
+import GF.Infra.Print
+import GF.Infra.Ident
+
+import Control.Monad
+
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG
+import GF.Formalism.FCFG
+import GF.Formalism.MCFG(Lin(..))
+import GF.Formalism.SimpleGFC
+import GF.Conversion.Types
+import GF.Canon.AbsGFC(CIdent(..))
+
+import GF.Data.BacktrackM
+import GF.Data.SortedList
+import GF.Data.Utilities (updateNthM)
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.List as List
+import Data.Array
+
+----------------------------------------------------------------------
+-- main conversion function
+
+convertGrammar :: SGrammar -> FGrammar
+convertGrammar srules = getFRules (loop frulesEnv)
+ where
+ (srulesMap,frulesEnv) = foldl helper (Map.empty,emptyFRulesEnv) srules
+ where
+ helper (srulesMap,frulesEnv) rule@(Rule (Abs decl _ _) (Cnc ctype _ _)) =
+ ( Map.insertWith (++) (decl2cat decl) [rule] srulesMap
+ , foldBM (\selector _ env -> convertRule selector rule env)
+ frulesEnv
+ (mkSingletonSelector ctype)
+ ()
+ )
+
+ loop frulesEnv =
+ let (todo, frulesEnv') = takeToDoRules srulesMap frulesEnv
+ in case todo of
+ [] -> frulesEnv'
+ _ -> loop $! foldl (\env (srules,selector) ->
+ foldl (\env srule -> convertRule selector srule env) env srules) frulesEnv' todo
+
+
+----------------------------------------------------------------------
+-- rule conversion
+
+convertRule :: STermSelector -> SRule -> FRulesEnv -> FRulesEnv
+convertRule selector (Rule (Abs decl decls (Name fun profile)) (Cnc ctype ctypes (Just term))) frulesEnv =
+ foldBM addRule
+ frulesEnv
+ (convertTerm selector term [Lin emptyPath []])
+ (let cat : args = map decl2cat (decl : decls)
+ in (initialFCat cat, map initialFCat args, ctype, ctypes))
+ where
+ addRule linRec (newCat', newArgs', _, _) env0 =
+ let (env1, newCat) = genFCatHead env0 newCat'
+ (env2, newArgs,idxArgs) = foldr (\(fcat,ctype,idx) (env,args,all_args) ->
+ let (env1, fcat1) = genFCatArg env fcat ctype
+ in case fcat of
+ FCat _ _ [] _ -> (env , args, all_args)
+ _ -> (env1,fcat1:args,(idx,fcat1):all_args)) (env1,[],[]) (zip3 newArgs' ctypes [0..])
+
+ (catPaths : argsPaths) = [rcs | (FCat _ _ rcs _) <- (newCat : newArgs)]
+
+ newLinRec = listArray (0,length linRec-1) [translateLin idxArgs path linRec | path <- catPaths]
+
+ (_,newProfile) = List.mapAccumL accumProf 0 newArgs'
+ where
+ accumProf nr (FCat _ _ [] _) = (nr, Unify [] )
+ accumProf nr _ = (nr+1, Unify [nr])
+
+ newName = Name fun (profile `composeProfiles` newProfile)
+ rule = FRule (Abs newCat newArgs (Name fun newProfile)) newLinRec
+ in addFCatRule env2 rule
+convertRule selector _ frulesEnv = frulesEnv
+
+translateLin idxArgs lbl' [] = array (0,-1) []
+translateLin idxArgs lbl' (Lin lbl syms : lins)
+ | lbl' == lbl = listArray (0,length syms-1) (map instSym syms)
+ | otherwise = translateLin idxArgs lbl' lins
+ where instSym = symbol (\(_, lbl, nr) -> instCat lbl nr 0 idxArgs) FSymTok
+ instCat lbl nr nr' ((idx,arg@(FCat _ _ rcs _)):idxArgs)
+ | nr == idx = FSymCat arg (index lbl rcs 0) nr'
+ | otherwise = instCat lbl nr (nr'+1) idxArgs
+
+ index lbl' (lbl:lbls) idx
+ | lbl' == lbl = idx
+ | otherwise = index lbl' lbls $! (idx+1)
+
+----------------------------------------------------------------------
+-- term conversion
+
+type CnvMonad a = BacktrackM Env a
+
+type Env = (FCat, [FCat], SLinType, [SLinType])
+type LinRec = [Lin SCat SPath Token]
+
+
+convertTerm :: STermSelector -> STerm -> LinRec -> CnvMonad LinRec
+convertTerm selector (Arg nr cat path) (Lin lbl_path lin : lins) = convertArg selector nr cat path lbl_path lin lins
+convertTerm selector (con :^ args) (Lin lbl_path lin : lins) = convertCon selector con args lbl_path lin lins
+convertTerm selector (Rec record) (Lin lbl_path lin : lins) = convertRec selector record lbl_path lin lins
+convertTerm selector (term :. lbl) lins = convertTerm (RecPrj lbl selector) term lins
+convertTerm selector (Tbl table) (Lin lbl_path lin : lins) = convertTbl selector table lbl_path lin lins
+convertTerm selector (term :! sel) lins = do sel <- evalTerm sel
+ convertTerm (TblPrj sel selector) term lins
+convertTerm selector (Variants vars) lins = do term <- member vars
+ convertTerm selector term lins
+convertTerm selector (t1 :++ t2) lins = do lins <- convertTerm selector t2 lins
+ lins <- convertTerm selector t1 lins
+ return lins
+convertTerm selector (Token str) (Lin lbl_path lin : lins) = do projectHead lbl_path
+ return (Lin lbl_path (Tok str : lin) : lins)
+convertTerm selector (Empty ) (Lin lbl_path lin : lins) = do projectHead lbl_path
+ return (Lin lbl_path lin : lins)
+
+convertArg (RecSel record) nr cat path lbl_path lin lins =
+ foldM (\lins (lbl, selector) -> convertArg selector nr cat (path ++. lbl) (lbl_path ++. lbl) lin lins) lins record
+convertArg (TblSel cases) nr cat path lbl_path lin lins =
+ foldM (\lins (term, selector) -> convertArg selector nr cat (path ++! term) (lbl_path ++! term) lin lins) lins cases
+convertArg (RecPrj lbl selector) nr cat path lbl_path lin lins =
+ convertArg selector nr cat (path ++. lbl ) lbl_path lin lins
+convertArg (TblPrj term selector) nr cat path lbl_path lin lins =
+ convertArg selector nr cat (path ++! term) lbl_path lin lins
+convertArg (ConSel terms) nr cat path lbl_path lin lins = do
+ sel <- member terms
+ restrictHead lbl_path sel
+ restrictArg nr lbl_path sel
+ return lins
+convertArg StrSel nr cat path lbl_path lin lins = do
+ projectHead lbl_path
+ projectArg nr path
+ return (Lin lbl_path (Cat (cat, path, nr) : lin) : lins)
+
+convertCon (ConSel terms) con args lbl_path lin lins = do
+ args <- mapM evalTerm args
+ let term = con :^ args
+ guard (term `elem` terms)
+ restrictHead lbl_path term
+ return lins
+
+convertRec selector [] lbl_path lin lins = return lins
+convertRec selector@(RecSel fields) ((label, val):record) lbl_path lin lins = select fields
+ where
+ select [] = convertRec selector record lbl_path lin lins
+ select ((label',sub_sel) : fields)
+ | label == label' = do lins <- convertTerm sub_sel val (Lin (lbl_path ++. label) lin : lins)
+ convertRec selector record lbl_path lin lins
+ | otherwise = select fields
+convertRec (RecPrj label sub_sel) record lbl_path lin lins = do
+ (label',val) <- member record
+ guard (label==label')
+ convertTerm sub_sel val (Lin lbl_path lin : lins)
+
+convertTbl selector [] lbl_path lin lins = return lins
+convertTbl selector@(TblSel cases) ((term, val):table) lbl_path lin lins = case selector of { TblSel cases -> select cases }
+ where
+ select [] = convertTbl selector table lbl_path lin lins
+ select ((term',sub_sel) : cases)
+ | term == term' = do lins <- convertTerm sub_sel val (Lin (lbl_path ++! term) lin : lins)
+ convertTbl selector table lbl_path lin lins
+ | otherwise = select cases
+convertTbl (TblPrj term sub_sel) table lbl_path lin lins = do
+ (term',val) <- member table
+ guard (term==term')
+ convertTerm sub_sel val (Lin lbl_path lin : lins)
+
+
+------------------------------------------------------------
+-- eval a term to ground terms
+
+evalTerm :: STerm -> CnvMonad STerm
+evalTerm arg@(Arg nr _ path) = do ctype <- readArgCType nr
+ unifyPType arg $ lintypeFollowPath path ctype
+evalTerm (con :^ terms) = do terms <- mapM evalTerm terms
+ return (con :^ terms)
+evalTerm (Rec record) = do record <- mapM evalAssign record
+ return (Rec record)
+evalTerm (term :. lbl) = do term <- evalTerm term
+ evalTerm (term +. lbl)
+evalTerm (Tbl table) = do table <- mapM evalCase table
+ return (Tbl table)
+evalTerm (term :! sel) = do sel <- evalTerm sel
+ evalTerm (term +! sel)
+evalTerm (Variants terms) = member terms >>= evalTerm
+evalTerm (t1 :++ t2) = do t1 <- evalTerm t1
+ t2 <- evalTerm t2
+ return (t1 :++ t2)
+evalTerm (Token str) = do return (Token str)
+evalTerm Empty = do return Empty
+
+evalAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
+evalAssign (lbl, term) = liftM ((,) lbl) $ evalTerm term
+
+evalCase :: (STerm, STerm) -> CnvMonad (STerm, STerm)
+evalCase (pat, term) = liftM2 (,) (evalTerm pat) (evalTerm 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
+ let (FCat _ _ _ tcs) = args !! nr
+ case lookup path tcs of
+ Just term -> return term
+ Nothing -> do term <- member terms
+ restrictArg nr path term
+ return term
+
+
+----------------------------------------------------------------------
+-- FRulesEnv
+
+data FRulesEnv = FRulesEnv {-# UNPACK #-} !Int FCatSet [FRule]
+
+type SRulesMap = Map.Map SCat [SRule]
+type FCatSet = Map.Map SCat (Map.Map [SPath] (Map.Map [(SPath,STerm)] (Either FCat FCat)))
+
+
+emptyFRulesEnv = FRulesEnv 0 Map.empty []
+
+genFCatHead :: FRulesEnv -> FCat -> (FRulesEnv, FCat)
+genFCatHead env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) =
+ case Map.lookup cat fcatSet >>= Map.lookup rcs >>= Map.lookup tcs of
+ Just (Left fcat) -> (FRulesEnv last_id (ins fcat) rules, fcat)
+ Just (Right fcat) -> (env, fcat)
+ Nothing -> let next_id = last_id+1
+ fcat = FCat next_id cat rcs tcs
+ in (FRulesEnv next_id (ins fcat) rules, fcat)
+ where
+ ins fcat = Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs x_fcat) rcs tmap_s) cat rmap_s fcatSet
+ where
+ x_fcat = Right fcat
+ tmap_s = Map.singleton tcs x_fcat
+ rmap_s = Map.singleton rcs tmap_s
+
+genFCatArg :: FRulesEnv -> FCat -> SLinType -> (FRulesEnv, FCat)
+genFCatArg env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) ctype =
+ case Map.lookup cat fcatSet >>= Map.lookup rcs of
+ Just tmap -> case Map.lookup tcs tmap of
+ Just (Left fcat) -> (env, fcat)
+ Just (Right fcat) -> (env, fcat)
+ Nothing -> ins tmap
+ Nothing -> ins Map.empty
+ where
+ ins tmap =
+ let next_id = last_id+1
+ fcat = FCat next_id cat rcs tcs
+ (x_fcat,last_id1,tmap1,rules1)
+ = foldBM (\tcs st (x_fcat,last_id,tmap,rules) ->
+ let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap
+ rule = FRule (Abs fcat [fcat_arg] coercionName)
+ (listArray (0,length rcs-1) [listArray (0,0) [FSymCat fcat_arg lbl 0] | lbl <- [0..length rcs-1]])
+ in if st
+ then (Right fcat,last_id1,tmap1,rule:rules)
+ else (x_fcat, last_id, tmap, rules))
+ (Left fcat,next_id,Map.insert tcs x_fcat tmap,rules)
+ (gen_tcs ctype emptyPath [])
+ False
+ rmap1 = Map.singleton rcs tmap1
+ in (FRulesEnv last_id1 (Map.insertWith (\_ -> Map.insert rcs tmap1) cat rmap1 fcatSet) rules1, fcat)
+ where
+ addArg tcs last_id tmap =
+ case Map.lookup tcs tmap of
+ Just (Left fcat) -> (last_id, tmap, fcat)
+ Just (Right fcat) -> (last_id, tmap, fcat)
+ Nothing -> let next_id = last_id+1
+ fcat = FCat next_id cat rcs tcs
+ in (next_id, Map.insert tcs (Left fcat) tmap, fcat)
+
+ gen_tcs :: SLinType -> SPath -> [(SPath,STerm)] -> BacktrackM Bool [(SPath,STerm)]
+ gen_tcs (RecT record) path acc = foldM (\acc (label,ctype) -> gen_tcs ctype (path ++. label) acc) acc record
+ gen_tcs (TblT terms ctype) path acc = foldM (\acc term -> gen_tcs ctype (path ++! term ) acc) acc terms
+ gen_tcs (StrT) path acc = return acc
+ gen_tcs (ConT terms) path acc =
+ case List.lookup path tcs of
+ Just term -> return ((path,term) : acc)
+ Nothing -> do writeState True
+ term <- member terms
+ return ((path,term) : acc)
+
+takeToDoRules :: SRulesMap -> FRulesEnv -> ([([SRule], STermSelector)], FRulesEnv)
+takeToDoRules srulesMap (FRulesEnv last_id fcatSet rules) = (todo,FRulesEnv last_id fcatSet' rules)
+ where
+ (todo,fcatSet') =
+ Map.mapAccumWithKey (\todo cat rmap ->
+ let (todo1,rmap1) = Map.mapAccumWithKey (\todo rcs tmap ->
+ let (tcss,tmap') = Map.mapAccumWithKey (\tcss tcs x_fcat ->
+ case x_fcat of
+ Left fcat -> (tcs:tcss,Right fcat)
+ Right fcat -> ( tcss, x_fcat)) [] tmap
+ in case tcss of
+ [] -> ( todo,tmap )
+ _ -> ((srules,mkSelector rcs tcss) : todo,tmap')) todo rmap
+ mb_srules = Map.lookup cat srulesMap
+ Just srules = mb_srules
+
+ in case mb_srules of
+ Just srules -> (todo1,rmap1)
+ Nothing -> (todo ,rmap1)) [] fcatSet
+
+addFCatRule :: FRulesEnv -> FRule -> FRulesEnv
+addFCatRule (FRulesEnv last_id fcatSet rules) rule = FRulesEnv last_id fcatSet (rule:rules)
+
+getFRules :: FRulesEnv -> [FRule]
+getFRules (FRulesEnv last_id fcatSet rules) = rules
+
+
+------------------------------------------------------------
+-- The STermSelector
+
+data STermSelector
+ = RecSel [(Label, STermSelector)]
+ | TblSel [(STerm, STermSelector)]
+ | RecPrj Label STermSelector
+ | TblPrj STerm STermSelector
+ | ConSel [STerm]
+ | StrSel
+ deriving Show
+
+
+mkSingletonSelector :: SLinType -> BacktrackM () STermSelector
+mkSingletonSelector ctype = do
+ let (rcss,tcss) = loop emptyPath ([],[]) ctype
+ rcs <- member rcss
+ return (mkSelector [rcs] tcss)
+ where
+ loop path st (RecT record) = foldl (\st (lbl,ctype) -> loop (path ++. lbl ) st ctype) st record
+ loop path st (TblT terms ctype) = foldl (\st term -> loop (path ++! term) st ctype) st terms
+ loop path (rcss,tcss) (ConT terms) = (rcss, map ((,) path) terms : tcss)
+ loop path (rcss,tcss) (StrT) = (path : rcss, tcss)
+
+
+mkSelector :: [SPath] -> [[(SPath,STerm)]] -> STermSelector
+mkSelector rcs tcss =
+ foldl addRestriction (case xs of
+ (path:xs) -> foldl addProjection (path2selector StrSel path) xs) ys
+ where
+ xs = [ reverse path | Path path <- rcs]
+ ys = [(reverse path,term) | tcs <- tcss, (Path path,term) <- tcs]
+
+ addProjection :: STermSelector -> [Either Label STerm] -> STermSelector
+ addProjection StrSel [] = StrSel
+ addProjection (RecSel fields) (Left lbl : path) = RecSel (add fields)
+ where
+ add [] = [(lbl,path2selector StrSel path)]
+ add (field@(lbl',sub_sel):fields)
+ | lbl == lbl' = (lbl',addProjection sub_sel path):fields
+ | otherwise = field : add fields
+ addProjection (TblSel cases) (Right pat : path) = TblSel (add cases)
+ where
+ add [] = [(pat,path2selector StrSel path)]
+ add (cas@(pat',sub_sel):cases)
+ | pat == pat' = (pat',addProjection sub_sel path):cases
+ | otherwise = cas : add cases
+ addProjection x y = error ("addProjection "++show x ++ " " ++ prt (Path y))
+
+ addRestriction :: STermSelector -> ([Either Label STerm],STerm) -> STermSelector
+ addRestriction (ConSel terms) ([] ,term) = ConSel (term:terms)
+ addRestriction (RecSel fields) (Left lbl : path,term) = RecSel (add fields)
+ where
+ add [] = [(lbl,path2selector (ConSel [term]) path)]
+ add (field@(lbl',sub_sel):fields)
+ | lbl == lbl' = (lbl',addRestriction sub_sel (path,term)):fields
+ | otherwise = field : add fields
+ addRestriction (TblSel cases) (Right pat : path,term) = TblSel (add cases)
+ where
+ add [] = [(pat,path2selector (ConSel [term]) path)]
+ add (field@(pat',sub_sel):cases)
+ | pat == pat' = (pat',addRestriction sub_sel (path,term)):cases
+ | otherwise = field : add cases
+
+ path2selector base [] = base
+ path2selector base (Left lbl : path) = RecSel [(lbl,path2selector base path)]
+ path2selector base (Right sel : path) = TblSel [(sel,path2selector base path)]
+
+
+------------------------------------------------------------
+-- updating the MCF rule
+
+readArgCType :: Int -> CnvMonad SLinType
+readArgCType arg = do (_, _, _, ctypes) <- readState
+ return (ctypes !! arg)
+
+restrictArg :: Int -> SPath -> STerm -> CnvMonad ()
+restrictArg arg path term
+ = do (head, args, ctype, ctypes) <- readState
+ args' <- updateNthM (restrictFCat path term) arg args
+ writeState (head, args', ctype, ctypes)
+
+projectArg :: Int -> SPath -> CnvMonad ()
+projectArg arg path
+ = do (head, args, ctype, ctypes) <- readState
+ args' <- updateNthM (projectFCat path) arg args
+ writeState (head, args', ctype, ctypes)
+
+readHeadCType :: CnvMonad SLinType
+readHeadCType = do (_, _, ctype, _) <- readState
+ return ctype
+
+restrictHead :: SPath -> STerm -> CnvMonad ()
+restrictHead path term
+ = do (head, args, ctype, ctypes) <- readState
+ head' <- restrictFCat path term head
+ writeState (head', args, ctype, ctypes)
+
+projectHead :: SPath -> CnvMonad ()
+projectHead path
+ = do (head, args, ctype, ctypes) <- readState
+ head' <- projectFCat path head
+ writeState (head', args, ctype, ctypes)
+
+restrictFCat :: SPath -> STerm -> FCat -> CnvMonad FCat
+restrictFCat path0 term0 (FCat id cat rcs tcs) = do
+ tcs <- addConstraint tcs
+ return (FCat id cat rcs tcs)
+ where
+ addConstraint (c@(path,term) : cs)
+ | path0 > path = liftM (c:) (addConstraint cs)
+ | path0 == path = guard (term0 == term) >>
+ return (c : cs)
+ addConstraint cs = return ((path0,term0) : cs)
+
+projectFCat :: SPath -> FCat -> CnvMonad FCat
+projectFCat path0 (FCat id cat rcs tcs) = do
+ return (FCat id cat (addConstraint rcs) tcs)
+ where
+ addConstraint (path : rcs)
+ | path0 > path = path : addConstraint rcs
+ | path0 == path = path : rcs
+ addConstraint rcs = path0 : rcs
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 16:24:55 +0000