diff options
Diffstat (limited to 'src/compiler/GF/Compile/GenerateFCFG.hs')
| -rw-r--r-- | src/compiler/GF/Compile/GenerateFCFG.hs | 568 |
1 files changed, 0 insertions, 568 deletions
diff --git a/src/compiler/GF/Compile/GenerateFCFG.hs b/src/compiler/GF/Compile/GenerateFCFG.hs deleted file mode 100644 index 52e95f686..000000000 --- a/src/compiler/GF/Compile/GenerateFCFG.hs +++ /dev/null @@ -1,568 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- 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.Compile.GenerateFCFG - (convertConcrete) where - -import PGF.CId -import PGF.Data -import PGF.Macros --hiding (prt) -import PGF.Parsing.FCFG.Utilities - -import GF.Data.BacktrackM -import GF.Data.SortedList -import GF.Data.Utilities (updateNthM, sortNub) - -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import qualified Data.Set as Set -import qualified Data.List as List -import qualified Data.ByteString.Char8 as BS -import Data.Array.IArray -import Data.Maybe -import Control.Monad - ----------------------------------------------------------------------- --- main conversion function - -convertConcrete :: Abstr -> Concr -> ParserInfo -convertConcrete abs cnc = fixHoasFuns $ convert abs_defs' conc' cats' - where abs_defs = Map.assocs (funs abs) - conc = Map.union (opers cnc) (lins cnc) -- "union big+small most efficient" - cats = lincats cnc - (abs_defs',conc',cats') = expandHOAS abs_defs conc cats - -expandHOAS :: [(CId,(Type,Int,[Equation]))] -> TermMap -> TermMap -> ([(CId,(Type,Int,[Equation]))],TermMap,TermMap) -expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns, - Map.unions [lins, hoLins, varLins], - Map.unions [lincats, hoLincats, varLincat]) - where - -- replace higher-order fun argument types with new categories - funs' = [(f,(fixType ty,a,e)) | (f,(ty,a,e)) <- funs] - where - fixType :: Type -> Type - fixType ty = let (ats,rt) = typeSkeleton ty in cftype (map catName ats) rt - - hoTypes :: [(Int,CId)] - hoTypes = sortNub [(n,c) | (_,(ty,_,_)) <- funs, (n,c) <- fst (typeSkeleton ty), n > 0] - hoCats = sortNub (map snd hoTypes) - -- for each Cat with N bindings, we add a new category _NCat - -- each new category contains a single function __NCat : Cat -> _Var -> ... -> _Var -> _NCat - hoFuns = [(funName ty,(cftype (c : replicate n varCat) (catName ty),0,[])) | ty@(n,c) <- hoTypes] - -- lincats for the new categories - hoLincats = Map.fromList [(catName ty, modifyRec (++ replicate n (S [])) (lincatOf c)) | ty@(n,c) <- hoTypes] - -- linearizations of the new functions, lin __NCat v_0 ... v_n-1 x = { s1 = x.s1; ...; sk = x.sk; $0 = v_0.s ... - hoLins = Map.fromList [ (funName ty, mkLin c n) | ty@(n,c) <- hoTypes] - where mkLin c n = modifyRec (\fs -> [P (V 0) (C j) | j <- [0..length fs-1]] ++ [P (V i) (C 0) | i <- [1..n]]) (lincatOf c) - -- for each Cat, we a add a fun _Var_Cat : _Var -> Cat - varFuns = [(varFunName cat, (cftype [varCat] cat,0,[])) | cat <- hoCats] - -- linearizations of the _Var_Cat functions - varLins = Map.fromList [(varFunName cat, R [P (V 0) (C 0)]) | cat <- hoCats] - -- lincat for the _Var category - varLincat = Map.singleton varCat (R [S []]) - - lincatOf c = fromMaybe (error $ "No lincat for " ++ showCId c) $ Map.lookup c lincats - - modifyRec :: ([Term] -> [Term]) -> Term -> Term - modifyRec f (R xs) = R (f xs) - modifyRec _ t = error $ "Not a record: " ++ show t - - varCat = mkCId "_Var" - - catName :: (Int,CId) -> CId - catName (0,c) = c - catName (n,c) = mkCId ("_" ++ show n ++ showCId c) - - funName :: (Int,CId) -> CId - funName (n,c) = mkCId ("__" ++ show n ++ showCId c) - - varFunName :: CId -> CId - varFunName c = mkCId ("_Var_" ++ showCId c) - --- replaces __NCat with _B and _Var_Cat with _. --- the temporary names are just there to avoid name collisions. -fixHoasFuns :: ParserInfo -> ParserInfo -fixHoasFuns pinfo = pinfo{functions=mkArray [FFun (fixName n) prof lins | FFun n prof lins <- elems (functions pinfo)]} - where fixName (CId n) | BS.pack "__" `BS.isPrefixOf` n = (mkCId "_B") - | BS.pack "_Var_" `BS.isPrefixOf` n = wildCId - fixName n = n - -convert :: [(CId,(Type,Int,[Equation]))] -> TermMap -> TermMap -> ParserInfo -convert abs_defs cnc_defs cat_defs = getParserInfo (loop grammarEnv) - where - srules = [ - (XRule id args res (map findLinType args) (findLinType res) term) | - (id, (ty,_,_)) <- abs_defs, let (args,res) = catSkeleton ty, - term <- maybeToList (Map.lookup id cnc_defs)] - - findLinType id = fromMaybe (error $ "No lincat for " ++ show id) (Map.lookup id cat_defs) - - (xrulesMap,grammarEnv) = List.foldl' helper (Map.empty,emptyFFunsEnv) srules - where - helper (xrulesMap,grammarEnv) rule@(XRule id abs_args abs_res cnc_args cnc_res term) = - let xrulesMap' = Map.insertWith (++) abs_res [rule] xrulesMap - grammarEnv' = List.foldl' (\env selector -> convertRule cnc_defs selector rule env) - grammarEnv - (mkSingletonSelectors cnc_defs cnc_res) - in xrulesMap' `seq` grammarEnv' `seq` (xrulesMap',grammarEnv') - - loop grammarEnv = - let (todo, grammarEnv') = takeToDoRules xrulesMap grammarEnv - in case todo of - [] -> grammarEnv' - _ -> loop $! List.foldl' (\env (srules,selector) -> - List.foldl' (\env srule -> convertRule cnc_defs selector srule env) env srules) grammarEnv' todo - -convertRule :: TermMap -> TermSelector -> XRule -> GrammarEnv -> GrammarEnv -convertRule cnc_defs selector (XRule fun args cat ctypes ctype term) grammarEnv = - foldBM addRule - grammarEnv - (convertTerm cnc_defs selector term [([],[])]) - (protoFCat cat, map (\scat -> (protoFCat scat,[])) args, ctype, ctypes) - where - addRule linRec (newCat', newArgs', _, _) env0 = - let (env1, newCat) = genFCatHead env0 newCat' - (env2, newArgs,idxArgs) = foldr (\((xcat@(PFCat cat rcs tcs),xpaths),ctype,idx) (env,args,all_args) -> - let xargs = xcat:[PFCat cat [path] tcs | path <- reverse xpaths] - (env1, xargs1) = List.mapAccumL (genFCatArg cnc_defs ctype) env xargs - in case xcat of - PFCat _ [] _ -> (env , args, all_args) - _ -> (env1,xargs1++args,(idx,zip xargs1 xargs):all_args)) - (env1,[],[]) (zip3 newArgs' ctypes [0..]) - - (env3,newLinRec) = List.mapAccumL (translateLin idxArgs linRec) env2 (case newCat' of {PFCat _ rcs _ -> rcs}) - - (_,newProfile) = List.mapAccumL accumProf 0 newArgs' - where - accumProf nr (PFCat _ [] _,_ ) = (nr, [] ) - accumProf nr (_ ,xpaths) = (nr+cnt+1, [nr..nr+cnt]) - where cnt = length xpaths - - (env4,funid) = addFFun env3 (FFun fun newProfile (mkArray newLinRec)) - - in addProduction env4 newCat (FApply funid newArgs) - -translateLin idxArgs [] grammarEnv lbl' = error "translateLin" -translateLin idxArgs ((lbl,syms) : lins) grammarEnv lbl' - | lbl' == lbl = addFSeq grammarEnv (lbl,map instSym syms) - | otherwise = translateLin idxArgs lins grammarEnv lbl' - where - instSym = either (\(lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs) - (\t -> case t of - KS s -> FSymKS [s] - KP strs vars -> FSymKP strs vars) - instCat lbl nr xnr nr' ((idx,xargs):idxArgs) - | nr == idx = let (fcat, PFCat _ rcs _) = xargs !! xnr - in FSymCat (nr'+xnr) (index lbl rcs 0) - | otherwise = instCat lbl nr xnr (nr'+length xargs) idxArgs - - index lbl' (lbl:lbls) idx - | lbl' == lbl = idx - | otherwise = index lbl' lbls $! (idx+1) - - ----------------------------------------------------------------------- --- term conversion - -type CnvMonad a = BacktrackM Env a - -type FPath = [FIndex] -type Env = (ProtoFCat, [(ProtoFCat,[FPath])], Term, [Term]) -type LinRec = [(FPath, [Either (FPath, FIndex, Int) Tokn])] - -type TermMap = Map.Map CId Term - -convertTerm :: TermMap -> TermSelector -> Term -> LinRec -> CnvMonad LinRec -convertTerm cnc_defs selector (V nr) ((lbl_path,lin) : lins) = convertArg selector nr [] lbl_path lin lins -convertTerm cnc_defs selector (C nr) ((lbl_path,lin) : lins) = convertCon selector nr lbl_path lin lins -convertTerm cnc_defs selector (R record) ((lbl_path,lin) : lins) = convertRec cnc_defs selector 0 record lbl_path lin lins - -convertTerm cnc_defs selector (P term sel) lins = do nr <- evalTerm cnc_defs [] sel - convertTerm cnc_defs (TuplePrj nr selector) term lins -convertTerm cnc_defs selector (FV vars) lins = do term <- member vars - convertTerm cnc_defs selector term lins -convertTerm cnc_defs selector (S ts) ((lbl_path,lin) : lins) = do projectHead lbl_path - foldM (\lins t -> convertTerm cnc_defs selector t lins) ((lbl_path,lin) : lins) (reverse ts) -convertTerm cnc_defs selector (K (KS str)) ((lbl_path,lin) : lins) = - do projectHead lbl_path - return ((lbl_path,Right (KS str) : lin) : lins) -convertTerm cnc_defs selector (K (KP strs vars))((lbl_path,lin) : lins) = - do projectHead lbl_path - toks <- member (strs:[strs' | Alt strs' _ <- vars]) - return ((lbl_path, map (Right . KS) toks ++ lin) : lins) -convertTerm cnc_defs selector (F id) lins = case Map.lookup id cnc_defs of - Just term -> convertTerm cnc_defs selector term lins - Nothing -> mzero -convertTerm cnc_defs selector (W s t) ((lbl_path,lin) : lins) = do - ss <- case t of - R ss -> return ss - F f -> case Map.lookup f cnc_defs of - Just (R ss) -> return ss - _ -> mzero - convertRec cnc_defs selector 0 [K (KS (s ++ s1)) | K (KS s1) <- ss] lbl_path lin lins -convertTerm cnc_defs selector x lins = error ("convertTerm ("++show x++")") - - -convertArg (TupleSel record) nr path lbl_path lin lins = - foldM (\lins (lbl, selector) -> convertArg selector nr (lbl:path) (lbl:lbl_path) lin lins) lins record -convertArg (TuplePrj lbl selector) nr path lbl_path lin lins = - convertArg selector nr (lbl:path) lbl_path lin lins -convertArg (ConSel indices) nr path lbl_path lin lins = do - index <- member indices - restrictHead lbl_path index - restrictArg nr path index - return lins -convertArg StrSel nr path lbl_path lin lins = do - projectHead lbl_path - xnr <- projectArg nr path - return ((lbl_path, Left (path, nr, xnr) : lin) : lins) - -convertCon (ConSel indices) index lbl_path lin lins = do - guard (index `elem` indices) - restrictHead lbl_path index - return lins -convertCon x _ _ _ _ = error $ "SimpleToFCFG,convertCon: " ++ show x - -convertRec cnc_defs selector index [] lbl_path lin lins = return lins -convertRec cnc_defs selector@(TupleSel fields) index (val:record) lbl_path lin lins = select fields - where - select [] = convertRec cnc_defs selector (index+1) record lbl_path lin lins - select ((index',sub_sel) : fields) - | index == index' = do lins <- convertTerm cnc_defs sub_sel val ((index:lbl_path,lin) : lins) - convertRec cnc_defs selector (index+1) record lbl_path lin lins - | otherwise = select fields -convertRec cnc_defs (TuplePrj index' sub_sel) index record lbl_path lin lins = do - convertTerm cnc_defs sub_sel (record !! (index'-index)) ((lbl_path,lin) : lins) - - ------------------------------------------------------------- --- eval a term to ground terms - -evalTerm :: TermMap -> FPath -> Term -> CnvMonad FIndex -evalTerm cnc_defs path (V nr) = do term <- readArgCType nr - unifyPType nr (reverse path) (selectTerm path term) -evalTerm cnc_defs path (C nr) = return nr -evalTerm cnc_defs path (R record) = case path of - (index:path) -> evalTerm cnc_defs path (record !! index) -evalTerm cnc_defs path (P term sel) = do index <- evalTerm cnc_defs [] sel - evalTerm cnc_defs (index:path) term -evalTerm cnc_defs path (FV terms) = member terms >>= evalTerm cnc_defs path -evalTerm cnc_defs path (F id) = case Map.lookup id cnc_defs of - Just term -> evalTerm cnc_defs path term - Nothing -> mzero -evalTerm cnc_defs path x = error ("evalTerm ("++show x++")") - -unifyPType :: FIndex -> FPath -> Term -> CnvMonad FIndex -unifyPType nr path (C max_index) = - do (_, args, _, _) <- get - let (PFCat _ _ tcs,_) = args !! nr - case lookup path tcs of - Just index -> return index - Nothing -> do index <- member [0..max_index] - restrictArg nr path index - return index -unifyPType nr path t = error $ "unifyPType " ++ show t ---- AR 2/10/2007 - -selectTerm :: FPath -> Term -> Term -selectTerm [] term = term -selectTerm (index:path) (R record) = selectTerm path (record !! index) - - ----------------------------------------------------------------------- --- GrammarEnv - - -data GrammarEnv = GrammarEnv {-# UNPACK #-} !Int FCatSet FSeqSet FFunSet (IntMap.IntMap (Set.Set Production)) -type FCatSet = Map.Map CId (Map.Map [FPath] (Map.Map [(FPath,FIndex)] (Either FCat FCat))) -type FSeqSet = Map.Map FSeq SeqId -type FFunSet = Map.Map FFun FunId - -data ProtoFCat = PFCat CId [FPath] [(FPath,FIndex)] - -protoFCat :: CId -> ProtoFCat -protoFCat cat = PFCat cat [] [] - -emptyFFunsEnv = GrammarEnv 0 initFCatSet Map.empty Map.empty IntMap.empty - where - initFCatSet = (ins fcatString (mkCId "String") [[0]] [] $ - ins fcatInt (mkCId "Int") [[0]] [] $ - ins fcatFloat (mkCId "Float") [[0]] [] $ - ins fcatVar (mkCId "_Var") [[0]] [] $ - Map.empty) - - ins fcat cat rcs tcs catSet = - Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s catSet - where - right_fcat = Right fcat - tmap_s = Map.singleton tcs right_fcat - rmap_s = Map.singleton rcs tmap_s - -addProduction :: GrammarEnv -> FCat -> Production -> GrammarEnv -addProduction (GrammarEnv last_id catSet seqSet funSet prodSet) cat p = - GrammarEnv last_id catSet seqSet funSet (IntMap.insertWith Set.union cat (Set.singleton p) prodSet) - -addFSeq :: GrammarEnv -> (FPath,[FSymbol]) -> (GrammarEnv,SeqId) -addFSeq env@(GrammarEnv last_id catSet seqSet funSet prodSet) (_,lst) = - case Map.lookup seq seqSet of - Just id -> (env,id) - Nothing -> let !last_seq = Map.size seqSet - in (GrammarEnv last_id catSet (Map.insert seq last_seq seqSet) funSet prodSet,last_seq) - where - seq = mkArray lst - -addFFun :: GrammarEnv -> FFun -> (GrammarEnv,FunId) -addFFun env@(GrammarEnv last_id catSet seqSet funSet prodSet) fun = - case Map.lookup fun funSet of - Just id -> (env,id) - Nothing -> let !last_funid = Map.size funSet - in (GrammarEnv last_id catSet seqSet (Map.insert fun last_funid funSet) prodSet,last_funid) - -getParserInfo :: GrammarEnv -> ParserInfo -getParserInfo (GrammarEnv last_id catSet seqSet funSet prodSet) = - ParserInfo { functions = mkArray funSet - , sequences = mkArray seqSet - , productions0= prodSet - , productions = prodSet - , startCats = Map.map getFCatList catSet - , totalCats = last_id+1 - } - where - mkArray map = array (0,Map.size map-1) [(v,k) | (k,v) <- Map.toList map] - - getFCatList rcs = Map.fold (\tcs lst -> Map.fold (\x lst -> either id id x : lst) lst tcs) [] rcs - - -genFCatHead :: GrammarEnv -> ProtoFCat -> (GrammarEnv, FCat) -genFCatHead env@(GrammarEnv last_id catSet seqSet funSet prodSet) (PFCat cat rcs tcs) = - case Map.lookup cat catSet >>= Map.lookup rcs >>= Map.lookup tcs of - Just (Left fcat) -> (GrammarEnv last_id (ins fcat) seqSet funSet prodSet, fcat) - Just (Right fcat) -> (env, fcat) - Nothing -> let fcat = last_id+1 - in (GrammarEnv fcat (ins fcat) seqSet funSet prodSet, fcat) - where - ins fcat = Map.insertWith (\_ -> Map.insertWith (\_ -> Map.insert tcs right_fcat) rcs tmap_s) cat rmap_s catSet - where - right_fcat = Right fcat - tmap_s = Map.singleton tcs right_fcat - rmap_s = Map.singleton rcs tmap_s - -genFCatArg :: TermMap -> Term -> GrammarEnv -> ProtoFCat -> (GrammarEnv, FCat) -genFCatArg cnc_defs ctype env@(GrammarEnv last_id catSet seqSet funSet prodSet) (PFCat cat rcs tcs) = - case Map.lookup cat catSet >>= 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 fcat = last_id+1 - (either_fcat,last_id1,tmap1,prodSet1) - = foldBM (\tcs st (either_fcat,last_id,tmap,prodSet) -> - let (last_id1,tmap1,fcat_arg) = addArg tcs last_id tmap - p = FCoerce fcat_arg - prodSet1 = IntMap.insertWith Set.union fcat (Set.singleton p) prodSet - in if st - then (Right fcat, last_id1,tmap1,prodSet1) - else (either_fcat,last_id, tmap ,prodSet )) - (Left fcat,fcat,Map.insert tcs either_fcat tmap,prodSet) - (gen_tcs ctype [] []) - False - rmap1 = Map.singleton rcs tmap1 - in (GrammarEnv last_id1 (Map.insertWith (\_ -> Map.insert rcs tmap1) cat rmap1 catSet) seqSet funSet prodSet1, 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 fcat = last_id+1 - in (fcat, Map.insert tcs (Left fcat) tmap, fcat) - - gen_tcs :: Term -> FPath -> [(FPath,FIndex)] -> BacktrackM Bool [(FPath,FIndex)] - gen_tcs (R record) path acc = foldM (\acc (label,ctype) -> gen_tcs ctype (label:path) acc) acc (zip [0..] record) - gen_tcs (S _) path acc = return acc - gen_tcs (C max_index) path acc = - case List.lookup path tcs of - Just index -> return $! addConstraint path index acc - Nothing -> do put True - index <- member [0..max_index] - return $! addConstraint path index acc - where - addConstraint path0 index0 (c@(path,index) : cs) - | path0 > path = c:addConstraint path0 index0 cs - addConstraint path0 index0 cs = (path0,index0) : cs - gen_tcs (F id) path acc = case Map.lookup id cnc_defs of - Just term -> gen_tcs term path acc - Nothing -> error ("unknown identifier: "++showCId id) - - - ------------------------------------------------------------- --- TODO queue organization - -type XRulesMap = Map.Map CId [XRule] -data XRule = XRule CId {- function -} - [CId] {- argument types -} - CId {- result type -} - [Term] {- argument lin-types representation -} - Term {- result lin-type representation -} - Term {- body -} - -takeToDoRules :: XRulesMap -> GrammarEnv -> ([([XRule], TermSelector)], GrammarEnv) -takeToDoRules xrulesMap (GrammarEnv last_id catSet seqSet funSet prodSet) = - (todo,GrammarEnv last_id catSet' seqSet funSet prodSet) - where - (todo,catSet') = - Map.mapAccumWithKey (\todo cat rmap -> - let (todo1,rmap1) = Map.mapAccumWithKey (\todo rcs tmap -> - let (tcss,tmap') = Map.mapAccumWithKey (\tcss tcs either_xcat -> - case either_xcat of - Left xcat -> (tcs:tcss,Right xcat) - Right xcat -> ( tcss,either_xcat)) [] tmap - in case tcss of - [] -> ( todo,tmap ) - _ -> ((srules,mkSelector rcs tcss) : todo,tmap')) todo rmap - mb_srules = Map.lookup cat xrulesMap - Just srules = mb_srules - - in case mb_srules of - Just srules -> (todo1,rmap1) - Nothing -> (todo ,rmap1)) [] catSet - - ------------------------------------------------------------- --- The TermSelector - -data TermSelector - = TupleSel [(FIndex, TermSelector)] - | TuplePrj FIndex TermSelector - | ConSel [FIndex] - | StrSel - deriving Show - -mkSingletonSelectors :: TermMap - -> Term -- ^ Type representation term - -> [TermSelector] -- ^ list of selectors containing just one string field -mkSingletonSelectors cnc_defs term = sels0 - where - (sels0,tcss0) = loop [] ([],[]) term - - loop path st (R record) = List.foldl' (\st (index,term) -> loop (index:path) st term) st (zip [0..] record) - loop path (sels,tcss) (C i) = ( sels,map ((,) path) [0..i] : tcss) - loop path (sels,tcss) (S _) = (mkSelector [path] tcss0 : sels, tcss) - loop path (sels,tcss) (F id) = case Map.lookup id cnc_defs of - Just term -> loop path (sels,tcss) term - Nothing -> error ("unknown identifier: "++showCId id) - -mkSelector :: [FPath] -> [[(FPath,FIndex)]] -> TermSelector -mkSelector rcs tcss = - List.foldl' addRestriction (case xs of - (path:xs) -> List.foldl' addProjection (path2selector StrSel path) xs) ys - where - xs = [ reverse path | path <- rcs] - ys = [(reverse path,term) | tcs <- tcss, (path,term) <- tcs] - - addRestriction :: TermSelector -> (FPath,FIndex) -> TermSelector - addRestriction (ConSel indices) ([] ,n_index) = ConSel (add indices) - where - add [] = [n_index] - add (index':indices) - | n_index == index' = index': indices - | otherwise = index':add indices - addRestriction (TupleSel fields) (index : path,n_index) = TupleSel (add fields) - where - add [] = [(index,path2selector (ConSel [n_index]) path)] - add (field@(index',sub_sel):fields) - | index == index' = (index',addRestriction sub_sel (path,n_index)):fields - | otherwise = field : add fields - - addProjection :: TermSelector -> FPath -> TermSelector - addProjection StrSel [] = StrSel - addProjection (TupleSel fields) (index : path) = TupleSel (add fields) - where - add [] = [(index,path2selector StrSel path)] - add (field@(index',sub_sel):fields) - | index == index' = (index',addProjection sub_sel path):fields - | otherwise = field : add fields - - path2selector base [] = base - path2selector base (index : path) = TupleSel [(index,path2selector base path)] - ------------------------------------------------------------- --- updating the MCF rule - -readArgCType :: FIndex -> CnvMonad Term -readArgCType nr = do (_, _, _, ctypes) <- get - return (ctypes !! nr) - -restrictArg :: FIndex -> FPath -> FIndex -> CnvMonad () -restrictArg nr path index = do - (head, args, ctype, ctypes) <- get - args' <- updateNthM (\(xcat,xs) -> do xcat <- restrictProtoFCat path index xcat - return (xcat,xs) ) nr args - put (head, args', ctype, ctypes) - -projectArg :: FIndex -> FPath -> CnvMonad Int -projectArg nr path = do - (head, args, ctype, ctypes) <- get - (xnr,args') <- updateArgs nr args - put (head, args', ctype, ctypes) - return xnr - where - updateArgs :: FIndex -> [(ProtoFCat,[FPath])] -> CnvMonad (Int,[(ProtoFCat,[FPath])]) - updateArgs 0 ((a@(PFCat _ rcs _),xpaths) : as) - | path `elem` rcs = return (length xpaths+1,(a,path:xpaths):as) - | otherwise = do a <- projectProtoFCat path a - return (0,(a,xpaths):as) - updateArgs n (a : as) = do - (xnr,as) <- updateArgs (n-1) as - return (xnr,a:as) - -readHeadCType :: CnvMonad Term -readHeadCType = do (_, _, ctype, _) <- get - return ctype - -restrictHead :: FPath -> FIndex -> CnvMonad () -restrictHead path term - = do (head, args, ctype, ctypes) <- get - head' <- restrictProtoFCat path term head - put (head', args, ctype, ctypes) - -projectHead :: FPath -> CnvMonad () -projectHead path - = do (head, args, ctype, ctypes) <- get - head' <- projectProtoFCat path head - put (head', args, ctype, ctypes) - -restrictProtoFCat :: FPath -> FIndex -> ProtoFCat -> CnvMonad ProtoFCat -restrictProtoFCat path0 index0 (PFCat cat rcs tcs) = do - tcs <- addConstraint tcs - return (PFCat cat rcs tcs) - where - addConstraint (c@(path,index) : cs) - | path0 > path = liftM (c:) (addConstraint cs) - | path0 == path = guard (index0 == index) >> - return (c : cs) - addConstraint cs = return ((path0,index0) : cs) - -projectProtoFCat :: FPath -> ProtoFCat -> CnvMonad ProtoFCat -projectProtoFCat path0 (PFCat cat rcs tcs) = do - return (PFCat cat (addConstraint rcs) tcs) - where - addConstraint (path : rcs) - | path0 > path = path : addConstraint rcs - | path0 == path = path : rcs - addConstraint rcs = path0 : rcs - -mkArray lst = listArray (0,length lst-1) lst |