diff options
Diffstat (limited to 'src/compiler/GF/Compile/Compute')
| -rw-r--r-- | src/compiler/GF/Compile/Compute/ConcreteNew.hs | 5 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Compute/ConcreteNew1.hs | 107 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Compute/Predef.hs | 4 |
3 files changed, 4 insertions, 112 deletions
diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs index e368d9d77..f8517c07e 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs @@ -1,8 +1,9 @@ -- | Functions for computing the values of terms in the concrete syntax, in -- | preparation for PMCFG generation. module GF.Compile.Compute.ConcreteNew - (GlobalEnv, resourceValues, normalForm, - --, Value(..), Env, value2term, eval, apply + (GlobalEnv(..), GLocation, resourceValues, normalForm, + Value(..), Bind(..), Env, value2term, + eval, value, toplevel ) where import GF.Grammar hiding (Env, VGen, VApp, VRecType) diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew1.hs b/src/compiler/GF/Compile/Compute/ConcreteNew1.hs deleted file mode 100644 index eba1db57b..000000000 --- a/src/compiler/GF/Compile/Compute/ConcreteNew1.hs +++ /dev/null @@ -1,107 +0,0 @@ -module GF.Compile.Compute.ConcreteNew1 - ( normalForm - , Value(..), Env, eval, apply, value2term - ) where - -import GF.Grammar hiding (Env, VGen, VApp, VRecType) -import GF.Grammar.Lookup -import GF.Grammar.Predef -import GF.Data.Operations -import Data.List (intersect) -import GF.Text.Pretty - -normalForm :: SourceGrammar -> Term -> Term -normalForm gr t = value2term gr [] (eval gr [] t) - -data Value - = VApp QIdent [Value] - | VGen Int [Value] - | VMeta MetaId Env [Value] - | VClosure Env Term - | VInt Int - | VFloat Double - | VString String - | VSort Ident - | VImplArg Value - | VTblType Value Value - | VRecType [(Label,Value)] - | VRec [(Label,Value)] - | VTbl Type [Value] --- | VC Value Value - | VPatt Patt - | VPattType Value - | VFV [Value] - | VAlts Value [(Value, Value)] - | VError String - deriving Show - -type Env = [(Ident,Value)] - -eval :: SourceGrammar -> Env -> Term -> Value -eval gr env (Vr x) = case lookup x env of - Just v -> v - Nothing -> error ("Unknown variable "++showIdent x) -eval gr env (Q x) - | x == (cPredef,cErrorType) -- to be removed - = let varP = identS "P" - in eval gr [] (mkProd [(Implicit,varP,typeType)] (Vr varP) []) - | fst x == cPredef = VApp x [] - | otherwise = case lookupResDef gr x of - Ok t -> eval gr [] t - Bad err -> error err -eval gr env (QC x) = VApp x [] -eval gr env (App e1 e2) = apply gr env e1 [eval gr env e2] -eval gr env (Meta i) = VMeta i env [] -eval gr env t@(Prod _ _ _ _) = VClosure env t -eval gr env t@(Abs _ _ _) = VClosure env t -eval gr env (EInt n) = VInt n -eval gr env (EFloat f) = VFloat f -eval gr env (K s) = VString s -eval gr env Empty = VString "" -eval gr env (Sort s) - | s == cTok = VSort cStr -- to be removed - | otherwise = VSort s -eval gr env (ImplArg t) = VImplArg (eval gr env t) -eval gr env (Table p res) = VTblType (eval gr env p) (eval gr env res) -eval gr env (RecType rs) = VRecType [(l,eval gr env ty) | (l,ty) <- rs] -eval gr env t@(ExtR t1 t2) = - let error = VError (show ("The term" <+> ppTerm Unqualified 0 t <+> "is not reducible")) - in case (eval gr env t1, eval gr env t2) of - (VRecType rs1, VRecType rs2) -> case intersect (map fst rs1) (map fst rs2) of - [] -> VRecType (rs1 ++ rs2) - _ -> error - (VRec rs1, VRec rs2) -> case intersect (map fst rs1) (map fst rs2) of - [] -> VRec (rs1 ++ rs2) - _ -> error - _ -> error -eval gr env (FV ts) = VFV (map (eval gr env) ts) -eval gr env t = error ("unimplemented: eval "++show t) - -apply gr env t [] = eval gr env t -apply gr env (Q x) vs - | fst x == cPredef = VApp x vs -- hmm - | otherwise = case lookupResDef gr x of - Ok t -> apply gr [] t vs - Bad err -> error err -apply gr env (App t1 t2) vs = apply gr env t1 (eval gr env t2 : vs) -apply gr env (Abs b x t) (v:vs) = case (b,v) of - (Implicit,VImplArg v) -> apply gr ((x,v):env) t vs - (Explicit, v) -> apply gr ((x,v):env) t vs -apply gr env t vs = error ("apply "++show t) - -value2term :: SourceGrammar -> [Ident] -> Value -> Term -value2term gr xs (VApp f vs) = foldl App (Q f) (map (value2term gr xs) vs) -value2term gr xs (VGen j vs) = foldl App (Vr (reverse xs !! j)) (map (value2term gr xs) vs) -value2term gr xs (VMeta j env vs) = foldl App (Meta j) (map (value2term gr xs) vs) -value2term gr xs (VClosure env (Prod bt x t1 t2)) = Prod bt x (value2term gr xs (eval gr env t1)) - (value2term gr (x:xs) (eval gr ((x,VGen (length xs) []) : env) t2)) -value2term gr xs (VClosure env (Abs bt x t)) = Abs bt x (value2term gr (x:xs) (eval gr ((x,VGen (length xs) []) : env) t)) -value2term gr xs (VInt n) = EInt n -value2term gr xs (VFloat f) = EFloat f -value2term gr xs (VString s) = if null s then Empty else K s -value2term gr xs (VSort s) = Sort s -value2term gr xs (VImplArg v) = ImplArg (value2term gr xs v) -value2term gr xs (VTblType p res) = Table (value2term gr xs p) (value2term gr xs res) -value2term gr xs (VRecType rs) = RecType [(l,value2term gr xs v) | (l,v) <- rs] -value2term gr xs (VFV vs) = FV (map (value2term gr xs) vs) -value2term gr xs v = error ("unimplemented: value2term "++show v) diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs index 0e02402f7..0acf85720 100644 --- a/src/compiler/GF/Compile/Compute/Predef.hs +++ b/src/compiler/GF/Compile/Compute/Predef.hs @@ -2,7 +2,6 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module GF.Compile.Compute.Predef(predef,predefName,delta) where ---import GF.Text.Pretty(render,hang) import qualified Data.Map as Map import Data.Array(array,(!)) import Data.List (isInfixOf) @@ -15,7 +14,6 @@ import GF.Compile.Compute.Value import GF.Infra.Ident (Ident,showIdent) --,varX import GF.Data.Operations(Err) -- ,err import GF.Grammar.Predef ---import PGF.Data(BindType(..)) -------------------------------------------------------------------------------- class Predef a where @@ -166,4 +164,4 @@ swap (x,y) = (y,x) bug msg = ppbug msg ppbug doc = error $ render $ hang "Internal error in Compute.Predef:" 4 doc --}
\ No newline at end of file +-} |