From 26be741dead81fe0cb4e92d993199cc178fdd65a Mon Sep 17 00:00:00 2001 From: krangelov Date: Tue, 5 Oct 2021 11:31:39 +0200 Subject: [PATCH] most primitives in Predef.gf are now implemented --- gf.cabal | 1 - src/compiler/GF/Compile/Compute/Concrete.hs | 76 +++++++- src/compiler/GF/Compile/Compute/Predef.hs | 180 ------------------ src/compiler/GF/Compile/GrammarToCanonical.hs | 1 - .../GF/Compile/TypeCheck/ConcreteNew.hs | 1 - src/compiler/GF/Grammar/Predef.hs | 1 - testsuite/compiler/compute/predef.gfs | 33 ++++ testsuite/compiler/compute/predef.gfs.gold | 28 +++ 8 files changed, 130 insertions(+), 191 deletions(-) delete mode 100644 src/compiler/GF/Compile/Compute/Predef.hs create mode 100644 testsuite/compiler/compute/predef.gfs create mode 100644 testsuite/compiler/compute/predef.gfs.gold diff --git a/gf.cabal b/gf.cabal index 3b52e0212..d768786ce 100644 --- a/gf.cabal +++ b/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 diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs index fa84fd0b2..b1ced50b7 100644 --- a/src/compiler/GF/Compile/Compute/Concrete.hs +++ b/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 diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs deleted file mode 100644 index 2896ec5a6..000000000 --- a/src/compiler/GF/Compile/Compute/Predef.hs +++ /dev/null @@ -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 --} --} diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 1ed628136..aedbf22d1 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/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) diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs index 26808a2a8..b2e27a978 100644 --- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/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(..)) diff --git a/src/compiler/GF/Grammar/Predef.hs b/src/compiler/GF/Grammar/Predef.hs index 95bdb1101..e330f583c 100644 --- a/src/compiler/GF/Grammar/Predef.hs +++ b/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! diff --git a/testsuite/compiler/compute/predef.gfs b/testsuite/compiler/compute/predef.gfs new file mode 100644 index 000000000..cd1b9c6c6 --- /dev/null +++ b/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" diff --git a/testsuite/compiler/compute/predef.gfs.gold b/testsuite/compiler/compute/predef.gfs.gold new file mode 100644 index 000000000..3affe57ce --- /dev/null +++ b/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