mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-12 06:19:33 -06:00
64 lines
1.9 KiB
Haskell
64 lines
1.9 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Maintainer : PL
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/05/09 09:28:44 $
|
|
-- > CVS $Author: peb $
|
|
-- > CVS $Revision: 1.5 $
|
|
--
|
|
-- Adding coercion functions to a MCFG if necessary.
|
|
-----------------------------------------------------------------------------
|
|
|
|
|
|
module GF.Conversion.SimpleToMCFG.Coercions
|
|
(addCoercions) where
|
|
|
|
import GF.System.Tracing
|
|
import GF.Infra.Print
|
|
|
|
import GF.Formalism.Utilities
|
|
import GF.Formalism.GCFG
|
|
import GF.Formalism.MCFG
|
|
import GF.Conversion.Types
|
|
import GF.Data.SortedList
|
|
import Data.List (groupBy)
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
addCoercions :: EGrammar -> EGrammar
|
|
addCoercions rules = coercions ++ rules
|
|
where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) |
|
|
Rule (Abs head args _) (Cnc lbls _ _) <- rules ]
|
|
allHeadSet = nubsort allHeads
|
|
allArgSet = union allArgs <\\> map fst allHeadSet
|
|
coercions = tracePrt "SimpleToMCFG.Coercions - MCFG coercions" (prt . length) $
|
|
concat $
|
|
tracePrt "SimpleToMCFG.Coercions - MCFG coercions per category"
|
|
(prtList . map length) $
|
|
combineCoercions
|
|
(groupBy sameECatFst allHeadSet)
|
|
(groupBy sameECat allArgSet)
|
|
sameECatFst a b = sameECat (fst a) (fst b)
|
|
|
|
|
|
combineCoercions [] _ = []
|
|
combineCoercions _ [] = []
|
|
combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs)
|
|
= case compare (ecat2scat $ fst $ head heads) (ecat2scat $ head args) of
|
|
LT -> combineCoercions allHeads allArgs'
|
|
GT -> combineCoercions allHeads' allArgs
|
|
EQ -> makeCoercion heads args : combineCoercions allHeads allArgs
|
|
|
|
|
|
makeCoercion heads args
|
|
= [ Rule (Abs arg [head] coercionName) (Cnc lbls [lbls] lins) |
|
|
(head@(ECat _ headCns), lbls) <- heads,
|
|
let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ],
|
|
arg@(ECat _ argCns) <- args,
|
|
argCns `subset` headCns ]
|
|
|
|
|
|
|