forked from GitHub/gf-core
the experimental type checker in GF.Compile.TypeCheck.ConcreteNew is now rewriten to use the complete evaluator in GF.Compile.Compute.ConcreteNew. The old sketchy implementation in GF.Compile.Compute.ConcreteNew1 is now removed.
This commit is contained in:
krasimir
@@ -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)
|
||||
|
||||
@@ -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)
|
||||
@@ -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
|
||||
-}
|
||||
-}
|
||||
|
||||
Reference in New Issue
Block a user