diff --git a/src/compiler/api/GF/Command/SourceCommands.hs b/src/compiler/api/GF/Command/SourceCommands.hs index 3aee7b41f..71f090fae 100644 --- a/src/compiler/api/GF/Command/SourceCommands.hs +++ b/src/compiler/api/GF/Command/SourceCommands.hs @@ -20,7 +20,7 @@ import GF.Grammar.Parser (runP, pExp) import GF.Grammar.ShowTerm import GF.Grammar.Lookup (allOpers,allOpersTo) import GF.Compile.Rename(renameSourceTerm) -import GF.Compile.Compute.Concrete(normalForm) +import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef) import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType) import GF.Compile.TypeCheck.Primitives(predefMod) @@ -257,7 +257,7 @@ checkComputeTerm os sgr0 t = Just mo -> (sgr0,mo) t <- renameSourceTerm sgr mo t (t,_) <- inferLType sgr [] t - fmap evalStr (normalForm sgr t) + fmap evalStr (normalForm (Gl sgr stdPredef) t) where -- ** Try to compute pre{...} tokens in token sequences evalStr t = diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs index e206362f7..20bc3ee70 100644 --- a/src/compiler/api/GF/Compile/CheckGrammar.hs +++ b/src/compiler/api/GF/Compile/CheckGrammar.hs @@ -29,7 +29,7 @@ import GF.Infra.Option import GF.Compile.TypeCheck.Abstract import GF.Compile.TypeCheck.Concrete(checkLType,inferLType,ppType) import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType) -import GF.Compile.Compute.Concrete(normalForm) +import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef) import GF.Grammar import GF.Grammar.Lexer @@ -174,7 +174,7 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do mty <- case mty of Just (L loc typ) -> chIn loc "linearization type of" $ do (typ,_) <- checkLType gr [] typ typeType - typ <- normalForm gr typ + typ <- normalForm (Gl gr stdPredef) typ return (Just (L loc typ)) Nothing -> return Nothing mdef <- case (mty,mdef) of @@ -217,7 +217,7 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do (Just (L loct ty), Just (L locd de)) -> do ty' <- chIn loct "operation" $ do (ty,_) <- checkLType gr [] ty typeType - normalForm gr ty + normalForm (Gl gr stdPredef) ty (de',_) <- chIn locd "operation" $ checkLType gr [] de ty' return (Just (L loct ty'), Just (L locd de')) @@ -253,7 +253,7 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do mkParamValues sm c cnt ts [] = return (sm,cnt,[],[]) mkParamValues sm@(mn,mi) c cnt ts ((p,co):pcs) = do - co <- mapM (\(b,v,ty) -> normalForm gr ty >>= \ty -> return (b,v,ty)) co + co <- mapM (\(b,v,ty) -> normalForm (Gl gr stdPredef) ty >>= \ty -> return (b,v,ty)) co sm <- case lookupIdent p (jments mi) of Ok (ResValue (L loc _) _) -> update sm p (ResValue (L loc (mkProdSimple co (QC (mn,c)))) cnt) Bad msg -> checkError (pp msg) @@ -327,6 +327,6 @@ linTypeOfType cnc m (L loc typ) = do plusRecType vars val return ((Explicit,varX i,rec),cat) lookLin (_,c) = checks [ --- rather: update with defLinType ? - lookupLincat cnc m c >>= normalForm cnc + lookupLincat cnc m c >>= normalForm (Gl cnc stdPredef) ,return defLinType ] diff --git a/src/compiler/api/GF/Compile/Compute/Concrete.hs b/src/compiler/api/GF/Compile/Compute/Concrete.hs index 8ca8d663f..af93e0890 100644 --- a/src/compiler/api/GF/Compile/Compute/Concrete.hs +++ b/src/compiler/api/GF/Compile/Compute/Concrete.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE RankNTypes, BangPatterns, CPP #-} +{-# LANGUAGE RankNTypes, BangPatterns, CPP, ExistentialQuantification #-} -- | Functions for computing the values of terms in the concrete syntax, in -- | preparation for PMCFG generation. module GF.Compile.Compute.Concrete - ( normalForm + ( normalForm, normalStringForm , Value(..), Thunk, ThunkState(..), Env, Scope, showValue - , MetaThunks, Constraint + , MetaThunks, Constraint, Globals(..), ConstValue(..) , EvalM(..), runEvalM, runEvalOneM, evalError, evalWarn - , eval, apply, force, value2term, patternMatch + , eval, apply, force, value2term, patternMatch, stdPredef + , unsafeIOToEvalM , newThunk, newEvaluatedThunk , newResiduation, newNarrowing, getVariables , getRef, setRef @@ -33,6 +34,7 @@ import Data.List import Data.Char import Control.Monad import Control.Monad.ST +import Control.Monad.ST.Unsafe import Control.Applicative hiding (Const) import qualified Control.Monad.Fail as Fail import qualified Data.Map as Map @@ -41,13 +43,20 @@ import PGF2.Transactions(LIndex) -- * Main entry points -normalForm :: Grammar -> Term -> Check Term -normalForm gr t = - fmap mkFV (runEvalM gr (eval [] t [] >>= value2term [])) +normalForm :: Globals -> Term -> Check Term +normalForm globals t = + fmap mkFV (runEvalM globals (eval [] t [] >>= value2term [])) where mkFV [t] = t mkFV ts = FV ts +normalStringForm :: Globals -> Term -> Check String +normalStringForm globals t = + fmap toStr (runEvalM globals (fmap value2string (eval [] t []))) + where + toStr [Const s] = s + toStr _ = "" + type Sigma s = Value s type Constraint s = Value s @@ -191,8 +200,8 @@ eval env (Let (x,(_,t1)) t2) vs = do tnk <- newThunk env t1 eval ((x,tnk):env) t2 vs eval env (Q q@(m,id)) vs | m == cPredef = do vs' <- mapM force vs - mb_res <- evalPredef id vs' - case mb_res of + res <- evalPredef id vs' + case res of Const res -> return res RunTime -> return (VApp q vs) NonExist -> return (VApp (cPredef,cNonExist) []) @@ -266,45 +275,32 @@ 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 apply v [] = return v -evalPredef id [v] - | id == cLength = case value2string v of - Const s -> return (Const (VInt (genericLength s))) - _ -> return RunTime -evalPredef id [v1,v2] - | id == cTake = return (fmap string2value (liftA2 genericTake (value2int v1) (value2string v2))) -evalPredef id [v1,v2] - | id == cDrop = return (fmap string2value (liftA2 genericDrop (value2int v1) (value2string v2))) -evalPredef id [v1,v2] - | id == cTk = return (fmap string2value (liftA2 genericTk (value2int v1) (value2string v2))) + +stdPredef :: Map.Map Ident ([Value s] -> EvalM s (ConstValue (Value s))) +stdPredef = Map.fromList + [(cLength, \[v] -> case value2string v of + Const s -> return (Const (VInt (genericLength s))) + _ -> return RunTime) + ,(cTake, \[v1,v2] -> return (fmap string2value (liftA2 genericTake (value2int v1) (value2string v2)))) + ,(cDrop, \[v1,v2] -> return (fmap string2value (liftA2 genericDrop (value2int v1) (value2string v2)))) + ,(cTk, \[v1,v2] -> return (fmap string2value (liftA2 genericTk (value2int v1) (value2string v2)))) + ,(cDp, \[v1,v2] -> return (fmap string2value (liftA2 genericDp (value2int v1) (value2string v2)))) + ,(cIsUpper,\[v] -> return (fmap toPBool (liftA (all isUpper) (value2string v)))) + ,(cToUpper,\[v] -> return (fmap string2value (liftA (map toUpper) (value2string v)))) + ,(cToLower,\[v] -> return (fmap string2value (liftA (map toLower) (value2string v)))) + ,(cEqStr, \[v1,v2] -> return (fmap toPBool (liftA2 (==) (value2string v1) (value2string v2)))) + ,(cOccur, \[v1,v2] -> return (fmap toPBool (liftA2 occur (value2string v1) (value2string v2)))) + ,(cOccurs, \[v1,v2] -> return (fmap toPBool (liftA2 occurs (value2string v1) (value2string v2)))) + ,(cEqInt, \[v1,v2] -> return (fmap toPBool (liftA2 (==) (value2int v1) (value2int v2)))) + ,(cLessInt,\[v1,v2] -> return (fmap toPBool (liftA2 (<) (value2int v1) (value2int v2)))) + ,(cPlus, \[v1,v2] -> return (fmap VInt (liftA2 (+) (value2int v1) (value2int v2)))) + ,(cError, \[v] -> case value2string v of + Const msg -> fail msg + _ -> fail "Indescribable error appeared") + ] where genericTk n = reverse . genericDrop n . reverse -evalPredef id [v1,v2] - | id == cDp = return (fmap string2value (liftA2 genericDp (value2int v1) (value2string v2))) - where genericDp n = reverse . genericTake n . reverse -evalPredef id [v] - | id == cIsUpper= return (fmap toPBool (liftA (all isUpper) (value2string v))) -evalPredef id [v] - | id == cToUpper= return (fmap string2value (liftA (map toUpper) (value2string v))) -evalPredef id [v] - | id == cToLower= return (fmap string2value (liftA (map toLower) (value2string v))) -evalPredef id [v1,v2] - | id == cEqStr = return (fmap toPBool (liftA2 (==) (value2string v1) (value2string v2))) -evalPredef id [v1,v2] - | id == cOccur = return (fmap toPBool (liftA2 occur (value2string v1) (value2string v2))) -evalPredef id [v1,v2] - | id == cOccurs = return (fmap toPBool (liftA2 occurs (value2string v1) (value2string v2))) -evalPredef id [v1,v2] - | id == cEqInt = return (fmap toPBool (liftA2 (==) (value2int v1) (value2int v2))) -evalPredef id [v1,v2] - | id == cLessInt= return (fmap toPBool (liftA2 (<) (value2int v1) (value2int v2))) -evalPredef id [v1,v2] - | id == cPlus = return (fmap VInt (liftA2 (+) (value2int v1) (value2int v2))) -evalPredef id [v] - | id == cError = case value2string v of - Const msg -> fail msg - _ -> fail "Indescribable error appeared" -evalPredef id vs = return RunTime toPBool True = VApp (cPredef,cPTrue) [] toPBool False = VApp (cPredef,cPFalse) [] @@ -457,17 +453,17 @@ vtableSelect v0 ty tnks tnk2 vs = do "cannot be evaluated at compile time.") -susp i ki = EvalM $ \gr k mt d r msgs -> do +susp i ki = EvalM $ \globals@(Gl gr _) k mt d r msgs -> do s <- readSTRef i case s of Narrowing id (QC q) -> case lookupOrigInfo gr q of - Ok (m,ResParam (Just (L _ ps)) _) -> bindParam gr k mt d r msgs s m ps + Ok (m,ResParam (Just (L _ ps)) _) -> bindParam globals k mt d r msgs s m ps Bad msg -> return (Fail (pp msg) msgs) Narrowing id ty | Just max <- isTypeInts ty - -> bindInt gr k mt d r msgs s 0 max + -> bindInt globals k mt d r msgs s 0 max Evaluated _ v -> case ki v of - EvalM f -> f gr k mt d r msgs + EvalM f -> f globals k mt d r msgs _ -> k (VSusp i ki []) mt d r msgs where bindParam gr k mt d r msgs s m [] = return (Success r msgs) @@ -712,7 +708,8 @@ value2int _ = RunTime type MetaThunks s = Map.Map MetaId (Thunk s) type Cont s r = MetaThunks s -> Int -> r -> [Message] -> ST s (CheckResult r [Message]) -newtype EvalM s a = EvalM (forall r . Grammar -> (a -> Cont s r) -> Cont s r) +data Globals = Gl Grammar (forall s . Map.Map Ident ([Value s] -> EvalM s (ConstValue (Value s)))) +newtype EvalM s a = EvalM (forall r . Globals -> (a -> Cont s r) -> Cont s r) instance Functor (EvalM s) where fmap f (EvalM g) = EvalM (\gr k -> g gr (k . f)) @@ -742,14 +739,14 @@ instance Alternative (EvalM s) where instance MonadPlus (EvalM s) where -runEvalM :: Grammar -> (forall s . EvalM s a) -> Check [a] +runEvalM :: Globals -> (forall s . EvalM s a) -> Check [a] runEvalM gr f = Check $ \(es,ws) -> case runST (case f of EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) Map.empty maxBound [] ws) of Fail msg ws -> Fail msg (es,ws) Success xs ws -> Success (reverse xs) (es,ws) -runEvalOneM :: Grammar -> (forall s . EvalM s a) -> Check a +runEvalOneM :: Globals -> (forall s . EvalM s a) -> Check a runEvalOneM gr f = Check $ \(es,ws) -> case runST (case f of EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) Map.empty maxBound [] ws) of @@ -763,26 +760,32 @@ evalError msg = EvalM (\gr k _ _ r msgs -> return (Fail msg msgs)) evalWarn :: Message -> EvalM s () evalWarn msg = EvalM (\gr k mt d r msgs -> k () mt d r (msg:msgs)) +evalPredef :: Ident -> [Value s] -> EvalM s (ConstValue (Value s)) +evalPredef id vs = EvalM (\globals@(Gl _ predef) k mt d r msgs -> + case fmap (\f -> f vs) (Map.lookup id predef) of + Just (EvalM f) -> f globals k mt d r msgs + Nothing -> k RunTime mt d r msgs) + getResDef :: QIdent -> EvalM s Term -getResDef q = EvalM $ \gr k mt d r msgs -> do +getResDef q = EvalM $ \(Gl gr _) k mt d r msgs -> do case lookupResDef gr q of Ok t -> k t mt d r msgs Bad msg -> return (Fail (pp msg) msgs) getInfo :: QIdent -> EvalM s (ModuleName,Info) -getInfo q = EvalM $ \gr k mt d r msgs -> do +getInfo q = EvalM $ \(Gl gr _) k mt d r msgs -> do case lookupOrigInfo gr q of Ok res -> k res mt d r msgs Bad msg -> return (Fail (pp msg) msgs) getResType :: QIdent -> EvalM s Type -getResType q = EvalM $ \gr k mt d r msgs -> do +getResType q = EvalM $ \(Gl gr _) k mt d r msgs -> do case lookupResType gr q of Ok t -> k t mt d r msgs Bad msg -> return (Fail (pp msg) msgs) getOverload :: Term -> QIdent -> EvalM s (Term,Type) -getOverload t q = EvalM $ \gr k mt d r msgs -> do +getOverload t q = EvalM $ \(Gl gr _) k mt d r msgs -> do case lookupOverloadTypes gr q of Ok ttys -> let err = "Overload resolution failed" $$ "of term " <+> pp t $$ @@ -798,7 +801,7 @@ getOverload t q = EvalM $ \gr k mt d r msgs -> do Bad msg -> return (Fail (pp msg) msgs) getAllParamValues :: Type -> EvalM s [Term] -getAllParamValues ty = EvalM $ \gr k mt d r msgs -> +getAllParamValues ty = EvalM $ \(Gl gr _) k mt d r msgs -> case allParamValues gr ty of Ok ts -> k ts mt d r msgs Bad msg -> return (Fail (pp msg) msgs) @@ -835,7 +838,7 @@ withVar d0 (EvalM f) = EvalM $ \gr k mt d1 r msgs -> in f gr k mt d r msgs getVariables :: EvalM s [(LVar,LIndex)] -getVariables = EvalM $ \gr k mt d ws r -> do +getVariables = EvalM $ \(Gl gr _) k mt d ws r -> do ps <- metas2params gr (Map.elems mt) k ps mt d ws r where @@ -912,3 +915,7 @@ tnk2term xs tnk = EvalM $ \gr k mt d r msgs -> Narrowing i _ -> k (Meta i) mt d r msgs scopeEnv scope = zipWithM (\x i -> newEvaluatedThunk (VGen i []) >>= \tnk -> return (x,tnk)) (reverse scope) [0..] + + +unsafeIOToEvalM :: IO a -> EvalM s a +unsafeIOToEvalM f = EvalM (\gr k mt d r msgs -> unsafeIOToST f >>= \x -> k x mt d r msgs) diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs index 0a0b23be4..c11c52bdf 100644 --- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs @@ -61,7 +61,7 @@ addPMCFG opts cwd gr cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing mprn <- case mprn of Nothing -> return Nothing Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do - prn <- normalForm gr prn + prn <- normalForm (Gl gr stdPredef) prn return (Just (L loc prn)) return (CncCat mty mdef mref mprn (Just (defs,refs)),seqs) addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) seqs = do @@ -71,17 +71,17 @@ addPMCFG opts cwd gr cmi id (CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L lo mprn <- case mprn of Nothing -> return Nothing Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do - prn <- normalForm gr prn + prn <- normalForm (Gl gr stdPredef) prn return (Just (L loc prn)) return (CncFun mty mlin mprn (Just rules),seqs) addPMCFG opts cwd gr cmi id info seqs = return (info,seqs) pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet) pmcfgForm gr t ctxt ty seqs = do - res <- runEvalM gr $ do + res <- runEvalM (Gl gr stdPredef) $ do (_,args) <- mapAccumM (\arg_no (_,_,ty) -> do - t <- EvalM (\gr k mt d r msgs -> do (mt,_,t) <- type2metaTerm gr arg_no mt 0 [] ty - k t mt d r msgs) + t <- EvalM (\(Gl gr _) k mt d r msgs -> do (mt,_,t) <- type2metaTerm gr arg_no mt 0 [] ty + k t mt d r msgs) tnk <- newThunk [] t return (arg_no+1,tnk)) 0 ctxt diff --git a/src/compiler/api/GF/Compile/GrammarToCanonical.hs b/src/compiler/api/GF/Compile/GrammarToCanonical.hs index eea42eac1..b7a1d5db6 100644 --- a/src/compiler/api/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/api/GF/Compile/GrammarToCanonical.hs @@ -19,7 +19,7 @@ import GF.Infra.Ident(ModuleName(..),Ident,identW,ident2raw,rawIdentS,showIdent) import GF.Infra.Option(Options,optionsPGF) import GF.Infra.CheckM import PGF2(Literal(..)) -import GF.Compile.Compute.Concrete(normalForm) +import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef) import GF.Grammar.Canonical as C import System.FilePath ((), (<.>)) import qualified Debug.Trace as T @@ -93,13 +93,13 @@ concrete2canonical gr absname cnc modinfo = do toCanonical gr absname (name,jment) = case jment of CncCat (Just (L loc typ)) _ _ pprn _ -> do - ntyp <- normalForm gr typ + ntyp <- normalForm (Gl gr stdPredef) typ let pts = paramTypes gr ntyp return [(pts,Left (LincatDef (gId name) (convType ntyp)))] CncFun (Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn _ -> do let params = [(b,x)|(b,x,_)<-ctx] args = map snd params - e0 <- normalForm gr (mkAbs params (mkApp def (map Vr args))) + e0 <- normalForm (Gl gr stdPredef) (mkAbs params (mkApp def (map Vr args))) let e = cleanupRecordFields lincat (unAbs (length params) e0) tts = tableTypes gr [e] return [(tts,Right (LinDef (gId name) (map gId args) (convert gr e)))] diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs index a0412d1b7..436ec6d48 100644 --- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs +++ b/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs @@ -10,7 +10,7 @@ import GF.Grammar.Lookup import GF.Grammar.Predef import GF.Grammar.PatternMatch import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord) -import GF.Compile.Compute.Concrete(normalForm) +import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef) import GF.Compile.TypeCheck.Primitives import Data.List @@ -215,7 +215,7 @@ inferLType gr g trm = case trm of v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr] v' <- case v' of Q q -> do t <- lookupResDef gr q - t <- normalForm gr t + t <- normalForm (Gl gr stdPredef) t case t of EPatt _ _ p -> mkStrs p _ -> return v' @@ -325,7 +325,7 @@ inferLType gr g trm = case trm of measurePatt gr p = case p of PM q -> do t <- lookupResDef gr q - t <- normalForm gr t + t <- normalForm (Gl gr stdPredef) t case t of EPatt minp maxp _ -> return (minp,maxp,p) _ -> checkError ("Expected pattern macro, but found:" $$ nest 2 (pp t)) diff --git a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs index 0f2a85f08..ce80af716 100644 --- a/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/api/GF/Compile/TypeCheck/ConcreteNew.hs @@ -23,15 +23,15 @@ import qualified Data.Map as Map import Data.Maybe(fromMaybe,isNothing) import qualified Control.Monad.Fail as Fail -checkLType :: Grammar -> Term -> Type -> Check (Term, Type) -checkLType gr t ty = runEvalOneM gr $ do +checkLType :: Globals -> Term -> Type -> Check (Term, Type) +checkLType globals t ty = runEvalOneM globals $ do vty <- eval [] ty [] (t,_) <- tcRho [] t (Just vty) t <- zonkTerm [] t return (t,ty) -inferLType :: Grammar -> Term -> Check (Term, Type) -inferLType gr t = runEvalOneM gr $ do +inferLType :: Globals -> Term -> Check (Term, Type) +inferLType globals t = runEvalOneM globals $ do (t,ty) <- inferSigma [] t t <- zonkTerm [] t ty <- value2term [] ty @@ -171,7 +171,7 @@ tcRho scope (Meta _) mb_ty = do return (Meta i, ty) tcRho scope (Let (var, (mb_ann_ty, rhs)) body) mb_ty = do -- LET (rhs,var_ty) <- case mb_ann_ty of - Nothing -> inferSigma scope rhs + Nothing -> tcRho scope rhs Nothing Just ann_ty -> do (ann_ty, _) <- tcRho scope ann_ty (Just vtypeType) env <- scopeEnv scope v_ann_ty <- eval env ann_ty [] @@ -1086,7 +1086,9 @@ zonkTerm xs (Meta i) = do st <- getRef tnk case st of Hole _ -> return (Meta i) - Residuation _ _ _ -> return (Meta i) + Residuation _ scope v -> case v of + Just v -> zonkTerm xs =<< value2term (map fst scope) v + Nothing -> return (Meta i) Narrowing _ _ -> return (Meta i) Evaluated _ v -> zonkTerm xs =<< value2term xs v zonkTerm xs t = composOp (zonkTerm xs) t diff --git a/src/compiler/api/GF/Term.hs b/src/compiler/api/GF/Term.hs index de47d243d..a78b728a6 100644 --- a/src/compiler/api/GF/Term.hs +++ b/src/compiler/api/GF/Term.hs @@ -1,4 +1,11 @@ -module GF.Term (renameSourceTerm, inferLType, checkLType, normalForm) where +module GF.Term (renameSourceTerm, + Globals(..), ConstValue(..), EvalM, stdPredef, + Value(..), showValue, newEvaluatedThunk, + evalError, evalWarn, + inferLType, checkLType, + normalForm, normalStringForm, + unsafeIOToEvalM + ) where import GF.Compile.Rename import GF.Compile.Compute.Concrete