Type annotations for option labels + new bubble impl

Author: phantamanta44

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

@@ -23,6 +23,7 @@ import GF.Compile.Compute.Concrete2
   , ChoiceMap
   , Globals(Gl)
   , OptionInfo(..)
+  , bubble
   , stdPredef
   , unit
   , eval
@@ -57,7 +58,6 @@ import GF.Infra.Ident (moduleNameS)
 import GF.Infra.Option (noOptions)
 import GF.Infra.UseIO (justModuleName)
 import GF.Text.Pretty (render)
-import Debug.Trace
 
 data ReplOpts = ReplOpts
   { lang :: Lang
@@ -282,11 +282,11 @@ runRepl' opts@ReplOpts { lang, evalToFlat } gl@(Gl g _) = do
         outputStrLn $ show i ++ (if null opts then ". " else "*. ") ++ render (ppTerm Unqualified 0 r)
 
     outputOptions ois os =
-      forM_ ois $ \(OptionInfo c n ls) -> do
+      forM_ ois $ \(OptionInfo c _ n ls) -> do
         outputStrLn ""
         outputStrLn $ show (unchoice c) ++ ") " ++ render (ppValue Unqualified 0 n)
         let sel = fromMaybe 0 (Map.lookup c os) + 1
-        forM_ (zip [1..] ls) $ \(i, l) ->
+        forM_ (zip [1..] ls) $ \(i, (_,l)) ->
           outputStrLn $ (if i == sel then "->" else "  ") ++ show i ++ ". " ++ render (ppValue Unqualified 0 l)
 
 runRepl :: ReplOpts -> IO ()

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

@@ -385,12 +385,17 @@ tcRho scope c (Reset ctl t) mb_ty =
                           case ty of
                             VApp c id [] -> return (Reset (Coordination mb_mn conj (snd id)) t, ty)
                             _            -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty)
-tcRho scope s (Opts n cs) mb_ty = do
+tcRho scope s (Opts (nty,n) cs) mb_ty = do
+  gl <- globals
   let (s1,s2,s3) = split3 s
-  (n,_) <- tcRho scope s1 n Nothing
-  (ls,_) <- tcUnifying scope s2 (fst <$> cs) Nothing
+  (n,nty) <- tcRho scope s1 n (nty <&> \ty -> eval gl [] poison ty [])
+  nty <- value2termM True [] nty
+  ls <- forCM s2 cs $ \s' ((lty,l),_) -> do
+    (l,lty) <- tcRho scope s' l (lty <&> \ty -> eval gl [] poison ty [])
+    lty <- value2termM True [] lty
+    return (Just lty, l)
   (ts,ty) <- tcUnifying scope s3 (snd <$> cs) mb_ty
-  return (Opts n (zip ls ts), ty)
+  return (Opts (Just nty, n) (zip ls ts), ty)
 tcRho scope s t _ = unimplemented ("tcRho "++show t)
 
 evalCodomain :: Scope -> Ident -> Value -> EvalM Value
@@ -1110,9 +1115,9 @@ quantify scope t tvs ty = do
     check m n xs (VFV c (VarFree vs)) = do
       (xs,vs) <- mapAccumM (check m n) xs vs
       return (xs,VFV c (VarFree vs))
-    check m n xs (VFV c (VarOpts name os)) = do
-      (xs,os) <- mapAccumM (\acc (l,v) -> second (l,) <$> check m n acc v) xs os
-      return (xs,VFV c (VarOpts name os))
+    check m n xs (VFV c (VarOpts nty name os)) = do
+      (xs,os) <- mapAccumM (\acc (lty,l,v) -> second (lty,l,) <$> check m n acc v) xs os
+      return (xs,VFV c (VarOpts nty name os))
     check m n xs (VAlts v vs)      = do
       (xs,v)  <- check m n xs v
       (xs,vs) <- mapAccumM (\xs (v1,v2) -> do (xs,v1) <- check m n xs v1

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

@@ -11,13 +11,13 @@
 -- Basic functions not in the standard libraries
 -----------------------------------------------------------------------------
 
-
+{-# LANGUAGE TupleSections #-}
 module GF.Data.Utilities(module GF.Data.Utilities) where
 
 import Data.Bifunctor (first)
 import Data.Maybe
 import Data.List
-import Control.Monad (MonadPlus(..),foldM,liftM,when)
+import Control.Monad (MonadPlus(..),foldM,liftM,liftM2,when)
 import Control.Applicative(liftA2)
 import qualified Data.Set as Set
 
@@ -128,7 +128,7 @@ compareBy f = both f compare
 both :: (a -> b) -> (b -> b -> c) -> a -> a -> c
 both f g x y = g (f x) (f y)
 
--- * functions on pairs
+-- * functions on tuples
 
 apFst :: (a -> a') -> (a, b) -> (a', b)
 apFst f (a, b) = (f a, b)
@@ -174,6 +174,18 @@ allM p = foldM (\b x -> if b then p x else return False) True
 anyM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m Bool
 anyM p = foldM (\b x -> if b then return True else p x) False
 
+-- | Lifts a monadic action to pairs in the first element.
+firstM :: Monad m => (a -> m a') -> (a, b) -> m (a', b)
+firstM f (a, b) = (,b) <$> f a
+
+-- | Lifts a monadic action to pairs in the second element.
+secondM :: Monad m => (b -> m b') -> (a, b) -> m (a, b')
+secondM f (a, b) = (a,) <$> f b
+
+-- | Lifts a pair of monadic actions to an action on pairs, sequencing left-to-right.
+bimapM :: Monad m => (a -> m a') -> (b -> m b') -> (a, b) -> m (a', b')
+bimapM f g (a, b) = liftM2 (,) (f a) (g b)
+
 -- * functions on Maybes
 
 -- | Returns the argument on the right, or a default value on the left.

src/compiler/api/GF/Data/Utilities.hs

@@ -344,9 +344,10 @@ data Info =
  | AnyInd Bool ModuleName                        -- ^ (/INDIR/) the 'Bool' says if canonical
   deriving Show
 
-type Type = Term
-type Cat  = QIdent
-type Fun  = QIdent
+type Type    = Term
+type MTyTerm = (Maybe Term, Term)
+type Cat     = QIdent
+type Fun     = QIdent
 
 type QIdent = (ModuleName,Ident)
 
@@ -374,7 +375,7 @@ data Term =
  | P Term Label                  -- ^ projection:  @r.p@
  | ExtR Term Term                -- ^ extension:   @R ** {x : A}@ (both types and terms)
 
- | Opts Term [Option]            -- ^ options:     @options s in { e => x ; ... }@
+ | Opts MTyTerm [Option]         -- ^ options:     @options s in { e => x ; ... }@
 
  | Table Term Term               -- ^ table type:  @P => A@
  | T TInfo [Case]                -- ^ table:       @table {p => c ; ...}@
@@ -474,7 +475,7 @@ type Equation = ([Patt],Term)
 
 type Labelling = (Label, Type) 
 type Assign = (Label, (Maybe Type, Term)) 
-type Option = (Term, Term)
+type Option = (MTyTerm, Term)
 type Case = (Patt, Term) 
 --type Cases = ([Patt], Term) 
 type LocalDef = (Ident, (Maybe Type, Term))

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

@@ -453,7 +453,7 @@ Exp4 :: { Term }
 Exp4
   : Exp4 Exp5                        { App $1 $2 }
   | Exp4 '{' Exp '}'                 { App $1 (ImplArg $3) } 
-  | 'option' Exp 'of' '{' ListOpt '}' { Opts $2 $5 }
+  | 'option' Exp 'of' '{' ListOpt '}' { Opts (Nothing, $2) $5 }
   | 'case' Exp 'of' '{' ListCase '}' { let annot = case $2 of
                                              Typed _ t -> TTyped t
                                              _         -> TRaw
@@ -612,7 +612,7 @@ ListPattTupleComp
 
 Opt :: { Option }
 Opt
-  : '(' Exp ')' '=>' Exp { ($2,$5) }
+  : '(' Exp ')' '=>' Exp { ((Nothing,$2),$5) }
 
 ListOpt :: { [Option] }
 ListOpt

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

@@ -219,6 +219,8 @@ ppTerm q d (S x y)     = case x of
 ppTerm q d (ExtR x y)  = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
 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 (Opts (_,n) cs) = prec d 4 ("option" <+> ppTerm q 0 n <+> "of" <+> braces (fsep (punctuate ';'
+                                        (map (\((_,l),t) -> parens (ppTerm q 0 l) <+> "=>" <+> ppTerm q 0 t) cs))))
 ppTerm q d (FV es)     = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
 ppTerm q d (AdHocOverload es)     = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
 ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))