mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-07 02:02:51 -06:00
GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3
This commit is contained in:
aarne
334
src-3.0/GF/Canon/CMacros.hs
Normal file
334
src-3.0/GF/Canon/CMacros.hs
Normal file
@@ -0,0 +1,334 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : CMacros
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/14 16:03:41 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.29 $
|
||||
--
|
||||
-- Macros for building and analysing terms in GFC concrete syntax.
|
||||
--
|
||||
-- macros for concrete syntax in GFC that do not need lookup in a grammar
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Canon.CMacros where
|
||||
|
||||
import GF.Infra.Ident
|
||||
import GF.Canon.AbsGFC
|
||||
import GF.Canon.GFC
|
||||
import qualified GF.Infra.Ident as A ---- no need to qualif? 21/9
|
||||
import qualified GF.Grammar.Values as V
|
||||
import qualified GF.Grammar.MMacros as M
|
||||
import GF.Grammar.PrGrammar
|
||||
import GF.Data.Str
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
import Data.Char
|
||||
import Control.Monad
|
||||
|
||||
-- | how to mark subtrees, dep. on node, position, whether focus
|
||||
type JustMarker = V.TrNode -> [Int] -> Bool -> (String, String)
|
||||
|
||||
-- | also to process the text (needed for escapes e.g. in XML)
|
||||
type Marker = (JustMarker, Maybe (String -> String))
|
||||
|
||||
defTMarker :: JustMarker -> Marker
|
||||
defTMarker = flip (curry id) Nothing
|
||||
|
||||
markSubtree :: Marker -> V.TrNode -> [Int] -> Bool -> Term -> Term
|
||||
markSubtree (mk,esc) n is = markSubterm esc . mk n is
|
||||
|
||||
escapeMkString :: Marker -> Maybe (String -> String)
|
||||
escapeMkString = snd
|
||||
|
||||
-- | if no marking is wanted, use the following
|
||||
noMark :: Marker
|
||||
noMark = defTMarker mk where
|
||||
mk _ _ _ = ("","")
|
||||
|
||||
-- | mark metas with their categories
|
||||
metaCatMark :: Marker
|
||||
metaCatMark = defTMarker mk where
|
||||
mk nod _ _ = case nod of
|
||||
V.N (_,V.AtM _,val,_,_) -> ("", '+':prt val)
|
||||
_ -> ("","")
|
||||
|
||||
-- | for vanilla brackets, focus, and position, use
|
||||
markBracket :: Marker
|
||||
markBracket = defTMarker mk where
|
||||
mk n p b = if b then ("[*" ++ show p,"*]") else ("[" ++ show p,"]")
|
||||
|
||||
-- | for focus only
|
||||
markFocus :: Marker
|
||||
markFocus = defTMarker mk where
|
||||
mk n p b = if b then ("[*","*]") else ("","")
|
||||
|
||||
-- | for XML, use
|
||||
markJustXML :: JustMarker
|
||||
markJustXML n i b =
|
||||
if b
|
||||
then ("<focus" +++ p +++ c ++ s ++ ">", "</focus>")
|
||||
else ("<subtree" +++ p +++ c ++ s ++ ">", "</subtree>")
|
||||
where
|
||||
c = "type=" ++ prt (M.valNode n)
|
||||
p = "position=" ++ (show $ reverse i)
|
||||
s = if (null (M.constrsNode n)) then "" else " status=incorrect"
|
||||
|
||||
markXML :: Marker
|
||||
markXML = (markJustXML, Just esc) where
|
||||
esc s = case s of
|
||||
'\\':'<':cs -> '\\':'<':esc cs
|
||||
'\\':'>':cs -> '\\':'>':esc cs
|
||||
'\\':'\\':cs -> '\\':'\\':esc cs
|
||||
----- the first 3 needed because marking may revisit; needs to be fixed
|
||||
|
||||
'<':cs -> '\\':'<':esc cs
|
||||
'>':cs -> '\\':'>':esc cs
|
||||
'\\':cs -> '\\':'\\':esc cs
|
||||
c :cs -> c :esc cs
|
||||
_ -> s
|
||||
|
||||
-- | for XML in JGF 1, use
|
||||
markXMLjgf :: Marker
|
||||
markXMLjgf = defTMarker mk where
|
||||
mk n p b =
|
||||
if b
|
||||
then ("<focus" +++ c ++ ">", "</focus>")
|
||||
else ("","")
|
||||
where
|
||||
c = "type=" ++ prt (M.valNode n)
|
||||
|
||||
-- | the marking engine
|
||||
markSubterm :: Maybe (String -> String) -> (String,String) -> Term -> Term
|
||||
markSubterm esc (beg, end) t = case t of
|
||||
R rs -> R $ map markField rs
|
||||
T ty cs -> T ty [Cas p (mark v) | Cas p v <- cs]
|
||||
FV ts -> FV $ map mark ts
|
||||
_ -> foldr1 C (tm beg ++ [mkEscIf t] ++ tm end) -- t : Str guaranteed?
|
||||
where
|
||||
mark = markSubterm esc (beg, end)
|
||||
markField lt@(Ass l t) = if isLinLabel l then (Ass l (mark t)) else lt
|
||||
tm s = if null s then [] else [tM s]
|
||||
mkEscIf t = case esc of
|
||||
Just f -> mkEsc f t
|
||||
_ -> t
|
||||
mkEsc f t = case t of
|
||||
K (KS s) -> K (KS (f s))
|
||||
C u v -> C (mkEsc f u) (mkEsc f v)
|
||||
FV ts -> FV (map (mkEsc f) ts)
|
||||
_ -> t ---- do we need to look at other cases?
|
||||
|
||||
tK,tM :: String -> Term
|
||||
tK = K . KS
|
||||
tM = K . KM
|
||||
|
||||
term2patt :: Term -> Err Patt
|
||||
term2patt trm = case trm of
|
||||
Par c aa -> do
|
||||
aa' <- mapM term2patt aa
|
||||
return (PC c aa')
|
||||
R r -> do
|
||||
let (ll,aa) = unzip [(l,a) | Ass l a <- r]
|
||||
aa' <- mapM term2patt aa
|
||||
return (PR (map (uncurry PAss) (zip ll aa')))
|
||||
LI x -> return $ PV x
|
||||
EInt i -> return $ PI i
|
||||
EFloat i -> return $ PF i
|
||||
FV (t:_) -> term2patt t ----
|
||||
_ -> prtBad "no pattern corresponds to term" trm
|
||||
|
||||
patt2term :: Patt -> Term
|
||||
patt2term p = case p of
|
||||
PC x ps -> Par x (map patt2term ps)
|
||||
PV x -> LI x
|
||||
PW -> anyTerm ----
|
||||
PR pas -> R [ Ass lbl (patt2term q) | PAss lbl q <- pas ]
|
||||
PI i -> EInt i
|
||||
PF i -> EFloat i
|
||||
|
||||
anyTerm :: Term
|
||||
anyTerm = LI (A.identC "_") --- should not happen
|
||||
|
||||
matchPatt :: [Case] -> Term -> Err Term
|
||||
matchPatt cs0 (FV ts) = liftM FV $ mapM (matchPatt cs0) ts
|
||||
matchPatt cs0 trm = term2patt trm >>= match cs0 where
|
||||
match cs t =
|
||||
case cs of
|
||||
Cas ps b :_ | elem t ps -> return b
|
||||
_:cs' -> match cs' t
|
||||
[] -> Bad $ "pattern not found for" +++ prt t
|
||||
+++ "among" ++++ unlines (map prt cs0) ---- debug
|
||||
|
||||
defLinType :: CType
|
||||
defLinType = RecType [Lbg (L (A.identC "s")) TStr]
|
||||
|
||||
defLindef :: Term
|
||||
defLindef = R [Ass (L (A.identC "s")) (Arg (A (A.identC "str") 0))]
|
||||
|
||||
isDiscontinuousCType :: CType -> Bool
|
||||
isDiscontinuousCType t = case t of
|
||||
RecType rs -> length [t | Lbg _ t <- rs, valTableType t == TStr] > 1
|
||||
_ -> True --- does not occur; would not behave well in lin commands
|
||||
|
||||
valTableType :: CType -> CType
|
||||
valTableType t = case t of
|
||||
Table _ v -> valTableType v
|
||||
_ -> t
|
||||
|
||||
strsFromTerm :: Term -> Err [Str]
|
||||
strsFromTerm t = case t of
|
||||
K (KS s) -> return [str s]
|
||||
K (KM s) -> return [str s]
|
||||
K (KP d vs) -> return $ [Str [TN d [(s,v) | Var s v <- vs]]]
|
||||
C s t -> do
|
||||
s' <- strsFromTerm s
|
||||
t' <- strsFromTerm t
|
||||
return [plusStr x y | x <- s', y <- t']
|
||||
FV ts -> liftM concat $ mapM strsFromTerm ts
|
||||
E -> return [str []]
|
||||
_ -> return [str ("BUG[" ++ prt t ++ "]")] ---- debug
|
||||
---- _ -> prtBad "cannot get Str from term " t
|
||||
|
||||
-- | recursively collect all branches in a table
|
||||
allInTable :: Term -> [Term]
|
||||
allInTable t = case t of
|
||||
T _ ts -> concatMap (\ (Cas _ v) -> allInTable v) ts --- expand ?
|
||||
_ -> [t]
|
||||
|
||||
-- | to gather s-fields; assumes term in normal form, preserves label
|
||||
allLinFields :: Term -> Err [[(Label,Term)]]
|
||||
allLinFields trm = case trm of
|
||||
---- R rs -> return [[(l,t) | (l,(Just ty,t)) <- rs, isStrType ty]] -- good
|
||||
R rs -> return [[(l,t) | Ass l t <- rs, isLinLabel l]] ---- bad
|
||||
FV ts -> do
|
||||
lts <- mapM allLinFields ts
|
||||
return $ concat lts
|
||||
|
||||
T _ ts -> liftM concat $ mapM allLinFields [t | Cas _ t <- ts]
|
||||
V _ ts -> liftM concat $ mapM allLinFields ts
|
||||
S t _ -> allLinFields t
|
||||
|
||||
_ -> prtBad "fields can only be sought in a record not in" trm
|
||||
|
||||
-- | deprecated
|
||||
isLinLabel :: Label -> Bool
|
||||
isLinLabel l = case l of
|
||||
L (A.IC ('s':cs)) | all isDigit cs -> True
|
||||
-- peb (28/4-04), for MCFG grammars to work:
|
||||
L (A.IC cs) | null cs || head cs `elem` ".!" -> True
|
||||
_ -> False
|
||||
|
||||
-- | to gather ultimate cases in a table; preserves pattern list
|
||||
allCaseValues :: Term -> [([Patt],Term)]
|
||||
allCaseValues trm = case trm of
|
||||
T _ cs -> [(p:ps, t) | Cas pp t0 <- cs, p <- pp, (ps,t) <- allCaseValues t0]
|
||||
_ -> [([],trm)]
|
||||
|
||||
-- | to gather all linearizations; assumes normal form, preserves label and args
|
||||
allLinValues :: Term -> Err [[(Label,[([Patt],Term)])]]
|
||||
allLinValues trm = do
|
||||
lts <- allLinFields trm
|
||||
mapM (mapPairsM (return . allCaseValues)) lts
|
||||
|
||||
-- | to gather all fields; does not assume s naming of fields;
|
||||
-- used in Morpho only
|
||||
allAllLinValues :: Term -> Err [[(Label,[([Patt],Term)])]]
|
||||
allAllLinValues trm = do
|
||||
lts <- allFields trm
|
||||
mapM (mapPairsM (return . allCaseValues)) lts
|
||||
where
|
||||
allFields trm = case trm of
|
||||
R rs -> return [[(l,t) | Ass l t <- rs]]
|
||||
FV ts -> do
|
||||
lts <- mapM allFields ts
|
||||
return $ concat lts
|
||||
_ -> prtBad "fields can only be sought in a record not in" trm
|
||||
|
||||
-- | to gather all linearizations, even from nested records; params ignored
|
||||
allLinBranches :: Term -> [([Label],Term)]
|
||||
allLinBranches trm = case trm of
|
||||
R rs -> [(l:ls,u) | Ass l t <- rs, (ls,u) <- allLinBranches t]
|
||||
FV ts -> concatMap allLinBranches ts
|
||||
T _ ts -> concatMap allLinBranches [t | Cas _ t <- ts]
|
||||
V _ ts -> concatMap allLinBranches ts
|
||||
_ -> [([],trm)]
|
||||
|
||||
redirectIdent :: A.Ident -> CIdent -> CIdent
|
||||
redirectIdent n f@(CIQ _ c) = CIQ n c
|
||||
|
||||
ciq :: A.Ident -> A.Ident -> CIdent
|
||||
ciq n f = CIQ n f
|
||||
|
||||
wordsInTerm :: Term -> [String]
|
||||
wordsInTerm trm = filter (not . null) $ case trm of
|
||||
K (KS s) -> [s]
|
||||
S c _ -> wo c
|
||||
R rs -> concat [wo t | Ass _ t <- rs]
|
||||
T _ cs -> concat [wo t | Cas _ t <- cs]
|
||||
V _ cs -> concat [wo t | t <- cs]
|
||||
C s t -> wo s ++ wo t
|
||||
FV ts -> concatMap wo ts
|
||||
K (KP ss vs) -> ss ++ concat [s | Var s _ <- vs]
|
||||
P t _ -> wo t --- not needed ?
|
||||
_ -> []
|
||||
where wo = wordsInTerm
|
||||
|
||||
onTokens :: (String -> String) -> Term -> Term
|
||||
onTokens f t = case t of
|
||||
K (KS s) -> K (KS (f s))
|
||||
K (KP ss vs) -> K (KP (map f ss) [Var (map f x) (map f y) | Var x y <- vs])
|
||||
_ -> composSafeOp (onTokens f) t
|
||||
|
||||
-- | to define compositional term functions
|
||||
composSafeOp :: (Term -> Term) -> Term -> Term
|
||||
composSafeOp op trm = case composOp (mkMonadic op) trm of
|
||||
Ok t -> t
|
||||
_ -> error "the operation is safe isn't it ?"
|
||||
where
|
||||
mkMonadic f = return . f
|
||||
|
||||
-- | to define compositional term functions
|
||||
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
|
||||
composOp co trm =
|
||||
case trm of
|
||||
Par x as ->
|
||||
do
|
||||
as' <- mapM co as
|
||||
return (Par x as')
|
||||
R as ->
|
||||
do
|
||||
let onAss (Ass l t) = liftM (Ass l) (co t)
|
||||
as' <- mapM onAss as
|
||||
return (R as')
|
||||
P a x ->
|
||||
do
|
||||
a' <- co a
|
||||
return (P a' x)
|
||||
T x as ->
|
||||
do
|
||||
let onCas (Cas ps t) = liftM (Cas ps) (co t)
|
||||
as' <- mapM onCas as
|
||||
return (T x as')
|
||||
S a b ->
|
||||
do
|
||||
a' <- co a
|
||||
b' <- co b
|
||||
return (S a' b')
|
||||
C a b ->
|
||||
do
|
||||
a' <- co a
|
||||
b' <- co b
|
||||
return (C a' b')
|
||||
FV as ->
|
||||
do
|
||||
as' <- mapM co as
|
||||
return (FV as')
|
||||
V x as ->
|
||||
do
|
||||
as' <- mapM co as
|
||||
return (V x as')
|
||||
_ -> return trm -- covers Arg, I, LI, K, E
|
||||
Reference in New Issue
Block a user