From 9f777aed7e916eb8d943edec9d8f2e4f478b3f30 Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Wed, 30 Nov 2011 20:56:31 +0000 Subject: [PATCH] Hopefully complete Value type and a little bit more on computations. --- .../GF/Compile/Compute/ConcreteNew.hs | 41 +++++++++++++++++-- .../GF/Compile/TypeCheck/ConcreteNew.hs | 7 +++- 2 files changed, 43 insertions(+), 5 deletions(-) diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs index 8ca08e348..f6f76e5c2 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs @@ -4,6 +4,9 @@ module GF.Compile.Compute.ConcreteNew ) where import GF.Grammar hiding (Env, VGen, VApp, VRecType) +import GF.Grammar.Lookup +import GF.Grammar.Predef +import GF.Data.Operations normalForm :: SourceGrammar -> Term -> Term normalForm gr t = value2term gr [] (eval gr [] t) @@ -13,9 +16,21 @@ data 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)] @@ -24,18 +39,34 @@ 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) = VApp x [] +eval gr env (Q x) + | 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) = 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 = error ("eval "++show t) -apply gr env t [] = eval gr env t -apply gr env t vs = error ("apply "++show t) +apply gr env t [] = eval gr env t +apply gr env (Q x) vs = case lookupResDef gr x of + Ok t -> apply gr [] t vs + Bad err -> error err +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) @@ -44,7 +75,11 @@ value2term gr xs (VMeta j env vs) = foldl App (Meta j) (map (value 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 v = error ("value2term "++show v) diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs index ffc09eec3..8fd196f87 100644 --- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs @@ -131,12 +131,15 @@ tcRho gr scope (T tt ps) mb_ty = do res_ty <- fmap Meta $ newMeta (eval gr [] typeType) ps <- mapM (tcCase gr scope (eval gr (scopeEnv scope) p_ty) (eval gr (scopeEnv scope) res_ty)) ps instSigma gr scope (T (TTyped p_ty) ps) (eval gr (scopeEnv scope) (Table p_ty res_ty)) mb_ty -tcRho gr scope (R rs) mb_ty = do +tcRho gr scope t@(R rs) mb_ty = do lttys <- case mb_ty of Nothing -> inferRecFields gr scope rs Just ty -> case ty of VRecType ltys -> checkRecFields gr scope rs ltys - _ -> tcError (text "Record expected") + _ -> tcError (text "Record type is inferred but:" $$ + nest 2 (ppTerm Unqualified 0 (value2term gr (scopeVars scope) ty)) $$ + text "is expected in the expresion:" $$ + nest 2 (ppTerm Unqualified 0 t)) return (R [(l, (Just (value2term gr (scopeVars scope) ty), t)) | (l,t,ty) <- lttys], VRecType [(l, ty) | (l,t,ty) <- lttys] )