more low-handing fruits in the partial evaluator

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

@@ -36,7 +36,9 @@ normalForm gr loc t =
 eval env (Vr x)         vs  = case lookup x env of
                                 Just tnk -> force tnk vs
                                 Nothing  -> error "Unknown variable"
-eval env (Con f)        vs  = return (VApp f vs)
+eval env (Sort s)       vs  = return (VSort s)
+eval env (EInt n)       vs  = return (VInt n)
+eval env (EFloat d)     vs  = return (VFlt d)
 eval env (K t)          vs  = return (VStr t)
 eval env Empty          vs  = return (VC [])
 eval env (App t1 t2)    vs  = do tnk <- newThunk env t2
@@ -45,6 +47,7 @@ eval env (Abs b x t)    []  = return (VClosure env (Abs b x t))
 eval env (Abs b x t) (v:vs) = eval ((x,v):env) t vs
 eval env (Meta i)       vs  = do tnk <- newMeta i
                                  return (VMeta tnk env vs)
+eval env (ImplArg t)    vs  = eval env t vs
 eval env (Typed t ty)   vs  = eval env t vs
 eval env (R as)         vs  = do as <- mapM (\(lbl,(_,t)) -> fmap ((,) lbl) (newThunk env t)) as
                                  return (VR as)
@@ -58,6 +61,7 @@ eval env (Let (x,(_,t1)) t2) vs = do tnk <- newThunk env t1
                                      eval ((x,tnk):env) t2 vs
 eval env (Q q)               vs = do t <- lookupGlobal q
                                      eval env t vs
+eval env (QC q)         vs  = return (VApp q vs)
 eval env (C t1 t2)      vs  = do v1 <- eval env t1 vs
                                  v2 <- eval env t2 vs
                                  case (v1,v2) of
@@ -75,8 +79,8 @@ apply (VGen i  vs0)                 vs  = return (VGen i (vs0++vs))
 apply (VClosure env (Abs b x t)) (v:vs) = eval ((x,v):env) t vs
 
 
-value2term i (VApp f tnks) =
-  foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (Con f) tnks
+value2term i (VApp q tnks) =
+  foldM (\e1 tnk -> fmap (App e1) (force tnk [] >>= value2term i)) (QC q) tnks
 value2term i (VMeta m env tnks) = do
   res <- zonk m tnks
   case res of
@@ -95,7 +99,10 @@ value2term i (VR as) = do
 value2term i (VP v lbl) = do
   t <- value2term i v
   return (P t lbl)
+value2term i (VSort s) = return (Sort s)
 value2term i (VStr tok) = return (K tok)
+value2term i (VInt n) = return (EInt n)
+value2term i (VFlt n) = return (EFloat n)
 value2term i (VC vs) = do
   ts <- mapM (value2term i) vs
   case ts of
@@ -120,6 +127,7 @@ instance Monad (EvalM s) where
   (EvalM f) >>= g = EvalM (\gr k -> f gr (\x -> case g x of
                                                   EvalM g -> g gr k))
 
+
 instance Alternative (EvalM s) where
   empty = EvalM (\gr k _ -> return)
   (EvalM f) <|> (EvalM g) = EvalM (\gr k mt r -> f gr k mt r >>= \r -> g gr k mt r)

src/compiler/GF/Compile/Compute/Value.hs

@@ -6,7 +6,7 @@ import Control.Monad
 import Control.Monad.ST
 import Control.Applicative
 
-import GF.Grammar.Grammar(MetaId,Term,Label)
+import GF.Grammar.Grammar(MetaId,Term,Label,QIdent)
 import PGF2(BindType)
 import GF.Infra.Ident(Ident)
 
@@ -19,11 +19,14 @@ type Thunk s = STRef s (ThunkState s)
 type Env s = [(Ident,Thunk s)]
 
 data Value s
-  = VApp Ident [Thunk s]
+  = VApp QIdent [Thunk s]
   | VMeta (Thunk s) (Env s) [Thunk s]
   | VGen  {-# UNPACK #-} !Int [Thunk s]
   | VClosure (Env s) Term
   | VR [(Label, Thunk s)]
   | VP (Value s) Label
+  | VSort Ident
+  | VInt Integer
+  | VFlt Double
   | VStr String
   | VC [Value s]