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 []