forked from GitHub/gf-core
207 lines
7.0 KiB
Haskell
207 lines
7.0 KiB
Haskell
---------------------------------------------------------------------
|
|
-- |
|
|
-- Maintainer : PL
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/08/08 09:01:25 $
|
|
-- > CVS $Author: peb $
|
|
-- > CVS $Revision: 1.5 $
|
|
--
|
|
-- Definitions of ranges, and operations on ranges
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Parsing.MCFG.Range
|
|
( Range(..), makeRange, concatRange, rangeEdge, edgeRange, minRange, maxRange,
|
|
LinRec, RangeRec,
|
|
makeRangeRec, rangeRestRec, rangeRestrictRule,
|
|
projection, unifyRec, substArgRec
|
|
) where
|
|
|
|
|
|
-- Haskell
|
|
import Data.List
|
|
import Control.Monad
|
|
|
|
-- GF modules
|
|
import GF.Formalism.GCFG
|
|
import GF.Formalism.MCFG
|
|
import GF.Formalism.Utilities
|
|
import GF.Infra.Print
|
|
import GF.Data.Assoc ((?))
|
|
import GF.Data.Utilities (updateNthM)
|
|
|
|
------------------------------------------------------------
|
|
-- ranges as single pairs
|
|
|
|
data Range = Range (Int, Int)
|
|
| EmptyRange
|
|
deriving (Eq, Ord, Show)
|
|
|
|
makeRange :: (Int, Int) -> Range
|
|
concatRange :: Range -> Range -> [Range]
|
|
rangeEdge :: a -> Range -> Edge a
|
|
edgeRange :: Edge a -> Range
|
|
minRange :: Range -> Int
|
|
maxRange :: Range -> Int
|
|
|
|
makeRange = Range
|
|
concatRange EmptyRange rng = return rng
|
|
concatRange rng EmptyRange = return rng
|
|
concatRange (Range(i,j)) (Range(j',k)) = [ Range(i,k) | j==j']
|
|
rangeEdge a (Range(i,j)) = Edge i j a
|
|
edgeRange (Edge i j _) = Range (i,j)
|
|
minRange (Range rho) = fst rho
|
|
maxRange (Range rho) = snd rho
|
|
|
|
instance Print Range where
|
|
prt (Range (i,j)) = "(" ++ show i ++ "-" ++ show j ++ ")"
|
|
prt (EmptyRange) = "(?)"
|
|
|
|
{-- Types --------------------------------------------------------------------
|
|
Linearization- and Range records implemented as lists
|
|
-----------------------------------------------------------------------------}
|
|
|
|
type LinRec c l t = [Lin c l t]
|
|
|
|
type RangeRec l = [(l, Range)]
|
|
|
|
|
|
{-- Functions ----------------------------------------------------------------
|
|
Concatenation : Concatenation of Ranges, Symbols and Linearizations
|
|
and records of Linearizations
|
|
Record transformation : Makes a Range record from a fully instantiated
|
|
Linearization record
|
|
Record projection : Given a label, returns the corresponding Range
|
|
Range restriction : Range restriction of Tokens, Symbols,
|
|
Linearizations and Records given a list of Tokens
|
|
Record replacment : Substitute a record for another in a list of Range
|
|
records
|
|
Argument substitution : Substitution of a Cat c to a Tok Range, where
|
|
Range is the cover of c
|
|
Note: The argument is still a Symbol c Range
|
|
Subsumation : Checks if a Range record subsumes another Range
|
|
record
|
|
Record unification : Unification of two Range records
|
|
-----------------------------------------------------------------------------}
|
|
|
|
|
|
--- Concatenation ------------------------------------------------------------
|
|
|
|
|
|
concSymbols :: [Symbol c Range] -> [[Symbol c Range]]
|
|
concSymbols (Tok rng:Tok rng':toks) = do rng'' <- concatRange rng rng'
|
|
concSymbols (Tok rng'':toks)
|
|
concSymbols (sym:syms) = do syms' <- concSymbols syms
|
|
return (sym:syms')
|
|
concSymbols [] = return []
|
|
|
|
|
|
concLin :: Lin c l Range -> [Lin c l Range]
|
|
concLin (Lin lbl syms) = do syms' <- concSymbols syms
|
|
return (Lin lbl syms')
|
|
|
|
|
|
concLinRec :: LinRec c l Range -> [LinRec c l Range]
|
|
concLinRec = mapM concLin
|
|
|
|
|
|
--- Record transformation ----------------------------------------------------
|
|
|
|
makeRangeRec :: LinRec c l Range -> RangeRec l
|
|
makeRangeRec lins = map convLin lins
|
|
where convLin (Lin lbl [Tok rng]) = (lbl, rng)
|
|
convLin (Lin lbl []) = (lbl, EmptyRange)
|
|
convLin _ = error "makeRangeRec"
|
|
|
|
|
|
--- Record projection --------------------------------------------------------
|
|
|
|
projection :: Ord l => l -> RangeRec l -> [Range]
|
|
projection l rec = maybe (fail "projection") return $ lookup l rec
|
|
|
|
|
|
--- Range restriction --------------------------------------------------------
|
|
|
|
rangeRestTok :: Ord t => Input t -> t -> [Range]
|
|
rangeRestTok toks tok = do rng <- inputToken toks ? tok
|
|
return (makeRange rng)
|
|
|
|
|
|
rangeRestSym :: Ord t => Input t -> Symbol a t -> [Symbol a Range]
|
|
rangeRestSym toks (Tok tok) = do rng <- rangeRestTok toks tok
|
|
return (Tok rng)
|
|
rangeRestSym _ (Cat c) = return (Cat c)
|
|
|
|
|
|
rangeRestLin :: Ord t => Input t -> Lin c l t -> [Lin c l Range]
|
|
rangeRestLin toks (Lin lbl syms) = do syms' <- mapM (rangeRestSym toks) syms
|
|
concLin (Lin lbl syms')
|
|
-- return (Lin lbl syms')
|
|
|
|
|
|
rangeRestRec :: Ord t => Input t -> LinRec c l t -> [LinRec c l Range]
|
|
rangeRestRec toks = mapM (rangeRestLin toks)
|
|
|
|
|
|
rangeRestrictRule :: Ord t => Input t -> MCFRule c n l t -> [MCFRule c n l Range]
|
|
rangeRestrictRule toks (Rule abs (Cnc l ls lins)) = liftM (Rule abs . Cnc l ls) $
|
|
rangeRestRec toks lins
|
|
|
|
--- Argument substitution ----------------------------------------------------
|
|
|
|
substArgSymbol :: Ord l => Int -> RangeRec l -> Symbol (c, l, Int) Range
|
|
-> Symbol (c, l, Int) Range
|
|
substArgSymbol i rec tok@(Tok rng) = tok
|
|
substArgSymbol i rec cat@(Cat (c, l, j))
|
|
| i==j = maybe err Tok $ lookup l rec
|
|
| otherwise = cat
|
|
where err = error "substArg: Label not in range-record"
|
|
|
|
substArgLin :: Ord l => Int -> RangeRec l -> Lin c l Range
|
|
-> [Lin c l Range]
|
|
substArgLin i rec (Lin lbl syms) =
|
|
concLin (Lin lbl (map (substArgSymbol i rec) syms))
|
|
|
|
|
|
substArgRec :: Ord l => Int -> RangeRec l -> LinRec c l Range
|
|
-> [LinRec c l Range]
|
|
substArgRec i rec lins = mapM (substArgLin i rec) lins
|
|
|
|
|
|
-- Record unification & replacment ---------------------------------------------------------
|
|
|
|
unifyRec :: Ord l => [RangeRec l] -> Int -> RangeRec l -> [[RangeRec l]]
|
|
unifyRec recs i rec = updateNthM update i recs
|
|
where update rec' = guard (subsumes rec' rec) >> return rec
|
|
|
|
-- unifyRec recs i rec = do guard $ subsumes (recs !! i) rec
|
|
-- return $ replaceRec recs i rec
|
|
|
|
replaceRec :: [RangeRec l] -> Int -> RangeRec l -> [RangeRec l]
|
|
replaceRec recs i rec = before ++ (rec : after)
|
|
where (before, _ : after) = splitAt i recs
|
|
|
|
subsumes :: Ord l => RangeRec l -> RangeRec l -> Bool
|
|
subsumes rec rec' = and [r `elem` rec' | r <- rec]
|
|
-- subsumes rec rec' = all (`elem` rec') rec
|
|
|
|
|
|
{-
|
|
--- Record unification -------------------------------------------------------
|
|
unifyRangeRecs :: Ord l => [RangeRec l] -> [RangeRec l] -> [[RangeRec l]]
|
|
unifyRangeRecs recs recs' = zipWithM unify recs recs'
|
|
where unify :: Ord l => RangeRec l -> RangeRec l -> [RangeRec l]
|
|
unify rec [] = return rec
|
|
unify [] rec = return rec
|
|
unify rec1'@(p1@(l1, r1):rec1) rec2'@(p2@(l2, r2):rec2)
|
|
= case compare l1 l2 of
|
|
LT -> do rec3 <- unify rec1 rec2'
|
|
return (p1:rec3)
|
|
GT -> do rec3 <- unify rec1' rec2
|
|
return (p2:rec3)
|
|
EQ -> do guard (r1 == r2)
|
|
rec3 <- unify rec1 rec2
|
|
return (p1:rec3)
|
|
-}
|