More work on the new partial evaluator

The work done by the partial evaluator is now divied in two stages:
 - A static "term traversal" stage that happens only once per term and uses
   only statically known information. In particular, the values of lambda bound
   variables are unknown during this stage. Some tables are transformed to
   reduce the cost of pattern matching.
 - A dynamic "function application" stage, where function bodies can be
   evaluated repeatedly with different arguments, without the term traversal
   overhead and without recomputing statically known information.

Also the treatment of predefined functions has been reworked to take advantage
of the staging and better handle partial applications.

src/compiler/GF/Compile/CheckGrammar.hs

@@ -218,7 +218,7 @@ checkInfo opts sgr (m,mo) c info = do
          (Just (L loct ty), Just (L locd de)) -> do
            ty'     <- chIn loct "operation" $
                          (if False --flag optNewComp opts
-                            then CN.checkLType gr ty typeType >>= return . CN.normalForm (CN.resourceValues gr) . fst -- !!
+                            then CN.checkLType gr ty typeType >>= return . CN.normalForm (CN.resourceValues gr) (L loct c) . fst -- !!
                             else checkLType gr [] ty typeType >>= computeLType gr [] . fst)
            (de',_) <- chIn locd "operation" $
                          (if False -- flag optNewComp opts

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

@@ -1,9 +1,8 @@
 -- | Functions for computing the values of terms in the concrete syntax, in
 -- | preparation for PMCFG generation.
 module GF.Compile.Compute.ConcreteNew
-           ( normalForm
+           (GlobalEnv, resourceValues, normalForm
-           , GlobalEnv, resourceValues
+           --, Value(..), Env, value2term, eval, apply
-           , Value(..), Env, eval, apply, value2term
            ) where
 
 import GF.Grammar hiding (Env, VGen, VApp, VRecType)
@@ -11,27 +10,30 @@ import GF.Grammar.Lookup(lookupResDef,allParamValues)
 import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr)
 import GF.Grammar.PatternMatch(matchPattern)
 import GF.Grammar.Lockfield(unlockRecord,lockLabel,isLockLabel,lockRecType)
-import GF.Compile.Compute.Value
+import GF.Compile.Compute.Value hiding (Predefined(..))
-import GF.Compile.Compute.Predef(predefs)
+import GF.Compile.Compute.Predef(predef,predefName,delta)
 import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok)
-import GF.Data.Operations(Err,err,maybeErr,combinations)
+import GF.Data.Operations(Err,err,maybeErr,combinations,mapPairsM)
-import GF.Data.Utilities(mapSnd,mapBoth,apBoth,apSnd)
+import GF.Data.Utilities(mapFst,mapSnd,mapBoth,apBoth,apSnd)
-import Control.Monad(liftM,liftM2,mplus)
+import Control.Monad(ap,liftM,liftM2,mplus)
-import Data.List (findIndex,intersect,isInfixOf,nub)
+import Data.List (findIndex,intersect,isInfixOf,nub,elemIndex)
 import Data.Char (isUpper,toUpper,toLower)
 import Text.PrettyPrint
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.Map as Map
-import Debug.Trace(trace)
+--import Debug.Trace(trace)
 
 -- * Main entry points
 
-normalForm :: GlobalEnv -> Term -> Term
+normalForm :: GlobalEnv -> L Ident -> Term -> Term
-normalForm = nfx . toplevel
+normalForm (GE gr rv _) loc = err bugloc id . nfx (GE gr rv loc)
-nfx env = value2term (srcgr env) [] . value env
+  where
+    bugloc s = ppbug $ hang (text "In"<+>ppL loc<>text ":") 4 (text s)
 
-eval :: GlobalEnv -> Term -> Value
+nfx env@(GE gr _ loc) t = value2term loc gr [] # eval env t
-eval = value . toplevel
+
+eval :: GlobalEnv -> Term -> Err Value
+eval ge t = ($[]) # value (toplevel ge) t
 
 apply env = apply' env
 
@@ -41,21 +43,36 @@ apply env = apply' env
 
 type ResourceValues = Map.Map Ident (Map.Map Ident (Err Value))
 
-data GlobalEnv = GE SourceGrammar ResourceValues
+data GlobalEnv = GE SourceGrammar ResourceValues (L Ident)
-data CompleteEnv = CE {srcgr::SourceGrammar,rvs::ResourceValues,local::Env}
+data CompleteEnv = CE {srcgr::SourceGrammar,rvs::ResourceValues,
+                       gloc::L Ident,local::LocalScope}
+type LocalScope = [Ident]
+type Stack = [Value]
+type OpenValue = Stack->Value
                             
 ext b env = env{local=b:local env}
 extend bs env = env{local=bs++local env}
-global env = GE (srcgr env) (rvs env)
+global env = GE (srcgr env) (rvs env) (gloc env)
-toplevel (GE gr rvs) = CE gr rvs []
+toplevel (GE gr rvs loc) = CE gr rvs loc []
 
-var env x = maybe unbound id (lookup x (local env))
+var :: CompleteEnv -> Ident -> Err OpenValue
-  where unbound = bug ("Unknown variable: "++showIdent x)
+var env x = maybe unbound pick' (elemIndex x (local env))
+  where
+    unbound = fail ("Unknown variable: "++showIdent x)
+    pick' i = return $ \ vs -> maybe (err i vs) id (pick i vs)
+    err i vs = bug $ "Stack problem: "++showIdent x++": "
+                    ++unwords (map showIdent (local env))
+                    ++" => "++show (i,length vs)
+
+pick :: Int -> Stack -> Maybe Value
+pick 0 (v:_) = Just v
+pick i (_:vs) = pick (i-1) vs
+pick i vs = Nothing -- bug $ "pick "++show (i,vs)
 
 resource env (m,c) =
-     err bug id $
+--  err bug id $
     if isPredefCat c
-    then fmap (value0 env) (lockRecType c defLinType) -- hmm
+    then value0 env =<< lockRecType c defLinType -- hmm
     else maybe e id $ Map.lookup c =<< Map.lookup m (rvs env)
   where e = fail $ "Not found: "++showIdent m++"."++showIdent c
 
@@ -63,64 +80,90 @@ resource env (m,c) =
 resourceValues :: SourceGrammar -> GlobalEnv
 resourceValues gr = env
   where
-    env = GE gr rvs
+    env = GE gr rvs (L NoLoc IW)
     rvs = Map.mapWithKey moduleResources (moduleMap gr)
     moduleResources m = Map.mapWithKey (moduleResource m) . jments
-    moduleResource m c _info = fmap (eval env) (lookupResDef gr (m,c))
+    moduleResource m c _info = eval (GE gr rvs (L NoLoc c)) =<< lookupResDef gr (m,c)
 
 -- * Computing values
 
 -- | Computing the value of a top-level term
+value0 :: CompleteEnv -> Term -> Err Value
 value0 = eval . global
 
 -- | Computing the value of a term
-value :: CompleteEnv -> Term -> Value
+value :: CompleteEnv -> Term -> Err OpenValue
 value env t0 =
+  -- Each terms is traversed only once by this function, using only statically
+  -- available information. Notably, the values of lambda bound variables 
+  -- will be unknown during the term traversal phase.
+  -- The result is an OpenValue, which is a function that may be applied many
+  -- times to different dynamic values, but without the term traversal overhead
+  -- and without recomputing other statically known information.
+  -- For this to work, there should be no recursive calls under lambdas here.
+  -- Whenever we need to construct the OpenValue function with an explicit
+  -- lambda, we have to lift the recursive calls outside the lambda.
+  -- (See e.g. the rules for Let, Prod and Abs)
+{-
+  trace (render $ text "value"<+>sep [ppL (gloc env)<>text ":",
+                                      brackets (fsep (map ppIdent (local env))),
+                                      ppTerm Unqualified 10 t0]) $
+-}
   case t0 of
     Vr x   -> var env x
     Q x@(m,f)
       | m == cPredef -> if f==cErrorType                -- to be removed
                         then let p = identC (BS.pack "P")   
-                             in value0 env (mkProd [(Implicit,p,typeType)] (Vr p) [])
+                             in const # value0 env (mkProd [(Implicit,p,typeType)] (Vr p) [])
-                        else VApp x []
+                        else const . flip VApp [] # predef f
-      | otherwise    -> resource env x --valueResDef (fst env) x
+      | otherwise    -> const # resource env x --valueResDef (fst env) x
-    QC x   -> VCApp x []
+    QC x   -> return $ const (VCApp x [])
-    App e1 e2 -> apply' env e1 [value env e2]
+    App e1 e2 -> apply' env e1 . (:[]) =<< value env e2
-    Let (x,(oty,t)) body -> value (ext (x,value env t) env) body
+    Let (x,(oty,t)) body -> do vb <- value (ext x env) body
-    Meta i -> VMeta i (local env) []
+                               vt <- value env t
-    Prod bt x t1 t2 -> VProd bt (value env t1) x (Bind $ \ vx -> value (ext (x,vx) env) t2)
+                               return $ \ vs -> vb (vt vs:vs)
-    Abs bt x t -> VAbs bt x (Bind $ \ vx -> value (ext (x,vx) env) t)
+    Meta i -> return $ \ vs -> VMeta i (zip (local env) vs) []
-    EInt n -> VInt n
+    Prod bt x t1 t2 ->
-    EFloat f -> VFloat f
+       do vt1 <- value env t1
-    K s -> VString s
+          vt2 <- value (ext x env) t2
-    Empty -> VString ""
+          return $ \ vs -> VProd bt (vt1 vs) x $ Bind $ \ vx -> vt2 (vx:vs)
-    Sort s | s == cTok -> VSort cStr                        -- to be removed 
+    Abs bt x t -> do vt <- value (ext x env) t
-           | otherwise -> VSort s
+                     return $ VAbs bt x . Bind . \ vs vx -> vt (vx:vs)
-    ImplArg t -> VImplArg (value env t)
+    EInt n -> return $ const (VInt n)
-    Table p res -> VTblType (value env p) (value env res)
+    EFloat f -> return $ const (VFloat f)
-    RecType rs -> VRecType [(l,value env ty) | (l,ty) <- rs]
+    K s -> return $ const (VString s)
-    t@(ExtR t1 t2) -> extR t (both (value env) (t1,t2))
+    Empty -> return $ const (VString "")
-    FV ts   -> vfv (map (value env) ts)
+    Sort s | s == cTok -> return $ const (VSort cStr)        -- to be removed 
-    R as    -> VRec [(lbl,value env t)|(lbl,(oty,t))<-as]
+           | otherwise -> return $ const (VSort s)
+    ImplArg t -> (VImplArg.) # value env t
+    Table p res -> liftM2 VTblType # value env p <# value env res
+    RecType rs -> do lovs <- mapPairsM (value env) rs
+                     return $ \vs->VRecType $ mapSnd ($vs) lovs
+    t@(ExtR t1 t2) -> ((extR t.)# both id) # both (value env) (t1,t2)
+    FV ts   -> ((vfv .) # sequence) # mapM (value env) ts
+    R as    -> do lovs <- mapPairsM (value env.snd) as
+                  return $ \ vs->VRec $ mapSnd ($vs) lovs
     T i cs  -> valueTable env i cs
-    V ty ts -> VV ty (paramValues env ty) (map (value env) ts)
+    V ty ts -> do pvs <- paramValues env ty
-    C t1 t2 -> vconcat (both (value env) (t1,t2))
+                  ((VV ty pvs .) . sequence) # mapM (value env) ts
-    S t1 t2 -> select env (both (value env) (t1,t2))
+    C t1 t2 -> ((vconcat.) # both id) # both (value env) (t1,t2)
+    S t1 t2 -> ((select env.) # both id) # both (value env) (t1,t2)
     P t l   -> --maybe (bug $ "project "++show l++" from "++show v) id $
-               maybe (VP v l) id $
+               do ov <- value env t
-               proj l v where v = (value env t)
+                  return $ \ vs -> let v = ov vs
-    Alts t tts -> VAlts (value env t) (mapBoth (value env) tts)
+                                   in maybe (VP v l) id (proj l v)
-    Strs ts    -> VStrs (map (value env) ts)
+    Alts t tts -> (\v vts -> VAlts # v <# mapM (both id) vts) # value env t <# mapM (both (value env)) tts
-    Glue t1 t2 -> glue (both (value env) (t1,t2))
+    Strs ts    -> ((VStrs.) # sequence) # mapM (value env) ts
-    ELin c r -> unlockVRec c (value env r)
+    Glue t1 t2 -> ((glue.) # both id) # both (value env) (t1,t2)
-    EPatt p  -> VPatt p -- hmm
+    ELin c r -> (unlockVRec c.) # value env r
-    t -> ppbug (text "value"<+>ppTerm Unqualified 10 t $$ text (show t))
+    EPatt p  -> return $ const (VPatt p) -- hmm
+    t -> fail.render $ text "value"<+>ppTerm Unqualified 10 t $$ text (show t)
 
 --valueResDef gr = err bug (value0 gr) . lookupResDef gr
 
-paramValues env ty = let pty = nfx env ty
+paramValues env ty = do let ge = global env
-                         ats = err bug id $ allParamValues (srcgr env) pty
+                        ats <- allParamValues (srcgr env) =<< nfx ge ty
-                     in map (value0 env) ats
+                        mapM (eval ge) ats
 
 vconcat vv@(v1,v2) =
     case vv of
@@ -242,57 +285,90 @@ select env vv =
             --let vs = map (value0 env) ats
             i <- maybeErr "no match" $ findIndex (==v2) vs
             return (rs!!i)
-      (v1@(VT i cs),v2) ->
+      (v1@(VT _ _ cs),v2) ->
-                 err bug (valueMatch env) $ matchPattern cs (value2term (srcgr env) [] v2)
+                 err bug id $ valueMatch env =<< matchPattern cs (value2term (gloc env) (srcgr env) [] v2)
       (VS (VV pty pvs rs) v12,v2) -> VS (VV pty pvs [select env (v11,v2)|v11<-rs]) v12
       (v1,v2) -> ok2 VS v1 v2
 
-valueMatch env (Bind f,env') = f (mapSnd (value0 env) env')
+valueMatch :: CompleteEnv -> (Bind Env,Substitution) -> Err Value
-
+valueMatch env (Bind f,env') = f # mapPairsM (value0 env) env'
+--{-
+valueTable :: CompleteEnv -> TInfo -> [Case] -> Err OpenValue
 valueTable env i cs =
     case i of
-      TComp ty -> VV ty (paramValues env ty) (map (value env.snd) cs)
+      TComp ty -> do pvs <- paramValues env ty
-      _ -> err keep id convert
+                     ((VV ty pvs .) # sequence) # mapM (value env.snd) cs
+      _ -> do vty <- value env =<< getTableType i
+              err (keep vty) return convert
   where
-    keep _ = VT i (err bug id $ mapM valueCase cs)
+    keep vty _ = cases vty # mapM valueCase cs
+    cases vty cs vs = VT wild (vty vs) (mapSnd ($vs) cs)
+    wild =  case i of
+              TWild _ -> True
+              _ -> False
 
     valueCase (p,t) = do p' <- inlinePattMacro p
-                         return (p',Bind $ \ bs' -> value (extend bs' env) t)
+                         let pvs = pattVars p'
+                         vt <- value (extend pvs env) t
+                         return (p', \ vs -> Bind $ \ bs -> vt (push' p' bs pvs vs))
 --{-
+    convert :: Err OpenValue
     convert = do ty   <- getTableType i
-                 let pty = nfx env ty
+                 pty  <- nfx (global env) ty
                  vs   <- allParamValues (srcgr env) pty
-                 let pvs = map (value0 env) vs
+                 pvs  <- mapM (value0 env) vs
                  cs'  <- mapM valueCase cs
                  sts  <- mapM (matchPattern cs') vs 
-                 return $ VV pty pvs (map (valueMatch env) sts)
+                 return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env) (mapFst ($vs) sts)
 --}
     inlinePattMacro p =
         case p of
-          PM qc -> case resource env qc of
+          PM qc -> do r <- resource env qc
+                      case r of
                         VPatt p' -> inlinePattMacro p'
-                     r -> ppbug $ hang (text "Expected pattern macro:") 4
+                        _ -> ppbug $ hang (text "Expected pattern macro:") 4
                                           (text (show r))
           _ -> composPattOp inlinePattMacro p
+--}
 
+push' p bs xs = if length bs/=length xs
+                then bug $ "push "++show (p,bs,xs)
+                else push bs xs
+
+push :: Env -> LocalScope -> Stack -> Stack
+push bs [] vs = vs
+push bs (x:xs) vs = maybe err id (lookup x bs):push bs xs vs
+  where  err = bug $ "Unbound pattern variable "++showIdent x
+
+apply' :: CompleteEnv -> Term -> [OpenValue] -> Err OpenValue
 apply' env t [] = value env t
 apply' env t vs =
   case t of
-    QC x                   -> VCApp x vs
+    QC x                   -> return $ \ svs -> VCApp x (map ($svs) vs)
-    Q x@(m,f) | m==cPredef -> let constr = --trace ("predef "++show x) .
+{-
+    Q x@(m,f) | m==cPredef -> return $
+                              let constr = --trace ("predef "++show x) .
                                            VApp x 
-                              in maybe constr id (Map.lookup f predefs) vs
+                              in \ svs -> maybe constr id (Map.lookup f predefs)
-              | otherwise  -> vapply (resource env x) vs
+                                          $ map ($svs) vs
-    App t1 t2              -> apply' env t1 (value env t2 : vs)
+              | otherwise  -> do r <- resource env x
---  Abs b x t              -> beta env b x t vs
+                                 return $ \ svs -> vapply r (map ($svs) vs)
-    _                      -> vapply (value env t) vs
+-}
+    App t1 t2              -> apply' env t1 . (:vs) =<< value env t2
+    _                      -> do fv <- value env t
+                                 return $ \ svs -> vapply (fv svs) (map ($svs) vs)
 
+vapply :: Value -> [Value] -> Value
 vapply v [] = v
 vapply v vs =
   case v of
     VError {} -> v
 --  VClosure env (Abs b x t) -> beta gr env b x t vs
     VAbs bt _ (Bind f) -> vbeta bt f vs
+    VApp pre vs1 -> err msg id $ delta pre (vs1++vs)
+      where
+        --msg = const (VApp pre (vs1++vs))
+        msg = bug . (("Applying Predef."++showIdent (predefName pre)++": ")++)
     VS (VV t pvs fs) s -> VS (VV t pvs [vapply f vs|f<-fs]) s
     VFV fs -> vfv [vapply f vs|f<-fs]
     v -> bug $ "vapply "++show v++" "++show vs
@@ -315,10 +391,10 @@ beta env b x t (v:vs) =
 --  tr s f vs = trace (s++" "++show vs++" = "++show r) r where r = f vs
 
 -- | Convert a value back to a term
-value2term :: SourceGrammar -> [Ident] -> Value -> Term
+value2term :: L Ident -> SourceGrammar -> [Ident] -> Value -> Term
-value2term gr xs v0 =
+value2term loc gr xs v0 =
   case v0 of
-    VApp f vs      -> foldl App (Q f)                  (map v2t vs)
+    VApp pre vs    -> foldl App (Q (cPredef,predefName pre)) (map v2t vs)
     VCApp f vs     -> foldl App (QC f)                 (map v2t vs)
     VGen j vs      -> foldl App (Vr (reverse xs !! j)) (map v2t vs)
     VMeta j env vs -> foldl App (Meta j)               (map v2t vs)
@@ -336,7 +412,8 @@ value2term gr xs v0 =
     VRecType rs    -> RecType [(l,v2t v) | (l,v) <- rs]
     VRec as        -> R [(l,(Nothing,v2t v))|(l,v) <- as]
     VV t _ vs      -> V t (map v2t vs)
-    VT i cs        -> T i (map nfcase cs)
+    VT wild v cs   -> T ((if wild then TWild else TTyped) (v2t v))
+                        (map nfcase cs)
     VFV vs         -> FV (map v2t vs)
     VC v1 v2       -> C (v2t v1) (v2t v2)
     VS v1 v2       -> S (v2t v1) (v2t v2)
@@ -346,30 +423,38 @@ value2term gr xs v0 =
 --  VGlue v1 v2    -> Glue (v2t v1) (v2t v2)
     VExtR v1 v2    -> ExtR (v2t v1) (v2t v2)
     VError err     -> Error err
-    _              -> bug ("value2term "++show v0)
+    _              -> bug ("value2term "++show loc++" "++show v0)
   where
-    v2t = value2term gr xs
+    v2t = value2term loc gr xs
-    v2t' x f = value2term gr (x:xs) (f (gen xs))
+    v2t' x f = value2term loc gr (x:xs) (f (gen xs))
 
     pushs xs e = foldr push e xs
     push x (env,xs) = ((x,gen xs):env,x:xs)
     gen xs = VGen (length xs) []
 
-    nfcase (p,Bind f) = (p,value2term gr xs' (f env'))
+    nfcase (p,Bind f) = (p,value2term loc gr xs' (f env'))
       where (env',xs') = pushs (pattVars p) ([],xs)
 
 --  nf gr (env,xs) = value2term gr xs . eval gr env
 
-pattVars = nub . pv
+pattVars = nub . allPattVars
-  where
+allPattVars p =
-    pv p = case p of
+    case p of
       PV i    -> [i]
-             PAs i p -> i:pv p
+      PAs i p -> i:allPattVars p
-             _ -> collectPattOp pv p
+      _       -> collectPattOp allPattVars p
 
 ---
 
-both = apBoth
+infixl 1 #,<#,@@
+
+f # x = fmap f x
+mf <# mx  = ap mf mx
+m1 @@ m2 = (m1 =<<) . m2
+
+both f (x,y) = (,) # f x <# f y
+
+ppL (L loc x) = ppLocation "" loc<>text ":"<>ppIdent x
 
 bug msg = ppbug (text msg)
 ppbug doc = error $ render $

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

@@ -1,93 +1,142 @@
 -- | Implementations of predefined functions
-module GF.Compile.Compute.Predef where
+{-# LANGUAGE FlexibleInstances #-}
+module GF.Compile.Compute.Predef(predef,predefName,delta) where
 
 import Text.PrettyPrint(render,hang,text)
 import qualified Data.Map as Map
+import Data.Array(array,(!))
 import Data.List (isInfixOf)
 import Data.Char (isUpper,toLower,toUpper)
+import Control.Monad(ap)
 
 import GF.Data.Utilities (mapSnd,apBoth)
 
 import GF.Compile.Compute.Value
-import GF.Infra.Ident (Ident,varX)
+import GF.Infra.Ident (Ident,varX,showIdent)
+import GF.Data.Operations(Err,err)
 import GF.Grammar.Predef
 import PGF.Data(BindType(..))
 
-predefs :: Map.Map Ident ([Value]->Value)
+--------------------------------------------------------------------------------
-predefs = Map.fromList $ mapSnd strictf
+class Predef a where
-    [(cDrop,apISS drop),(cTake,apISS take),(cTk,apISS tk),(cDp,apISS dp),
+  toValue :: a -> Value
-     (cEqStr,apSSB (==)),(cOccur,apSSB occur),(cOccurs,apSSB occurs),
+  fromValue :: Value -> Err a
-     (cToUpper,apSS (map toUpper)),(cToLower,apSS (map toLower)),
+
-     (cIsUpper,apSB (all isUpper)),(cLength,apSS' (VInt . length)),
+instance Predef Int where
-     (cPlus,apIII (+)),(cEqInt,apIIB (==)),(cLessInt,apIIB (<)),
+  toValue = VInt
-     (cShow,unimpl),(cRead,unimpl),(cToStr,unimpl),(cMapStr,unimpl),
+  fromValue (VInt i) = return i
-     (cEqVal,unimpl),(cError,apSS' VError)]
+  fromValue v = verror "Int" v
-    --- add more functions!!!
+
+instance Predef Bool where
+  toValue = boolV
+
+instance Predef String where
+  toValue = string
+  fromValue v = case norm v of
+                  VString s -> return s
+                  _ -> verror "String" v
+
+instance Predef Value where
+  toValue = id
+  fromValue = return
+{-
+instance (Predef a,Predef b) => Predef (a->b) where
+  toValue f = VAbs Explicit (varX 0) $ Bind $ err bug (toValue . f) . fromValue
+-}
+verror t v =
+  case v of
+    VError e -> fail e
+    VGen {}  -> fail $ "Expected a static value of type "++t
+                       ++", got a dynamic value"
+    _ -> fail $ "Expected a value of type "++t++", got "++show v
+
+--------------------------------------------------------------------------------
+
+predef f = maybe undef return (Map.lookup f predefs)
   where
-    unimpl = bug "unimplemented predefined function"
+    undef = fail $ "Unimplemented predfined operator: Predef."++showIdent f
 
-    tk i s = take (max 0 (length s - i)) s
+predefs :: Map.Map Ident Predefined
-    dp i s = drop (max 0 (length s - i)) s
+predefs = Map.fromList predefList
-    occur s t = isInfixOf s t
-    occurs s t = any (`elem` t) s
 
-    apIII f vs = case vs of
+predefName pre = predefNames ! pre
-                   [VInt i1, VInt i2] -> VInt (f i1 i2)
+predefNames = array (minBound,maxBound) (map swap predefList)
-                   _ -> bug $ "f::Int->Int->Int got "++show vs
 
-    apIIB f vs = case vs of
+predefList =
-                   [VInt i1, VInt i2] -> boolV (f i1 i2)
+    [(cDrop,Drop),(cTake,Take),(cTk,Tk),(cDp,Dp),(cEqStr,EqStr),
-                   _ -> bug $ "f::Int->Int->Bool got "++show vs
+     (cOccur,Occur),(cOccurs,Occurs),(cToUpper,ToUpper),(cToLower,ToLower),
+     (cIsUpper,IsUpper),(cLength,Length),(cPlus,Plus),(cEqInt,EqInt),
+     (cLessInt,LessInt),
+     -- cShow, cRead, cMapStr, cEqVal
+     (cError,Error),
+     -- Canonical values:
+     (cPBool,PBool),(cPFalse,PFalse),(cPTrue,PTrue),(cInts,Ints)]
+    --- add more functions!!!
 
-    apISS f vs = case vs of
+delta f vs =
-                   [VInt i, VString s] -> string (f i s)
+    case f of
-                   [VInt i] -> VAbs Explicit (varX 0) $ Bind $ \ v ->
+      Drop    -> ap2 (drop::Int->String->String)
-                               case norm v of
+      Take    -> ap2 (take::Int->String->String)
-                                 VString s -> string (f i s)
+      Tk      -> ap2 tk
-                                 _ -> bug $ "f::Int->Str->Str got "++show (vs++[v])
+      Dp      -> ap2 dp
-                   _ -> bug $ "f::Int->Str->Str got "++show vs
+      EqStr   -> ap2 ((==)::String->String->Bool)
+      Occur   -> ap2 occur
+      Occurs  -> ap2 occurs
+      ToUpper -> ap1 (map toUpper)
+      ToLower -> ap1 (map toLower)
+      IsUpper -> ap1 (all isUpper)
+      Length  -> ap1 (length::String->Int)
+      Plus    -> ap2 ((+)::Int->Int->Int)
+      EqInt   -> ap2 ((==)::Int->Int->Bool)
+      LessInt -> ap2 ((<)::Int->Int->Bool)
+    {- | Show | Read | ToStr | MapStr | EqVal -}
+      Error   -> ap1 VError
+      -- Canonical values:
+      PBool   -> canonical
+      Ints    -> canonical
+      PFalse  -> canonical
+      PTrue   -> canonical
+  where
+    canonical = delay
+    delay = return (VApp f vs) -- wrong number of arguments
 
-    apSSB f vs = case vs of
+    ap1 f = case vs of
-                   [VString s1, VString s2] -> boolV (f s1 s2)
+              [v1] -> (toValue . f) `fmap` fromValue v1
-                   _ -> bug $ "f::Str->Str->Bool got "++show vs
+              _ -> delay
 
-    apSB  f vs = case vs of
+    ap2 f = case vs of
-                   [VString s] -> boolV (f s)
+             [v1,v2] -> toValue `fmap` (f `fmap` fromValue v1 `ap` fromValue v2)
-                   _ -> bug $ "f::Str->Bool got "++show vs
+             _ -> delay
 
-    apSS  f vs = case vs of
+    unimpl id = bug $ "unimplemented predefined function: "++showIdent id
-                   [VString s] -> string (f s)
+--  problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs
-                   _ -> bug $ "f::Str->Str got "++show vs
 
-    apSS' f vs = case vs of
+    tk i s = take (max 0 (length s - i)) s :: String
-                   [VString s] -> f s
+    dp i s = drop (max 0 (length s - i)) s :: String
-                   _ -> bug $ "f::Str->_ got "++show vs
+    occur s t = isInfixOf (s::String) t
+    occurs s t = any (`elem` t) (s::String)
 
-    boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) []
+boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) []
 
-    strictf f vs = case normvs vs of
+norm v =
-                     Left err -> VError err
-                     Right vs -> f vs
-
-    normvs = mapM (strict . norm)
-
-    norm v =
   case v of
     VC v1 v2 -> case apBoth norm (v1,v2) of
                   (VString s1,VString s2) -> VString (s1++" "++s2)
                   (v1,v2) -> VC v1 v2
     _ -> v
 
-    strict v = case v of
+strict v = case v of
              VError err -> Left err
              _ -> Right v
 
-    string s = case words s of
+string s = case words s of
              [] -> VString ""
              ss -> foldr1 VC (map VString ss)
 
 ---
 
+swap (x,y) = (y,x)
+
 bug msg = ppbug (text msg)
 ppbug doc = error $ render $
                     hang (text "Internal error in Compute.Predef:") 4 doc

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

@@ -3,10 +3,11 @@ import GF.Grammar.Grammar(Label,Type,TInfo,MetaId,Patt,QIdent)
 import PGF.Data(BindType)
 import GF.Infra.Ident(Ident)
 import Text.Show.Functions
+import Data.Ix(Ix)
 
 -- | Self-contained (not quite) representation of values
 data Value
-  = VApp QIdent [Value] -- from Q, always Predef.x, has a built-in value
+  = VApp Predefined [Value] -- from Q, always Predef.x, has a built-in value
   | VCApp QIdent [Value] -- from QC, constructors
   | VGen Int [Value] -- for lambda bound variables, possibly applied
   | VMeta MetaId Env [Value]
@@ -22,7 +23,7 @@ data Value
   | VRecType [(Label,Value)]
   | VRec [(Label,Value)]
   | VV Type [Value] [Value] -- preserve type for conversion back to Term
-  | VT TInfo [(Patt,Bind Env)]
+  | VT Wild Value [(Patt,Bind Env)]
   | VC Value Value
   | VS Value Value
   | VP Value Label
@@ -36,9 +37,19 @@ data Value
   | VError String
   deriving (Eq,Show)
 
+type Wild = Bool
 type Binding = Bind Value
 data Bind a = Bind (a->Value) deriving Show
 
 instance Eq (Bind a) where x==y = False
 
 type Env = [(Ident,Value)]
+
+-- | Predefined functions
+data Predefined = Drop | Take | Tk | Dp | EqStr | Occur | Occurs | ToUpper
+                | ToLower | IsUpper | Length | Plus | EqInt | LessInt 
+             {- | Show | Read | ToStr | MapStr | EqVal -}
+                | Error
+                -- Canonical values below:
+                | PBool | PFalse | PTrue | Ints
+                deriving (Show,Eq,Ord,Ix,Bounded,Enum)

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -66,13 +66,13 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
 
 
 addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Ident -> Ident -> SeqSet -> Ident -> Info -> IO (SeqSet, Info)
-addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L _ term)) mprn Nothing) = do
+addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L loc term)) mprn Nothing) = do
   let pres  = protoFCat gr res val
       pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
 
       pmcfgEnv0   = emptyPMCFGEnv
 
-      b          = convert opts gr cenv term val pargs
+      b          = convert opts gr cenv (L loc id) term val pargs
       (seqs1,b1) = addSequencesB seqs b
       pmcfgEnv1  = foldBM addRule
                           pmcfgEnv0
@@ -99,13 +99,13 @@ addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val))
           newArgs  = map getFIds newArgs'
       in addFunction env0 newCat fun newArgs
 
-addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L _ term)) mprn Nothing) = do
+addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L loc term)) mprn Nothing) = do
   let pres = protoFCat gr (am,id) lincat
       parg = protoFCat gr (identW,cVar) typeStr
 
       pmcfgEnv0  = emptyPMCFGEnv
 
-      b          = convert opts gr cenv term lincat [parg]
+      b          = convert opts gr cenv (L loc id) term lincat [parg]
       (seqs1,b1) = addSequencesB seqs b
       pmcfgEnv1  = foldBM addRule
                           pmcfgEnv0
@@ -122,12 +122,12 @@ addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) m
 
 addPMCFG opts gr cenv am cm seqs id info = return (seqs, info)
 
-convert opts gr cenv term val pargs =
+convert opts gr cenv loc term val pargs =
     runCnvMonad gr conv (pargs,[])
   where
-    conv = convertTerm opts CNil val =<< unfactor cenv term'
+    conv = convertTerm opts CNil val =<< unfactor term'
     term' = if flag optNewComp opts
-            then normalForm cenv (recordExpand val term) -- new evaluator
+            then normalForm cenv loc (recordExpand val term) -- new evaluator
             else term -- old evaluator is invoked from GF.Compile.Optimize
 
 recordExpand :: Type -> Term -> Term
@@ -143,8 +143,8 @@ recordExpand typ trm =
              _ -> R [assign lab (P trm lab) | (lab,_) <- tys]
      _ -> trm
 
-unfactor :: GlobalEnv -> Term -> CnvMonad Term
+unfactor :: Term -> CnvMonad Term
-unfactor cenv t = CM (\gr c -> c (unfac gr t))
+unfactor t = CM (\gr c -> c (unfac gr t))
   where
     unfac gr t = 
       case t of

src/compiler/GFI.hs

@@ -333,7 +333,7 @@ checkComputeTerm' new sgr t = do
                  ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
                                             inferLType sgr [] t
                  t1 <- if new
-                       then return (CN.normalForm (CN.resourceValues sgr) t)
+                       then return (CN.normalForm (CN.resourceValues sgr) (L NoLoc IW) t)
                        else computeConcrete sgr t
                  checkPredefError sgr t1