removed src for 2.9

1 files changed, 0 insertions, 334 deletions

diff --git a/src/GF/Canon/CMacros.hs b/src/GF/Canon/CMacros.hs
deleted file mode 100644
index 572f09763..000000000
--- a/src/GF/Canon/CMacros.hs
+++ /dev/null
@@ -1,334 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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