most primitives in Predef.gf are now implemented

gf.cabal

@@ -109,7 +109,6 @@ executable gf
     GF.Command.TreeOperations
     GF.Compile.CFGtoPGF
     GF.Compile.CheckGrammar
-    GF.Compile.Compute.Predef
     GF.Compile.Compute.Concrete
     GF.Compile.ExampleBased
     GF.Compile.Export

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

@@ -10,16 +10,17 @@ import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import GF.Grammar hiding (Env, VGen, VApp, VRecType)
 import GF.Grammar.Lookup(lookupResDef,allParamValues)
-import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr,cTrace,cPBool)
+import GF.Grammar.Predef
 import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel
 import GF.Grammar.Printer
-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,errIn,maybeErr,mapPairsM)
 import GF.Data.Utilities(mapFst,mapSnd)
 import GF.Infra.Option
 import Data.STRef
 import Data.Maybe(fromMaybe)
+import Data.List
+import Data.Char
 import Control.Monad
 import Control.Monad.ST
 import Control.Applicative
@@ -109,7 +110,13 @@ eval env t@(S t1 t2)    vs  = do v1   <- eval env t1 []
                                    v1      -> return v0
 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 (Q q@(m,id))   vs
+  | m == cPredef            = do vs' <- mapM (flip force []) vs
+                                 mb_res <- evalPredef id vs'
+                                 case mb_res of
+                                   Just res -> return res
+                                   Nothing  -> return (VApp q vs)
+  | otherwise               = do t <- lookupGlobal q
                                  eval env t vs
 eval env (QC q)         vs  = return (VApp q vs)
 eval env (C t1 t2)      []  = do v1 <- eval env t1 []
@@ -129,6 +136,58 @@ apply (VMeta m env vs0)             vs  = return (VMeta m env (vs0++vs))
 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
 
+evalPredef id [v]
+  | id == cLength = return (fmap VInt (liftM genericLength (value2string v)))
+evalPredef id [v1,v2]
+  | id == cTake   = return (fmap VStr (liftM2 genericTake (value2int v1) (value2string v2)))
+evalPredef id [v1,v2]
+  | id == cDrop   = return (fmap VStr (liftM2 genericDrop (value2int v1) (value2string v2)))
+evalPredef id [v1,v2]
+  | id == cTk     = return (fmap VStr (liftM2 genericTk (value2int v1) (value2string v2)))
+  where
+    genericTk n = reverse . genericTake n . reverse
+evalPredef id [v1,v2]
+  | id == cDp     = return (fmap VStr (liftM2 genericDp (value2int v1) (value2string v2)))
+  where
+    genericDp n = reverse . genericDrop n . reverse
+evalPredef id [v]
+  | id == cToUpper= return (fmap VStr (liftM (map toUpper) (value2string v)))
+evalPredef id [v]
+  | id == cToLower= return (fmap VStr (liftM (map toLower) (value2string v)))
+evalPredef id [v]
+  | id == cIsUpper= return (fmap toPBool (liftM (all isUpper) (value2string v)))
+evalPredef id [v1,v2]
+  | id == cEqStr  = return (fmap toPBool (liftM2 (==) (value2string v1) (value2string v2)))
+evalPredef id [v1,v2]
+  | id == cOccur  = return (fmap toPBool (liftM2 occur (value2string v1) (value2string v2)))
+evalPredef id [v1,v2]
+  | id == cOccurs  = return (fmap toPBool (liftM2 occurs (value2string v1) (value2string v2)))
+evalPredef id [v1,v2]
+  | id == cEqInt  = return (fmap toPBool (liftM2 (==) (value2int v1) (value2int v2)))
+evalPredef id [v1,v2]
+  | id == cLessInt= return (fmap toPBool (liftM2 (<) (value2int v1) (value2int v2)))
+evalPredef id [v1,v2]
+  | id == cPlus   = return (fmap VInt (liftM2 (+) (value2int v1) (value2int v2)))
+evalPredef id [v]
+  | id == cError  = case value2string v of
+                      Just msg -> fail msg
+                      Nothing  -> return Nothing
+evalPredef id vs  = return Nothing
+
+toPBool True  = VApp (cPredef,cPTrue)  []
+toPBool False = VApp (cPredef,cPFalse) []
+
+occur s1 []          = False
+occur s1 s2@(_:tail) = check s1 s2
+  where
+    check xs        []  = False
+    check []        ys  = True
+    check (x:xs) (y:ys)
+      | x == y          = check xs ys
+    check _      _      = occur s1 tail
+
+occurs cs s2 = any (\c -> elem c s2) cs
+
 patternMatch v0 []                      = fail "No matching pattern found"
 patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
   where
@@ -187,10 +246,6 @@ patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0
         Just tnk -> matchRec env pas as (p:ps) eqs (tnk:args)
         Nothing  -> evalError ("Missing value for label" <+> pp lbl)
 
-    value2string (VStr s) = Just s
-    value2string (VC vs)  = fmap unwords (mapM value2string vs)
-    value2string _        = Nothing
-
     matchStr env ps eqs i ds []     args = do
       arg1 <- newEvaluatedThunk (vc (reverse ds))
       arg2 <- newEvaluatedThunk (vc [])
@@ -263,6 +318,13 @@ value2term i (VC vs) = do
     []     -> return Empty
     (t:ts) -> return (foldl C t ts)
 
+value2string (VStr s) = Just s
+value2string (VC vs)  = fmap unwords (mapM value2string vs)
+value2string _        = Nothing
+
+value2int (VInt n) = Just n
+value2int _        = Nothing
+
 -----------------------------------------------------------------------
 -- * Evaluation monad
 

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

@@ -1,180 +0,0 @@
--- | Implementations of predefined functions
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-module GF.Compile.Compute.Predef(predef,predefName,delta) where
-
-predef = undefined
-predefName = undefined
-delta = undefined
-{-
-import qualified Data.Map as Map
-import Data.Array(array,(!))
-import Data.List (isInfixOf,genericTake,genericDrop,genericLength)
-import Data.Char (isUpper,toLower,toUpper)
-import Control.Monad(ap)
-
-import GF.Data.Utilities (apBoth) --mapSnd
-
-import GF.Infra.Ident (Ident,showIdent) --,varX
-import GF.Data.Operations(Err) -- ,err
-import GF.Grammar.Predef
-
---------------------------------------------------------------------------------
-class Predef a where
-  toValue :: a -> Value
-  fromValue :: Value -> Err a
-
-instance Predef Integer where
-  toValue = VInt
-  fromValue (VInt i) = return i
-  fromValue v = verror "Int" v
-
-instance Predef Bool where
-  toValue = boolV
-  fromValue v = case v of
-    VCApp (mn,i) [] | mn == cPredef && i == cPTrue -> return True
-    VCApp (mn,i) [] | mn == cPredef && i == cPFalse -> return False
-    _ -> verror "Bool" v
-
-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 Predefined where
-  toValue p = VApp p []
-  fromValue v = case v of
-                  VApp p _ -> return p
-                  _        -> fail $ "Expected a predefined constant, got something else"
-
-{-
-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
-    undef = fail $ "Unimplemented predfined operator: Predef."++showIdent f
-
-predefs :: Map.Map Ident Predefined
-predefs = Map.fromList predefList
-
-predefName pre = predefNames ! pre
-predefNames = array (minBound,maxBound) (map swap predefList)
-
-predefList =
-    [(cDrop,Drop),(cTake,Take),(cTk,Tk),(cDp,Dp),(cEqStr,EqStr),
-     (cOccur,Occur),(cOccurs,Occurs),(cToUpper,ToUpper),(cToLower,ToLower),
-     (cIsUpper,IsUpper),(cLength,Length),(cPlus,Plus),(cEqInt,EqInt),
-     (cLessInt,LessInt),
-     -- cShow, cRead, cMapStr, cEqVal
-     (cError,Error),(cTrace,Trace),
-     -- Canonical values:
-     (cPBool,PBool),(cPFalse,PFalse),(cPTrue,PTrue),(cInt,Int),(cFloat,Float),
-     (cInts,Ints),(cNonExist,NonExist)
-     ,(cBIND,BIND),(cSOFT_BIND,SOFT_BIND),(cSOFT_SPACE,SOFT_SPACE)
-     ,(cCAPIT,CAPIT),(cALL_CAPIT,ALL_CAPIT)]
-    --- add more functions!!!
-
-delta f vs =
-    case f of
-      Drop    -> fromNonExist vs NonExist (ap2 (genericDrop::Integer->String->String))
-      Take    -> fromNonExist vs NonExist (ap2 (genericTake::Integer->String->String))
-      Tk      -> fromNonExist vs NonExist (ap2 tk)
-      Dp      -> fromNonExist vs NonExist (ap2 dp)
-      EqStr   -> fromNonExist vs PFalse   (ap2 ((==)::String->String->Bool))
-      Occur   -> fromNonExist vs PFalse   (ap2 occur)
-      Occurs  -> fromNonExist vs PFalse   (ap2 occurs)
-      ToUpper -> fromNonExist vs NonExist (ap1 (map toUpper))
-      ToLower -> fromNonExist vs NonExist (ap1 (map toLower))
-      IsUpper -> fromNonExist vs PFalse   (ap1 (all' isUpper))
-      Length  -> fromNonExist vs (0::Integer) (ap1 (genericLength::String->Integer))
-      Plus    -> ap2 ((+)::Integer->Integer->Integer)
-      EqInt   -> ap2 ((==)::Integer->Integer->Bool)
-      LessInt -> ap2 ((<)::Integer->Integer->Bool)
-    {- -- | Show | Read | ToStr | MapStr | EqVal -}
-      Error   -> ap1 VError
-      Trace   -> ap2 vtrace
-      -- Canonical values:
-      PBool   -> canonical
-      Int     -> canonical
-      Float   -> canonical
-      Ints    -> canonical
-      PFalse  -> canonical
-      PTrue   -> canonical
-      NonExist-> canonical
-      BIND    -> canonical
-      SOFT_BIND->canonical
-      SOFT_SPACE->canonical
-      CAPIT   -> canonical
-      ALL_CAPIT->canonical
-  where
-    canonical = delay
-    delay = return (VApp f vs) -- wrong number of arguments
-
-    ap1 f = case vs of
-              [v1] -> (toValue . f) `fmap` fromValue v1
-              _ -> delay
-
-    ap2 f = case vs of
-             [v1,v2] -> toValue `fmap` (f `fmap` fromValue v1 `ap` fromValue v2)
-             _ -> delay
-
-    fromNonExist vs a b
-      | null [v | v@(VApp NonExist _) <- vs] = b
-      | otherwise                            = return (toValue a)
-
-    vtrace :: Value -> Value -> Value
-    vtrace x y = y -- tracing is implemented elsewhere
-
---  unimpl id = bug $ "unimplemented predefined function: "++showIdent id
---  problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs
-
-    tk :: Integer -> String -> String
-    tk i s = genericTake (max 0 (genericLength s - i)) s
-
-    dp :: Integer -> String -> String
-    dp i s = genericDrop (max 0 (genericLength s - i)) s
-
-    occur s t = isInfixOf (s::String) (t::String)
-    occurs s t = any (`elem` (t::String)) (s::String)
-    all' = all :: (a->Bool) -> [a] -> Bool
-
-boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) []
-
-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
-             VError err -> Left err
-             _ -> Right v
--}
-string s = case words s of
-             [] -> VString ""
-             ss -> foldr1 VC (map VString ss)
-
----
-
-swap (x,y) = (y,x)
-{-
-bug msg = ppbug msg
-ppbug doc = error $ render $
-                    hang "Internal error in Compute.Predef:" 4 doc
--}
--}

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -15,7 +15,6 @@ import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
 import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
 import GF.Grammar.Lockfield(isLockLabel)
 import GF.Grammar.Predef(cPredef,cInts)
-import GF.Compile.Compute.Predef(predef)
 -- import GF.Compile.Compute.Value(Predefined(..))
 import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
 import GF.Infra.Option(Options,optionsPGF)

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

@@ -11,7 +11,6 @@ import GF.Grammar.Lookup
 import GF.Grammar.Predef
 import GF.Grammar.Lockfield
 import GF.Compile.Compute.Concrete
-import GF.Compile.Compute.Predef(predef,predefName)
 import GF.Infra.CheckM
 import GF.Data.Operations
 import Control.Applicative(Applicative(..))

src/compiler/GF/Grammar/Predef.hs

@@ -61,7 +61,6 @@ cRead = identS "read"
 cToStr = identS "toStr"
 cMapStr = identS "mapStr"
 cError = identS "error"
-cTrace = identS "trace"
 
 -- * Hacks: dummy identifiers used in various places.
 -- Not very nice!

testsuite/compiler/compute/predef.gfs

@@ -0,0 +1,33 @@
+i -retain prelude/Predef.gfo
+cc length "abcd"
+cc length ("ab"++"cd")
+cc <\x -> length x : Str -> Int>
+cc take 2 "abcd"
+cc drop 2 "abcd"
+cc tk 1 "abcd"
+cc dp 1 "abcd"
+cc toUpper "abcd"
+cc toLower "ABCD"
+cc isUpper "abcd"
+cc isUpper "ABCD"
+cc isUpper "AbCd"
+cc case isUpper "abcd" of {PTrue => "yes"; PFalse => "no"}
+cc case isUpper "ABCD" of {PTrue => "yes"; PFalse => "no"}
+cc case isUpper "AbCd" of {PTrue => "yes"; PFalse => "no"}
+cc eqStr "ab cd" ("ab"++"cd")
+cc occur "bc" "abcd"
+cc occur "bc" "acbd"
+cc occurs "bc" "xxxxbxxx"
+cc occurs "bc" "xxxxcxxx"
+cc occurs "bc" "xxxxxxxx"
+cc eqInt (length "abcd") 4
+cc lessInt (length "abcd") 3
+cc lessInt (length "abcd") 5
+cc plus (length "abcd") 1
+cc error "user error"++"!"
+cc "x"++nonExist++"y"
+cc "x"++BIND++"y"
+cc "x"++SOFT_BIND++"y"
+cc "x"++SOFT_SPACE++"y"
+cc "x"++CAPIT++"y"
+cc "x"++ALL_CAPIT++"y"

testsuite/compiler/compute/predef.gfs.gold

@@ -0,0 +1,28 @@
+4
+5
+\v0 -> Predef.length v0
+"ab"
+"cd"
+"d"
+"abc"
+"ABCD"
+"abcd"
+Predef.PFalse
+Predef.PTrue
+Predef.PFalse
+"no"
+"yes"
+"no"
+Predef.PTrue
+Predef.PTrue
+Predef.PFalse
+Predef.PTrue
+Predef.PTrue
+Predef.PFalse
+Predef.PTrue
+Predef.PFalse
+Predef.PTrue
+5
+: In _: user error
+CallStack (from HasCallStack):
+  error, called at src/compiler/GF/Compile/Compute/Concrete.hs:36:18 in main:GF.Compile.Compute.Concrete