mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-16 08:19:31 -06:00
add the FCFG parser
This commit is contained in:
kr.angelov
459
src/GF/Conversion/SimpleToFCFG.hs
Normal file
459
src/GF/Conversion/SimpleToFCFG.hs
Normal file
@@ -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
|
||||
Reference in New Issue
Block a user