Merge branch 'majestic' of github.com:krangelov/gf-core into majestic

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

@@ -232,12 +232,12 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do
     ResOverload os tysts -> chIn NoLoc "overloading" $ do
       tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType g t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts  -- return explicit ones
       tysts0 <- lookupOverload gr (fst sm,c)  -- check against inherited ones too
-      tysts1 <- mapM (uncurry $ flip (checkLType g))
+      tysts1 <- sequence
-                  [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
+                  [checkLType g tr (mkFunType args val) | (args,(val,tr)) <- tysts0]
       --- this can only be a partial guarantee, since matching
       --- with value type is only possible if expected type is given
-      checkUniq $
+      --checkUniq $
-        sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
+      --  sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
       update sm c (ResOverload os [(y,x) | (x,y) <- tysts'])
 
     ResParam (Just (L loc pcs)) _ -> do

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

@@ -3,13 +3,13 @@
 module GF.Compile.Compute.Concrete2
            (Env, Scope, Value(..), Variants(..), OptionInfo(..), ChoiceMap, cleanOptions,
             ConstValue(..), ConstVariants(..), Globals(..), PredefTable, EvalM,
-            mapVariants, unvariants, variants2consts, consts2variants,
+            mapVariants, mapVariantsC, unvariants, variants2consts, consts2variants,
-            runEvalM, runEvalMWithOpts, stdPredef, globals, withState,
+            runEvalM, runEvalMWithOpts, stdPredef, globals,
             PredefImpl, Predef(..), ($\),
             pdCanonicalArgs, pdArity,
             normalForm, normalFlatForm,
-            eval, apply, value2term, value2termM, bubble, patternMatch, vtableSelect, State(..),
+            eval, apply, value2term, value2termM, value2int, value2float, bubble, patternMatch, vtableSelect, State(..),
-            newResiduation, getMeta, setMeta, MetaState(..), variants, try,
+            newResiduation, checkpoint, getMeta, setMeta, MetaState(..), variants, try,
             evalError, evalWarn, ppValue, Choice(..), unit, poison, split, split3, split4, mapC, mapCM) where
 
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
@@ -24,6 +24,7 @@ import GF.Grammar.Predef
 import GF.Grammar.Printer hiding (ppValue)
 import GF.Grammar.Lockfield(lockLabel)
 import GF.Text.Pretty hiding (empty)
+import qualified GF.Text.Pretty as PP
 import Control.Monad
 import Control.Applicative hiding (Const)
 import qualified Control.Applicative as A
@@ -65,7 +66,7 @@ data Value
   | VGen  {-# UNPACK #-} !Int [Value]
   | VClosure Env Choice Term
   | VProd BindType Ident Value Value
-  | VRecType [(Label, Bool, Value)]
+  | VRecType [(Label, Bool, Value)] Bool
   | VR [(Label, Value)]
   | VP Value Label [Value]
   | VExtR Value Value
@@ -89,16 +90,20 @@ data Value
   | VReset Ident (Maybe Value) Value (Maybe QIdent)
   | VSymCat Int LIndex [(LIndex, (Value, Type))]
   | VError Doc
-  | VInts (Maybe Integer) (Maybe Integer)
+  | VInts Integer Bool
 
 data Variants
   = VarFree [Value]
-  | VarOpts Value [(Value, Value)]
+  | VarOpts Value [(Maybe Value, Value)]
 
 mapVariants :: (Value -> Value) -> Variants -> Variants
 mapVariants f (VarFree vs)   = VarFree (f <$> vs)
 mapVariants f (VarOpts n cs) = VarOpts n (second f <$> cs)
 
+mapVariantsC :: (Choice -> Value -> Value) -> Choice -> Variants -> Variants
+mapVariantsC f c (VarFree vs)   = VarFree (mapC f c vs)
+mapVariantsC f c (VarOpts n cs) = VarOpts n (mapC (\c (x,y) -> (x,f c y)) c cs)
+
 unvariants :: Variants -> [Value]
 unvariants (VarFree vs)   = vs
 unvariants (VarOpts n cs) = snd <$> cs
@@ -106,7 +111,7 @@ unvariants (VarOpts n cs) = snd <$> cs
 isCanonicalForm :: Bool -> Value -> Bool
 isCanonicalForm flat  (VClosure {})       = True
 isCanonicalForm flat  (VProd b x d cod)   = isCanonicalForm flat d && isCanonicalForm flat cod
-isCanonicalForm flat  (VRecType fs)       = all (\(l,_,ty) -> isCanonicalForm flat ty) fs
+isCanonicalForm flat  (VRecType fs _)     = all (\(l,_,ty) -> isCanonicalForm flat ty) fs
 isCanonicalForm flat  (VR {})             = True
 isCanonicalForm flat  (VTable d cod)      = isCanonicalForm flat d && isCanonicalForm flat cod
 isCanonicalForm flat  (VT {})             = True
@@ -133,7 +138,7 @@ data ConstValue a
 
 data ConstVariants a
   = ConstFree [ConstValue a]
-  | ConstOpts Value [(Value, ConstValue a)]
+  | ConstOpts Value [(Maybe Value, ConstValue a)]
 
 mapConstVs :: (ConstValue a -> ConstValue b) -> ConstVariants a -> ConstVariants b
 mapConstVs f (ConstFree vs)   = ConstFree (f <$> vs)
@@ -200,7 +205,7 @@ eval g env s (Prod b x t1 t2)[]
   | otherwise                   = let (s1,s2) = split s
                                   in VProd b x (eval g env s1 t1 []) (VClosure env s2 t2)
 eval g env s (Typed t ty)   vs  = eval g env s t vs
-eval g env s (RecType lbls) []  = VRecType (mapC (\s (lbl,ty) -> (lbl, True, eval g env s ty [])) s lbls)
+eval g env s (RecType lbls) []  = VRecType (mapC (\s (lbl,ty) -> (lbl, True, eval g env s ty [])) s lbls) False
 eval g env s (R as)         []  = VR (mapC (\s (lbl,(ty,t)) -> (lbl, eval g env s t [])) s as)
 eval g env s (P t lbl)      vs  = let project (VR as)        = case lookup lbl as of
                                                                  Nothing -> VError ("Missing value for label" <+> pp lbl $$
@@ -214,7 +219,7 @@ eval g env s (P t lbl)      vs  = let project (VR as)        = case lookup lbl a
 eval g env s (ExtR t1 t2)   []  = let (s1,s2) = split s
 
                                       extend (VR       as1) (VR       as2)   = VR       (foldl (\as (lbl,v) -> update lbl v as) as1 as2)
-                                      extend (VRecType as1) (VRecType as2)   = VRecType (foldl (\as (lbl,o,v) -> update3 lbl o v as) as1 as2)
+                                      extend (VRecType as1 e1) (VRecType as2 e2)=VRecType (foldl (\as (lbl,o,v) -> update3 lbl o v as) as1 as2) (e1 || e2)
                                       extend (VFV i fvs)    v2               = VFV i (mapVariants (`extend` v2) fvs)
                                       extend v1             (VFV i fvs)      = VFV i (mapVariants (v1 `extend`) fvs)
                                       extend (VMeta i vs)   v2               = VSusp i (\v -> extend (apply g v vs) v2) []
@@ -316,7 +321,7 @@ eval g env s (FV ts)        vs  = VFV s (VarFree (mapC (\s t -> eval g env s t v
 eval g env s (Alts d as)    []  = let (!s1,!s2) = split s
                                       vd  = eval g env s1 d []
                                       vas = mapC (\s (t1,t2) -> let (!s1,!s2) = split s
-                                                              in (eval g env s1 t1 [],eval g env s2 t2 [])) s2 as
+                                                                in (eval g env s1 t1 [],eval g env s2 t2 [])) s2 as
                                   in VAlts vd vas
 eval g env c (Strs ts)      []  = VStrs (mapC (\c t -> eval g env c t []) c ts)
 eval g env c (Markup tag as ts) [] =
@@ -332,7 +337,8 @@ eval g env c t@(Opts n cs)  vs  = if null cs
                                            vn = eval g env c1 n []
                                            vcs = mapC evalOpt c cs
                                        in VFV c3 (VarOpts vn vcs)
-  where evalOpt c' (l,t) = let (c1,c2) = split c' in (eval g env c1 l [], eval g env c2 t vs)
+  where evalOpt c' (Just l, t) = let (c1,c2) = split c' in (Just (eval g env c1 l []), eval g env c2 t vs)
+        evalOpt c' (Nothing,t) = let (c1,c2) = split c' in (Nothing,                   eval g env c2 t vs)
 eval g env c t              vs  = VError ("Cannot reduce term" <+> pp t)
 
 evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value
@@ -348,7 +354,7 @@ evalPredef g@(Gl gr pds) c n args =
 
 stdPredef :: Globals -> PredefTable
 stdPredef g = Map.fromList
-  [(cInts,   pdArity 1 $\ \g c vs -> Const (case vs of {[VInt i] -> VInts (Just i) (Just i); vs -> VApp c (cPredef,cInts) vs}))
+  [(cInts,   pdArity 1 $\ \g c vs -> Const (case vs of {[VInt i] -> VInts i False; vs -> VApp c (cPredef,cInts) vs}))
   ,(cLength, pdArity 1 $\ \g c [v] -> fmap (VInt . genericLength) (value2string g v))
   ,(cTake,   pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericTake (value2int g v1) (value2string g v2)))
   ,(cDrop,   pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericDrop (value2int g v1) (value2string g v2)))
@@ -392,9 +398,9 @@ bubble v = snd (bubble v)
     bubble (VGen i vs) = liftL (VGen i) vs
     bubble (VClosure env c t) = liftL' (\env -> VClosure env c t) env
     bubble (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2
-    bubble v@(VRecType lbls) =
+    bubble v@(VRecType lbls ext) =
       let (union,lbls') = mapAccumL descendR Map.empty lbls
-      in (union, addVariants (VRecType lbls') union)
+      in (union, addVariants (VRecType lbls' ext) union)
     bubble (VR as) = liftL' VR as
     bubble (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
     bubble (VExtR v1 v2) = lift2 VExtR v1 v2
@@ -414,18 +420,20 @@ bubble v = snd (bubble v)
     bubble v@(VFV c (VarFree vs))
       | null vs   = (Map.empty, v)
       | otherwise = let (union,vs') = mapAccumL descend Map.empty vs
-                    in (Map.insert c (BubbleFree (length vs),1) union, addVariants (VFV c (VarFree vs')) union)
+                    in (Map.insert c (BubbleFree (length vs),1) union, VFV c (VarFree vs'))
     bubble v@(VFV c (VarOpts n os))
       | null os   = (Map.empty, v)
       | otherwise = let (union,os') = mapAccumL (\acc (k,v) -> second (k,) $ descend acc v) Map.empty os
-                    in (Map.insert c (BubbleOpts n (fst <$> os),1) union, addVariants (VFV c (VarOpts n os')) union)
+                    in (Map.insert c (BubbleOpts n (map (\(l,t) -> fromMaybe t l) os),1) union, VFV c (VarOpts n os'))
     bubble (VAlts v vs) = lift1L2 VAlts v vs
     bubble (VStrs vs) = liftL VStrs vs
     bubble (VMarkup tag attrs vs) =
       let (union1,attrs') = mapAccumL descend' Map.empty attrs
           (union2,vs')    = mapAccumL descend  union1 vs
       in (union2, VMarkup tag attrs' vs')
-    bubble (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v
+    bubble (VReset ctl mb_cv v id) =
+      let (union,v') = bubble v
+      in (Map.empty,VReset ctl mb_cv v' id)
     bubble (VSymCat d i0 vs) =
       let (union,vs') = mapAccumL descendC Map.empty vs
       in (union, addVariants (VSymCat d i0 vs') union)
@@ -501,7 +509,7 @@ bubble v = snd (bubble v)
         addVariant c (bvs,cnt) v
           | cnt > 1   = VFV c $ case bvs of
                                   BubbleFree k    -> VarFree (replicate k v)
-                                  BubbleOpts n os -> VarOpts n ((,v) <$> os)
+                                  BubbleOpts n os -> VarOpts n (map (\l -> (Just l,v)) os)
           | otherwise = v
 
     unitfy = fmap (\(n,_) -> (n,1))
@@ -733,9 +741,6 @@ runEvalMWithOpts g cs (EvalM f) = Check $ \(es,ws) ->
   where
     init = State cs Map.empty []
 
-withState :: State -> EvalM a -> EvalM a
-withState state (EvalM f) = EvalM $ \g k _ r ws -> f g k state r ws
-
 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
@@ -773,24 +778,36 @@ variants' c f xs = EvalM (\g k state@(State choices metas opts) r msgs ->
                      Fail    msg msgs -> Fail msg msgs
                      Success ts  msgs -> backtrack g (j+1) xs choices metas opts ts msgs
 
-try :: (a -> EvalM b) -> ([(b,State)] -> EvalM b) -> [a] -> EvalM b
+try :: Int -> (a -> EvalM b) -> ([b] -> EvalM b) -> [a] -> EvalM b
-try f select xs = EvalM (\g k state r msgs ->
+try sz f select xs = EvalM (\g k state r msgs ->
-  let (res,msgs') = backtrack g xs state [] msgs
+  let (state',res,msgs') = backtrack sz g xs state [] msgs
   in case select res of
-       EvalM f' -> f' g k state r msgs')
+       EvalM f' -> f' g k state' r msgs')
   where
-    backtrack g []     state res msgs = (res,msgs)
+    backtrack sz g []     state res msgs = (state,res,msgs)
-    backtrack g (x:xs) state res msgs =
+    backtrack sz g (x:xs) state res msgs =
       case f x of
-        EvalM f -> case f g (\x state res msgs -> Success ((x,state):res) msgs) state res msgs of
+        EvalM f -> case f g (\y state' (_,ys) msgs -> Success (cut sz state state',y:ys) msgs) state (state,res) msgs of
-                     Fail msg _       -> backtrack g xs state res msgs
+                     Fail msg _               -> backtrack sz g xs state res msgs
-                     Success res msgs -> backtrack g xs state res msgs
+                     Success (state,res) msgs -> backtrack sz g xs state res msgs
+
+    cut sz state state' = state'{metaVars=Map.mapWithKey select (metaVars state')}
+      where
+        select k ms
+          | k <= sz   = ms
+          | otherwise = case Map.lookup k (metaVars state) of
+                          Just ms -> ms
+                          Nothing -> ms
 
 newResiduation :: Scope -> EvalM MetaId
 newResiduation scope = EvalM (\g k (State choices metas opts) r msgs ->
   let meta_id = Map.size metas+1
   in k meta_id (State choices (Map.insert meta_id (Residuation scope) metas) opts) r msgs)
 
+checkpoint :: EvalM Int
+checkpoint = EvalM (\g k state r msgs ->
+  k (Map.size (metaVars state)) state r msgs)
+
 getMeta :: MetaId -> EvalM MetaState
 getMeta i = EvalM (\g k state r msgs ->
   case Map.lookup i (metaVars state) of
@@ -833,7 +850,7 @@ value2termM flat xs (VProd b x v1 v2) = do
   t1 <- value2termM flat xs v1
   t2 <- value2termM flat xs v2
   return (Prod b x t1 t2)
-value2termM flat xs (VRecType lbls) = do
+value2termM flat xs (VRecType lbls _) = do
   lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls
   return (RecType lbls)
 value2termM flat xs (VR as) = do
@@ -908,7 +925,7 @@ value2termM flat xs (VFV i (VarOpts n os)) =
     let j = fromMaybe 0 (Map.lookup i choices)
     in case os `maybeAt` j of
          Just (l,t) -> case value2termM flat xs t of
-                         EvalM f -> let oi = OptionInfo i n (fst <$> os)
+                         EvalM f -> let oi = OptionInfo i n (map (\(l,t) -> fromMaybe t l) os)
                                     in f g k (State choices metas (oi:opts)) r msgs
          Nothing    -> Fail ("Index" <+> j <+> "out of bounds for option:" $$ ppValue Unqualified 0 n) msgs
 value2termM flat xs (VPatt min max p) = return (EPatt min max p)
@@ -941,11 +958,36 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
          case ts of
            [t] -> return t
            ts  -> return (Markup identW [] 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
+           []  -> mzero
+           [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 == cSelect =
+         case mb_cv of
+           Just (VInt n) | n >= 0    -> select n      ts'
+                         | otherwise -> select (-n-1) (reverse ts')
+                         where
+                           ts' = sortBy compareKey ts
+
+                           select _ []     = mzero
+                           select 0 (t:ts) =
+                             case t of
+                               R rs -> case lookup (ident2label cp1) rs  of
+                                         Just (_,t) -> return t
+                                         Nothing    -> evalError (pp "Missing label p1")
+                               _    -> evalError (pp "The term must be a record")
+                           select n (t:ts) = select (n-1) ts
+           _             -> evalError (pp "[select: .. | ..] requires an integer constant")
       | ctl == cDefault =
          case (ts,mb_cv) of
            ([]  ,Nothing) -> mzero
@@ -962,15 +1004,23 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do
                 t <- listify mn cat ts
                 return (App (App (QC (mn,identS ("Conj"++cat))) ct) t)
            _             -> evalError (pp "[list: .. | ..] requires an argument")
+      | ctl == cLen =
+         case mb_cv of
+           Just cv  -> do g <- globals
+                          value2termM True xs (apply g cv [VInt (genericLength ts)])
+           Nothing  -> return (EInt (genericLength ts))
       | 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)
+
+    compareKey (R rs1) (R rs2) =
+      case (lookup (ident2label cp2) rs1, lookup (ident2label cp2) rs2) of
+        (Just (_,K s1), Just (_,K s2)) -> compare s1 s2
+
 value2termM flat xs (VError msg) = evalError msg
-value2termM flat xs (VInts Nothing    Nothing) = return (App (Q (cPredef,cInts)) (Meta 0))
+value2termM flat xs (VInts n _) = return (App (Q (cPredef,cInts)) (EInt n))
-value2termM flat xs (VInts (Just min) Nothing) = return (App (Q (cPredef,cInts)) (EInt min))
-value2termM flat xs (VInts _       (Just max)) = return (App (Q (cPredef,cInts)) (EInt max))
 value2termM flat xs v = evalError ("value2termM" <+> ppValue Unqualified 5 v)
 
 
@@ -986,6 +1036,7 @@ pattVars st (PSeq _ _ p1 _ _ p2) = pattVars (pattVars st p1) p2
 pattVars st _            = st
 
 
+
 ppValue q d (VApp c f vs) = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs))
 ppValue q d (VMeta i vs) = prec d 4 (hsep ((if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
 ppValue q d (VSusp i k vs) = prec d 4 (hsep (pp "#susp" : (if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs))
@@ -995,13 +1046,13 @@ ppValue q d (VProd bt x a b) =
   if x == identW && bt == Explicit
     then prec d 0 (ppValue q 4 a <+> "->" <+> ppValue q 0 b)
     else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppValue q 0 a) <+> "->" <+> ppValue q 0 b)
-ppValue q d (VRecType xs)
+ppValue q d (VRecType xs ext)
   | q == Terse         = case [cat | (l,_,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
                            [cat] -> pp cat
                            _     -> doc
   | otherwise          = doc
   where
-    doc = braces (fsep (punctuate ';' [l <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs]))
+    doc = braces (fsep (punctuate ';' ([l <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs] ++ [pp ".." | ext])))
 ppValue q d (VR _) = pp "VR"
 ppValue q d (VP v l vs) = prec d 5 (hsep (ppValue q 5 v <> '.' <> l : map (ppValue q 5) vs))
 ppValue q d (VExtR _ _) = pp "VExtR"
@@ -1021,17 +1072,20 @@ ppValue q d VEmpty = pp "[]"
 ppValue q d (VC v1 v2) = prec d 1 (hang (ppValue q 2 v1) 2 ("++" <+> ppValue q 1 v2))
 ppValue q d (VGlue v1 v2) = prec d 2 (ppValue q 3 v1 <+> '+'  <+> ppValue q 2 v2)
 ppValue q d (VPatt _ _ _) = pp "VPatt"
-ppValue q d (VPattType _) = pp "VPattType"
+ppValue q d (VPattType v) = prec d 4 ("pattern" <+> ppValue q 0 v)
 ppValue q d (VFV i vs) = prec d 4 ("variants" <+> pp i <+> braces (fsep (punctuate ';' (map (ppValue q 0) (unvariants vs)))))
 ppValue q d (VAlts e xs) = prec d 4 ("pre" <+> braces (ppValue q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
 ppValue q d (VStrs _) = pp "VStrs"
 ppValue q d (VMarkup _ _ _) = pp "VMarkup"
+ppValue q d (VReset ctl ct t _) = pp "[" <> pp ctl <> 
+                                  maybe PP.empty (\v -> pp ':' <+> ppValue q 6 v) ct <>
+                                  pp "|" <> ppValue q 0 t <>
+                                  pp "]"
 ppValue q d (VSymCat i r rs) = pp '<' <> pp i <> pp ',' <> pp r <> pp '>'
 ppValue q d (VError msg) = prec d 4 (pp "error" <+> ppTerm q 5 (K (show msg)))
-ppValue q d (VInts Nothing    Nothing)    = prec d 4 (pp "Ints ?")
+ppValue q d (VInts n ext)
-ppValue q d (VInts (Just min) Nothing)    = prec d 4 (pp "Ints" <+> brackets (pp min <> ".."))
+  | ext       = prec d 4 (pp "Ints" <+> brackets (pp n <> ".."))
-ppValue q d (VInts Nothing    (Just max)) = prec d 4 (pp "Ints" <+> brackets (".." <> pp max))
+  | otherwise = prec d 4 (pp "Ints" <+> pp n)
-ppValue q d (VInts (Just min) (Just max)) = prec d 4 (pp "Ints" <+> brackets (pp min <> ".." <> pp max))
 
 ppAltern q (x,y) = ppValue q 0 x <+> '/' <+> ppValue q 0 y
 
@@ -1103,6 +1157,12 @@ value2int g (VInt n)         = Const n
 value2int g (VFV s vs)       = CFV s (variants2consts (value2int g) vs)
 value2int g _                = RunTime
 
+value2float g (VMeta i vs)     = CSusp i (\v -> value2float g (apply g v vs))
+value2float g (VSusp i k vs)   = CSusp i (\v -> value2float g (apply g (k v) vs))
+value2float g (VFlt f)         = Const f
+value2float g (VFV s vs)       = CFV s (variants2consts (value2float g) vs)
+value2float g _                = RunTime
+
 newtype Choice = Choice { unchoice :: Integer }
   deriving (Eq,Ord,Pretty,Show)
 

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

@@ -214,11 +214,28 @@ str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
 str2lin (VSymVar d r)    = return [SymVar d r]
 str2lin VEmpty           = return []
 str2lin (VC v1 v2)       = liftM2 (++) (str2lin v1) (str2lin v2)
-str2lin (VAlts def alts) = do def <- str2lin def
+str2lin v0@(VAlts def alts)
-                              alts <- forM alts $ \(v,VStrs vs) -> do
+                         = do def <- str2lin def
-                                lin <- str2lin v
+                              alts <- forM alts $ \(v1,v2) -> do
-                                return (lin,[s | VStr s <- vs])
+                                lin <- str2lin v1
+                                ss  <- to_strs v2
+                                return (lin,ss)
                               return [SymKP def alts]
+  where
+    to_strs (VStrs vs)    = mapM to_str vs
+    to_strs (VPatt _ _ p) = from_patt p
+    to_strs v             = fail
+
+    to_str (VStr s) = return s
+    to_str _        = fail
+
+    from_patt (PAlt p1 p2) = liftM2 (++) (from_patt p1) (from_patt p2)
+    from_patt (PSeq _ _ p1 _ _ p2) = liftM2 (liftM2 (++)) (from_patt p1) (from_patt p2)
+    from_patt (PString s)  = return [s]
+    from_patt (PChars cs)  = return (map (:[]) cs)
+    from_patt _            = fail
+
+    fail = evalError ("Complex patterns are not supported in:" $$ nest 2 (pp (showValue v0)))
 str2lin v                = do t <- value2term False [] v
                               evalError ("the string:" <+> ppTerm Unqualified 0 t $$
                                          "cannot be evaluated at compile time.")

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

@@ -466,7 +466,7 @@ type Equation = ([Patt],Term)
 
 type Labelling = (Label, Type) 
 type Assign = (Label, (Maybe Type, Term)) 
-type Option = (Term, Term)
+type Option = (Maybe Term, Term)
 type Case = (Patt, Term) 
 --type Cases = ([Patt], Term) 
 type LocalDef = (Ident, (Maybe Type, Term))

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

@@ -404,6 +404,7 @@ composOp co trm =
    RecType r        -> liftM RecType (mapPairsM co r)
    P t i            -> liftM2 P (co t) (return i)
    ExtR a c         -> liftM2 ExtR (co a) (co c)
+   Opts t os        -> liftM2 Opts (co t) (mapM (\(t1,t2) -> liftM2 (,) (maybe (return Nothing) (liftM Just . co) t1) (co t2)) os)
    T i cc           -> liftM2 (flip T) (mapPairsM co cc) (changeTableType co i)
    V ty vs          -> liftM2 V (co ty) (mapM co vs)
    Let (x,(mt,a)) b -> liftM3 let' (co a) (T.mapM co mt) (co b)
@@ -450,7 +451,7 @@ collectOp co trm = case trm of
   S c a        -> co c <> co a
   Table a c    -> co a <> co c
   ExtR a c     -> co a <> co c
-  Opts t os    -> co t <> mconcatMap (\(a,b) -> co a <> co b) os
+  Opts t os    -> co t <> mconcatMap (\(a,b) -> maybe mempty co a <> co b) os
   R r          -> mconcatMap (\ (_,(mt,a)) -> maybe mempty co mt <> co a) r
   RecType r    -> mconcatMap (co . snd) r
   P t i        -> co t

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

@@ -275,10 +275,10 @@ ParamDef
 
 OperDef :: { [(Ident,Info)] }
 OperDef
-  : Posn LhsNames ':' Exp ';'        Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $6 $4)) Nothing  ] }
+  : Posn LhsNames ':' Exp ';'         Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $6 $4)) Nothing  ] }
-  | Posn LhsNames '=' Markup         Posn { [(i, info) | i <- $2,   info <- mkOverload Nothing   (Just (mkL $1 $5 $4))] }
+  | Posn LhsNames '=' Exp ';'         Posn { [(i, info) | i <- $2,   info <- mkOverload Nothing   (Just (mkL $1 $6 $4))] }
-  | Posn LhsName ListArg '=' Markup  Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing   (Just (mkL $1 $6 (mkAbs $3 $5)))] }
+  | Posn LhsName ListArg '=' Exp ';'  Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing   (Just (mkL $1 $7 (mkAbs $3 $5)))] }
-  | Posn LhsNames ':' Exp '=' Markup Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 $6))] }
+  | Posn LhsNames ':' Exp '=' Exp ';' Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $8 $4)) (Just (mkL $1 $8 $6))] }
 
 LinDef :: { [(Ident,Info)] }
 LinDef
@@ -452,7 +452,11 @@ Exp4 :: { Term }
 Exp4
   : Exp4 Exp5                        { App $1 $2 }
   | Exp4 '{' Exp '}'                 { App $1 (ImplArg $3) } 
-  | 'option' Exp 'of' '{' ListOpt '}' { Opts $2 $5 }
+  | 'option' Exp 'of' '{' ListExp '}' { let toOption t =
+                                              case t of
+                                                Table x y -> (Just x,  y)
+                                                y         -> (Nothing, y)
+                                        in Opts $2 (map toOption $5) }
   | 'case' Exp 'of' '{' ListCase '}' { let annot = case $2 of
                                              Typed _ t -> TTyped t
                                              _         -> TRaw
@@ -487,8 +491,7 @@ Exp6
   | '{' ListLocDef '}'    {% mkR $2 }
   | '<' ListTupleComp '>' { R (tuple2record $2) }
   | '<' Exp ':' Exp '>'   { Typed $2 $4      }
-  | '[' Control '|' Tag ']'      { Reset (fst $2) (snd $2) $4 Nothing }
+  | '[' Control '|' ListMarkup ']'      { Reset (fst $2) (snd $2) (mkMarkup $4) Nothing }
-  | '[' Control '|' Exp ']'      { Reset (fst $2) (snd $2) $4 Nothing }
   | '(' Exp ')'           { $2 }
 
 ListExp :: { [Term] }
@@ -609,15 +612,6 @@ ListPattTupleComp
   | Patt                       { [$1]    }
   | Patt ',' ListPattTupleComp { $1 : $3 }
 
-Opt :: { Option }
-Opt
-  : '(' Exp ')' '=>' Exp { ($2,$5) }
-
-ListOpt :: { [Option] }
-ListOpt
-  : Opt             { [$1]    }
-  | Opt ';' ListOpt { $1 : $3 }
-
 Case :: { Case }
 Case
   : Patt '=>' Exp { ($1,$3) } 
@@ -720,14 +714,21 @@ ERHS3 :: { ERHS }
   | '(' ERHS0 ')'         { $2         }
 
 NLG :: { Map.Map Ident Info }
-  : ListNLGDef     { Map.fromList $1 }
+  : ListNLGDef             { Map.fromList $1 }
-  | Posn Tag Posn  { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
+  | Posn Exp         Posn  { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
-  | Posn Exp Posn  { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) }
+  | Posn ListMarkup2 Posn  { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 (mkMarkup $2)))) }
 
 ListNLGDef :: { [(Ident,Info)] }
 ListNLGDef
-  : {- empty -}               { []       }
+  : 'oper' NLGDef            { []       }
-  | 'oper' OperDef ListNLGDef { $2 ++ $3 }
+  | 'oper' NLGDef ListNLGDef { $2 ++ $3 }
+
+NLGDef :: { [(Ident,Info)] }
+NLGDef
+  : Posn LhsNames ':' Exp ';'             Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $6 $4)) Nothing  ] }
+  | Posn LhsNames '=' ListMarkup2         Posn { [(i, info) | i <- $2,   info <- mkOverload Nothing   (Just (mkL $1 $5 (mkMarkup $4)))] }
+  | Posn LhsName ListArg '=' ListMarkup2  Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing   (Just (mkL $1 $6 (mkAbs $3 (mkMarkup $5))))] }
+  | Posn LhsNames ':' Exp '=' ListMarkup2 Posn { [(i, info) | i <- $2,   info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 (mkMarkup $6)))] }
 
 Markup :: { Term }
 Markup
@@ -746,6 +747,10 @@ ListMarkup :: { [Term] }
   | Exp                { [$1]    }
   | Markup ListMarkup  { $1 : $2 }
 
+ListMarkup2 :: { [Term] }
+  : Markup              { [$1]    }
+  | Markup ListMarkup2  { $1 : $2 }
+
 Control :: { (Ident,Maybe Term) }
   : Ident            { ($1, Nothing) }
   | Ident ':' Exp6   { ($1, Just $3) }
@@ -884,4 +889,7 @@ mkAlts cs = case cs of
 mkL :: Posn -> Posn -> x -> L x
 mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
 
+mkMarkup [t] = t
+mkMarkup ts  = Markup identW [] ts
+
 }

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

@@ -63,9 +63,15 @@ cError = identS "error"
 
 -- * Used in the delimited continuations
 cConcat = identS "concat"
+cConcat' = identS "concat'"
 cOne = identS "one"
+cSelect = identS "select"
 cDefault = identS "default"
 cList = identS "list"
+cLen = identS "len"
+
+cp1 = identS "p1"
+cp2 = identS "p2"
 
 -- * Hacks: dummy identifiers used in various places.
 -- Not very nice!

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

@@ -218,6 +218,9 @@ ppTerm q d (S x y)     = case x of
                                            '}'
                            _          -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
 ppTerm q d (ExtR x y)  = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
+ppTerm q d (Opts t opts) = "option" <+> ppTerm q 0 t <+>"of" <+> '{' $$
+                              nest 2 (vcat (punctuate ';' (map (ppOpt q) opts))) $$
+                           '}'
 ppTerm q d (App x y)   = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
 ppTerm q d (V e es)    = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
 ppTerm q d (FV es)     = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
@@ -269,6 +272,9 @@ 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
 
+ppOpt q (Just p, e) = ppTerm q 0 p <+> "=>" <+> ppTerm q 0 e
+ppOpt q (Nothing,e) = ppTerm q 0 e
+
 ppControl q (id,Nothing) = pp id
 ppControl q (id,Just t ) = pp id <> ':' <+> ppTerm q 6 t