diff options
Diffstat (limited to 'src/compiler/GF/Compile/Compute')
| -rw-r--r-- | src/compiler/GF/Compile/Compute/ConcreteNew.hs | 287 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Compute/Predef.hs | 177 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Compute/Value.hs | 15 |
3 files changed, 312 insertions, 167 deletions
diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs index 66dc4b7c8..661c8681b 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs +++ b/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 - , Value(..), Env, eval, apply, value2term + (GlobalEnv, resourceValues, normalForm + --, Value(..), Env, value2term, eval, apply ) 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.Predef(predefs) +import GF.Compile.Compute.Value hiding (Predefined(..)) +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.Utilities(mapSnd,mapBoth,apBoth,apSnd) -import Control.Monad(liftM,liftM2,mplus) -import Data.List (findIndex,intersect,isInfixOf,nub) +import GF.Data.Operations(Err,err,maybeErr,combinations,mapPairsM) +import GF.Data.Utilities(mapFst,mapSnd,mapBoth,apBoth,apSnd) +import Control.Monad(ap,liftM,liftM2,mplus) +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 = nfx . toplevel -nfx env = value2term (srcgr env) [] . value env +normalForm :: GlobalEnv -> L Ident -> Term -> Term +normalForm (GE gr rv _) loc = err bugloc id . nfx (GE gr rv loc) + where + bugloc s = ppbug $ hang (text "In"<+>ppL loc<>text ":") 4 (text s) + +nfx env@(GE gr _ loc) t = value2term loc gr [] # eval env t -eval :: GlobalEnv -> Term -> Value -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 CompleteEnv = CE {srcgr::SourceGrammar,rvs::ResourceValues,local::Env} - +data GlobalEnv = GE SourceGrammar ResourceValues (L Ident) +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) -toplevel (GE gr rvs) = CE gr rvs [] +global env = GE (srcgr env) (rvs env) (gloc env) +toplevel (GE gr rvs loc) = CE gr rvs loc [] + +var :: CompleteEnv -> Ident -> Err OpenValue +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) -var env x = maybe unbound id (lookup x (local env)) - where unbound = bug ("Unknown variable: "++showIdent x) +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) []) - else VApp x [] - | otherwise -> resource env x --valueResDef (fst env) x - QC x -> VCApp x [] - App e1 e2 -> apply' env e1 [value env e2] - Let (x,(oty,t)) body -> value (ext (x,value env t) env) body - Meta i -> VMeta i (local env) [] - Prod bt x t1 t2 -> VProd bt (value env t1) x (Bind $ \ vx -> value (ext (x,vx) env) t2) - Abs bt x t -> VAbs bt x (Bind $ \ vx -> value (ext (x,vx) env) t) - EInt n -> VInt n - EFloat f -> VFloat f - K s -> VString s - Empty -> VString "" - Sort s | s == cTok -> VSort cStr -- to be removed - | otherwise -> VSort s - ImplArg t -> VImplArg (value env t) - Table p res -> VTblType (value env p) (value env res) - RecType rs -> VRecType [(l,value env ty) | (l,ty) <- rs] - t@(ExtR t1 t2) -> extR t (both (value env) (t1,t2)) - FV ts -> vfv (map (value env) ts) - R as -> VRec [(lbl,value env t)|(lbl,(oty,t))<-as] + in const # value0 env (mkProd [(Implicit,p,typeType)] (Vr p) []) + else const . flip VApp [] # predef f + | otherwise -> const # resource env x --valueResDef (fst env) x + QC x -> return $ const (VCApp x []) + App e1 e2 -> apply' env e1 . (:[]) =<< value env e2 + Let (x,(oty,t)) body -> do vb <- value (ext x env) body + vt <- value env t + return $ \ vs -> vb (vt vs:vs) + Meta i -> return $ \ vs -> VMeta i (zip (local env) vs) [] + Prod bt x t1 t2 -> + do vt1 <- value env t1 + vt2 <- value (ext x env) t2 + return $ \ vs -> VProd bt (vt1 vs) x $ Bind $ \ vx -> vt2 (vx:vs) + Abs bt x t -> do vt <- value (ext x env) t + return $ VAbs bt x . Bind . \ vs vx -> vt (vx:vs) + EInt n -> return $ const (VInt n) + EFloat f -> return $ const (VFloat f) + K s -> return $ const (VString s) + Empty -> return $ const (VString "") + Sort s | s == cTok -> return $ const (VSort cStr) -- to be removed + | 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) - C t1 t2 -> vconcat (both (value env) (t1,t2)) - S t1 t2 -> select env (both (value env) (t1,t2)) + V ty ts -> do pvs <- paramValues env ty + ((VV ty pvs .) . sequence) # mapM (value env) ts + 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 $ - proj l v where v = (value env t) - Alts t tts -> VAlts (value env t) (mapBoth (value env) tts) - Strs ts -> VStrs (map (value env) ts) - Glue t1 t2 -> glue (both (value env) (t1,t2)) - ELin c r -> unlockVRec c (value env r) - EPatt p -> VPatt p -- hmm - t -> ppbug (text "value"<+>ppTerm Unqualified 10 t $$ text (show t)) + do ov <- value env t + return $ \ vs -> let v = ov vs + in maybe (VP v l) id (proj l v) + Alts t tts -> (\v vts -> VAlts # v <# mapM (both id) vts) # value env t <# mapM (both (value env)) tts + Strs ts -> ((VStrs.) # sequence) # mapM (value env) ts + Glue t1 t2 -> ((glue.) # both id) # both (value env) (t1,t2) + ELin c r -> (unlockVRec c.) # value env r + 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 - ats = err bug id $ allParamValues (srcgr env) pty - in map (value0 env) ats +paramValues env ty = do let ge = global env + ats <- allParamValues (srcgr env) =<< nfx ge ty + 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) -> - err bug (valueMatch env) $ matchPattern cs (value2term (srcgr env) [] v2) + (v1@(VT _ _ cs),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) - _ -> err keep id convert + TComp ty -> do pvs <- paramValues env ty + ((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 = do ty <- getTableType i - let pty = nfx env ty + convert :: Err OpenValue + convert = do ty <- getTableType i + 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 - VPatt p' -> inlinePattMacro p' - r -> ppbug $ hang (text "Expected pattern macro:") 4 - (text (show r)) + PM qc -> do r <- resource env qc + case r of + VPatt p' -> inlinePattMacro p' + _ -> 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' env t [] = value env t +apply' :: CompleteEnv -> Term -> [OpenValue] -> Err OpenValue +apply' env t [] = value env t apply' env t vs = case t of - QC x -> VCApp x vs - Q x@(m,f) | m==cPredef -> let constr = --trace ("predef "++show x) . + QC x -> return $ \ svs -> VCApp x (map ($svs) vs) +{- + Q x@(m,f) | m==cPredef -> return $ + let constr = --trace ("predef "++show x) . VApp x - in maybe constr id (Map.lookup f predefs) vs - | otherwise -> vapply (resource env x) vs - App t1 t2 -> apply' env t1 (value env t2 : vs) --- Abs b x t -> beta env b x t vs - _ -> vapply (value env t) vs + in \ svs -> maybe constr id (Map.lookup f predefs) + $ map ($svs) vs + | otherwise -> do r <- resource env x + return $ \ svs -> vapply r (map ($svs) 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 gr xs v0 = +value2term :: L Ident -> SourceGrammar -> [Ident] -> Value -> Term +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' x f = value2term gr (x:xs) (f (gen xs)) + v2t = value2term loc gr 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 - where - pv p = case p of - PV i -> [i] - PAs i p -> i:pv p - _ -> collectPattOp pv p +pattVars = nub . allPattVars +allPattVars p = + case p of + PV i -> [i] + PAs i p -> i:allPattVars 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 $ diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs index e6fd6af7c..f37fd989f 100644 --- a/src/compiler/GF/Compile/Compute/Predef.hs +++ b/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 - [(cDrop,apISS drop),(cTake,apISS take),(cTk,apISS tk),(cDp,apISS dp), - (cEqStr,apSSB (==)),(cOccur,apSSB occur),(cOccurs,apSSB occurs), - (cToUpper,apSS (map toUpper)),(cToLower,apSS (map toLower)), - (cIsUpper,apSB (all isUpper)),(cLength,apSS' (VInt . length)), - (cPlus,apIII (+)),(cEqInt,apIIB (==)),(cLessInt,apIIB (<)), - (cShow,unimpl),(cRead,unimpl),(cToStr,unimpl),(cMapStr,unimpl), - (cEqVal,unimpl),(cError,apSS' VError)] - --- add more functions!!! +-------------------------------------------------------------------------------- +class Predef a where + toValue :: a -> Value + fromValue :: Value -> Err a + +instance Predef Int where + toValue = VInt + fromValue (VInt i) = return i + fromValue v = verror "Int" v + +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" - - tk i s = take (max 0 (length s - i)) s - dp i s = drop (max 0 (length s - i)) s - occur s t = isInfixOf s t - occurs s t = any (`elem` t) s - - apIII f vs = case vs of - [VInt i1, VInt i2] -> VInt (f i1 i2) - _ -> bug $ "f::Int->Int->Int got "++show vs - - apIIB f vs = case vs of - [VInt i1, VInt i2] -> boolV (f i1 i2) - _ -> bug $ "f::Int->Int->Bool got "++show vs - - apISS f vs = case vs of - [VInt i, VString s] -> string (f i s) - [VInt i] -> VAbs Explicit (varX 0) $ Bind $ \ v -> - case norm v of - VString s -> string (f i s) - _ -> bug $ "f::Int->Str->Str got "++show (vs++[v]) - _ -> bug $ "f::Int->Str->Str got "++show vs - - apSSB f vs = case vs of - [VString s1, VString s2] -> boolV (f s1 s2) - _ -> bug $ "f::Str->Str->Bool got "++show vs + 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), + -- Canonical values: + (cPBool,PBool),(cPFalse,PFalse),(cPTrue,PTrue),(cInts,Ints)] + --- add more functions!!! - apSB f vs = case vs of - [VString s] -> boolV (f s) - _ -> bug $ "f::Str->Bool got "++show vs +delta f vs = + case f of + Drop -> ap2 (drop::Int->String->String) + Take -> ap2 (take::Int->String->String) + Tk -> ap2 tk + Dp -> ap2 dp + 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 - apSS f vs = case vs of - [VString s] -> string (f s) - _ -> bug $ "f::Str->Str got "++show vs + ap1 f = case vs of + [v1] -> (toValue . f) `fmap` fromValue v1 + _ -> delay - apSS' f vs = case vs of - [VString s] -> f s - _ -> bug $ "f::Str->_ got "++show vs + ap2 f = case vs of + [v1,v2] -> toValue `fmap` (f `fmap` fromValue v1 `ap` fromValue v2) + _ -> delay - boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) [] + unimpl id = bug $ "unimplemented predefined function: "++showIdent id +-- problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs - strictf f vs = case normvs vs of - Left err -> VError err - Right vs -> f vs + tk i s = take (max 0 (length s - i)) s :: String + dp i s = drop (max 0 (length s - i)) s :: String + occur s t = isInfixOf (s::String) t + occurs s t = any (`elem` t) (s::String) - normvs = mapM (strict . norm) +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 +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 +strict v = case v of + VError err -> Left err + _ -> Right v - string s = case words s of - [] -> VString "" - ss -> foldr1 VC (map VString ss) +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 diff --git a/src/compiler/GF/Compile/Compute/Value.hs b/src/compiler/GF/Compile/Compute/Value.hs index 07d79ca26..bbc751ee4 100644 --- a/src/compiler/GF/Compile/Compute/Value.hs +++ b/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) |