diff options
Diffstat (limited to 'src-3.0/GF/Canon/CMacros.hs')
| -rw-r--r-- | src-3.0/GF/Canon/CMacros.hs | 334 |
1 files changed, 334 insertions, 0 deletions
diff --git a/src-3.0/GF/Canon/CMacros.hs b/src-3.0/GF/Canon/CMacros.hs new file mode 100644 index 000000000..572f09763 --- /dev/null +++ b/src-3.0/GF/Canon/CMacros.hs @@ -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 |