a draft for the generalized control operators

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

@@ -287,10 +287,6 @@ 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 (Reset c t) [] = do let limit All       = id
-                                 limit (Limit n) = fmap (genericTake n)
-                             vs <- limit c (reset (eval env t []))
-                             return (VMarkup identW [] 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))

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

@@ -86,7 +86,7 @@ data Value
   | VAlts Value [(Value, Value)]
   | VStrs [Value]
   | VMarkup Ident [(Ident,Value)] [Value]
-  | VReset Control Value
+  | VReset Ident (Maybe Value) Value QIdent
   | VSymCat Int LIndex [(LIndex, (Value, Type))]
   | VError Doc
     -- These two constructors are only used internally
@@ -124,7 +124,7 @@ isCanonicalForm False (VFV c vs)          = all (isCanonicalForm False) (unvaria
 isCanonicalForm flat  (VAlts d vs)        = all (isCanonicalForm flat . snd) vs
 isCanonicalForm flat  (VStrs vs)          = all (isCanonicalForm flat) vs
 isCanonicalForm flat  (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat) vs
-isCanonicalForm flat  (VReset ctl v)      = isCanonicalForm flat v
+isCanonicalForm flat  (VReset ctl cv v _) = maybe True (isCanonicalForm flat) cv && isCanonicalForm flat v
 isCanonicalForm flat  _ = False
 
 data ConstValue a
@@ -324,7 +324,7 @@ eval g env c (Markup tag as ts) [] =
                                   vas = mapC (\c (id,t) -> (id,eval g env c t [])) c1 as
                                   vs  = mapC (\c t -> eval g env c t []) c2 ts
                               in (VMarkup tag vas vs)
-eval g env c (Reset ctl t) [] = VReset ctl (eval g env c t [])
+eval g env c (Reset ctl mb_ct t qid) [] = VReset ctl (fmap (\t -> eval g env c t []) mb_ct) (eval g env c t []) qid
 eval g env c (TSymCat d r rs) []= VSymCat d r [(i,(fromJust (lookup pv env),ty)) | (i,(pv,ty)) <- rs]
 eval g env c t@(Opts n cs)  vs  = if null cs
                                   then VError ("No options in expression:" $$ ppTerm Unqualified 0 t)
@@ -422,7 +422,7 @@ bubble v = snd (bubble v)
       let (union1,attrs') = mapAccumL descend' Map.empty attrs
           (union2,vs')    = mapAccumL descend  union1 vs
       in (union2, VMarkup tag attrs' vs')
-    bubble (VReset ctl v) = lift1 (VReset ctl) v
+    bubble (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v
     bubble (VSymCat d i0 vs) =
       let (union,vs') = mapAccumL descendC Map.empty vs
       in (union, addVariants (VSymCat d i0 vs') union)
@@ -932,26 +932,42 @@ value2termM flat xs (VMarkup tag as vs) = do
   as <- mapM (\(id,v) -> value2termM flat xs v >>= \t -> return (id,t)) as
   ts <- mapM (value2termM flat xs) vs
   return (Markup tag as ts)
-value2termM flat xs (VReset ctl v) = do
+value2termM flat xs (VReset ctl mb_cv v qid) = do
   ts <- reset (value2termM True xs v)
-  case ctl of
+  reduce ctl mb_cv ts
-    All     -> case ts of
-                 [t] -> return t
-                 ts  -> return (Markup identW [] ts)
-    One     -> case ts of
-                 []     -> mzero
-                 (t:ts) -> return t
-    Limit n -> case genericTake n ts of
-                 [t] -> return t
-                 ts  -> return (Markup identW [] ts)
-    Coordination (Just mn) conj id ->
-                case ts of
-                  []  -> mzero
-                  [t] -> return t
-                  ts  -> do let cat = showIdent id
-                            t <- listify mn cat ts
-                            return (App (App (QC (mn,identS ("Conj"++cat))) (QC (mn,conj))) t)
   where
+    reduce ctl mb_cv ts
+      | ctl == cConcat = do
+         ts' <- case mb_cv of
+                     Just (VInt n) -> return (genericTake n ts)
+                     Nothing       -> return ts
+                     _             -> evalError (pp "[concat: .. | ..] requires an integer constant")
+         case ts of
+           [t] -> return t
+           ts  -> return (Markup identW [] ts)
+      | ctl == cOne =
+         case (ts,mb_cv) of
+           ([]  ,Nothing) -> mzero
+           ([]  ,Just v)  -> value2termM flat xs v
+           (t:ts,_)       -> return t
+      | ctl == cDefault =
+         case (ts,mb_cv) of
+           ([]  ,Nothing) -> mzero
+           ([]  ,Just v)  -> value2termM flat xs v
+           (ts,_)         -> msum (map pure ts)
+      | ctl == cList =
+         case (ts,mb_cv) of
+           ([],       _) -> mzero
+           ([t],      _) -> return t
+           (ts,Just cv)  ->
+             do let cat = showIdent (snd qid)
+                    mn  = fst qid
+                ct <- value2termM flat xs cv
+                t <- listify mn cat ts
+                return (App (App (QC (mn,identS ("Conj"++cat))) ct) t)
+           _             -> evalError (pp "[list: .. | ..] requires an argument")
+      | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
+
     listify mn cat [t1,t2] = do return (App (App (QC (mn,identS ("Base"++cat))) t1) t2)
     listify mn cat (t1:ts) = do t2 <- listify mn cat ts
                                 return (App (App (QC (mn,identS ("Cons"++cat))) t1) t2)

src/compiler/api/GF/Compile/Rename.hs

@@ -238,21 +238,12 @@ renameTerm env vars = ren vars where
       (p',_) <- renpatt p
       return $ EPatt minp maxp p'
 
-    Reset ctl t -> do
+    Reset ctl mb_ct t qid -> do
-      ctl <- case ctl of
+      mv_ct <- case mb_ct of
-               Coordination _ conj cat ->
+                 Just ct -> liftM Just $ ren vs ct
-                                 checks [ do t <- renid' (Cn conj)
+                 Nothing -> return mb_ct
-                                             case t of
-                                               Q  (mn,id) -> return (Coordination (Just mn) conj cat)
-                                               QC (mn,id) -> return (Coordination (Just mn) conj cat)
-                                               _          -> return (Coordination Nothing   conj cat)
-                                        , if showIdent conj == "one"
-                                            then return One
-                                            else checkError ("Undefined control" <+> pp conj)
-                                        ]
-               ctl                     -> do return ctl
       t <- ren vs t
-      return (Reset ctl t)
+      return (Reset ctl mv_ct t qid)
 
     _ -> composOp (ren vs) trm
 

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

@@ -370,21 +370,43 @@ tcRho scope c (Markup tag attrs children) mb_ty = do
                  c1 attrs
   res <- mapCM (\c child -> tcRho scope c child Nothing) c2 children
   instSigma scope c3 (Markup tag attrs (map fst res)) vtypeMarkup mb_ty
-tcRho scope c (Reset ctl t) mb_ty =
+tcRho scope c (Reset ctl mb_ct t qid) mb_ty
+  | ctl == cConcat = do
+      let (c1,c23) = split c
+          (c2,c3 ) = split c23
+      (t,_) <- tcRho scope c1 t Nothing
+      mb_ct <- case mb_ct of
+                 Just ct -> do (ct,_) <- tcRho scope c2 ct (Just vtypeInt)
+                               return (Just ct)
+                 Nothing -> return Nothing
+      instSigma scope c2 (Reset ctl mb_ct t qid) vtypeMarkup mb_ty
+  | ctl == cOne = do
       let (c1,c2) = split c
-  in case ctl of
+      (t,ty) <- tcRho scope c1 t mb_ty
-       All          -> do (t,_) <- tcRho scope c1 t Nothing
+      mb_ct  <- case mb_ct of
-                          instSigma scope c2 (Reset ctl t) vtypeMarkup mb_ty
+                  Just ct -> do (ct,ty) <- tcRho scope c2 ct (Just ty)
-       One          -> do (t,ty) <- tcRho scope c t mb_ty
+                                return (Just ct)
-                          return (Reset ctl t,ty)
+                  Nothing -> return Nothing
-       Limit n      -> do (t,_) <- tcRho scope c1 t Nothing
+      return (Reset ctl mb_ct t qid,ty)
-                          instSigma scope c2 (Reset ctl t) vtypeMarkup mb_ty
+  | ctl == cDefault = do
-       Coordination mb_mn@(Just mn) conj _
+      let (c1,c2) = split c
-                    -> do tcRho scope c1 (QC (mn,conj)) (Just (VApp poison (mn,identS "Conj") []))
+      (t,ty) <- tcRho scope c1 t mb_ty
+      mb_ct  <- case mb_ct of
+                  Just ct -> do (ct,ty) <- tcRho scope c2 ct (Just ty)
+                                return (Just ct)
+                  Nothing -> evalError (pp "[list: .. | ..] requires an argument")
+      return (Reset ctl mb_ct t qid,ty)
+  | ctl == cList = do
+      do let (c1,c2) = split c
+         mb_ct  <- case mb_ct of
+                     Just ct -> do (ct,ty) <- tcRho scope c1 ct Nothing
+                                   return (Just ct)
+                     Nothing -> evalError (pp "[list: .. | ..] requires an argument")
          (t,ty) <- tcRho scope c2 t mb_ty
          case ty of
-                            VApp c id [] -> return (Reset (Coordination mb_mn conj (snd id)) t, ty)
+           VApp c qid [] -> return (Reset ctl mb_ct t qid, ty)
            _             -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
+  | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
 tcRho scope s (Opts n cs) mb_ty = do
   let (s1,s2,s3) = split3 s
   (n,_) <- tcRho scope s1 n Nothing

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

@@ -44,7 +44,6 @@ module GF.Grammar.Grammar (
         Fun,
         QIdent,
         BindType(..),
-        Control(..),
         Patt(..),
         TInfo(..),
         Label(..),
@@ -400,7 +399,7 @@ data Term =
  | FV [Term]                     -- ^ alternatives in free variation: @variants { s ; ... }@
 
  | Markup Ident [(Ident,Term)] [Term]
- | Reset Control Term
+ | Reset Ident (Maybe Term) Term QIdent
 
  | Alts Term [(Term, Term)]      -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
  | Strs [Term]                   -- ^ conditioning prefix strings: @strs {s ; ...}@
@@ -408,13 +407,6 @@ data Term =
  | TSymVar Int Int
   deriving (Show, Eq, Ord)
 
-data Control
-  = All
-  | One
-  | Limit Integer
-  | Coordination (Maybe ModuleName) Ident Ident
-  deriving (Show, Eq, Ord)
-
 -- | Patterns
 data Patt =
    PC Ident [Patt]        -- ^ constructor pattern: @C p1 ... pn@    @C@ 

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

@@ -129,14 +129,8 @@ term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag)
                                                 , ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs))
                                                 , ("children",showJSON (map term2json children))
                                                 ]
-term2json (Reset ctl t) =
+term2json (Reset ctl ct t qid) =
-  let jctl = case ctl of
+  makeObj ([("ctl",showJSON ctl)]++maybe [] (\t->[("ct",term2json t)]) ct++[("term",term2json t), ("qid",showJSON qid)])
-               All     -> showJSON "all"
-               One     -> showJSON "one"
-               Limit n -> showJSON n
-               Coordination Nothing    conj cat -> makeObj [("conj",showJSON conj), ("cat",showJSON cat)]
-               Coordination (Just mod) conj cat -> makeObj [("mod",showJSON mod), ("conj",showJSON conj), ("cat",showJSON cat)]
-  in makeObj [("reset",jctl), ("term",term2json t)]
 term2json (Alts def alts) = makeObj [("def",term2json def), ("alts",showJSON (map (\(t1,t2) -> (term2json t1, term2json t2)) alts))]
 term2json (Strs ts) = makeObj [("strs",showJSON (map term2json ts))]
 term2json (EPatt _ _ p) = makeObj [("epatt",patt2json p)]
@@ -186,7 +180,8 @@ json2term o  = Vr      <$> o!:"vr"
     <|>        Markup  <$> (o!:"tag") <*>
                            (o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*>
                            (o!:"children" >>= mapM json2term)
-    <|>        Reset   <$> (readJSON >=> valFromObj "reset" >=> json2ctl) o <*> o!<"term"
+    <|>        Reset   <$> o!:"ctl" <*> fmap Just (o!<"ct") <*> o!<"term" <*> o!:"qid"
+    <|>        Reset   <$> o!:"ctl" <*> pure Nothing <*> o!<"term" <*> o!:"qid"
     <|>        Alts    <$> (o!<"def") <*> (o!:"alts" >>= mapM (\(x,y) -> liftM2 (,) (json2term x) (json2term y)))
     <|>        Strs    <$> (o!:"strs" >>= mapM json2term)
     where
@@ -202,17 +197,6 @@ json2term o  = Vr      <$> o!:"vr"
       mkC []     = Empty
       mkC (t:ts) = foldl C t ts
 
-      json2ctl (JSString (JSONString "all")) = return All
-      json2ctl (JSString (JSONString "one")) = return One
-      json2ctl (JSRational _ i) = return (Limit (round i))
-      json2ctl (JSObject o) = do
-        mb_mod <- fmap Just (valFromObj "mod" o) <|> return Nothing
-        conj <- valFromObj "conj" o
-        cat  <- valFromObj "cat" o
-        return (Coordination mb_mod conj cat)
-      json2ctl _ = fail "Invalid control value for reset"
-
-
 patt2json (PC id ps)     = makeObj [("pc",showJSON id),("args",showJSON (map patt2json ps))]
 patt2json (PP (mn,id) ps) = makeObj [("mod",showJSON mn),("pc",showJSON id),("args",showJSON (map patt2json ps))]
 patt2json (PV id)        = makeObj [("pv",showJSON id)]

src/compiler/api/GF/Grammar/Lexer.x

@@ -116,7 +116,6 @@ data Token
  | T_lam
  | T_lamlam
  | T_cbrack
- | T_reset
  | T_ocurly
  | T_bar
  | T_ccurly
@@ -213,7 +212,6 @@ coreResWords = Map.fromList
  , b "?"  T_questmark
  , b "["  T_obrack
  , b "]"  T_cbrack
- , b "[:" T_reset
  , b "\\" T_lam
  , b "\\\\" T_lamlam
  , b "{"  T_ocurly

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

@@ -418,7 +418,7 @@ composOp co trm =
    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)
-   Reset c t        -> liftM (Reset c) (co t)
+   Reset ctl ct t qid->liftM2 (\mb_ct t->Reset ctl ct t qid) (maybe (pure Nothing) (fmap Just . co) ct) (co t)
    Typed t ty       -> liftM2 Typed (co t) (co ty)
    _ -> return trm -- covers K, Vr, Cn, Sort, EPatt
 
@@ -459,7 +459,7 @@ collectOp co trm = case trm of
   FV ts        -> mconcatMap co ts
   Strs tt      -> mconcatMap co tt
   Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs
-  Reset _ t    -> co t
+  Reset _ ct t _-> maybe mempty co ct <> co t
   _            -> mempty -- covers K, Vr, Cn, Sort
 
 mconcatMap f = mconcat . map f

src/compiler/api/GF/Grammar/Parser.y

@@ -68,7 +68,6 @@ import qualified Data.Map as Map
  '@'          { T_at        }
  '['          { T_obrack    }
  ']'          { T_cbrack    }
- '[:'         { T_reset     }
  '{'          { T_ocurly    }
  '}'          { T_ccurly    }
  '\\'         { T_lam       }
@@ -488,8 +487,8 @@ Exp6
   | '{' ListLocDef '}'    {% mkR $2 }
   | '<' ListTupleComp '>' { R (tuple2record $2) }
   | '<' Exp ':' Exp '>'   { Typed $2 $4      }
-  | '[:' Control '|' Tag ']'      { Reset $2 $4 }
+  | '[' Control '|' Tag ']'      { Reset (fst $2) (snd $2) $4 undefined }
-  | '[:' Control '|' Exp ']'      { Reset $2 $4 }
+  | '[' Control '|' Exp ']'      { Reset (fst $2) (snd $2) $4 undefined }
   | '(' Exp ')'           { $2 }
 
 ListExp :: { [Term] }
@@ -747,10 +746,9 @@ ListMarkup :: { [Term] }
   | Exp                { [$1]    }
   | Markup ListMarkup  { $1 : $2 }
 
-Control :: { Control }
+Control :: { (Ident,Maybe Term) }
-  :            { All                     }
+  : Ident            { ($1, Nothing) }
-  | Integer    { Limit (fromIntegral $1) }
+  | Ident ':' Exp6   { ($1, Just $3) }
-  | Ident      { Coordination Nothing $1 identW }
 
 Attributes :: { [(Ident,Term)] }
 Attributes

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

@@ -61,6 +61,12 @@ cToStr = identS "toStr"
 cMapStr = identS "mapStr"
 cError = identS "error"
 
+-- * Used in the delimited continuations
+cConcat = identS "concat"
+cOne = identS "one"
+cDefault = identS "default"
+cList = identS "list"
+
 -- * Hacks: dummy identifiers used in various places.
 -- Not very nice!
 

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

@@ -256,8 +256,11 @@ ppTerm q d (Markup tag attrs children)
   | otherwise     = pp "<" <> pp tag <+> hsep (map (ppMarkupAttr q) attrs) <> pp ">" $$
                     nest 3 (ppMarkupChildren q children) $$
                     pp "</" <> pp tag <> pp ">"
-ppTerm q d (Reset ctl t)
+ppTerm q d (Reset ctl ct t _)
-                  = pp "[:" <> ppControl q ctl <+> pp "|" <> ppTerm q 0 t <> pp "]"
+                  = pp "[" <> pp ctl <> 
+                              maybe empty (\t -> ':' <+> ppTerm q 6 t) ct <>
+                    pp "|" <> ppTerm q 0 t <>
+                    pp "]"
 ppTerm q d (TSymCat i r rs) = pp '<' <> pp i <> pp ',' <> ppLinFun (pp.fst) r rs <> pp '>'
 ppTerm q d (TSymVar i r) = pp '<' <> pp i <> pp ',' <> pp '$' <> pp r <> pp '>'
 
@@ -265,12 +268,8 @@ ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
 
 ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
 
-ppControl q All       = empty
+ppControl q (id,Nothing) = pp id
-ppControl q One       = pp "one"
+ppControl q (id,Just t ) = pp id <> ':' <+> ppTerm q 6 t
-ppControl q (Limit n) = pp n
-ppControl q (Coordination mb_mn n _) = ppTerm q 0 (case mb_mn of
-                                                     Just mn -> QC (mn,n)
-                                                     Nothing -> Cn n)
 
 instance Pretty Patt where pp = ppPatt Unqualified 0