sketch an implementation for reset

Author: krangelov

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

@@ -64,6 +64,7 @@ data Value
   | VAlts Value [(Value, Value)]
   | VStrs [Value]
   | VMarkup Ident [(Ident,Value)] [Value]
+  | VReset Control Value
   | VSymCat Int LIndex [(LIndex, (Value, Type))]
   | VError Doc
     -- These two constructors are only used internally
@@ -254,10 +255,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) [] =
-                              let limit All       = id
-                                  limit (Limit n) = fmap (genericTake n)
-                              in (VMarkup identW [] [eval g env c t []])
+eval g env c (Reset ctl t) [] = VReset ctl (eval g env c t [])
 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              vs  = VError ("Cannot reduce term" <+> pp t)
 
@@ -325,6 +323,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 (VSymCat d i0 vs) =
       let (union,vs') = mapAccumL descendC Map.empty vs
       in (union, addVariants (VSymCat d i0 vs') union)
@@ -610,6 +609,14 @@ runEvalM g (EvalM f) = Check $ \(es,ws) ->
   where
     empty = State Map.empty Map.empty
 
+reset :: EvalM a -> EvalM [a]
+reset (EvalM f) = EvalM $ \g k state r ws ->
+  case f g (\x state xs ws -> Success (x:xs) ws) state [] ws of
+    Fail   msg ws -> Fail msg ws
+    Success xs ws -> k (reverse xs) state r ws
+  where
+    empty = State Map.empty Map.empty
+
 globals :: EvalM Globals
 globals = EvalM (\g k -> k g)
 
@@ -784,6 +791,29 @@ 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
+  ts <- reset (value2termM True xs v)
+  case ctl of
+    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
+    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 id ts
+                                return (App (App (QC (mn,identS ("Cons"++cat))) t1) t2)
 value2termM flat xs (VError msg) = evalError msg
 value2termM flat xs (VCRecType lbls) = do
   lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls

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

@@ -238,6 +238,22 @@ renameTerm env vars = ren vars where
       (p',_) <- renpatt p
       return $ EPatt minp maxp p'
 
+    Reset ctl t -> do
+      ctl <- case ctl of
+               Coordination _ conj cat ->
+                                 checks [ do t <- renid' (Cn conj)
+                                             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)
+
     _ -> composOp (ren vs) trm
 
   renid = renameIdentTerm env

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

@@ -388,10 +388,21 @@ 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 = do
+tcRho scope c (Reset ctl t) mb_ty =
   let (c1,c2) = split c
-  (t,_) <- tcRho scope c1 t Nothing
-  instSigma scope c2 (Reset ctl t) vtypeMarkup mb_ty
+  in case ctl of
+       All          -> do (t,_) <- tcRho scope c1 t Nothing
+                          instSigma scope c2 (Reset ctl t) vtypeMarkup mb_ty
+       One          -> do (t,ty) <- tcRho scope c t mb_ty
+                          return (Reset ctl t,ty)
+       Limit n      -> do (t,_) <- tcRho scope c1 t Nothing
+                          instSigma scope c2 (Reset ctl t) vtypeMarkup mb_ty
+       Coordination mb_mn@(Just mn) conj _
+                    -> do tcRho scope c1 (QC (mn,conj)) (Just (VApp (mn,identS "Conj") []))
+                          (t,ty) <- tcRho scope c2 t mb_ty
+                          case ty of
+                            VApp id [] -> return (Reset (Coordination mb_mn conj (snd id)) t, ty)
+                            _          -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
 tcRho scope s t _ = unimplemented ("tcRho "++show t)
 
 evalCodomain :: Scope -> Ident -> Value -> EvalM Value

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

@@ -407,7 +407,9 @@ data Term =
 
 data Control
   = All
+  | One
   | Limit Integer
+  | Coordination (Maybe ModuleName) Ident Ident
   deriving (Show, Eq, Ord)
 
 -- | Patterns

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

@@ -739,6 +739,7 @@ ListMarkup :: { [Term] }
 Control :: { Control }
   :            { All                     }
   | Integer    { Limit (fromIntegral $1) }
+  | Ident      { Coordination Nothing $1 identW }
 
 Attributes :: { [(Ident,Term)] }
 Attributes

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

@@ -256,17 +256,21 @@ 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 c t)
-                  = pp "[:" <> ppControl c <+> pp "|" <> ppTerm q 0 t <> pp "]"
+ppTerm q d (Reset ctl t)
+                  = pp "[:" <> ppControl q ctl <+> 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 '>'
 
 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 All       = empty
-ppControl (Limit n) = pp n
+ppControl q All       = empty
+ppControl q One       = pp "one"
+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