diff options
Diffstat (limited to 'src/compiler/GF/Compile/Compute')
| -rw-r--r-- | src/compiler/GF/Compile/Compute/ConcreteNew.hs | 418 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Compute/ConcreteNew1.hs | 108 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Compute/Predef.hs | 88 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/Compute/Value.hs | 44 |
4 files changed, 564 insertions, 94 deletions
diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs index d614c022a..49752aebb 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs @@ -1,108 +1,338 @@ +-- | Functions for computing the values of terms in the concrete syntax, in +-- | preparation for PMCFG generation. module GF.Compile.Compute.ConcreteNew ( 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.Grammar.Lookup(lookupResDef,allParamValues) +import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr) +import GF.Grammar.PatternMatch(matchPattern) +import GF.Grammar.Lockfield(unlockRecord,lockLabel,isLockLabel) +import GF.Compile.Compute.Value +import GF.Compile.Compute.Predef(predefs) +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 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) + +-- * Main entry points 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)] +normalForm gr = nfx gr [] +nfx gr env = value2term gr [] . eval gr env 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 = identC (BS.pack "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 (text "The term" <+> ppTerm Unqualified 0 t <+> text "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) +eval gr env t = value (gr,env) t + +apply gr env = apply' (gr,env) + +-------------------------------------------------------------------------------- + +-- * Environments + +type CompleteEnv = (SourceGrammar,Env) + +ext b (gr,env) = (gr,b:env) + +var env x = maybe unbound id (lookup x (snd env)) + where unbound = bug ("Unknown variable: "++showIdent x) + +-- * Computing values + +-- | Computing the value of a top-level term +value0 gr t = eval gr [] t + +-- | Computing the value of a term +value :: CompleteEnv -> Term -> Value +value env 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 (fst env) (mkProd [(Implicit,p,typeType)] (Vr p) []) + else VApp x [] + | otherwise -> err bug (value0 (fst env)) (lookupResDef (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 (snd 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] + T i cs -> valueTable env i cs + V ty ts -> VV ty (map (value env) ts) + C t1 t2 -> vconcat (both (value env) (t1,t2)) + S t1 t2 -> select (fst env) (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) + t -> ppbug (text "value"<+>ppTerm Unqualified 10 t $$ text (show t)) + +vconcat vv@(v1,v2) = + case vv of + (VError _,_) -> v1 + (VString "",_) -> v2 + (_,VError _) -> v2 + (_,VString "") -> v1 + _ -> VC v1 v2 + +proj l v | isLockLabel l = return (VRec []) + ---- a workaround 18/2/2005: take this away and find the reason + ---- why earlier compilation destroys the lock field +proj l v = + case v of + VFV vs -> liftM vfv (mapM (proj l) vs) + VRec rs -> lookup l rs + VExtR v1 v2 -> proj l v2 `mplus` proj l v1 -- hmm + _ -> return (ok1 VP v l) + +ok1 f v1@(VError {}) _ = v1 +ok1 f v1 v2 = f v1 v2 + +ok2 f v1@(VError {}) _ = v1 +ok2 f _ v2@(VError {}) = v2 +ok2 f v1 v2 = f v1 v2 + +unlockVRec ::Ident -> Value -> Value +unlockVRec c v = + case v of +-- VClosure env t -> err bug (VClosure env) (unlockRecord c t) + VAbs bt x (Bind f) -> VAbs bt x (Bind $ \ v -> unlockVRec c (f v)) + VRec rs -> plusVRec rs lock + _ -> VExtR v (VRec lock) -- hmm +-- _ -> bug $ "unlock non-record "++show v + where + lock = [(lockLabel c,VRec [])] + +-- suspicious, but backwards compatible +plusVRec rs1 rs2 = VRec ([(l,v)|(l,v)<-rs1,l `notElem` ls2] ++ rs2) + where ls2 = map fst rs2 + +extR t vv = + case vv of + (VFV vs,v2) -> vfv [extR t (v1,v2)|v1<-vs] + (v1,VFV vs) -> vfv [extR t (v1,v2)|v2<-vs] + (VRecType rs1, VRecType rs2) -> + case intersect (map fst rs1) (map fst rs2) of + [] -> VRecType (rs1 ++ rs2) + ls -> error $ text "clash"<+>text (show ls) + (VRec rs1, VRec rs2) -> plusVRec rs1 rs2 + (v1 , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm + (VS (VV t vs) s,v2) -> VS (VV t [extR t (v1,v2)|v1<-vs]) s + (v1,v2) -> ok2 VExtR v1 v2 -- hmm +-- (v1,v2) -> error $ text "not records" $$ text (show v1) $$ text (show v2) + where + error explain = ppbug $ text "The term" <+> ppTerm Unqualified 0 t + <+> text "is not reducible" $$ explain + +glue vv = case vv of + (VFV vs,v2) -> vfv [glue (v1,v2)|v1<-vs] + (v1,VFV vs) -> vfv [glue (v1,v2)|v2<-vs] + (VString s1,VString s2) -> VString (s1++s2) + (v1,VAlts d vs) -> VAlts (glx d) [(glx v,c) | (v,c) <- vs] + where glx v2 = glue (v1,v2) + (v1@(VAlts {}),v2) -> + --err (const (ok2 VGlue v1 v2)) id $ + err bug id $ + do y' <- strsFromValue v2 + x' <- strsFromValue v1 + return $ vfv [foldr1 VC (map VString (str2strings (glueStr v u))) | v <- x', u <- y'] + (VC va vb,v2) -> VC va (glue (vb,v2)) + (v1,VC va vb) -> VC (glue (va,va)) vb + (VS (VV ty vs) vb,v2) -> VS (VV ty [glue (v,v2)|v<-vs]) vb + (v1,VS (VV ty vs) vb) -> VS (VV ty [glue (v1,v)|v<-vs]) vb +-- (v1,v2) -> ok2 VGlue v1 v2 + (v1,v2) -> bug vv + where + bug vv = ppbug $ text "glue"<+>text (show vv) + +-- | to get a string from a value that represents a sequence of terminals +strsFromValue :: Value -> Err [Str] +strsFromValue t = case t of + VString s -> return [str s] + VC s t -> do + s' <- strsFromValue s + t' <- strsFromValue t + return [plusStr x y | x <- s', y <- t'] +{- + VGlue s t -> do + s' <- strsFromValue s + t' <- strsFromValue t + return [glueStr x y | x <- s', y <- t'] +-} + VAlts d vs -> do + d0 <- strsFromValue d + v0 <- mapM (strsFromValue . fst) vs + c0 <- mapM (strsFromValue . snd) vs + let vs' = zip v0 c0 + return [strTok (str2strings def) vars | + def <- d0, + vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | + vv <- combinations v0] + ] + VFV ts -> mapM strsFromValue ts >>= return . concat + VStrs ts -> mapM strsFromValue ts >>= return . concat + _ -> fail "cannot get Str from value" +vfv vs = case nub vs of + [v] -> v + vs -> VFV vs + +select gr vv = + case vv of + (v1,VFV vs) -> vfv [select gr (v1,v2)|v2<-vs] + (VFV vs,v2) -> vfv [select gr (v1,v2)|v1<-vs] + (v1@(VV pty rs),v2) -> + err (const (VS v1 v2)) id $ + do ats <- allParamValues gr pty + let vs = map (value0 gr) ats + i <- maybeErr "no match" $ findIndex (==v2) vs + return (rs!!i) + (v1@(VT i cs),v2) -> + err bug (valueMatch gr) $ matchPattern cs (value2term gr [] v2) + (VS (VV pty rs) v12,v2) -> VS (VV pty [select gr (v11,v2)|v11<-rs]) v12 + (v1,v2) -> ok2 VS v1 v2 + +valueMatch gr (Bind f,env') = f (mapSnd (value0 gr) env') + +valueTable env@(gr,bs) i cs = + case i of + TComp ty -> VV ty (map (value env.snd) cs) + _ -> err keep id convert + where + keep _ = VT i (err bug id $ mapM valueCase cs) + + valueCase (p,t) = do p' <- inlinePattMacro p + return (p',Bind $ \ bs' -> value (gr,bs'++bs) t) + + convert = do ty <- getTableType i + let pty = nfx gr bs ty + vs <- allParamValues gr pty + cs' <- mapM valueCase cs + sts <- mapM (matchPattern cs') vs + return $ VV pty (map (valueMatch gr) sts) + + inlinePattMacro p = case p of + PM qc -> do EPatt p' <- lookupResDef gr qc + inlinePattMacro p' + _ -> composPattOp inlinePattMacro p + +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) . + VApp x + in maybe constr id (Map.lookup f predefs) vs + | otherwise -> err bug (\t->apply' (fst env,[]) t vs) + (lookupResDef (fst env) x) + 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 + +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 + VS (VV t fs) s -> VS (VV t [vapply f vs|f<-fs]) s + v -> bug $ "vapply "++show v++" "++show vs + +vbeta bt f (v:vs) = + case (bt,v) of + (Implicit,VImplArg v) -> vapply (f v) vs + (Explicit, v) -> vapply (f v) vs +{- +beta env b x t (v:vs) = + case (b,v) of + (Implicit,VImplArg v) -> apply' (ext (x,v) env) t vs + (Explicit, v) -> apply' (ext (x,v) env) t 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 (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) +value2term gr xs v0 = + case v0 of + VApp f vs -> foldl App (Q f) (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) +-- VClosure env (Prod bt x t1 t2) -> Prod bt x (v2t (eval gr env t1)) +-- (nf gr (push x (env,xs)) t2) +-- VClosure env (Abs bt x t) -> Abs bt x (nf gr (push x (env,xs)) t) + VProd bt v x (Bind f) -> Prod bt x (v2t v) (v2t' x f) + VAbs bt x (Bind f) -> Abs bt x (v2t' x f) + VInt n -> EInt n + VFloat f -> EFloat f + VString s -> if null s then Empty else K s + VSort s -> Sort s + VImplArg v -> ImplArg (v2t v) + VTblType p res -> Table (v2t p) (v2t res) + 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) + VFV vs -> FV (map v2t vs) + VC v1 v2 -> C (v2t v1) (v2t v2) + VS v1 v2 -> S (v2t v1) (v2t v2) + VP v l -> P (v2t v) l + VAlts v vvs -> Alts (v2t v) (mapBoth v2t vvs) + VStrs vs -> Strs (map v2t vs) +-- VGlue v1 v2 -> Glue (v2t v1) (v2t v2) + VExtR v1 v2 -> ExtR (v2t v1) (v2t v2) + VError err -> Error err + _ -> bug ("value2term "++show v0) + where + v2t = value2term gr xs + v2t' x f = value2term 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')) + 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 + +--- + +both = apBoth + +bug msg = ppbug (text msg) +ppbug doc = error $ render $ + hang (text "Internal error in Compute.ConcreteNew2:") 4 doc diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew1.hs b/src/compiler/GF/Compile/Compute/ConcreteNew1.hs new file mode 100644 index 000000000..59c9ef6b4 --- /dev/null +++ b/src/compiler/GF/Compile/Compute/ConcreteNew1.hs @@ -0,0 +1,108 @@ +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 Text.PrettyPrint +import qualified Data.ByteString.Char8 as BS + +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 = identC (BS.pack "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 (text "The term" <+> ppTerm Unqualified 0 t <+> text "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 new file mode 100644 index 000000000..1647b2a92 --- /dev/null +++ b/src/compiler/GF/Compile/Compute/Predef.hs @@ -0,0 +1,88 @@ +-- | Implementations of predefined functions +module GF.Compile.Compute.Predef where + +import Text.PrettyPrint(render,hang,text) +import qualified Data.Map as Map +import Data.List (isInfixOf) +import Data.Char (isUpper,toLower,toUpper) + +import GF.Data.Utilities (mapSnd,apBoth) + +import GF.Compile.Compute.Value +import GF.Infra.Ident (Ident) +import GF.Grammar.Predef + +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!!! + 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) + _ -> 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 + + apSB f vs = case vs of + [VString s] -> boolV (f s) + _ -> bug $ "f::Str->Bool got "++show vs + + apSS f vs = case vs of + [VString s] -> string (f s) + _ -> bug $ "f::Str->Str got "++show vs + + apSS' f vs = case vs of + [VString s] -> f s + _ -> bug $ "f::Str->_ got "++show vs + + boolV b = VCApp (cPredef,if b then cPTrue else cPFalse) [] + + strictf f vs = case normvs vs of + Left err -> VError err + Right vs -> f vs + + normvs = mapM (strict . norm) + + 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 + + string s = case words s of + [] -> VString "" + ss -> foldr1 VC (map VString ss) + +--- + +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 new file mode 100644 index 000000000..c47c67acb --- /dev/null +++ b/src/compiler/GF/Compile/Compute/Value.hs @@ -0,0 +1,44 @@ +module GF.Compile.Compute.Value where +import GF.Grammar.Grammar(Label,Type,TInfo,MetaId,Patt,QIdent) +import PGF.Data(BindType) +import GF.Infra.Ident(Ident) +import Text.Show.Functions + +-- | Self-contained (not quite) representation of values +data Value + = VApp QIdent [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] +-- | VClosure Env Term -- used in Typecheck.ConcreteNew + | VAbs BindType Ident Binding -- used in Compute.ConcreteNew + | VProd BindType Value Ident Binding -- used in Compute.ConcreteNew + | VInt Int + | VFloat Double + | VString String + | VSort Ident + | VImplArg Value + | VTblType Value Value + | VRecType [(Label,Value)] + | VRec [(Label,Value)] + | VV Type [Value] + | VT TInfo [(Patt,Bind Env)] + | VC Value Value + | VS Value Value + | VP Value Label + | VPatt Patt + | VPattType Value + | VFV [Value] + | VAlts Value [(Value, Value)] + | VStrs [Value] +-- | VGlue Value Value -- hmm + | VExtR Value Value -- hmm + | VError String + deriving (Eq,Show) + +type Binding = Bind Value +data Bind a = Bind (a->Value) deriving Show + +instance Eq (Bind a) where x==y = False + +type Env = [(Ident,Value)] |