typechecking and evaluation for markup

src/compiler/api/GF/Compile/Compute/Concrete.hs

@@ -104,6 +104,7 @@ data Value s
   | VPattType (Value s)
   | VAlts (Value s) [(Value s, Value s)]
   | VStrs [Value s]
+  | VMarkup Ident [(Ident,Value s)] [Value s]
     -- These two constructors are only used internally
     -- in the PMCFG generator.
   | VSymCat Int LIndex [(LIndex, (Thunk s, Type))]
@@ -267,6 +268,10 @@ eval env (Alts d as)    []  = do vd <- eval env d []
                                  return (VAlts vd vas)
 eval env (Strs ts)      []  = do vs <- mapM (\t -> eval env t []) ts
                                  return (VStrs vs)
+eval env (Markup tag as ts) [] =
+                              do as <- mapM (\(id,t) -> eval env t [] >>= \v -> return (id,v)) as
+                                 vs <- mapM (\t -> eval env t []) ts
+                                 return (VMarkup tag as vs)
 eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,(pv,ty)) ->
                                          case lookup pv env of
                                            Just tnk -> return (i,(tnk,ty))
@@ -606,6 +611,10 @@ value2term flat xs (VAlts vd vas) = do
 value2term flat xs (VStrs vs) = do
   ts <- mapM (value2term flat xs) vs
   return (Strs ts)
+value2term flat xs (VMarkup tag as vs) = do
+  as <- mapM (\(id,v) -> value2term flat xs v >>= \t -> return (id,t)) as
+  ts <- mapM (value2term flat xs) vs
+  return (Markup tag as ts)
 value2term flat xs (VCInts (Just i) Nothing) = return (App (Q (cPredef,cInts)) (EInt i))
 value2term flat xs (VCInts Nothing (Just j)) = return (App (Q (cPredef,cInts)) (EInt j))
 value2term flat xs (VCRecType lctrs) = do

src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs

@@ -14,7 +14,7 @@ import GF.Compile.Compute.Concrete
 import GF.Infra.CheckM
 import GF.Data.Operations
 import Control.Applicative(Applicative(..))
-import Control.Monad(ap,liftM,mplus,foldM,zipWithM)
+import Control.Monad(ap,liftM,mplus,foldM,zipWithM,forM)
 import Control.Monad.ST
 import GF.Text.Pretty
 import Data.STRef
@@ -52,6 +52,7 @@ vtypeStr   = VSort cStr
 vtypeStrs  = VSort cStrs
 vtypeType  = VSort cType
 vtypePType = VSort cPType
+vtypeMarkup= VApp (cPredef,cMarkup) []
 
 tcRho :: Scope s -> Term -> Maybe (Rho s) -> EvalM s (Term, Rho s)
 tcRho scope t@(EInt i)   mb_ty = vtypeInts i >>= \sigma -> instSigma scope t sigma mb_ty -- INT
@@ -357,6 +358,12 @@ tcRho scope t@(EPatt min max p) mb_ty = do
                                     _            -> evalError (ppTerm Unqualified 0 t <+> "must be of pattern type but" <+> ppTerm Unqualified 0 t <+> "is expected")
   tcPatt scope p ty
   return (f (EPatt min max p), ty)
+tcRho scope (Markup tag attrs children) mb_ty = do
+  attrs <- forM attrs $ \(id,t) -> do
+              (t,_) <- tcRho scope t Nothing
+              return (id,t)
+  res <- mapM (\child -> tcRho scope child Nothing) children
+  return (Markup tag attrs (map fst res), vtypeMarkup)
 tcRho scope t _ = unimplemented ("tcRho "++show t)
 
 tcCases scope []         p_ty res_ty = return []

src/compiler/api/GF/Grammar/Macros.hs

@@ -179,6 +179,11 @@ mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
 mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
   where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
 
+mapAttrs :: Monad m => (Term -> m c) -> [(Ident,Term)] -> m [(Ident,c)]
+mapAttrs f []          = return []
+mapAttrs f ((id,t):as) = do t  <- f t
+                            as <- mapAttrs f as
+                            return ((id,t):as)
 -- *** Records
 
 mkRecordN :: Int -> (Int -> Label) -> [Term] -> Term
@@ -412,6 +417,7 @@ composOp co trm =
    ELincat c ty     -> liftM (ELincat c) (co ty)
    ELin c ty        -> liftM (ELin c) (co ty)
    ImplArg t        -> liftM ImplArg (co t)
+   Markup t as cs   -> liftM2 (Markup t) (mapAttrs co as) (mapM co cs)
    _ -> return trm -- covers K, Vr, Cn, Sort, EPatt
 
 composSafePattOp op = runIdentity . composPattOp (return . op)
@@ -450,6 +456,7 @@ collectOp co trm = case trm of
   Alts t aa    -> let (x,y) = unzip aa in co t <> mconcatMap co (x <> y)
   FV ts        -> mconcatMap co ts
   Strs tt      -> mconcatMap co tt
+  Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs
   _            -> mempty -- covers K, Vr, Cn, Sort
 
 mconcatMap f = mconcat . map f

src/compiler/api/GF/Grammar/Predef.hs

@@ -33,7 +33,7 @@ cSOFT_BIND = identS "SOFT_BIND"
 cSOFT_SPACE = identS "SOFT_SPACE"
 cCAPIT = identS "CAPIT"
 cALL_CAPIT = identS "ALL_CAPIT"
-cHtml = identS "Html"
+cMarkup = identS "Markup"
 
 isPredefCat :: Ident -> Bool
 isPredefCat c = elem c [cInt,cString,cFloat]