Skip to content

Commit 3d7c8ad

Browse files
krangelovkrangelov
committed
a draft for the generalized control operators
1 parent 544bbd9 commit 3d7c8ad

File tree

11 files changed

+105
-103
lines changed

11 files changed

+105
-103
lines changed

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

Lines changed: 0 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -287,10 +287,6 @@ eval env (Markup tag as ts) [] =
287287
do as <- mapM (\(id,t) -> eval env t [] >>= \v -> return (id,v)) as
288288
vs <- mapM (\t -> eval env t []) ts
289289
return (VMarkup tag as vs)
290-
eval env (Reset c t) [] = do let limit All = id
291-
limit (Limit n) = fmap (genericTake n)
292-
vs <- limit c (reset (eval env t []))
293-
return (VMarkup identW [] vs)
294290
eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,(pv,ty)) ->
295291
case lookup pv env of
296292
Just tnk -> return (i,(tnk,ty))

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

Lines changed: 38 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -86,7 +86,7 @@ data Value
8686
| VAlts Value [(Value, Value)]
8787
| VStrs [Value]
8888
| VMarkup Ident [(Ident,Value)] [Value]
89-
| VReset Control Value
89+
| VReset Ident (Maybe Value) Value QIdent
9090
| VSymCat Int LIndex [(LIndex, (Value, Type))]
9191
| VError Doc
9292
-- These two constructors are only used internally
@@ -124,7 +124,7 @@ isCanonicalForm False (VFV c vs) = all (isCanonicalForm False) (unvaria
124124
isCanonicalForm flat (VAlts d vs) = all (isCanonicalForm flat . snd) vs
125125
isCanonicalForm flat (VStrs vs) = all (isCanonicalForm flat) vs
126126
isCanonicalForm flat (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat) vs
127-
isCanonicalForm flat (VReset ctl v) = isCanonicalForm flat v
127+
isCanonicalForm flat (VReset ctl cv v _) = maybe True (isCanonicalForm flat) cv && isCanonicalForm flat v
128128
isCanonicalForm flat _ = False
129129

130130
data ConstValue a
@@ -324,7 +324,7 @@ eval g env c (Markup tag as ts) [] =
324324
vas = mapC (\c (id,t) -> (id,eval g env c t [])) c1 as
325325
vs = mapC (\c t -> eval g env c t []) c2 ts
326326
in (VMarkup tag vas vs)
327-
eval g env c (Reset ctl t) [] = VReset ctl (eval g env c t [])
327+
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
328328
eval g env c (TSymCat d r rs) []= VSymCat d r [(i,(fromJust (lookup pv env),ty)) | (i,(pv,ty)) <- rs]
329329
eval g env c t@(Opts n cs) vs = if null cs
330330
then VError ("No options in expression:" $$ ppTerm Unqualified 0 t)
@@ -422,7 +422,7 @@ bubble v = snd (bubble v)
422422
let (union1,attrs') = mapAccumL descend' Map.empty attrs
423423
(union2,vs') = mapAccumL descend union1 vs
424424
in (union2, VMarkup tag attrs' vs')
425-
bubble (VReset ctl v) = lift1 (VReset ctl) v
425+
bubble (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v
426426
bubble (VSymCat d i0 vs) =
427427
let (union,vs') = mapAccumL descendC Map.empty vs
428428
in (union, addVariants (VSymCat d i0 vs') union)
@@ -932,26 +932,42 @@ value2termM flat xs (VMarkup tag as vs) = do
932932
as <- mapM (\(id,v) -> value2termM flat xs v >>= \t -> return (id,t)) as
933933
ts <- mapM (value2termM flat xs) vs
934934
return (Markup tag as ts)
935-
value2termM flat xs (VReset ctl v) = do
935+
value2termM flat xs (VReset ctl mb_cv v qid) = do
936936
ts <- reset (value2termM True xs v)
937-
case ctl of
938-
All -> case ts of
939-
[t] -> return t
940-
ts -> return (Markup identW [] ts)
941-
One -> case ts of
942-
[] -> mzero
943-
(t:ts) -> return t
944-
Limit n -> case genericTake n ts of
945-
[t] -> return t
946-
ts -> return (Markup identW [] ts)
947-
Coordination (Just mn) conj id ->
948-
case ts of
949-
[] -> mzero
950-
[t] -> return t
951-
ts -> do let cat = showIdent id
952-
t <- listify mn cat ts
953-
return (App (App (QC (mn,identS ("Conj"++cat))) (QC (mn,conj))) t)
937+
reduce ctl mb_cv ts
954938
where
939+
reduce ctl mb_cv ts
940+
| ctl == cConcat = do
941+
ts' <- case mb_cv of
942+
Just (VInt n) -> return (genericTake n ts)
943+
Nothing -> return ts
944+
_ -> evalError (pp "[concat: .. | ..] requires an integer constant")
945+
case ts of
946+
[t] -> return t
947+
ts -> return (Markup identW [] ts)
948+
| ctl == cOne =
949+
case (ts,mb_cv) of
950+
([] ,Nothing) -> mzero
951+
([] ,Just v) -> value2termM flat xs v
952+
(t:ts,_) -> return t
953+
| ctl == cDefault =
954+
case (ts,mb_cv) of
955+
([] ,Nothing) -> mzero
956+
([] ,Just v) -> value2termM flat xs v
957+
(ts,_) -> msum (map pure ts)
958+
| ctl == cList =
959+
case (ts,mb_cv) of
960+
([], _) -> mzero
961+
([t], _) -> return t
962+
(ts,Just cv) ->
963+
do let cat = showIdent (snd qid)
964+
mn = fst qid
965+
ct <- value2termM flat xs cv
966+
t <- listify mn cat ts
967+
return (App (App (QC (mn,identS ("Conj"++cat))) ct) t)
968+
_ -> evalError (pp "[list: .. | ..] requires an argument")
969+
| otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
970+
955971
listify mn cat [t1,t2] = do return (App (App (QC (mn,identS ("Base"++cat))) t1) t2)
956972
listify mn cat (t1:ts) = do t2 <- listify mn cat ts
957973
return (App (App (QC (mn,identS ("Cons"++cat))) t1) t2)

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

Lines changed: 5 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -238,21 +238,12 @@ renameTerm env vars = ren vars where
238238
(p',_) <- renpatt p
239239
return $ EPatt minp maxp p'
240240

241-
Reset ctl t -> do
242-
ctl <- case ctl of
243-
Coordination _ conj cat ->
244-
checks [ do t <- renid' (Cn conj)
245-
case t of
246-
Q (mn,id) -> return (Coordination (Just mn) conj cat)
247-
QC (mn,id) -> return (Coordination (Just mn) conj cat)
248-
_ -> return (Coordination Nothing conj cat)
249-
, if showIdent conj == "one"
250-
then return One
251-
else checkError ("Undefined control" <+> pp conj)
252-
]
253-
ctl -> do return ctl
241+
Reset ctl mb_ct t qid -> do
242+
mv_ct <- case mb_ct of
243+
Just ct -> liftM Just $ ren vs ct
244+
Nothing -> return mb_ct
254245
t <- ren vs t
255-
return (Reset ctl t)
246+
return (Reset ctl mv_ct t qid)
256247

257248
_ -> composOp (ren vs) trm
258249

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

Lines changed: 37 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -370,21 +370,43 @@ tcRho scope c (Markup tag attrs children) mb_ty = do
370370
c1 attrs
371371
res <- mapCM (\c child -> tcRho scope c child Nothing) c2 children
372372
instSigma scope c3 (Markup tag attrs (map fst res)) vtypeMarkup mb_ty
373-
tcRho scope c (Reset ctl t) mb_ty =
374-
let (c1,c2) = split c
375-
in case ctl of
376-
All -> do (t,_) <- tcRho scope c1 t Nothing
377-
instSigma scope c2 (Reset ctl t) vtypeMarkup mb_ty
378-
One -> do (t,ty) <- tcRho scope c t mb_ty
379-
return (Reset ctl t,ty)
380-
Limit n -> do (t,_) <- tcRho scope c1 t Nothing
381-
instSigma scope c2 (Reset ctl t) vtypeMarkup mb_ty
382-
Coordination mb_mn@(Just mn) conj _
383-
-> do tcRho scope c1 (QC (mn,conj)) (Just (VApp poison (mn,identS "Conj") []))
384-
(t,ty) <- tcRho scope c2 t mb_ty
385-
case ty of
386-
VApp c id [] -> return (Reset (Coordination mb_mn conj (snd id)) t, ty)
387-
_ -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
373+
tcRho scope c (Reset ctl mb_ct t qid) mb_ty
374+
| ctl == cConcat = do
375+
let (c1,c23) = split c
376+
(c2,c3 ) = split c23
377+
(t,_) <- tcRho scope c1 t Nothing
378+
mb_ct <- case mb_ct of
379+
Just ct -> do (ct,_) <- tcRho scope c2 ct (Just vtypeInt)
380+
return (Just ct)
381+
Nothing -> return Nothing
382+
instSigma scope c2 (Reset ctl mb_ct t qid) vtypeMarkup mb_ty
383+
| ctl == cOne = do
384+
let (c1,c2) = split c
385+
(t,ty) <- tcRho scope c1 t mb_ty
386+
mb_ct <- case mb_ct of
387+
Just ct -> do (ct,ty) <- tcRho scope c2 ct (Just ty)
388+
return (Just ct)
389+
Nothing -> return Nothing
390+
return (Reset ctl mb_ct t qid,ty)
391+
| ctl == cDefault = do
392+
let (c1,c2) = split c
393+
(t,ty) <- tcRho scope c1 t mb_ty
394+
mb_ct <- case mb_ct of
395+
Just ct -> do (ct,ty) <- tcRho scope c2 ct (Just ty)
396+
return (Just ct)
397+
Nothing -> evalError (pp "[list: .. | ..] requires an argument")
398+
return (Reset ctl mb_ct t qid,ty)
399+
| ctl == cList = do
400+
do let (c1,c2) = split c
401+
mb_ct <- case mb_ct of
402+
Just ct -> do (ct,ty) <- tcRho scope c1 ct Nothing
403+
return (Just ct)
404+
Nothing -> evalError (pp "[list: .. | ..] requires an argument")
405+
(t,ty) <- tcRho scope c2 t mb_ty
406+
case ty of
407+
VApp c qid [] -> return (Reset ctl mb_ct t qid, ty)
408+
_ -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
409+
| otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined")
388410
tcRho scope s (Opts n cs) mb_ty = do
389411
let (s1,s2,s3) = split3 s
390412
(n,_) <- tcRho scope s1 n Nothing

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

Lines changed: 1 addition & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,6 @@ module GF.Grammar.Grammar (
4444
Fun,
4545
QIdent,
4646
BindType(..),
47-
Control(..),
4847
Patt(..),
4948
TInfo(..),
5049
Label(..),
@@ -400,21 +399,14 @@ data Term =
400399
| FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@
401400

402401
| Markup Ident [(Ident,Term)] [Term]
403-
| Reset Control Term
402+
| Reset Ident (Maybe Term) Term QIdent
404403

405404
| Alts Term [(Term, Term)] -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
406405
| Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@
407406
| TSymCat Int LIndex [(LIndex,(Ident,Type))]
408407
| TSymVar Int Int
409408
deriving (Show, Eq, Ord)
410409

411-
data Control
412-
= All
413-
| One
414-
| Limit Integer
415-
| Coordination (Maybe ModuleName) Ident Ident
416-
deriving (Show, Eq, Ord)
417-
418410
-- | Patterns
419411
data Patt =
420412
PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@

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

Lines changed: 4 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -129,14 +129,8 @@ term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag)
129129
, ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs))
130130
, ("children",showJSON (map term2json children))
131131
]
132-
term2json (Reset ctl t) =
133-
let jctl = case ctl of
134-
All -> showJSON "all"
135-
One -> showJSON "one"
136-
Limit n -> showJSON n
137-
Coordination Nothing conj cat -> makeObj [("conj",showJSON conj), ("cat",showJSON cat)]
138-
Coordination (Just mod) conj cat -> makeObj [("mod",showJSON mod), ("conj",showJSON conj), ("cat",showJSON cat)]
139-
in makeObj [("reset",jctl), ("term",term2json t)]
132+
term2json (Reset ctl ct t qid) =
133+
makeObj ([("ctl",showJSON ctl)]++maybe [] (\t->[("ct",term2json t)]) ct++[("term",term2json t), ("qid",showJSON qid)])
140134
term2json (Alts def alts) = makeObj [("def",term2json def), ("alts",showJSON (map (\(t1,t2) -> (term2json t1, term2json t2)) alts))]
141135
term2json (Strs ts) = makeObj [("strs",showJSON (map term2json ts))]
142136
term2json (EPatt _ _ p) = makeObj [("epatt",patt2json p)]
@@ -186,7 +180,8 @@ json2term o = Vr <$> o!:"vr"
186180
<|> Markup <$> (o!:"tag") <*>
187181
(o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*>
188182
(o!:"children" >>= mapM json2term)
189-
<|> Reset <$> (readJSON >=> valFromObj "reset" >=> json2ctl) o <*> o!<"term"
183+
<|> Reset <$> o!:"ctl" <*> fmap Just (o!<"ct") <*> o!<"term" <*> o!:"qid"
184+
<|> Reset <$> o!:"ctl" <*> pure Nothing <*> o!<"term" <*> o!:"qid"
190185
<|> Alts <$> (o!<"def") <*> (o!:"alts" >>= mapM (\(x,y) -> liftM2 (,) (json2term x) (json2term y)))
191186
<|> Strs <$> (o!:"strs" >>= mapM json2term)
192187
where
@@ -202,17 +197,6 @@ json2term o = Vr <$> o!:"vr"
202197
mkC [] = Empty
203198
mkC (t:ts) = foldl C t ts
204199

205-
json2ctl (JSString (JSONString "all")) = return All
206-
json2ctl (JSString (JSONString "one")) = return One
207-
json2ctl (JSRational _ i) = return (Limit (round i))
208-
json2ctl (JSObject o) = do
209-
mb_mod <- fmap Just (valFromObj "mod" o) <|> return Nothing
210-
conj <- valFromObj "conj" o
211-
cat <- valFromObj "cat" o
212-
return (Coordination mb_mod conj cat)
213-
json2ctl _ = fail "Invalid control value for reset"
214-
215-
216200
patt2json (PC id ps) = makeObj [("pc",showJSON id),("args",showJSON (map patt2json ps))]
217201
patt2json (PP (mn,id) ps) = makeObj [("mod",showJSON mn),("pc",showJSON id),("args",showJSON (map patt2json ps))]
218202
patt2json (PV id) = makeObj [("pv",showJSON id)]

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

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -116,7 +116,6 @@ data Token
116116
| T_lam
117117
| T_lamlam
118118
| T_cbrack
119-
| T_reset
120119
| T_ocurly
121120
| T_bar
122121
| T_ccurly
@@ -213,7 +212,6 @@ coreResWords = Map.fromList
213212
, b "?" T_questmark
214213
, b "[" T_obrack
215214
, b "]" T_cbrack
216-
, b "[:" T_reset
217215
, b "\\" T_lam
218216
, b "\\\\" T_lamlam
219217
, b "{" T_ocurly

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -418,7 +418,7 @@ composOp co trm =
418418
ELin c ty -> liftM (ELin c) (co ty)
419419
ImplArg t -> liftM ImplArg (co t)
420420
Markup t as cs -> liftM2 (Markup t) (mapAttrs co as) (mapM co cs)
421-
Reset c t -> liftM (Reset c) (co t)
421+
Reset ctl ct t qid->liftM2 (\mb_ct t->Reset ctl ct t qid) (maybe (pure Nothing) (fmap Just . co) ct) (co t)
422422
Typed t ty -> liftM2 Typed (co t) (co ty)
423423
_ -> return trm -- covers K, Vr, Cn, Sort, EPatt
424424

@@ -459,7 +459,7 @@ collectOp co trm = case trm of
459459
FV ts -> mconcatMap co ts
460460
Strs tt -> mconcatMap co tt
461461
Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs
462-
Reset _ t -> co t
462+
Reset _ ct t _-> maybe mempty co ct <> co t
463463
_ -> mempty -- covers K, Vr, Cn, Sort
464464

465465
mconcatMap f = mconcat . map f

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

Lines changed: 5 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -68,7 +68,6 @@ import qualified Data.Map as Map
6868
'@' { T_at }
6969
'[' { T_obrack }
7070
']' { T_cbrack }
71-
'[:' { T_reset }
7271
'{' { T_ocurly }
7372
'}' { T_ccurly }
7473
'\\' { T_lam }
@@ -488,8 +487,8 @@ Exp6
488487
| '{' ListLocDef '}' {% mkR $2 }
489488
| '<' ListTupleComp '>' { R (tuple2record $2) }
490489
| '<' Exp ':' Exp '>' { Typed $2 $4 }
491-
| '[:' Control '|' Tag ']' { Reset $2 $4 }
492-
| '[:' Control '|' Exp ']' { Reset $2 $4 }
490+
| '[' Control '|' Tag ']' { Reset (fst $2) (snd $2) $4 undefined }
491+
| '[' Control '|' Exp ']' { Reset (fst $2) (snd $2) $4 undefined }
493492
| '(' Exp ')' { $2 }
494493

495494
ListExp :: { [Term] }
@@ -747,10 +746,9 @@ ListMarkup :: { [Term] }
747746
| Exp { [$1] }
748747
| Markup ListMarkup { $1 : $2 }
749748

750-
Control :: { Control }
751-
: { All }
752-
| Integer { Limit (fromIntegral $1) }
753-
| Ident { Coordination Nothing $1 identW }
749+
Control :: { (Ident,Maybe Term) }
750+
: Ident { ($1, Nothing) }
751+
| Ident ':' Exp6 { ($1, Just $3) }
754752

755753
Attributes :: { [(Ident,Term)] }
756754
Attributes

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

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -61,6 +61,12 @@ cToStr = identS "toStr"
6161
cMapStr = identS "mapStr"
6262
cError = identS "error"
6363

64+
-- * Used in the delimited continuations
65+
cConcat = identS "concat"
66+
cOne = identS "one"
67+
cDefault = identS "default"
68+
cList = identS "list"
69+
6470
-- * Hacks: dummy identifiers used in various places.
6571
-- Not very nice!
6672

0 commit comments

Comments
 (0)