diff --git a/src/compiler/api/GF/Compile/Compute/Concrete.hs b/src/compiler/api/GF/Compile/Compute/Concrete.hs index bcc930d68..cf0ff0d28 100644 --- a/src/compiler/api/GF/Compile/Compute/Concrete.hs +++ b/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 diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs index cc9601dc8..e4f1aefd8 100644 --- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/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 [] diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs index 7d083fbe3..b41014a39 100644 --- a/src/compiler/api/GF/Grammar/Macros.hs +++ b/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 diff --git a/src/compiler/api/GF/Grammar/Predef.hs b/src/compiler/api/GF/Grammar/Predef.hs index a92a31f6c..2bc167193 100644 --- a/src/compiler/api/GF/Grammar/Predef.hs +++ b/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]