diff --git a/src/compiler/api/GF/Command/Importing.hs b/src/compiler/api/GF/Command/Importing.hs index ec2070605..5944e22f7 100644 --- a/src/compiler/api/GF/Command/Importing.hs +++ b/src/compiler/api/GF/Command/Importing.hs @@ -1,7 +1,7 @@ module GF.Command.Importing (importGrammar, importSource) where import PGF2 -import PGF2.Transactions +import PGF2.Transactions hiding (Rule(..)) import GF.Compile import GF.Compile.Multi (readMulti) diff --git a/src/compiler/api/GF/Command/SourceCommands.hs b/src/compiler/api/GF/Command/SourceCommands.hs index 33badb3ea..024f7c889 100644 --- a/src/compiler/api/GF/Command/SourceCommands.hs +++ b/src/compiler/api/GF/Command/SourceCommands.hs @@ -19,8 +19,8 @@ import GF.Grammar.Analyse import GF.Grammar.ShowTerm import GF.Grammar.Lookup (allOpers,allOpersTo) import GF.Compile.Rename(renameSourceTerm) -import GF.Compile.Compute.Concrete2(normalForm,normalFlatForm,Globals(..),stdPredef) -import GF.Compile.TypeCheck.Concrete as TC(inferLType) +import GF.Compile.Compute(normalForm,normalFlatForm,Globals(..),stdPredef) +import GF.Compile.TypeCheck as TC(inferLType) import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts) import GF.Command.CommandInfo @@ -253,7 +253,7 @@ checkComputeTerm os sgr t = -- ** Try to compute pre{...} tokens in token sequences singleton x = [x] - g = Gl sgr (stdPredef g) + g = Gl sgr (stdPredef g) False evalStr t = case t of diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs index 5f0deb696..4bd0e6617 100644 --- a/src/compiler/api/GF/Compile/CheckGrammar.hs +++ b/src/compiler/api/GF/Compile/CheckGrammar.hs @@ -26,13 +26,13 @@ import Prelude hiding ((<>)) import GF.Infra.Ident import GF.Infra.Option -import GF.Compile.TypeCheck.Abstract -import GF.Compile.TypeCheck.Concrete(checkLType,inferLType) -import GF.Compile.Compute.Concrete2(normalForm,Globals(..),stdPredef) +import GF.Compile.TypeCheck(checkLType,inferLType,checkContext,checkDef) +import GF.Compile.Compute(normalForm,Globals(..),noPredef,stdPredef) import GF.Grammar import GF.Grammar.Lexer import GF.Grammar.Lookup +import GF.Grammar.Lockfield import GF.Data.Operations import GF.Infra.CheckM @@ -52,8 +52,8 @@ checkModule opts cwd sgr mo@(m,mi) = do abs <- lookupModule gr a checkCompleteGrammar opts cwd gr (a,abs) mo _ -> return mo - infoss <- checkInModule cwd mi NoLoc empty $ topoSortJments2 mo - foldM (foldM (checkInfo opts cwd sgr)) mo infoss + infos <- checkInModule cwd mi NoLoc empty $ topoSortJments mo + foldM (checkInfo opts cwd sgr) mo infos -- check if restricted inheritance modules are still coherent -- i.e. that the defs of remaining names don't depend on omitted names @@ -70,7 +70,7 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty let incld c = Set.member c (Set.fromList incl) let illegal c = Set.member c (Set.fromList excl) let illegals = [(f,is) | - (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)] + (f,_,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)] case illegals of [] -> return () cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$ @@ -92,7 +92,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc where checkAbs js i@(c,info) = case info of - AbsFun (Just (L loc ty)) _ _ _ + AbsFun (Just (L loc ty)) _ -> do let mb_def = do let (cxt,(_,i),_) = typeForm ty info <- lookupIdent i js @@ -134,7 +134,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc checkCnc js (c,info) = case info of CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of - Ok (_,AbsFun (Just (L loc ty)) _ _ _) -> + Ok (_,AbsFun (Just (L loc ty)) _) -> do linty <- linTypeOfType gr cm (L loc ty) return $ Map.insert c (CncFun (Just linty) d mn mf) js _ -> do checkWarn ("function" <+> c <+> "is not in abstract") @@ -156,57 +156,69 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do checkReservedId c case info of AbsCat (Just (L loc cont)) -> - mkCheck loc "the category" $ - checkContext gr cont + chIn loc "the category" $ do + cont <- checkContext ga cont + update sm c (AbsCat (Just (L loc cont))) - AbsFun (Just (L loc typ)) ma md moper -> do - mkCheck loc "the type of function" $ - checkTyp gr typ - typ <- compAbsTyp [] typ -- to calculate let definitions - case md of - Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $ - checkDef gr (fst sm,c) typ eq) eqs - Nothing -> return () - update sm c (AbsFun (Just (L loc typ)) ma md moper) + AbsFun (Just (L loc typ)) md -> do + (typ,_) <- chIn loc "the type of function" $ + checkLType ga typ typeType + typ <- normalForm ga typ -- to calculate let definitions + sm <- update sm c (AbsFun (Just (L loc typ)) md) + let gr' = prependModule sgr sm + ga' = Gl gr' noPredef True + md <- case md of + Just (_,eqs) -> do eqs <- mapM (\(L loc eq) -> chIn loc "the definition of function" $ + fmap (L loc) (checkDef ga (fst sm,c) typ eq)) eqs + arity <- + case [length ps | L _ (ps,_) <- eqs] of + [] -> return 0 + (arity : as) + | all (==arity) as -> return arity + _ -> checkError ("The following equations have different arities" $$ + nest 4 (vcat [ppQIdent Unqualified (fst sm,c) <+> hsep (map (ppPatt Unqualified 2) ps) | L _ (ps,_) <- eqs])) + return (Just (arity,eqs)) + Nothing -> return Nothing + update sm c (AbsFun (Just (L loc typ)) md) CncCat mty mdef mref mpr mpmcfg -> do mty <- case mty of Just (L loc typ) -> chIn loc "linearization type of" $ do - (typ,_) <- checkLType g typ typeType - typ <- normalForm g typ + (typ,_) <- checkLType gc typ typeType + typ <- normalForm gc typ return (Just (L loc typ)) Nothing -> return Nothing mdef <- case (mty,mdef) of (Just (L _ typ),Just (L loc def)) -> chIn loc "default linearization of" $ do - (def,_) <- checkLType g def (mkFunType [typeStr] typ) + (def,_) <- checkLType gc def (mkFunType [typeStr] typ) return (Just (L loc def)) _ -> return Nothing mref <- case (mty,mref) of (Just (L _ typ),Just (L loc ref)) -> chIn loc "reference linearization of" $ do - (ref,_) <- checkLType g ref (mkFunType [typ] typeStr) + (ref,_) <- checkLType gc ref (mkFunType [typ] typeStr) return (Just (L loc ref)) _ -> return Nothing mpr <- case mpr of (Just (L loc t)) -> chIn loc "print name of" $ do - (t,_) <- checkLType g t typeStr + (t,_) <- checkLType gc t typeStr return (Just (L loc t)) _ -> return Nothing update sm c (CncCat mty mdef mref mpr mpmcfg) CncFun mty mt mpr mpmcfg -> do mt <- case (mty,mt) of - (Just (_,cat,cont,val),Just (L loc trm)) -> + (Just (args,cat,cont,val),Just (L loc trm)) -> chIn loc "linearization of" $ do - (trm,_) <- checkLType g trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars + (trm,_) <- checkLType gc trm (mkFunType (zipWith (\cat (_,_,ty) -> lock cat ty) args cont) val) -- erases arg vars return (Just (L loc (etaExpand [] trm cont))) _ -> return mt mpr <- case mpr of (Just (L loc t)) -> chIn loc "print name of" $ do - (t,_) <- checkLType g t typeStr + (t,_) <- checkLType gc t typeStr return (Just (L loc t)) _ -> return Nothing update sm c (CncFun mty mt mpr mpmcfg) @@ -215,14 +227,14 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do (pty', pde') <- case (pty,pde) of (Just (L loct ty), Just (L locd de)) -> do ty' <- chIn loct "operation" $ do - (ty,_) <- checkLType g ty typeType - normalForm g ty + (ty,_) <- checkLType gc ty typeType + normalForm gc ty (de',_) <- chIn locd "operation" $ - checkLType g de ty' + checkLType gc de ty' return (Just (L loct ty'), Just (L locd de')) (Nothing , Just (L locd de)) -> do (de',ty') <- chIn locd "operation" $ - inferLType g de + inferLType gc de return (Just (L locd ty'), Just (L locd de')) (Just (L loct ty), Nothing) -> do chIn loct "operation" $ @@ -230,10 +242,10 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do update sm c (ResOper pty' pde') ResOverload os tysts -> chIn NoLoc "overloading" $ do - tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType g t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones + tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gc t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones tysts0 <- lookupOverload gr (fst sm,c) -- check against inherited ones too tysts1 <- sequence - [checkLType g tr (mkFunType args val) | (args,(val,tr)) <- tysts0] + [checkLType gc tr (mkFunType args val) | (args,(val,tr)) <- tysts0] --- this can only be a partial guarantee, since matching --- with value type is only possible if expected type is given --checkUniq $ @@ -248,12 +260,13 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do _ -> return sm where gr = prependModule sgr sm - g = Gl gr (stdPredef g) + ga = Gl gr noPredef True + gc = Gl gr (stdPredef gc) False chIn loc cat = checkInModule cwd (snd sm) loc ("Happened in" <+> cat <+> c) 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 g ty >>= \ty -> return (b,v,ty)) co + co <- mapM (\(b,v,ty) -> normalForm gc 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) @@ -268,22 +281,6 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do | otherwise -> checkUniq $ y:xs _ -> return () - mkCheck loc cat ss = case ss of - [] -> return sm - _ -> chIn loc cat $ checkError (vcat ss) - - compAbsTyp g t = case t of - Vr x -> maybe (checkError ("no value given to variable" <+> x)) return $ lookup x g - Let (x,(_,a)) b -> do - a' <- compAbsTyp g a - compAbsTyp ((x, a'):g) b - Prod b x a t -> do - a' <- compAbsTyp g a - t' <- compAbsTyp ((x,Vr x):g) t - return $ Prod b x a' t' - Abs _ _ _ -> return t - _ -> composOp (compAbsTyp g) t - etaExpand xs t [] = t etaExpand xs (Abs bt x t) (_ :cont) = Abs bt x (etaExpand (x:xs) t cont) etaExpand xs t ((bt,_,ty):cont) = Abs bt x (etaExpand (x:xs) (App t (Vr x)) cont) @@ -330,4 +327,4 @@ linTypeOfType cnc m (L loc typ) = do lookupLincat cnc m c >>= normalForm g ,return defLinType ] - g = Gl cnc (stdPredef g) + g = Gl cnc (stdPredef g) False diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute.hs similarity index 80% rename from src/compiler/api/GF/Compile/Compute/Concrete2.hs rename to src/compiler/api/GF/Compile/Compute.hs index a8dfbaaa4..76400d7d7 100644 --- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs +++ b/src/compiler/api/GF/Compile/Compute.hs @@ -1,23 +1,22 @@ {-# LANGUAGE RankNTypes, BangPatterns, GeneralizedNewtypeDeriving, TupleSections #-} -module GF.Compile.Compute.Concrete2 +module GF.Compile.Compute (Env, Scope, Value(..), Variants(..), OptionInfo(..), - ConstValue(..), Globals(..), PredefTable, EvalM, + ConstValue(..), Globals(..), PredefTable, EvalM(..), mapVariantsC, unvariants, - runEvalM, runEvalMWithInput, stdPredef, globals, - PredefImpl, Predef(..), ($\), - pdCanonicalArgs, pdArity, + runEvalM, runEvalMWithInput, stdPredef, noPredef, globals, + PredefImpl, Predef, pdArity, normalForm, normalFlatForm, eval, apply, value2term, value2termM, value2string, value2int, value2float, value2expr, string2value, bubble, patternMatch, vtableSelect, State(..), newResiduation, checkpoint, getMeta, setMeta, MetaState(..), variants, try, - evalError, evalWarn, ppValue, Choice(..), unit, poison, split, split3, split4, mapC, mapCM) where + evalError, evalWarn, ppValue, Choice(..), unit, split, split3, split4, mapC, mapCM) where import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import GF.Infra.Ident import GF.Infra.CheckM import GF.Data.Operations(Err(..)) import GF.Data.Utilities(maybeAt,splitAt',(<||>),anyM,secondM,bimapM) -import GF.Grammar.Lookup(lookupResDef,lookupOrigInfo) +import GF.Grammar.Lookup import GF.Grammar.Grammar import GF.Grammar.Macros import GF.Grammar.Predef @@ -37,31 +36,20 @@ import Data.Char import PGF2(Expr(..),Literal(..)) type PredefImpl = Globals -> Choice -> [Value] -> ConstValue Value -newtype Predef = Predef { runPredef :: PredefImpl } +data Predef = Predef { predefArity :: Int, predefRun :: PredefImpl } -infix 1 $\ - -($\) :: (Predef -> Predef) -> PredefImpl -> Predef -k $\ f = k (Predef f) - -pdCanonicalArgs :: Bool -> Predef -> Predef -pdCanonicalArgs flat def = Predef $ \g c args -> - if all (isCanonicalForm flat) args then runPredef def g c args else RunTime - -pdArity :: Int -> Predef -> Predef -pdArity n def = Predef $ \g c args -> - case splitAt' n args of - Nothing -> RunTime - Just (usedArgs, remArgs) -> - runPredef def g c usedArgs <&> \v -> apply g v remArgs +pdArity :: Int -> PredefImpl -> Predef +pdArity n def = Predef n def type Env = [(Ident,Value)] type Scope = [(Ident,Value)] type PredefTable = Map.Map Ident Predef -data Globals = Gl Grammar PredefTable +data Globals = Gl Grammar PredefTable Bool {- True for abstract, False for concrete -} data Value - = VApp Choice QIdent [Value] + = VApp QIdent [Value] -- application of a constructor + | VPAP Choice QIdent [Value] -- partially applied function + | VConst QIdent [Value] -- function application that cannot be evaluated | VMeta {-# UNPACK #-} !MetaId [Value] | VSusp {-# UNPACK #-} !MetaId (Value -> Value) [Value] | VGen {-# UNPACK #-} !Int [Value] @@ -87,7 +75,7 @@ data Value | VFV Choice (Variants Value) | VAlts Value [(Value, Value)] | VStrs [Value] - | VMarkup Ident [(Ident,Value)] [Value] + | VMarkup Ident [(Ident,Value)] [L Value] | VReset Ident (Maybe Value) Value (Maybe QIdent) | VSymCat Int LIndex [(LIndex, (Value, Type))] | VError Doc @@ -126,7 +114,7 @@ isCanonicalForm True (VFV {}) = False isCanonicalForm False (VFV c vs) = all (isCanonicalForm False) (unvariants vs) isCanonicalForm flat (VAlts d vs) = all (isCanonicalForm flat . snd) vs isCanonicalForm flat (VStrs vs) = all (isCanonicalForm flat) vs -isCanonicalForm flat (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat) vs +isCanonicalForm flat (VMarkup tag as vs) = all (isCanonicalForm flat . snd) as && all (isCanonicalForm flat . unLoc) vs isCanonicalForm flat (VReset ctl cv v _) = maybe True (isCanonicalForm flat) cv && isCanonicalForm flat v isCanonicalForm flat _ = False @@ -186,7 +174,14 @@ eval g env s (Prod b x t1 t2)[] | otherwise = let (s1,s2) = split s in VProd b x (eval g env s1 t1 []) (VClosure env s2 t2) eval g env s (Typed t ty) vs = eval g env s t vs -eval g env s (RecType lbls) [] = VRecType (mapC (\s (lbl,ty) -> (lbl, True, eval g env s ty [])) s lbls) False +eval g env c (RecType rs) [] = VRecType + (mapC (\c (lbl,deps,ty) -> + let v = case deps of + [] -> eval g env c ty [] + xs -> VClosure env c (foldr (Abs Explicit) ty deps) + in (lbl,True,v)) + c rs) + False eval g env s (R as) [] = VR (mapC (\s (lbl,(ty,t)) -> (lbl, eval g env s t [])) s as) eval g env s (P t lbl) vs = let project (VR as) = case lookup lbl as of Nothing -> VError ("Missing value for label" <+> pp lbl $$ @@ -195,6 +190,7 @@ eval g env s (P t lbl) vs = let project (VR as) = case lookup lbl a project (VFV s fvs) = VFV s (fmap project fvs) project (VMeta i vs) = VSusp i (\v -> project (apply g v vs)) [] project (VSusp i k vs) = VSusp i (\v -> project (apply g (k v) vs)) [] + project (VError msg) = VError msg project v = VP v lbl vs in project (eval g env s t []) eval g env s (ExtR t1 t2) [] = let (s1,s2) = split s @@ -207,6 +203,8 @@ eval g env s (ExtR t1 t2) [] = let (s1,s2) = split s extend v1 (VMeta i vs) = VSusp i (\v -> extend v1 (apply g v vs)) [] extend (VSusp i k vs) v2 = VSusp i (\v -> extend (apply g (k v) vs) v2) [] extend v1 (VSusp i k vs) = VSusp i (\v -> extend v1 (apply g (k v) vs)) [] + extend (VError msg) v2 = VError msg + extend v1 (VError msg) = VError msg extend v1 v2 = VExtR v1 v2 in extend (eval g env s1 t1 []) (eval g env s2 t2 []) @@ -224,15 +222,11 @@ eval g env s (S t1 t2) vs = let (!s1,!s2) = split s v0 = VS v1 v2 vs select (VT _ env s cs) = patternMatch g s v0 (map (\(p,t) -> (env,[p],v2:vs,t)) cs) - select (VV vty tvs) = case value2termM False (map fst env) vty of - EvalM f -> case f g (\x state xs ws -> Success (x:xs) ws) empty [] [] of - Fail msg ws -> VError msg - Success tys ws -> case tys of - [ty] -> vtableSelect g v0 ty tvs v2 vs - tys -> vtableSelect g v0 (FV (reverse tys)) tvs v2 vs + select (VV vty tvs) = vtableSelect g v0 vty tvs v2 vs select (VFV i fvs) = VFV i (fmap select fvs) select (VMeta i vs) = VSusp i (\v -> select (apply g v vs)) [] select (VSusp i k vs) = VSusp i (\v -> select (apply g (k v) vs)) [] + select (VError msg) = VError msg select v1 = v0 -- FIXME: options=[] is definitely not correct and this shouldn't be using value2termM at all @@ -243,12 +237,13 @@ eval g env s (Let (x,(_,t1)) t2) vs = let (!s1,!s2) = split s in eval g ((x,eval g env s1 t1 []):env) s2 t2 vs eval g env c (Q q@(m,id)) vs | m == cPredef = evalPredef g c id vs + | isAbstract = evalAbsDef g c q vs | otherwise = case lookupResDef gr q of - Ok t -> eval g env c t vs + Ok t -> eval g [] c t vs Bad msg -> error msg where - Gl gr predef = g -eval g env s (QC q) vs = VApp s q vs + Gl gr predef isAbstract = g +eval g env c (QC q) vs = VApp q vs eval g env s (C t1 t2) [] = let (!s1,!s2) = split s concat v1 VEmpty = v1 @@ -259,6 +254,8 @@ eval g env s (C t1 t2) [] = let (!s1,!s2) = split s concat v1 (VMeta i vs) = VSusp i (\v -> concat v1 (apply g v vs)) [] concat (VSusp i k vs) v2 = VSusp i (\v -> concat (apply g (k v) vs) v2) [] concat v1 (VSusp i k vs) = VSusp i (\v -> concat v1 (apply g (k v) vs)) [] + concat (VError msg) v2 = VError msg + concat v1 (VError msg) = VError msg concat v1 v2 = VC v1 v2 in concat (eval g env s1 t1 []) (eval g env s2 t2 []) @@ -266,12 +263,12 @@ eval g env s (Glue t1 t2) [] = let (!s1,!s2) = split s glue VEmpty v = v glue (VC v1 v2) v = VC v1 (glue v2 v) - glue (VApp c q []) v - | q == (cPredef,cNonExist) = VApp c q [] + glue (VApp q []) v + | q == (cPredef,cNonExist) = VApp q [] glue v VEmpty = v glue v (VC v1 v2) = VC (glue v v1) v2 - glue v (VApp c q []) - | q == (cPredef,cNonExist) = VApp c q [] + glue v (VApp q []) + | q == (cPredef,cNonExist) = VApp q [] glue (VStr s1) (VStr s2) = VStr (s1++s2) glue v (VAlts d vas) = VAlts (glue v d) [(glue v v',ss) | (v',ss) <- vas] glue (VAlts d vas) (VStr s) = pre d vas s @@ -282,6 +279,8 @@ eval g env s (Glue t1 t2) [] = let (!s1,!s2) = split s glue v1 (VMeta i vs) = VSusp i (\v -> glue v1 (apply g v vs)) [] glue (VSusp i k vs) v2 = VSusp i (\v -> glue (apply g (k v) vs) v2) [] glue v1 (VSusp i k vs)= VSusp i (\v -> glue v1 (apply g (k v) vs)) [] + glue (VError msg) v2 = VError msg + glue v1 (VError msg) = VError msg glue v1 v2 = VGlue v1 v2 pre vd [] s = glue vd (VStr s) @@ -294,7 +293,7 @@ eval g env s (EPatt min max p) [] = VPatt min max p eval g env s (EPattType t) [] = VPattType (eval g env s t []) eval g env s (ELincat c ty) [] = let lbl = lockLabel c lty = RecType [] - in eval g env s (ExtR ty (RecType [(lbl,lty)])) [] + in eval g env s (ExtR ty (RecType [(lbl,[],lty)])) [] eval g env s (ELin c t) [] = let lbl = lockLabel c lt = R [] in eval g env s (ExtR t (R [(lbl,(Nothing,lt))])) [] @@ -308,7 +307,7 @@ eval g env c (Strs ts) [] = VStrs (mapC (\c t -> eval g env c t []) c ts) eval g env c (Markup tag as ts) [] = let (c1,c2) = split c vas = mapC (\c (id,t) -> (id,eval g env c t [])) c1 as - vs = mapC (\c t -> eval g env c t []) c2 ts + vs = mapC (\c (L loc t) -> L loc (eval g env c t [])) c2 ts in (VMarkup tag vas vs) eval g env c (Reset ctl mb_ct t qid) [] = VReset ctl (fmap (\t -> eval g env c t []) mb_ct) (eval g env c t []) qid eval g env c (TSymCat d r rs) []= VSymCat d r [(i,(fromJust (lookup pv env),ty)) | (i,(pv,ty)) <- rs] @@ -320,51 +319,71 @@ eval g env c t@(Opts n cs) vs = if null cs in VFV c3 (VarOpts vn vcs) where evalOpt c' (Just l, t) = let (c1,c2) = split c' in (eval g env c1 l [], eval g env c2 t vs) evalOpt c' (Nothing,t) = let v = eval g env c' t vs in (v, v) -eval g env c t vs = VError ("Cannot reduce term" <+> pp t) +eval g env c t vs = VError ("Cannot reduce term" <+> pp t) evalPredef :: Globals -> Choice -> Ident -> [Value] -> Value -evalPredef g@(Gl gr pds) c n args = +evalPredef g@(Gl gr pds _) c n args = case Map.lookup n pds of - Nothing -> VApp c (cPredef,n) args - Just def -> let valueOf (Const res) = res - valueOf (CFV i vs) = VFV i (fmap valueOf vs) - valueOf (CSusp i k) = VSusp i (valueOf . k) [] - valueOf RunTime = VApp c (cPredef,n) args - valueOf NonExist = VApp c (cPredef,cNonExist) [] - in valueOf (runPredef def g c args) + Nothing -> VApp (cPredef,n) args + Just (Predef k def) -> case splitAt' k args of + Nothing -> VPAP c (cPredef,n) args + Just (usedArgs, remArgs) -> + apply g (valueOf (def g c usedArgs)) remArgs + where + valueOf (Const res) = res + valueOf (CFV i vs) = VFV i (fmap valueOf vs) + valueOf (CSusp i k) = VSusp i (valueOf . k) [] + valueOf RunTime = VConst (cPredef,n) args + valueOf NonExist = VApp (cPredef,cNonExist) [] + +noPredef :: PredefTable +noPredef = Map.empty stdPredef :: Globals -> PredefTable stdPredef g = Map.fromList - [(cInts, pdArity 1 $\ \g c vs -> Const (case vs of {[VInt i] -> VInts i False; vs -> VApp c (cPredef,cInts) vs})) - ,(cLength, pdArity 1 $\ \g c [v] -> fmap (VInt . genericLength) (value2string g v)) - ,(cTake, pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericTake (value2int g v1) (value2string g v2))) - ,(cDrop, pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericDrop (value2int g v1) (value2string g v2))) - ,(cTk, pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericTk (value2int g v1) (value2string g v2))) - ,(cDp, pdArity 2 $\ \g c [v1,v2] -> fmap string2value (liftA2 genericDp (value2int g v1) (value2string g v2))) - ,(cIsUpper,pdArity 1 $\ \g c [v] -> fmap toPBool (liftA (all isUpper) (value2string g v))) - ,(cToUpper,pdArity 1 $\ \g c [v] -> fmap string2value (liftA (map toUpper) (value2string g v))) - ,(cToLower,pdArity 1 $\ \g c [v] -> fmap string2value (liftA (map toLower) (value2string g v))) - ,(cEqStr, pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 (==) (value2string g v1) (value2string g v2))) - ,(cOccur, pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 occur (value2string g v1) (value2string g v2))) - ,(cOccurs, pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 occurs (value2string g v1) (value2string g v2))) - ,(cEqInt, pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 (==) (value2int g v1) (value2int g v2))) - ,(cLessInt,pdArity 2 $\ \g c [v1,v2] -> fmap toPBool (liftA2 (<) (value2int g v1) (value2int g v2))) - ,(cPlus, pdArity 2 $\ \g c [v1,v2] -> fmap VInt (liftA2 (+) (value2int g v1) (value2int g v2))) - ,(cError, pdArity 1 $\ \g c [v] -> fmap (VError . pp) (value2string g v)) + [(cInts, pdArity 1 $ \g c vs -> Const (case vs of {[VInt i] -> VInts i False; vs -> VApp (cPredef,cInts) vs})) + ,(cLength, pdArity 1 $ \g c [v] -> fmap (VInt . genericLength) (value2string g v)) + ,(cTake, pdArity 2 $ \g c [v1,v2] -> fmap string2value (liftA2 genericTake (value2int g v1) (value2string g v2))) + ,(cDrop, pdArity 2 $ \g c [v1,v2] -> fmap string2value (liftA2 genericDrop (value2int g v1) (value2string g v2))) + ,(cTk, pdArity 2 $ \g c [v1,v2] -> fmap string2value (liftA2 genericTk (value2int g v1) (value2string g v2))) + ,(cDp, pdArity 2 $ \g c [v1,v2] -> fmap string2value (liftA2 genericDp (value2int g v1) (value2string g v2))) + ,(cIsUpper,pdArity 1 $ \g c [v] -> fmap toPBool (liftA (all isUpper) (value2string g v))) + ,(cToUpper,pdArity 1 $ \g c [v] -> fmap string2value (liftA (map toUpper) (value2string g v))) + ,(cToLower,pdArity 1 $ \g c [v] -> fmap string2value (liftA (map toLower) (value2string g v))) + ,(cEqStr, pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 (==) (value2string g v1) (value2string g v2))) + ,(cOccur, pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 occur (value2string g v1) (value2string g v2))) + ,(cOccurs, pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 occurs (value2string g v1) (value2string g v2))) + ,(cEqInt, pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 (==) (value2int g v1) (value2int g v2))) + ,(cLessInt,pdArity 2 $ \g c [v1,v2] -> fmap toPBool (liftA2 (<) (value2int g v1) (value2int g v2))) + ,(cPlus, pdArity 2 $ \g c [v1,v2] -> fmap VInt (liftA2 (+) (value2int g v1) (value2int g v2))) + ,(cError, pdArity 1 $ \g c [v] -> fmap (VError . pp) (value2string g v)) ] where genericTk n = reverse . genericDrop n . reverse genericDp n = reverse . genericTake n . reverse +evalAbsDef :: Globals -> Choice -> QIdent -> [Value] -> Value +evalAbsDef g@(Gl gr pds _) c q args = + case lookupAbsDef gr q of + Ok (Just (arity,eqs)) -> + case splitAt' arity args of + Nothing -> VPAP c q args + Just (_,_) -> patternMatch g c (VConst q args) (map (\(ps,t) -> ([],ps,args,t)) eqs) + Ok Nothing -> VApp q args + Bad msg -> error msg + apply g (VMeta i vs0) vs = VMeta i (vs0++vs) apply g (VSusp i k vs0) vs = VSusp i k (vs0++vs) -apply g (VApp c f@(m,n) vs0) vs +apply g (VApp f vs0) vs = VApp f (vs0++vs) +apply g (VPAP c q@(m,n) vs0) vs | m == cPredef = evalPredef g c n (vs0++vs) - | otherwise = VApp c f (vs0++vs) -apply g (VGen i vs0) vs = VGen i (vs0++vs) + | otherwise = evalAbsDef g c q (vs0++vs) +apply g (VConst f vs0) vs = VConst f (vs0++vs) +apply g (VGen i vs0) vs = VGen i (vs0++vs) apply g (VFV i fvs) vs = VFV i (fmap (\v -> apply g v vs) fvs) apply g (VS v1 v2 vs') vs = VS v1 v2 (vs'++vs) apply g (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs +apply g (VError msg) _ = VError msg apply g v [] = v data BubbleVariants @@ -373,7 +392,9 @@ data BubbleVariants bubble v = snd (bubble v) where - bubble (VApp c f vs) = liftL (VApp c f) vs + bubble (VApp f vs) = liftL (VApp f) vs + bubble (VPAP c f vs) = liftL (VPAP c f) vs + bubble (VConst f vs) = liftL (VConst f) vs bubble (VMeta metaid vs) = liftL (VMeta metaid) vs bubble (VSusp metaid k vs) = liftL (VSusp metaid k) vs bubble (VGen i vs) = liftL (VGen i) vs @@ -410,7 +431,7 @@ bubble v = snd (bubble v) bubble (VStrs vs) = liftL VStrs vs bubble (VMarkup tag attrs vs) = let (union1,attrs') = mapAccumL descend' Map.empty attrs - (union2,vs') = mapAccumL descend union1 vs + (union2,vs') = mapAccumL descendL union1 vs in (union2, VMarkup tag attrs' vs') bubble (VReset ctl mb_cv v id) = let (union,v') = bubble v @@ -481,6 +502,10 @@ bubble v = snd (bubble v) let (choices,v') = bubble v in (mergeChoices1 union choices,(i,(v',ty))) + descendL union (L loc v) = + let (choices,v') = bubble v + in (mergeChoices1 union choices,L loc v') + descendR union (l,b,v) = let (choices,v') = bubble v in (mergeChoices1 union choices,(l,b,v')) @@ -497,8 +522,8 @@ bubble v = snd (bubble v) mergeChoices1 = Map.mergeWithKey (\c (n,cnt) _ -> Just (n,cnt+1)) id unitfy mergeChoices2 = Map.mergeWithKey (\c (n,cnt) _ -> Just (n,2)) unitfy unitfy -toPBool True = VApp poison (cPredef,cPTrue) [] -toPBool False = VApp poison (cPredef,cPFalse) [] +toPBool True = VApp (cPredef,cPTrue) [] +toPBool False = VApp (cPredef,cPFalse) [] occur s1 [] = False occur s1 s2@(_:tail) = check s1 s2 @@ -534,20 +559,25 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0 (pp t)) Bad msg -> error msg where - Gl gr _ = g - match env (PV v :ps) eqs (arg:args) = match ((v,arg):env) ps eqs args + Gl gr _ _ = g + match env (PV v :ps) eqs (arg:args) + | v == identW = match env ps eqs args + | otherwise = match ((v,arg):env) ps eqs args match env (PAs v p :ps) eqs (arg:args) = match ((v,arg):env) (p:ps) eqs (arg:args) - match env (PW :ps) eqs (arg:args) = match env ps eqs args match env (PTilde _ :ps) eqs (arg:args) = match env ps eqs args match env (p :ps) eqs (arg:args) = match' env p ps eqs arg args match' env p ps eqs arg args = case (p,arg) of + (p, VConst q vs) -> v0 (p, VMeta i vs) -> VSusp i (\v -> match' env p ps eqs (apply g v vs) args) [] (p, VGen i vs) -> v0 (p, VSusp i k vs) -> VSusp i (\v -> match' env p ps eqs (apply g (k v) vs) args) [] (p, VFV s vs) -> VFV s (fmap (\arg -> match' env p ps eqs arg args) vs) - (PP q qs, VApp c r vs) + (p, VP _ _ _) -> v0 + (p, VS _ _ _) -> v0 + (p, VSymCat _ _ _) -> v0 + (PP q qs, VApp r vs) | q == r -> match env (qs++ps) eqs (vs++args) (PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args (PString s1, VStr s2) @@ -555,24 +585,27 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0 (PString s1, VEmpty) | null s1 -> match env ps eqs args (PSeq min1 max1 p1 min2 max2 p2,v) - -> case value2string g v of - Const str -> let n = length str - lo = min1 `max` (n-fromMaybe n max2) - hi = (n-min2) `min` fromMaybe n max1 - (ds,cs) = splitAt lo str + -> let match_seq (Const str) = let n = length str + lo = min1 `max` (n-fromMaybe n max2) + hi = (n-min2) `min` fromMaybe n max1 + (ds,cs) = splitAt lo str - eqs' = matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args - - in patternMatch g s v0 eqs' - RunTime -> v0 - NonExist -> patternMatch g s v0 eqs + eqs' = matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args + in patternMatch g s v0 eqs' + match_seq (CSusp i k) = VSusp i (match_seq . k) [] + match_seq (CFV c vs) = VFV c (fmap match_seq vs) + match_seq RunTime = v0 + match_seq NonExist = patternMatch g s v0 eqs + in match_seq (value2string g v) (PRep minp maxp p, v) - -> case value2string g v of - Const str -> let n = length (str::String) `div` (max minp 1) - eqs' = matchRep env n minp maxp p minp maxp p ps ((env,PString []:ps,(arg:args),t) : eqs) (arg:args) - in patternMatch g s v0 eqs' - RunTime -> v0 - NonExist -> patternMatch g s v0 eqs + -> let match_rep (Const str) = let n = length (str::String) `div` (max minp 1) + eqs' = matchRep env n minp maxp p minp maxp p ps ((env,PString []:ps,(arg:args),t) : eqs) (arg:args) + in patternMatch g s v0 eqs' + match_rep (CSusp i k) = VSusp i (match_rep . k) [] + match_rep (CFV c vs) = VFV c (fmap match_rep vs) + match_rep RunTime = v0 + match_rep NonExist = patternMatch g s v0 eqs + in match_rep (value2string g v) (PChar, VStr [_]) -> match env ps eqs args (PChars cs, VStr [c]) | elem c cs -> match env ps eqs args @@ -608,19 +641,19 @@ vtableSelect g v0 ty cs v2 vs = select (CFV c vs) = VFV c (fmap select vs) select _ = v0 - value2index (VMeta i vs) ty = CSusp i (\v -> value2index (apply g v vs) ty) - value2index (VSusp i k vs) ty = CSusp i (\v -> value2index (apply g (k v) vs) ty) - value2index (VR as) (RecType lbls) = compute lbls + value2index (VMeta i vs) vty = CSusp i (\v -> value2index (apply g v vs) vty) + value2index (VSusp i k vs) vty = CSusp i (\v -> value2index (apply g (k v) vs) vty) + value2index (VR as) (VRecType lbls _) = compute lbls where - compute [] = pure (0,1) - compute ((lbl,ty):lbls) = + compute [] = pure (0,1) + compute ((lbl,_,vty):lbls) = case lookup lbl as of Just v -> liftA2 (\(r, cnt) (r',cnt') -> (r*cnt'+r',cnt*cnt')) - (value2index v ty) + (value2index v vty) (compute lbls) Nothing -> error (show ("Missing value for label" <+> pp lbl $$ "among" <+> hsep (punctuate (pp ',') (map fst as)))) - value2index (VApp c q args) ty = + value2index (VApp q args) vty = let (r ,ctxt,cnt ) = getIdxCnt q in fmap (\(r', cnt') -> (r+r',cnt)) (compute ctxt args) where @@ -633,7 +666,7 @@ vtableSelect g v0 ty cs v2 vs = compute [] [] = pure (0,1) compute ((_,_,ty):ctxt) (v:vs) = liftA2 (\(r, cnt) (r',cnt') -> (r*cnt'+r',cnt*cnt')) - (value2index v ty) + (value2index v (eval g [] unit ty [])) (compute ctxt vs) getInfo :: QIdent -> (ModuleName,Info) @@ -642,11 +675,11 @@ vtableSelect g v0 ty cs v2 vs = Ok res -> res Bad msg -> error msg - Gl gr _ = g - value2index (VInt n) ty - | Just max <- isTypeInts ty = Const (fromIntegral n,fromIntegral max+1) - value2index (VFV c vs) ty = CFV c (fmap (\v -> value2index v ty) vs) - value2index v ty = RunTime + Gl gr _ _ = g + value2index (VInt n) (VApp c [VInt max]) + | Q c == cnPredef cInts = Const (fromIntegral n,fromIntegral max+1) + value2index (VFV c vs) vty = CFV c (fmap (\v -> value2index v vty) vs) + value2index v vty = RunTime value2term :: Globals -> [Ident] -> Value -> Check Term @@ -658,7 +691,7 @@ value2term g xs v = do data MetaState = Bound Scope Value - | Narrowing Type + | Narrowing Choice Type | Residuation Scope data OptionInfo = OptionInfo @@ -805,8 +838,12 @@ setMeta i ms = EvalM (\g k (State input choices metas opts) r msgs -> in k () state' r msgs) value2termM :: Bool -> [Ident] -> Value -> EvalM Term -value2termM flat xs (VApp c q vs) = - foldM (\t v -> fmap (App t) (value2termM flat xs v)) (if fst q == cPredef then Q q else QC q) vs +value2termM flat xs (VApp q vs) = + vapp2termM flat xs q (QC q) vs +value2termM flat xs (VPAP _ q vs) = + vapp2termM flat xs q (Q q) vs +value2termM flat xs (VConst q vs) = + vapp2termM flat xs q (Q q) vs value2termM flat xs (VMeta i vs) = do mv <- getMeta i case mv of @@ -835,9 +872,16 @@ value2termM flat xs (VProd b x v1 v2) = do t1 <- value2termM flat xs v1 t2 <- value2termM flat xs v2 return (Prod b x t1 t2) -value2termM flat xs (VRecType lbls _) = do - lbls <- mapM (\(lbl,_,v) -> fmap ((,) lbl) (value2termM flat xs v)) lbls +value2termM flat xs (VRecType lbls ext) = do + g <- globals + lbls <- mapM (\(lbl,_,v) -> uncover g lbl xs v) lbls return (RecType lbls) + where + uncover g lbl xs (VClosure env c (Abs b x t)) = do (lbl,deps,t) <- uncover g lbl (x:xs) (VClosure ((x,VGen (length xs) []):env) c t) + return (lbl,x:deps,t) + uncover g lbl xs (VClosure env c t) = fmap ((,,) lbl []) (value2termM flat xs (eval g env c t [])) + uncover g lbl xs v = fmap ((,,) lbl []) (value2termM flat xs v) + value2termM flat xs (VR as) = do as <- mapM (\(lbl,v) -> fmap (\t -> (lbl,(Nothing,t))) (value2termM flat xs v)) as return (R as) @@ -934,7 +978,7 @@ value2termM flat xs (VStrs vs) = do return (Strs ts) value2termM flat xs (VMarkup tag as vs) = do as <- mapM (\(id,v) -> value2termM flat xs v >>= \t -> return (id,t)) as - ts <- mapM (value2termM flat xs) vs + ts <- mapM (mapM (value2termM flat xs)) vs return (Markup tag as ts) value2termM flat xs (VReset ctl mb_cv v mb_qid) = do ts <- reset (value2termM True xs v) @@ -948,7 +992,7 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do _ -> evalError (pp "[concat: .. | ..] requires an integer constant") case ts of [t] -> return t - ts -> return (Markup identW [] ts) + ts -> return (Markup identW [] (map noLoc ts)) | ctl == cConcat' = do ts <- case mb_cv of Just (VInt n) -> return (genericTake n ts) @@ -957,7 +1001,7 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do case ts of [] -> mzero [t] -> return t - ts -> return (Markup identW [] ts) + ts -> return (Markup identW [] (map noLoc ts)) | ctl == cOne = case (ts,mb_cv) of ([] ,Nothing) -> mzero @@ -979,6 +1023,16 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do _ -> evalError (pp "The term must be a record") select n (t:ts) = select (n-1) ts _ -> evalError (pp "[select: .. | ..] requires an integer constant") + | ctl == cFilter = + let filter [] = mzero + filter (t:ts) = + case t of + R rs -> case (lookup (ident2label cp1) rs, lookup (ident2label cp2) rs) of + (Just (_,t), Just (_,Q q)) + | q == (cPredef,cTrue) -> pure t `mplus` filter ts + _ -> filter ts + _ -> evalError (pp "The term must be a record") + in filter ts | ctl == cDefault = case (ts,mb_cv) of ([] ,Nothing) -> mzero @@ -1000,6 +1054,11 @@ value2termM flat xs (VReset ctl mb_cv v mb_qid) = do Just cv -> do g <- globals value2termM True xs (apply g cv [VInt (genericLength ts)]) Nothing -> return (EInt (genericLength ts)) + | ctl == cConst = + case mb_cv of + Just cv -> do ct <- value2termM flat xs cv + msum (map (pure . const ct) ts) + _ -> evalError (pp "[const: .. | ..] requires an argument") | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined") listify mn cat [t1,t2] = do return (App (App (QC (mn,identS ("Base"++cat))) t1) t2) @@ -1014,6 +1073,18 @@ value2termM flat xs (VError msg) = evalError msg value2termM flat xs (VInts n _) = return (App (Q (cPredef,cInts)) (EInt n)) value2termM flat xs v = evalError ("value2termM" <+> ppValue Unqualified 5 v) +vapp2termM flat xs q t vs = do + g@(Gl gr _ isAbstract) <- globals + case (if isAbstract then fmap snd (lookupAbsType gr q) else lookupResType gr q) of + Bad msg -> evalError (pp msg) + Ok ty -> do (t,_) <- foldM app (t,ty) vs + return t + where + app (t,Prod bt _ _ ty) v = do + arg <- value2termM flat xs v + case bt of + Explicit -> return (App t arg,ty) + Implicit -> return (App t (ImplArg arg),ty) pattVars st (PP _ ps) = foldl pattVars st ps pattVars st (PV x) = case st of @@ -1028,10 +1099,23 @@ pattVars st _ = st -ppValue q d (VApp c f vs) = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs)) -ppValue q d (VMeta i vs) = prec d 4 (hsep ((if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs)) +ppValue q d (VApp f vs) + | null vs = ppQIdent q f + | otherwise = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs)) +ppValue q d (VPAP _ f vs) + | null vs = ppQIdent q f + | otherwise = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs)) +ppValue q d (VConst f vs) + | null vs = ppQIdent q f + | otherwise = prec d 4 (hsep (ppQIdent q f : map (ppValue q 5) vs)) +ppValue q d (VMeta i vs) + | null vs = meta + | otherwise = prec d 4 (hsep (meta : map (ppValue q 5) vs)) + where + meta | i > 0 = pp "?" <> pp i + | otherwise = pp "?" ppValue q d (VSusp i k vs) = prec d 4 (hsep (pp "#susp" : (if i > 0 then pp "?" <> pp i else pp "?") : map (ppValue q 5) vs)) -ppValue q d (VGen _ _) = pp "VGen" +ppValue q d (VGen i vs) = prec d 4 (hsep (pp "#gen" : pp i : map (ppValue q 5) vs)) ppValue q d (VClosure env c t) = pp "[|" <> ppTerm q 4 t <> pp "|]" ppValue q d (VProd bt x a b) = if x == identW && bt == Explicit @@ -1043,8 +1127,9 @@ ppValue q d (VRecType xs ext) _ -> doc | otherwise = doc where - doc = braces (fsep (punctuate ';' ([l <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs] ++ [pp ".." | ext]))) -ppValue q d (VR _) = pp "VR" + doc = braces (fsep (punctuate ';' ([l <+> (if o then ":" else ":?") <+> ppValue q 0 v | (l,o,v) <- xs] ++ [pp ".." | ext]))) +ppValue q d (VR []) = pp "<>" -- to distinguish from {} empty RecType +ppValue q d (VR xs) = braces (fsep (punctuate ';' [l <+> '=' <+> ppValue q 0 v | (l,v) <- xs])) ppValue q d (VP v l vs) = prec d 5 (hsep (ppValue q 5 v <> '.' <> l : map (ppValue q 5) vs)) ppValue q d (VExtR _ _) = pp "VExtR" ppValue q d (VTable kt vt) = prec d 0 (ppValue q 3 kt <+> "=>" <+> ppValue q 0 vt) @@ -1096,24 +1181,24 @@ value2string' g (VC v1 v2) b ws qs = concat v1 (value2string' g v2 b concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs concat v1 (CFV c vs) = CFV c (fmap (concat v1) vs) concat v1 res = res -value2string' g (VApp c q []) b ws qs +value2string' g (VApp q []) b ws qs | q == (cPredef,cNonExist) = NonExist -value2string' g (VApp c q []) b ws qs +value2string' g (VApp q []) b ws qs | q == (cPredef,cSOFT_SPACE) = if null ws then Const (b,ws,q:qs) else Const (b,ws,qs) -value2string' g (VApp c q []) b ws qs +value2string' g (VApp q []) b ws qs | q == (cPredef,cBIND) || q == (cPredef,cSOFT_BIND) = if null ws then Const (True,ws,q:qs) else Const (True,ws,qs) -value2string' g (VApp c q []) b ws qs +value2string' g (VApp q []) b ws qs | q == (cPredef,cCAPIT) = capit ws where capit [] = Const (b,[],q:qs) capit ((c:cs) : ws) = Const (b,(toUpper c : cs) : ws,qs) capit ws = Const (b,ws,qs) -value2string' g (VApp c q []) b ws qs +value2string' g (VApp q []) b ws qs | q == (cPredef,cALL_CAPIT) = all_capit ws where all_capit [] = Const (b,[],q:qs) @@ -1154,7 +1239,7 @@ value2float g (VFlt f) = Const f value2float g (VFV s vs) = CFV s (fmap (value2float g) vs) value2float g _ = RunTime -value2expr g xs (VApp _ (m,f) vs) +value2expr g xs (VApp (m,f) vs) | m /= cPredef = foldl (\e v -> fmap EApp e <*> value2expr g xs v) (pure (EFun (showIdent f))) vs value2expr g xs (VMeta i vs) = CSusp i (\v -> value2expr g xs (apply g v vs)) value2expr g xs (VSusp i k vs) = CSusp i (\v -> value2expr g xs (apply g (k v) vs)) @@ -1174,9 +1259,6 @@ newtype Choice = Choice { unchoice :: Integer } unit :: Choice unit = Choice 1 -poison :: Choice -poison = Choice (-1) - split :: Choice -> (Choice,Choice) split (Choice c) = (Choice (2*c), Choice (2*c+1)) diff --git a/src/compiler/api/GF/Compile/Compute/Abstract.hs b/src/compiler/api/GF/Compile/Compute/Abstract.hs deleted file mode 100644 index 5ba2eeb21..000000000 --- a/src/compiler/api/GF/Compile/Compute/Abstract.hs +++ /dev/null @@ -1,138 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Compile.Abstract.Compute --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/02 20:50:19 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.8 $ --- --- computation in abstract syntax w.r.t. explicit definitions. --- --- old GF computation; to be updated ------------------------------------------------------------------------------ - -module GF.Compile.Compute.Abstract (LookDef, - compute, - computeAbsTerm, - computeAbsTermIn, - beta - ) where - -import GF.Data.Operations - -import GF.Grammar -import GF.Grammar.Lookup - -import Debug.Trace -import Data.List(intersperse) -import Control.Monad (liftM, liftM2) -import GF.Text.Pretty - --- for debugging -tracd m t = t --- tracd = trace - -compute :: SourceGrammar -> Term -> Err Term -compute = computeAbsTerm - -computeAbsTerm :: SourceGrammar -> Term -> Err Term -computeAbsTerm gr = computeAbsTermIn (lookupAbsDef gr) [] - --- | a hack to make compute work on source grammar as well -type LookDef = Ident -> Ident -> Err (Maybe Int,Maybe [Equation]) - -computeAbsTermIn :: LookDef -> [Ident] -> Term -> Err Term -computeAbsTermIn lookd xs e = errIn (render (text "computing" <+> ppTerm Unqualified 0 e)) $ compt xs e where - compt vv t = case t of --- Prod x a b -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b) --- Abs x b -> liftM (Abs x) (compt (x:vv) b) - _ -> do - let t' = beta vv t - (yy,f,aa) <- termForm t' - let vv' = map snd yy ++ vv - aa' <- mapM (compt vv') aa - case look f of - Just eqs -> tracd (text "\nmatching" <+> ppTerm Unqualified 0 f) $ - case findMatch eqs aa' of - Ok (d,g) -> do - --- let (xs,ts) = unzip g - --- ts' <- alphaFreshAll vv' ts - let g' = g --- zip xs ts' - d' <- compt vv' $ substTerm vv' g' d - tracd (text "by Egs:" <+> ppTerm Unqualified 0 d') $ return $ mkAbs yy $ d' - _ -> tracd (text "no match" <+> ppTerm Unqualified 0 t') $ - do - let v = mkApp f aa' - return $ mkAbs yy $ v - _ -> do - let t2 = mkAbs yy $ mkApp f aa' - tracd (text "not defined" <+> ppTerm Unqualified 0 t2) $ return t2 - - look t = case t of - (Q (m,f)) -> case lookd m f of - Ok (_,md) -> md - _ -> Nothing - _ -> Nothing - -beta :: [Ident] -> Exp -> Exp -beta vv c = case c of - Let (x,(_,a)) b -> beta vv $ substTerm vv [(x,beta vv a)] (beta (x:vv) b) - App f a -> - let (a',f') = (beta vv a, beta vv f) in - case f' of - Abs _ x b -> beta vv $ substTerm vv [(x,a')] (beta (x:vv) b) - _ -> (if a'==a && f'==f then id else beta vv) $ App f' a' - Prod b x a t -> Prod b x (beta vv a) (beta (x:vv) t) - Abs b x t -> Abs b x (beta (x:vv) t) - _ -> c - --- special version of pattern matching, to deal with comp under lambda - -findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution) -findMatch cases terms = case cases of - [] -> Bad $ render (text "no applicable case for" <+> hcat (punctuate comma (map (ppTerm Unqualified 0) terms))) - (patts,_):_ | length patts /= length terms -> - Bad (render (text "wrong number of args for patterns :" <+> - hsep (map (ppPatt Unqualified 0) patts) <+> text "cannot take" <+> hsep (map (ppTerm Unqualified 0) terms))) - (patts,val):cc -> case mapM tryMatch (zip patts terms) of - Ok substs -> return (tracd (text "value" <+> ppTerm Unqualified 0 val) val, concat substs) - _ -> findMatch cc terms - -tryMatch :: (Patt, Term) -> Err [(Ident, Term)] -tryMatch (p,t) = do - t' <- termForm t - trym p t' - where - - trym p t' = err (\s -> tracd s (Bad s)) (\t -> tracd (prtm p t) (return t)) $ ---- - case (p,t') of - (PW, _) | notMeta t -> return [] -- optimization with wildcard - (PV x, _) | notMeta t -> return [(x,t)] - (PString s, ([],K i,[])) | s==i -> return [] - (PInt s, ([],EInt i,[])) | s==i -> return [] - (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding? - (PP (q,p) pp, ([], QC (r,f), tt)) | - p `eqStrIdent` f && length pp == length tt -> do - matches <- mapM tryMatch (zip pp tt) - return (concat matches) - (PP (q,p) pp, ([], Q (r,f), tt)) | - p `eqStrIdent` f && length pp == length tt -> do - matches <- mapM tryMatch (zip pp tt) - return (concat matches) - (PT _ p',_) -> trym p' t' - (PAs x p',_) -> do - subst <- trym p' t' - return $ (x,t) : subst - _ -> Bad (render (text "no match in pattern" <+> ppPatt Unqualified 0 p <+> text "for" <+> ppTerm Unqualified 0 t)) - - notMeta e = case e of - Meta _ -> False - App f a -> notMeta f && notMeta a - Abs _ _ b -> notMeta b - _ -> True - - prtm p g = - ppPatt Unqualified 0 p <+> colon $$ hsep (punctuate semi [ppIdent x <+> char '=' <+> ppTerm Unqualified 0 y | (x,y) <- g]) diff --git a/src/compiler/api/GF/Compile/Compute/Concrete.hs b/src/compiler/api/GF/Compile/Compute/Concrete.hs deleted file mode 100644 index 7306fab4f..000000000 --- a/src/compiler/api/GF/Compile/Compute/Concrete.hs +++ /dev/null @@ -1,1023 +0,0 @@ -{-# 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, normalFlatForm, normalStringForm - , Value(..), Thunk, ThunkState(..), Env, Scope, showValue, isCanonicalForm - , PredefImpl, Predef(..), PredefCombinator, ($\) - , pdForce, pdCanonicalArgs, pdArity, pdStandard - , MetaThunks, Constraint, PredefTable, Globals(..), ConstValue(..) - , EvalM(..), runEvalM, runEvalOneM, reset, try, evalError, evalWarn - , eval, apply, force, value2term, patternMatch, stdPredef - , unsafeIOToEvalM - , newThunk, newEvaluatedThunk - , newResiduation, newNarrowing, getVariables - , getRef, setRef - , getResDef, getInfo, getResType, getOverload - , getAllParamValues - ) where - -import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint -import GF.Grammar hiding (Env, VGen, VApp, VRecType) -import GF.Grammar.Lookup(lookupResDef,lookupResType, - lookupOrigInfo,lookupOverloadTypes, - allParamValues) -import GF.Grammar.Predef -import GF.Grammar.Lockfield(lockLabel) -import GF.Grammar.Printer -import GF.Data.Operations(Err(..)) -import GF.Data.Utilities(splitAt') -import GF.Infra.CheckM -import GF.Infra.Option -import Data.STRef -import Data.Maybe(fromMaybe) -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 Data.Functor ((<&>)) -import qualified Data.Map as Map -import GF.Text.Pretty -import PGF2.Transactions(LIndex) - --- * Main entry points - --- | The term is fully evaluated. Variants are only expanded if necessary for the evaluation. -normalForm :: Globals -> Term -> Check Term -normalForm globals t = - fmap mkFV (runEvalM globals (eval [] t [] >>= value2term False [])) - where - mkFV [t] = t - mkFV ts = FV ts - --- | The result is a list of terms and contains all variants. Each term by itself does not contain any variants. -normalFlatForm :: Globals -> Term -> Check [Term] -normalFlatForm globals t = - runEvalM globals (eval [] t [] >>= value2term True []) - -normalStringForm :: Globals -> Term -> Check [String] -normalStringForm globals t = - fmap toStrs (runEvalM globals (fmap value2string (eval [] t []))) - where - toStrs [] = [] - toStrs (Const s:cfs) = s : toStrs cfs - toStrs (_ :cfs) = toStrs cfs - -type Sigma s = Value s -type Constraint s = Value s - -data ThunkState s - = Unevaluated (Env s) Term - | Evaluated {-# UNPACK #-} !Int (Value s) - | Hole {-# UNPACK #-} !MetaId - | Narrowing {-# UNPACK #-} !MetaId Type - | Residuation {-# UNPACK #-} !MetaId (Scope s) (Maybe (Constraint s)) - -type Thunk s = STRef s (ThunkState s) -type Env s = [(Ident,Thunk s)] -type Scope s = [(Ident,Value s)] - -data Value s - = VApp QIdent [Thunk s] - | VMeta (Thunk s) [Thunk s] - | VSusp (Thunk s) (Value s -> EvalM s (Value s)) [Thunk s] - | VGen {-# UNPACK #-} !Int [Thunk s] - | VClosure (Env s) Term - | VProd BindType Ident (Value s) (Value s) - | VRecType [(Label, Value s)] - | VR [(Label, Thunk s)] - | VP (Value s) Label [Thunk s] - | VExtR (Value s) (Value s) - | VTable (Value s) (Value s) - | VT (Value s) (Env s) [Case] - | VV (Value s) [Thunk s] - | VS (Value s) (Thunk s) [Thunk s] - | VSort Ident - | VInt Integer - | VFlt Double - | VStr String - | VEmpty - | VC (Value s) (Value s) - | VGlue (Value s) (Value s) - | VPatt Int (Maybe Int) Patt - | VPattType (Value s) - | VAlts (Value s) [(Value s, Value s)] - | VStrs [Value s] - | VMarkup Ident [(Ident,Value s)] [Value s] - -- These two constructors are only used internally - -- in the PMCFG generator. - | VSymCat Int LIndex [(LIndex, (Thunk s, Type))] - | VSymVar Int Int - -- These two constructors are only used internally - -- in the type checker. - | VCRecType [(Label, Bool, Constraint s)] - | VCInts (Maybe Integer) (Maybe Integer) - -showValue (VApp q tnks) = "(VApp "++unwords (show q : map (const "_") tnks) ++ ")" -showValue (VMeta _ _) = "VMeta" -showValue (VSusp _ _ _) = "VSusp" -showValue (VGen i _) = "(VGen "++show i++")" -showValue (VClosure _ _) = "VClosure" -showValue (VProd _ x v1 v2) = "VProd ("++show x++") ("++showValue v1++") ("++showValue v2++")" -showValue (VRecType _) = "VRecType" -showValue (VR lbls) = "(VR {"++unwords (map (\(lbl,_) -> show lbl) lbls)++"})" -showValue (VP v l _) = "(VP "++showValue v++" "++show l++")" -showValue (VExtR _ _) = "VExtR" -showValue (VTable v1 v2) = "VTable ("++showValue v1++") ("++showValue v2++")" -showValue (VT _ _ cs) = "(VT "++show cs++")" -showValue (VV _ _) = "VV" -showValue (VS v _ _) = "(VS "++showValue v++")" -showValue (VSort s) = "(VSort "++show s++")" -showValue (VInt _) = "VInt" -showValue (VFlt _) = "VFlt" -showValue (VStr s) = "(VStr "++show s++")" -showValue VEmpty = "VEmpty" -showValue (VC v1 v2) = "(VC "++showValue v1++" "++showValue v2++")" -showValue (VGlue _ _) = "VGlue" -showValue (VPatt _ _ _) = "VPatt" -showValue (VPattType _) = "VPattType" -showValue (VAlts _ _) = "VAlts" -showValue (VStrs _) = "VStrs" -showValue (VSymCat _ _ _) = "VSymCat" - -isCanonicalForm :: Value s -> Bool -isCanonicalForm (VClosure {}) = True -isCanonicalForm (VProd b x d cod) = isCanonicalForm d && isCanonicalForm cod -isCanonicalForm (VRecType fs) = all (isCanonicalForm . snd) fs -isCanonicalForm (VR {}) = True -isCanonicalForm (VTable d cod) = isCanonicalForm d && isCanonicalForm cod -isCanonicalForm (VT {}) = True -isCanonicalForm (VV {}) = True -isCanonicalForm (VSort {}) = True -isCanonicalForm (VInt {}) = True -isCanonicalForm (VFlt {}) = True -isCanonicalForm (VStr {}) = True -isCanonicalForm VEmpty = True -isCanonicalForm (VAlts d vs) = all (isCanonicalForm . snd) vs -isCanonicalForm (VStrs vs) = all isCanonicalForm vs -isCanonicalForm (VMarkup tag as vs) = all (isCanonicalForm . snd) as && all isCanonicalForm vs -isCanonicalForm _ = False - -eval env (Vr x) vs = do (tnk,depth) <- lookup x env - withVar depth $ do - v <- force tnk - apply v vs - where - lookup x [] = evalError ("Variable" <+> pp x <+> "is not in scope") - lookup x ((y,tnk):env) - | x == y = return (tnk,length env) - | otherwise = lookup x env -eval env (Sort s) [] - | s == cTok = return (VSort cStr) - | otherwise = return (VSort s) -eval env (EInt n) [] = return (VInt n) -eval env (EFloat d) [] = return (VFlt d) -eval env (K t) [] = return (VStr t) -eval env Empty [] = return VEmpty -eval env (App t1 t2) vs = do tnk <- newThunk env t2 - eval env t1 (tnk : vs) -eval env (Abs b x t) [] = return (VClosure env (Abs b x t)) -eval env (Abs b x t) (v:vs) = eval ((x,v):env) t vs -eval env (Meta i) vs = do tnk <- newHole i - return (VMeta tnk vs) -eval env (ImplArg t) [] = eval env t [] -eval env (Prod b x t1 t2)[] = do v1 <- eval env t1 [] - return (VProd b x v1 (VClosure env t2)) -eval env (Typed t ty) vs = eval env t vs -eval env (RecType lbls) [] = do lbls <- mapM (\(lbl,ty) -> fmap ((,) lbl) (eval env ty [])) lbls - return (VRecType (sortRec lbls)) -eval env (R as) [] = do as <- mapM (\(lbl,(_,t)) -> fmap ((,) lbl) (newThunk env t)) as - return (VR as) -eval env (P t lbl) vs = do v <- eval env t [] - case v of - VR as -> case lookup lbl as of - Nothing -> evalError ("Missing value for label" <+> pp lbl $$ - "in" <+> pp (P t lbl)) - Just tnk -> do v <- force tnk - apply v vs - v -> return (VP v lbl vs) -eval env (ExtR t1 t2) [] = do v1 <- eval env t1 [] - v2 <- eval env t2 [] - case (v1,v2) of - (VR as1,VR as2) -> return (VR (foldl (\as (lbl,v) -> update lbl v as) as1 as2)) - (VRecType as1,VRecType as2) -> return (VRecType (foldl (\as (lbl,v) -> update lbl v as) as1 as2)) - _ -> return (VExtR v1 v2) -eval env (Table t1 t2) [] = do v1 <- eval env t1 [] - v2 <- eval env t2 [] - return (VTable v1 v2) -eval env (T (TTyped ty) cs)[]=do vty <- eval env ty [] - return (VT vty env cs) -eval env (T (TWild ty) cs) []=do vty <- eval env ty [] - return (VT vty env cs) -eval env (V ty ts) [] = do vty <- eval env ty [] - tnks <- mapM (newThunk env) ts - return (VV vty tnks) -eval env (S t1 t2) vs = do v1 <- eval env t1 [] - tnk2 <- newThunk env t2 - let v0 = VS v1 tnk2 vs - case v1 of - VT _ env cs -> patternMatch v0 (map (\(p,t) -> (env,[p],tnk2:vs,t)) cs) - VV vty tnks -> do ty <- value2term True (map fst env) vty - vtableSelect v0 ty tnks tnk2 vs - v1 -> return v0 -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 = evalPredef id vs - | otherwise = do t <- getResDef q - eval env t vs -eval env (QC q) vs = return (VApp q vs) -eval env (C t1 t2) [] = do v1 <- eval env t1 [] - v2 <- eval env t2 [] - case (v1,v2) of - (v1, VEmpty) -> return v1 - (VEmpty,v2 ) -> return v2 - _ -> return (VC v1 v2) -eval env t@(Glue t1 t2) [] = do v1 <- eval env t1 [] - v2 <- eval env t2 [] - let glue VEmpty v = v - glue (VC v1 v2) v = VC v1 (glue v2 v) - glue (VApp q []) v - | q == (cPredef,cNonExist) = VApp q [] - glue v VEmpty = v - glue v (VC v1 v2) = VC (glue v v1) v2 - glue v (VApp q []) - | q == (cPredef,cNonExist) = VApp q [] - glue (VStr s1) (VStr s2) = VStr (s1++s2) - glue v (VAlts d vas) = VAlts (glue v d) [(glue v v',ss) | (v',ss) <- vas] - glue (VAlts d vas) (VStr s) = pre d vas s - glue (VAlts d vas) v = glue d v - glue v1 v2 = VGlue v1 v2 - - pre vd [] s = glue vd (VStr s) - pre vd ((v,VStrs ss):vas) s - | or [startsWith s' s | VStr s' <- ss] = glue v (VStr s) - | otherwise = pre vd vas s - - return (glue v1 v2) -eval env (EPatt min max p) [] = return (VPatt min max p) -eval env (EPattType t) [] = do v <- eval env t [] - return (VPattType v) -eval env (ELincat c ty) [] = do v <- eval env ty [] - let lbl = lockLabel c - lv = VRecType [] - case v of - (VRecType as) -> return (VRecType (update lbl lv as)) - _ -> return (VExtR v (VRecType [(lbl,lv)])) -eval env (ELin c t) [] = do v <- eval env t [] - let lbl = lockLabel c - tnk <- newEvaluatedThunk (VR []) - case v of - (VR as) -> return (VR (update lbl tnk as)) - _ -> return (VExtR v (VR [(lbl,tnk)])) -eval env (FV ts) vs = msum [eval env t vs | t <- ts] -eval env (Alts d as) [] = do vd <- eval env d [] - vas <- forM as $ \(t,s) -> do - vt <- eval env t [] - vs <- eval env s [] - return (vt,vs) - return (VAlts vd vas) -eval env (Strs ts) [] = do vs <- mapM (\t -> eval env t []) ts - return (VStrs vs) -eval env (Markup tag as ts) [] = - do as <- mapM (\(id,t) -> eval env t [] >>= \v -> return (id,v)) as - vs <- mapM (\t -> eval env t []) ts - return (VMarkup tag as vs) -eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,(pv,ty)) -> - case lookup pv env of - Just tnk -> return (i,(tnk,ty)) - Nothing -> evalError ("Variable" <+> pp pv <+> "is not in scope") - return (VSymCat d r rs) -eval env (TSymVar d r) [] = do return (VSymVar d r) -eval env t@(Opts n cs) vs = EvalM $ \gr k e mt b r msgs -> - case cs of - [] -> return $ Fail ("No options in expression:" $$ ppTerm Unqualified 0 t) msgs - ((l,t):_) -> case eval env t vs of EvalM f -> f gr k e mt b r msgs -eval env t vs = evalError ("Cannot reduce term" <+> pp t) - -apply v [] = return v -apply (VMeta m vs0) vs = return (VMeta m (vs0++vs)) -apply (VSusp m k vs0) vs = return (VSusp m k (vs0++vs)) -apply (VApp f@(m,p) vs0) vs - | m == cPredef = evalPredef p (vs0++vs) - | otherwise = return (VApp f (vs0++vs)) -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 - - -stdPredef :: PredefTable s -stdPredef = Map.fromList - [(cLength, pd 1 $\ \[v] -> case value2string v of - Const s -> return (Const (VInt (genericLength s))) - _ -> return RunTime) - ,(cTake, pd 2 $\ \[v1,v2] -> return (fmap string2value (liftA2 genericTake (value2int v1) (value2string v2)))) - ,(cDrop, pd 2 $\ \[v1,v2] -> return (fmap string2value (liftA2 genericDrop (value2int v1) (value2string v2)))) - ,(cTk, pd 2 $\ \[v1,v2] -> return (fmap string2value (liftA2 genericTk (value2int v1) (value2string v2)))) - ,(cDp, pd 2 $\ \[v1,v2] -> return (fmap string2value (liftA2 genericDp (value2int v1) (value2string v2)))) - ,(cIsUpper,pd 1 $\ \[v] -> return (fmap toPBool (liftA (all isUpper) (value2string v)))) - ,(cToUpper,pd 1 $\ \[v] -> return (fmap string2value (liftA (map toUpper) (value2string v)))) - ,(cToLower,pd 1 $\ \[v] -> return (fmap string2value (liftA (map toLower) (value2string v)))) - ,(cEqStr, pd 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 (==) (value2string v1) (value2string v2)))) - ,(cOccur, pd 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 occur (value2string v1) (value2string v2)))) - ,(cOccurs, pd 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 occurs (value2string v1) (value2string v2)))) - ,(cEqInt, pd 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 (==) (value2int v1) (value2int v2)))) - ,(cLessInt,pd 2 $\ \[v1,v2] -> return (fmap toPBool (liftA2 (<) (value2int v1) (value2int v2)))) - ,(cPlus, pd 2 $\ \[v1,v2] -> return (fmap VInt (liftA2 (+) (value2int v1) (value2int v2)))) - ,(cError, pd 1 $\ \[v] -> case value2string v of - Const msg -> fail msg - _ -> fail "Indescribable error appeared") - ] - where - pd n = pdArity n . pdForce - genericTk n = reverse . genericDrop n . reverse - genericDp n = reverse . genericTake n . reverse - -toPBool True = VApp (cPredef,cPTrue) [] -toPBool False = VApp (cPredef,cPFalse) [] - -occur s1 [] = False -occur s1 s2@(_:tail) = check s1 s2 - where - check xs [] = False - check [] ys = True - check (x:xs) (y:ys) - | x == y = check xs ys - check _ _ = occur s1 tail - -occurs cs s2 = any (\c -> elem c s2) cs - -update lbl v [] = [(lbl,v)] -update lbl v (a@(lbl',_):as) - | lbl==lbl' = (lbl,v) : as - | otherwise = a : update lbl v as - - -patternMatch v0 [] = return v0 -patternMatch v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0 - where - match env [] eqs args = eval env t args - match env (PT ty p :ps) eqs args = match env (p:ps) eqs args - match env (PAlt p1 p2:ps) eqs args = match env (p1:ps) ((env,p2:ps,args,t):eqs) args - match env (PM q :ps) eqs args = do t <- getResDef q - v <- eval [] t [] - case v of - VPatt _ _ p -> match env (p:ps) eqs args - _ -> evalError $ hang "Expected pattern macro:" 4 - (pp t) - match env (PV v :ps) eqs (arg:args) = match ((v,arg):env) ps eqs args - match env (PAs v p :ps) eqs (arg:args) = match ((v,arg):env) (p:ps) eqs (arg:args) - match env (PW :ps) eqs (arg:args) = match env ps eqs args - match env (PTilde _ :ps) eqs (arg:args) = match env ps eqs args - match env (p :ps) eqs (arg:args) = do - v <- force arg - match' env p ps eqs arg v args - - match' env p ps eqs arg v args = do - case (p,v) of - (p, VMeta i vs) -> susp i (\v -> apply v vs >>= \v -> match' env p ps eqs arg v args) - (p, VGen i vs) -> return v0 - (p, VSusp i k vs) -> susp i (\v -> k v >>= \v -> apply v vs >>= \v -> match' env p ps eqs arg v args) - (PP q qs, VApp r tnks) - | q == r -> match env (qs++ps) eqs (tnks++args) - (PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args - (PString s1, VStr s2) - | s1 == s2 -> match env ps eqs args - (PString s1, VEmpty) - | null s1 -> match env ps eqs args - (PSeq min1 max1 p1 min2 max2 p2,v) - -> case value2string v of - Const s -> let n = length s - lo = min1 `max` (n-fromMaybe n max2) - hi = (n-min2) `min` fromMaybe n max1 - (ds,cs) = splitAt lo s - in if lo <= hi - then do eqs <- matchStr env (p1:p2:ps) eqs (hi-lo) (reverse ds) cs args - patternMatch v0 eqs - else patternMatch v0 eqs - RunTime -> return v0 - NonExist-> patternMatch v0 eqs - (PRep minp maxp p, v) - -> case value2string v of - Const s -> do let n = length s `div` (max minp 1) - eqs <- matchRep env n minp maxp p minp maxp p ps ((env,PString []:ps,(arg:args),t) : eqs) (arg:args) - patternMatch v0 eqs - RunTime -> return v0 - NonExist-> patternMatch v0 eqs - (PChar, VStr [c]) -> match env ps eqs args - (PChars cs, VStr [c]) - | elem c cs -> match env ps eqs args - (PInt n, VInt m) - | n == m -> match env ps eqs args - (PFloat n, VFlt m) - | n == m -> match env ps eqs args - _ -> patternMatch v0 eqs - - matchRec env [] as ps eqs args = match env ps eqs args - matchRec env ((lbl,p):pas) as ps eqs args = - case lookup lbl as of - Just tnk -> matchRec env pas as (p:ps) eqs (tnk:args) - Nothing -> evalError ("Missing value for label" <+> pp lbl) - - matchStr env ps eqs i ds [] args = do - arg1 <- newEvaluatedThunk (string2value (reverse ds)) - arg2 <- newEvaluatedThunk (string2value []) - return ((env,ps,arg1:arg2:args,t) : eqs) - matchStr env ps eqs 0 ds cs args = do - arg1 <- newEvaluatedThunk (string2value (reverse ds)) - arg2 <- newEvaluatedThunk (string2value cs) - return ((env,ps,arg1:arg2:args,t) : eqs) - matchStr env ps eqs i ds (c:cs) args = do - arg1 <- newEvaluatedThunk (string2value (reverse ds)) - arg2 <- newEvaluatedThunk (string2value (c:cs)) - eqs <- matchStr env ps eqs (i-1 :: Int) (c:ds) cs args - return ((env,ps,arg1:arg2:args,t) : eqs) - - matchRep env 0 minp maxp p minq maxq q ps eqs args = do - return eqs - matchRep env n minp maxp p minq maxq q ps eqs args = do - matchRep env (n-1) minp maxp p (minp+minq) (liftM2 (+) maxp maxq) (PSeq minp maxp p minq maxq q) ps ((env,q:ps,args,t) : eqs) args - - -vtableSelect v0 ty tnks tnk2 vs = do - v2 <- force tnk2 - (i,_) <- value2index v2 ty - v <- force (tnks !! i) - apply v vs - where - value2index (VR as) (RecType lbls) = compute lbls - where - compute [] = return (0,1) - compute ((lbl,ty):lbls) = do - case lookup lbl as of - Just tnk -> do v <- force tnk - (r, cnt ) <- value2index v ty - (r',cnt') <- compute lbls - return (r*cnt'+r',cnt*cnt') - Nothing -> evalError ("Missing value for label" <+> pp lbl $$ - "among" <+> hsep (punctuate (pp ',') (map fst as))) - value2index (VApp q tnks) ty = do - (r ,ctxt,cnt ) <- getIdxCnt q - (r', cnt') <- compute ctxt tnks - return (r+r',cnt) - where - getIdxCnt q = do - (_,ResValue (L _ ty) idx) <- getInfo q - let (ctxt,QC p) = typeFormCnc ty - (_,ResParam _ (Just (_,cnt))) <- getInfo p - return (idx,ctxt,cnt) - - compute [] [] = return (0,1) - compute ((_,_,ty):ctxt) (tnk:tnks) = do - v <- force tnk - (r, cnt ) <- value2index v ty - (r',cnt') <- compute ctxt tnks - return (r*cnt'+r',cnt*cnt') - value2index (VInt n) ty - | Just max <- isTypeInts ty = return (fromIntegral n,fromIntegral max+1) - value2index (VMeta i vs) ty = do - v <- susp i (\v -> apply v vs) - value2index v ty - value2index (VSusp i k vs) ty = do - v <- susp i (\v -> k v >>= \v -> apply v vs) - value2index v ty - value2index v ty = do t <- value2term True [] v - evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$ - "cannot be evaluated at compile time.") - - -susp i ki = EvalM $ \globals@(Gl gr _) k e 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 globals k e mt d r msgs s m ps - Bad msg -> return (Fail (pp msg) msgs) - Narrowing id ty - | Just max <- isTypeInts ty - -> bindInt globals k e mt d r msgs s 0 max - Evaluated _ v -> case ki v of - EvalM f -> f globals k e mt d r msgs - _ -> k (VSusp i ki []) mt d r msgs - where - bindParam gr k e mt d r msgs s m [] = return (Success r msgs) - bindParam gr k e mt d r msgs s m ((p, ctxt):ps) = do - (mt',tnks) <- mkArgs mt ctxt - let v = VApp (m,p) tnks - writeSTRef i (Evaluated 0 v) - res <- case ki v of - EvalM f -> f gr k e mt' d r msgs - writeSTRef i s - case res of - Fail msg msgs -> return (Fail msg msgs) - Success r msgs -> bindParam gr k e mt d r msgs s m ps - - mkArgs mt [] = return (mt,[]) - mkArgs mt ((_,_,ty):ctxt) = do - let i = case Map.maxViewWithKey mt of - Just ((i,_),_) -> i+1 - _ -> 0 - tnk <- newSTRef (Narrowing i ty) - (mt,tnks) <- mkArgs (Map.insert i tnk mt) ctxt - return (mt,tnk:tnks) - - bindInt gr k e mt d r msgs s iv max - | iv <= max = do - let v = VInt iv - writeSTRef i (Evaluated 0 v) - res <- case ki v of - EvalM f -> f gr k e mt d r msgs - writeSTRef i s - case res of - Fail msg msgs -> return (Fail msg msgs) - Success r msgs -> bindInt gr k e mt d r msgs s (iv+1) max - | otherwise = return (Success r msgs) - - -value2term flat xs (VApp q tnks) = - foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (if fst q == cPredef then Q q else QC q) tnks -value2term flat xs (VMeta m vs) = do - s <- getRef m - case s of - Evaluated _ v -> do v <- apply v vs - value2term flat xs v - Unevaluated env t -> do v <- eval env t vs - value2term flat xs v - Hole i -> foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (Meta i) vs - Residuation i _ ctr -> case ctr of - Just ctr -> value2term flat xs ctr - Nothing -> foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (Meta i) vs - Narrowing i _ -> foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (Meta i) vs -value2term flat xs (VSusp j k vs) = do - v <- k (VGen maxBound vs) - value2term flat xs v -value2term flat xs (VGen j tnks) = - foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (Vr (reverse xs !! j)) tnks -value2term flat xs (VClosure env (Abs b x t)) = do - tnk <- newEvaluatedThunk (VGen (length xs) []) - v <- eval ((x,tnk):env) t [] - let x' = mkFreshVar xs x - t <- value2term flat (x':xs) v - return (Abs b x' t) -value2term flat xs (VProd b x v1 v2) - | x == identW = do t1 <- value2term flat xs v1 - v2 <- case v2 of - VClosure env t2 -> eval env t2 [] - v2 -> return v2 - t2 <- value2term flat xs v2 - return (Prod b x t1 t2) - | otherwise = do t1 <- value2term flat xs v1 - tnk <- newEvaluatedThunk (VGen (length xs) []) - v2 <- case v2 of - VClosure env t2 -> eval ((x,tnk):env) t2 [] - v2 -> return v2 - t2 <- value2term flat (x:xs) v2 - return (Prod b (mkFreshVar xs x) t1 t2) -value2term flat xs (VRecType lbls) = do - lbls <- mapM (\(lbl,v) -> fmap ((,) lbl) (value2term flat xs v)) lbls - return (RecType lbls) -value2term flat xs (VR as) = do - as <- mapM (\(lbl,tnk) -> fmap (\t -> (lbl,(Nothing,t))) (tnk2term flat xs tnk)) as - return (R as) -value2term flat xs (VP v lbl tnks) = do - t <- value2term flat xs v - foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (P t lbl) tnks -value2term flat xs (VExtR v1 v2) = do - t1 <- value2term flat xs v1 - t2 <- value2term flat xs v2 - return (ExtR t1 t2) -value2term flat xs (VTable v1 v2) = do - t1 <- value2term flat xs v1 - t2 <- value2term flat xs v2 - return (Table t1 t2) -value2term flat xs (VT vty env cs)= do - ty <- value2term flat xs vty - cs <- forM cs $ \(p,t) -> do - (_,xs',env') <- pattVars (length xs,xs,env) p - v <- eval env' t [] - t <- value2term flat xs' v - return (p,t) - return (T (TTyped ty) cs) -value2term flat xs (VV vty tnks)= do - ty <- value2term flat xs vty - ts <- mapM (tnk2term flat xs) tnks - return (V ty ts) -value2term flat xs (VS v1 tnk2 tnks) = do - t1 <- value2term flat xs v1 - t2 <- tnk2term flat xs tnk2 - foldM (\e1 tnk -> fmap (App e1) (tnk2term flat xs tnk)) (S t1 t2) tnks -value2term flat xs (VSort s) = return (Sort s) -value2term flat xs (VStr tok) = return (K tok) -value2term flat xs (VInt n) = return (EInt n) -value2term flat xs (VFlt n) = return (EFloat n) -value2term flat xs VEmpty = return Empty -value2term flat xs (VC v1 v2) = do - t1 <- value2term flat xs v1 - t2 <- value2term flat xs v2 - return (C t1 t2) -value2term flat xs (VGlue v1 v2) = do - t1 <- value2term flat xs v1 - t2 <- value2term flat xs v2 - return (Glue t1 t2) -value2term flat xs (VPatt min max p) = return (EPatt min max p) -value2term flat xs (VPattType v) = do - t <- value2term flat xs v - return (EPattType t) -value2term flat xs (VAlts vd vas) = do - d <- value2term flat xs vd - as <- forM vas $ \(vt,vs) -> do - t <- value2term flat xs vt - s <- value2term flat xs vs - return (t,s) - return (Alts d as) -value2term flat xs (VStrs vs) = do - ts <- mapM (value2term flat xs) vs - return (Strs ts) -value2term flat xs (VMarkup tag as vs) = do - as <- mapM (\(id,v) -> value2term flat xs v >>= \t -> return (id,t)) as - ts <- mapM (value2term flat xs) vs - return (Markup tag as ts) -value2term flat xs (VCInts (Just i) Nothing) = return (App (Q (cPredef,cInts)) (EInt i)) -value2term flat xs (VCInts Nothing (Just j)) = return (App (Q (cPredef,cInts)) (EInt j)) -value2term flat xs (VCRecType lctrs) = do - ltys <- mapM (\(l,o,ctr) -> value2term flat xs ctr >>= \ty -> return (l,ty)) lctrs - return (RecType ltys) -value2term flat xs (VSymCat d r rs) = return (TSymCat d r [(i,(identW,ty)) | (i,(_,ty)) <- rs]) -value2term flat xs v = error (showValue v) - -pattVars st (PP _ ps) = foldM pattVars st ps -pattVars st (PV x) = case st of - (i,xs,env) -> do tnk <- newEvaluatedThunk (VGen i []) - return (i+1,x:xs,(x,tnk):env) -pattVars st (PR as) = foldM (\st (_,p) -> pattVars st p) st as -pattVars st (PT ty p) = pattVars st p -pattVars st (PAs x p) = do st <- case st of - (i,xs,env) -> do tnk <- newEvaluatedThunk (VGen i []) - return (i+1,x:xs,(x,tnk):env) - pattVars st p -pattVars st (PImplArg p) = pattVars st p -pattVars st (PSeq _ _ p1 _ _ p2) = do st <- pattVars st p1 - pattVars st p2 -pattVars st _ = return st - -data ConstValue a - = Const a - | RunTime - | NonExist - -instance Functor ConstValue where - fmap f (Const c) = Const (f c) - fmap f RunTime = RunTime - fmap f NonExist = NonExist - -instance Applicative ConstValue where - pure = Const - - (Const f) <*> (Const x) = Const (f x) - NonExist <*> _ = NonExist - _ <*> NonExist = NonExist - RunTime <*> _ = RunTime - _ <*> RunTime = RunTime - -#if MIN_VERSION_base(4,10,0) - liftA2 f (Const a) (Const b) = Const (f a b) - liftA2 f NonExist _ = NonExist - liftA2 f _ NonExist = NonExist - liftA2 f RunTime _ = RunTime - liftA2 f _ RunTime = RunTime -#endif - -instance Foldable ConstValue where - foldr f a (Const x) = f x a - foldr f a RunTime = a - foldr f a NonExist = a - -instance Traversable ConstValue where - traverse f (Const x) = Const <$> f x - traverse f RunTime = pure RunTime - traverse f NonExist = pure NonExist - -value2string v = fmap (\(_,ws,_) -> unwords ws) (value2string' v False [] []) - -value2string' (VStr w1) True (w2:ws) qs = Const (False,(w1++w2):ws,qs) -value2string' (VStr w) _ ws qs = Const (False,w :ws,qs) -value2string' VEmpty b ws qs = Const (b,ws,qs) -value2string' (VC v1 v2) b ws qs = - case value2string' v2 b ws qs of - Const (b,ws,qs) -> value2string' v1 b ws qs - res -> res -value2string' (VApp q []) b ws qs - | q == (cPredef,cNonExist) = NonExist -value2string' (VApp q []) b ws qs - | q == (cPredef,cSOFT_SPACE) = if null ws - then Const (b,ws,q:qs) - else Const (b,ws,qs) -value2string' (VApp q []) b ws qs - | q == (cPredef,cBIND) || q == (cPredef,cSOFT_BIND) - = if null ws - then Const (True,ws,q:qs) - else Const (True,ws,qs) -value2string' (VApp q []) b ws qs - | q == (cPredef,cCAPIT) = capit ws - where - capit [] = Const (b,[],q:qs) - capit ((c:cs) : ws) = Const (b,(toUpper c : cs) : ws,qs) - capit ws = Const (b,ws,qs) -value2string' (VApp q []) b ws qs - | q == (cPredef,cALL_CAPIT) = all_capit ws - where - all_capit [] = Const (b,[],q:qs) - all_capit (w : ws) = Const (b,map toUpper w : ws,qs) -value2string' (VAlts vd vas) b ws qs = - case ws of - [] -> value2string' vd b ws qs - (w:_) -> pre vd vas w b ws qs - where - pre vd [] w = value2string' vd - pre vd ((v,VStrs ss):vas) w - | or [startsWith s w | VStr s <- ss] = value2string' v - | otherwise = pre vd vas w -value2string' _ _ _ _ = RunTime - -startsWith [] _ = True -startsWith (x:xs) (y:ys) - | x == y = startsWith xs ys -startsWith _ _ = False - - -string2value s = string2value' (words s) - -string2value' [] = VEmpty -string2value' [w] = VStr w -string2value' (w:ws) = VC (VStr w) (string2value' ws) - -value2int (VInt n) = Const n -value2int _ = RunTime - ------------------------------------------------------------------------ --- * Global/built-in definitions - -type PredefImpl a s = [a] -> EvalM s (ConstValue (Value s)) -newtype Predef a s = Predef { runPredef :: PredefImpl a s } -type PredefCombinator a b s = Predef a s -> Predef b s - -infix 1 $\\ - -($\) :: PredefCombinator a b s -> PredefImpl a s -> Predef b s -k $\ f = k (Predef f) - -pdForce :: PredefCombinator (Value s) (Thunk s) s -pdForce def = Predef $ \args -> do - argValues <- mapM force args - runPredef def argValues - -pdCanonicalArgs :: PredefCombinator (Value s) (Value s) s -pdCanonicalArgs def = Predef $ \args -> - if all isCanonicalForm args then runPredef def args else return RunTime - -pdArity :: Int -> PredefCombinator (Thunk s) (Thunk s) s -pdArity n def = Predef $ \args -> - case splitAt' n args of - Nothing -> return RunTime - Just (usedArgs, remArgs) -> do - res <- runPredef def usedArgs - forM res $ \v -> apply v remArgs - -pdStandard :: Int -> PredefCombinator (Value s) (Thunk s) s -pdStandard n = pdArity n . pdForce . pdCanonicalArgs - ------------------------------------------------------------------------ --- * Evaluation monad - -type MetaThunks s = Map.Map MetaId (Thunk s) -type Do s r = [Message] -> ST s (CheckResult r [Message]) -type Cont s r = MetaThunks s -> Int -> r -> Do s r -type PredefTable s = Map.Map Ident (Predef (Thunk s) s) -data Globals = Gl Grammar (forall s . PredefTable s) -newtype EvalM s a = EvalM (forall r . Globals -> (a -> Cont s r) -> (Message -> Do s r) -> Cont s r) - -instance Functor (EvalM s) where - fmap f (EvalM g) = EvalM (\gr k e -> g gr (k . f) e) - -instance Applicative (EvalM s) where - pure x = EvalM (\gr k e -> k x) - (EvalM f) <*> (EvalM x) = EvalM (\gr k e -> f gr (\f -> x gr (\x -> k (f x)) e) e) - -instance Monad (EvalM s) where - (EvalM f) >>= g = EvalM (\gr k e -> f gr (\x -> case g x of - EvalM g -> g gr k e) e) - -instance Fail.MonadFail (EvalM s) where - fail msg = EvalM (\gr k e _ _ r -> e (pp msg)) - -instance Alternative (EvalM s) where - empty = EvalM (\gr k e _ _ r msgs -> return (Success r msgs)) - (EvalM f) <|> (EvalM g) = EvalM $ \gr k e mt b r msgs -> do - res <- f gr k e mt b r msgs - case res of - Fail msg msgs -> return (Fail msg msgs) - Success r msgs -> g gr k e mt b r msgs - -instance MonadPlus (EvalM s) where - -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)) (\msg ws -> return (Fail msg ws)) Map.empty maxBound [] ws) of - Fail msg ws -> Fail msg (es,ws) - Success xs ws -> Success (reverse xs) (es,ws) - -runEvalOneM :: Globals -> (forall s . EvalM s (Term,Type)) -> Check (Term,Type) -runEvalOneM gr f = Check $ \(es,ws) -> - case runST (case f of - EvalM f -> f gr (\x mt _ xs ws -> return (Success (x:xs) ws)) (\msg ws -> return (Fail msg ws)) Map.empty maxBound [] ws) of - Fail msg ws -> Fail msg (es,ws) - Success [] ws -> Fail (pp "The evaluation produced no results") (es,ws) - Success xs ws -> Success (FV (map fst xs),snd (head xs)) (es,ws) - -reset :: EvalM s a -> EvalM s [a] -reset (EvalM f) = EvalM $ \gl k e mt d r ws -> do - res <- f gl (\x mt d xs ws -> return (Success (x:xs) ws)) (\msg ws -> return (Fail msg ws)) mt d [] ws - case res of - Fail msg ws -> e msg ws - Success xs ws -> k (reverse xs) mt d r ws - -try :: EvalM s a -> EvalM s a -> EvalM s a -try (EvalM f) (EvalM g) = EvalM (\gl k e mt d r ws -> f gl k (\msg _ -> g gl k e mt d r ws) mt d r ws) - -evalError :: Message -> EvalM s a -evalError msg = EvalM (\gr k e _ _ r ws -> e msg ws) - -evalWarn :: Message -> EvalM s () -evalWarn msg = EvalM (\gr k e mt d r msgs -> k () mt d r (msg:msgs)) - -evalPredef :: Ident -> [Thunk s] -> EvalM s (Value s) -evalPredef id args = do - res <- EvalM $ \globals@(Gl _ predef) k e mt d r msgs -> - case Map.lookup id predef <&> \def -> runPredef def args of - Just (EvalM f) -> f globals k e mt d r msgs - Nothing -> k RunTime mt d r msgs - case res of - Const res -> return res - RunTime -> return $ VApp (cPredef,id) args - NonExist -> return $ VApp (cPredef,cNonExist) [] - -getResDef :: QIdent -> EvalM s Term -getResDef q = EvalM $ \(Gl gr _) k e mt d r msgs -> do - case lookupResDef gr q of - Ok t -> k t mt d r msgs - Bad msg -> e (pp msg) msgs - -getInfo :: QIdent -> EvalM s (ModuleName,Info) -getInfo q = EvalM $ \(Gl gr _) k e mt d r msgs -> do - case lookupOrigInfo gr q of - Ok res -> k res mt d r msgs - Bad msg -> e (pp msg) msgs - -getResType :: QIdent -> EvalM s Type -getResType q = EvalM $ \(Gl gr _) k e mt d r msgs -> do - case lookupResType gr q of - Ok t -> k t mt d r msgs - Bad msg -> e (pp msg) msgs - -getOverload :: Term -> QIdent -> EvalM s (Term,Type) -getOverload t q = EvalM $ \(Gl gr _) k e mt d r msgs -> do - case lookupOverloadTypes gr q of - Ok ttys -> let err = "Overload resolution failed" $$ - "of term " <+> pp t $$ - "with types" <+> vcat [ppTerm Terse 0 ty | (_,ty) <- ttys] - - go r [] = return (Success r msgs) - go r (tty:ttys) = do res <- k tty mt d r msgs - case res of - Fail _ _ -> go r ttys - Success r msgs -> go r ttys - - in go r ttys - Bad msg -> e (pp msg) msgs - -getAllParamValues :: Type -> EvalM s [Term] -getAllParamValues ty = EvalM $ \(Gl gr _) k e mt d r msgs -> - case allParamValues gr ty of - Ok ts -> k ts mt d r msgs - Bad msg -> e (pp msg) msgs - -newThunk env t = EvalM $ \gr k e mt d r msgs -> do - tnk <- newSTRef (Unevaluated env t) - k tnk mt d r msgs - -newEvaluatedThunk v = EvalM $ \gr k e mt d r msgs -> do - tnk <- newSTRef (Evaluated maxBound v) - k tnk mt d r msgs - -newHole i = EvalM $ \gr k e mt d r msgs -> - if i == 0 - then do tnk <- newSTRef (Hole i) - k tnk mt d r msgs - else case Map.lookup i mt of - Just tnk -> k tnk mt d r msgs - Nothing -> do tnk <- newSTRef (Hole i) - k tnk (Map.insert i tnk mt) d r msgs - -newResiduation scope = EvalM $ \gr k e mt d r msgs -> do - let i = Map.size mt + 1 - tnk <- newSTRef (Residuation i scope Nothing) - k (i,tnk) (Map.insert i tnk mt) d r msgs - -newNarrowing ty = EvalM $ \gr k e mt d r msgs -> do - let i = Map.size mt + 1 - tnk <- newSTRef (Narrowing i ty) - k (i,tnk) (Map.insert i tnk mt) d r msgs - -withVar d0 (EvalM f) = EvalM $ \gr k e mt d1 r msgs -> - let !d = min d0 d1 - in f gr k e mt d r msgs - -getVariables :: EvalM s [(LVar,LIndex)] -getVariables = EvalM $ \(Gl gr _) k e mt d ws r -> do - ps <- metas2params gr (Map.elems mt) - k ps mt d ws r - where - metas2params gr [] = return [] - metas2params gr (tnk:tnks) = do - st <- readSTRef tnk - case st of - Narrowing i ty -> do let cnt = case allParamValues gr ty of - Ok ts -> length ts - Bad msg -> error msg - params <- metas2params gr tnks - if cnt > 1 - then return ((i-1,cnt):params) - else return params - _ -> metas2params gr tnks - -getRef tnk = EvalM $ \gr k e mt d r msgs -> readSTRef tnk >>= \st -> k st mt d r msgs -setRef tnk st = EvalM $ \gr k e mt d r msgs -> do - old <- readSTRef tnk - writeSTRef tnk st - res <- k () mt d r msgs - writeSTRef tnk old - return res - -force tnk = EvalM $ \gr k e mt d r msgs -> do - s <- readSTRef tnk - case s of - Unevaluated env t -> case eval env t [] of - EvalM f -> f gr (\v mt b r msgs -> do let d = length env - writeSTRef tnk (Evaluated d v) - r <- k v mt d r msgs - writeSTRef tnk s - return r) e mt d r msgs - Evaluated d v -> k v mt d r msgs - Hole _ -> k (VMeta tnk []) mt d r msgs - Residuation _ _ _ -> k (VMeta tnk []) mt d r msgs - Narrowing _ _ -> k (VMeta tnk []) mt d r msgs - -tnk2term True xs tnk = force tnk >>= value2term True xs -tnk2term False xs tnk = EvalM $ \gr k e mt d r msgs -> - let join f g = do res <- f - case res of - Fail msg msgs -> return (Fail msg msgs) - Success r msgs -> g r msgs - - flush [] k1 mt r msgs = k1 mt r msgs - flush [x] k1 mt r msgs = join (k x mt d r msgs) (k1 mt) - flush xs k1 mt r msgs = join (k (FV (reverse xs)) mt d r msgs) (k1 mt) - - acc d0 x mt d (r,!c,xs) msgs - | d < d0 = flush xs (\mt r msgs -> join (k x mt d r msgs) (\r msgs -> return (Success (r,c+1,[]) msgs))) mt r msgs - | otherwise = return (Success (r,c+1,x:xs) msgs) - - err msg msgs = return (Fail msg msgs) - - in do s <- readSTRef tnk - case s of - Unevaluated env t -> do let d0 = length env - res <- case eval env t [] of - EvalM f -> f gr (\v mt d msgs r -> do writeSTRef tnk (Evaluated d0 v) - r <- case value2term False xs v of - EvalM f -> f gr (acc d0) err mt d msgs r - writeSTRef tnk s - return r) err mt maxBound (r,0,[]) msgs - case res of - Fail msg msgs -> return (Fail msg msgs) - Success (r,0,xs) msgs -> k (FV []) mt d r msgs - Success (r,c,xs) msgs -> flush xs (\mt msgs r -> return (Success msgs r)) mt r msgs - Evaluated d0 v -> do res <- case value2term False xs v of - EvalM f -> f gr (acc d0) err mt maxBound (r,0,[]) msgs - case res of - Fail msg msgs -> return (Fail msg msgs) - Success (r,0,xs) msgs -> k (FV []) mt d r msgs - Success (r,c,xs) msgs -> flush xs (\mt r msgs -> return (Success r msgs)) mt r msgs - Hole i -> k (Meta i) mt d r msgs - Residuation i _ _ -> k (Meta i) 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 e mt d r msgs -> unsafeIOToST f >>= \x -> k x mt d r msgs) - diff --git a/src/compiler/api/GF/Compile/ConcreteToHaskell.hs b/src/compiler/api/GF/Compile/ConcreteToHaskell.hs index 03da6ac83..4c25aacdb 100644 --- a/src/compiler/api/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/api/GF/Compile/ConcreteToHaskell.hs @@ -93,7 +93,7 @@ concrete2haskell opts abstr@(absname,_) concr@(cncname,mi) = | s == cStr = tcon0 (identS "Str") convLinType (QC (_,p)) = tcon0 (gId p) convLinType (RecType lbls) = tcon (rcon' ls) (map convLinType ts) - where (ls,ts) = unzip $ sortOn fst lbls + where (ls,_,ts) = unzip3 $ sortOn (\(l,_,_)->l) lbls convLinType (Table pt lt) = Fun (convLinType pt) (convLinType lt) lincatDef c ty = tsyn0 (lincatName c) (convLinType ty) @@ -170,8 +170,9 @@ concrete2haskell opts abstr@(absname,_) concr@(cncname,mi) = convertPatt (PC c ps) = ConP (gId c) (map convertPatt ps) convertPatt (PP (_,c) ps) = ConP (gId c) (map convertPatt ps) - convertPatt (PV v) = VarP v - convertPatt PW = WildP + convertPatt (PV v) + | v == identW = WildP + | otherwise = VarP v convertPatt (PR lbls) = ConP (rcon' ls) (map convertPatt ps) where (ls,ps) = unzip $ sortOn fst lbls convertPatt (PString s) = Lit s diff --git a/src/compiler/api/GF/Compile/Export.hs b/src/compiler/api/GF/Compile/Export.hs index 1b1b0be4f..f126fb84e 100644 --- a/src/compiler/api/GF/Compile/Export.hs +++ b/src/compiler/api/GF/Compile/Export.hs @@ -49,7 +49,6 @@ exportPGF opts fmt pgf = FmtSLF -> single "slf" slfPrinter FmtRegExp -> single "rexp" regexpPrinter FmtFA -> single "dot" slfGraphvizPrinter - FmtLR -> single "dot" (\_ -> graphvizLRAutomaton) where name = fromMaybe (abstractName pgf) (flag optName opts) diff --git a/src/compiler/api/GF/Compile/GenerateBC.hs b/src/compiler/api/GF/Compile/GenerateBC.hs index 338c2bf7d..db84037b9 100644 --- a/src/compiler/api/GF/Compile/GenerateBC.hs +++ b/src/compiler/api/GF/Compile/GenerateBC.hs @@ -13,7 +13,7 @@ import Data.Maybe(fromMaybe) generateByteCode :: SourceGrammar -> Int -> [L Equation] -> [[Instr]] generateByteCode gr arity eqs = let (bs,instrs) = compileEquations gr arity (arity+1) is - (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) + (map (\(L _ (ps,t)) -> ([],ps,t)) eqs) Nothing [b] b = if arity == 0 || null eqs @@ -50,8 +50,9 @@ compileEquations gr arity st (i:is) eqs fl bs = whilePP eqs Map.empty in (bs3,[PUSH_FRAME, EVAL (shiftIVal (st+2) i) RecCall] ++ instrs1) whilePV [] vrs = compileEquations gr arity st is vrs fl bs - whilePV ((vs, PV x : ps, t):eqs) vrs = whilePV eqs (((x,i):vs,ps,t) : vrs) - whilePV ((vs, PW : ps, t):eqs) vrs = whilePV eqs (( vs,ps,t) : vrs) + whilePV ((vs, PV x : ps, t):eqs) vrs + | x == identW = whilePV eqs (( vs,ps,t) : vrs) + | otherwise = whilePV eqs (((x,i):vs,ps,t) : vrs) whilePV ((vs, PTilde _ : ps, t):eqs) vrs = whilePV eqs (( vs,ps,t) : vrs) whilePV ((vs, PImplArg p:ps, t):eqs) vrs = whilePV ((vs,p:ps,t):eqs) vrs whilePV ((vs, PT _ p : ps, t):eqs) vrs = whilePV ((vs,p:ps,t):eqs) vrs @@ -101,11 +102,11 @@ compileFun gr eval st vs (App e1 e2) h0 bs args = let (h1,bs1,arg,is1) = compileArg gr st vs e2 h0 bs (h2,bs2,is2) = compileFun gr eval st vs e1 h1 bs1 (arg:args) in (h2,bs2,is1++is2) -compileFun gr eval st vs (Q (m,id)) h0 bs args = - case lookupAbsDef gr m id of - Ok (_,Just _) +compileFun gr eval st vs (Q q@(m,id)) h0 bs args = + case lookupAbsDef gr q of + Ok (Just _) -> (h0,bs,eval st (GLOBAL (showIdent id)) args) - _ -> let Ok ty = lookupFunType gr m id + _ -> let Ok ty = lookupFunType gr q (ctxt,_,_) = typeForm ty c_arity = length ctxt n_args = length args @@ -164,10 +165,10 @@ compileFun gr eval st vs e@(Glue e1 e2) h0 bs args = in (h1,bs1,[PUSH_ACCUM (LFlt 0)]++is++[POP_ACCUM]++eval (st+1) (ARG_VAR st) []) compileFun gr eval st vs e _ _ _ = error (show e) -compileArg gr st vs (Q(m,id)) h0 bs = - case lookupAbsDef gr m id of - Ok (_,Just _) -> (h0,bs,GLOBAL (showIdent id),[]) - _ -> let Ok ty = lookupFunType gr m id +compileArg gr st vs (Q q@(m,id)) h0 bs = + case lookupAbsDef gr q of + Ok (Just _) -> (h0,bs,GLOBAL (showIdent id),[]) + _ -> let Ok ty = lookupFunType gr q (ctxt,_,_) = typeForm ty c_arity = length ctxt in if c_arity == 0 @@ -201,17 +202,9 @@ compileArg gr st vs (ImplArg e) h0 bs = compileArg gr st vs e h0 bs compileArg gr st vs e h0 bs = let (f,es) = appForm e - isConstr = case f of - Q c@(m,id) -> case lookupAbsDef gr m id of - Ok (_,Just _) -> Nothing - _ -> Just c - QC c@(m,id) -> case lookupAbsDef gr m id of - Ok (_,Just _) -> Nothing - _ -> Just c - _ -> Nothing - in case isConstr of - Just (m,id) -> - let Ok ty = lookupFunType gr m id + in case f of + QC q@(m,id) -> + let Ok ty = lookupFunType gr q (ctxt,_,_) = typeForm ty c_arity = length ctxt ((h1,bs1,is1),args) = mapAccumL (\(h,bs,is) e -> let (h1,bs1,arg,is1) = compileArg gr st vs e h bs @@ -234,7 +227,7 @@ compileArg gr st vs e h0 bs = EVAL (HEAP h0) (TailCall diff) : [] in (h2,b:bs1,HEAP h1,is1 ++ (PUT_CLOSURE (length bs):is2)) - Nothing -> compileLambda gr st vs [] e h0 bs + _ -> compileLambda gr st vs [] e h0 bs compileLambda gr st vs xs (Abs _ x e) h0 bs = compileLambda gr st vs (x:xs) e h0 bs diff --git a/src/compiler/api/GF/Compile/GeneratePMCFG.hs b/src/compiler/api/GF/Compile/GeneratePMCFG.hs index 383b11e41..3bc8cd5ce 100644 --- a/src/compiler/api/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/api/GF/Compile/GeneratePMCFG.hs @@ -1,235 +1,327 @@ -{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-} ----------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- Convert PGF grammar to PMCFG grammar. --- ------------------------------------------------------------------------------ - +{-# LANGUAGE RankNTypes #-} module GF.Compile.GeneratePMCFG (generatePMCFG, pmcfgForm, type2fields ) where -import GF.Grammar hiding (VApp,VRecType) -import GF.Grammar.Predef -import GF.Grammar.Lookup -import GF.Infra.CheckM +import GF.Infra.Ident import GF.Infra.Option -import GF.Text.Pretty -import GF.Compile.Compute.Concrete -import GF.Data.Operations(Err(..)) -import PGF2.Transactions -import Control.Monad -import Control.Monad.State -import Control.Monad.ST -import qualified Data.Map.Strict as Map -import qualified Data.Sequence as Seq -import Data.List(mapAccumL,sortOn,sortBy) -import Data.Maybe(fromMaybe,isNothing) -import Data.STRef +import GF.Infra.CheckM +import GF.Data.Operations +import GF.Grammar.Grammar +import GF.Grammar.Lookup +import GF.Grammar.Macros +import GF.Grammar.Predef +import GF.Grammar.Printer hiding (ppValue) +import GF.Text.Pretty hiding (empty) +import GF.Compile.Compute hiding ( getMeta, setMeta, globals, variants ) +import qualified GF.Text.Pretty as PP +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Applicative +import Control.Monad (foldM,zipWithM,liftM,liftM2,forM,MonadPlus(..)) +import Control.Monad.Fix +import Data.Maybe +import Data.List(mapAccumL,sortBy,sortOn,intersperse) +import Data.Containers.ListUtils(nubOrd) +import Prelude hiding ((<>)) + generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule generatePMCFG opts cwd gr cmo@(cm,cmi) - | mstatus cmi == MSComplete && isModCnc cmi && isNothing (mseqs cmi) = + | mstatus cmi == MSComplete && isModCnc cmi = do let gr' = prependModule gr cmo - (js,seqs) <- runStateT (Map.traverseWithKey (\id info -> StateT (addPMCFG opts cwd gr' cmi id info)) (jments cmi)) Map.empty - return (cm,cmi{jments = js, mseqs=Just (mapToSequence seqs)}) + g = Gl gr' (stdPredef g) False + js <- Map.traverseWithKey (addPMCFG cwd g cmi) (jments cmi) + return (cm,cmi{jments = js}) | otherwise = return cmo - where - mapToSequence m = Seq.fromList (map fst (sortOn snd (Map.toList m))) -type SequenceSet = Map.Map [Symbol] Int - -addPMCFG opts cwd gr cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) seqs = do - (defs,seqs) <- - case mdef of - Nothing -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do - term <- mkLinDefault gr ty - pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs - Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do - pmcfgForm gr term [(Explicit,identW,typeStr)] ty seqs - (refs,seqs) <- - case mref of - Nothing -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do - term <- mkLinReference gr ty - pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs - Just (L loc term) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do - pmcfgForm gr term [(Explicit,identW,ty)] typeStr seqs +addPMCFG cwd g cmi id (CncCat mty@(Just (L loc ty)) mdef mref mprn Nothing) = do + defs <- case mdef of + Nothing -> checkInModule cwd cmi loc ("Happened in the rule generation for the lindef of" <+> id) $ do + t <- mkLinDefault sgr ty + pmcfgForm g t [(Explicit,identW,Sort cStr)] ty + Just (L loc t) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the lindef of" <+> id) $ do + pmcfgForm g t [(Explicit,identW,Sort cStr)] ty + refs <- case mref of + Nothing -> checkInModule cwd cmi loc ("Happened in the rule generation for the linref of" <+> id) $ do + t <- mkLinReference sgr ty + pmcfgForm g t [(Explicit,identW,ty)] (Sort cStr) + Just (L loc t) -> checkInModule cwd cmi loc ("Happened in the PMCFG generation for the linref of" <+> id) $ do + pmcfgForm g t [(Explicit,identW,ty)] (Sort cStr) 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 (Gl gr stdPredef) prn + prn <- normalForm g 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 - (rules,seqs) <- - checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $ - pmcfgForm gr term ctxt val seqs + return (CncCat mty mdef mref mprn (Just (defs,refs))) + where + Gl sgr _ _ = g +addPMCFG cwd g cmi id (CncFun (Just lty@(cats,cat,ctxt,ty)) mlin@(Just (L loc term)) mprn Nothing) = do + rules <- checkInModule cwd cmi loc ("Happened in the rule generation for" <+> id) $ + pmcfgForm g term ctxt ty 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 (Gl gr stdPredef) prn + prn <- normalForm g 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 (Gl gr stdPredef) $ do - (_,args) <- mapAccumM (\arg_no (_,_,ty) -> do - t <- EvalM (\(Gl gr _) k e 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 - v <- eval [] t args - (lins,params) <- flatten v ty ([],[]) - lins <- fmap reverse $ mapM str2lin lins - (r,rs,_) <- compute params - args <- zipWithM tnk2lparam args ctxt - vars <- getVariables - let res = LParam r (order rs) - return (vars,args,res,lins) - return (runState (mapM mkProduction res) seqs) + return (CncFun (Just lty) mlin mprn (Just rules)) where - tnk2lparam tnk (_,_,ty) = do - v <- force tnk - (_,params) <- flatten v ty ([],[]) - (r,rs,_) <- compute params - return (PArg [] (LParam r (order rs))) + Gl sgr _ _ = g - compute [] = return (0,[],1) - compute ((v,ty):params) = do - (r, rs ,cnt ) <- param2int v ty - (r',rs',cnt') <- compute params - return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt') +addPMCFG cwd g cmi id info = return info - mkProduction (vars,args,res,lins) = do - lins <- mapM getSeqId lins - return (Production vars args res lins) +pmcfgForm g t ctxt ty = do + let (ms,s',t',arg_params) = apply 0 Map.empty unit ctxt t [] + let v = eval g [] s' t' [] + (ms,_,_,fn) <- breakDown g ms unit 0 [] v ty (return []) empty + res <- fmap nubOrd $ runGenM g ms [] $ do + (r,rs,v,res_params) <- fn + (subst,arg_params) <- mapAccumM params2int Map.empty arg_params + (subst,res_params) <- params2int subst res_params + (subst,lin_idx) <- params2int' subst r rs + (subst,seq) <- flatten subst v + qs <- quantifiers (Map.toList subst) + return (Rule qs res_params arg_params lin_idx seq) + length res `seq` return res + where + Gl sgr _ _ = g + + quantifiers vars = GenM (\(Gl sgr _ _) k svs ms -> + k [boundsOf sgr ms variable | (variable,v) <- sortOn snd vars] + svs ms) where - getSeqId :: [Symbol] -> State (Map.Map [Symbol] SeqId) SeqId - getSeqId lin = state $ \m -> - case Map.lookup lin m of - Just seqid -> (seqid,m) - Nothing -> let seqid = Map.size m - in (seqid,Map.insert lin seqid m) + boundsOf sgr ms i = + case Map.lookup i ms of + Just (Narrowing _ pty) -> case countParamValues sgr pty of + Ok c -> c + Bad msg -> error msg + _ -> error (show (ppLVar i <+> "is not a free variable")) -type2metaTerm :: SourceGrammar -> Int -> MetaThunks s -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> ST s (MetaThunks s,Int,Term) -type2metaTerm gr d ms r rs (Sort s) | s == cStr = - return (ms,r+1,TSymCat d r rs) -type2metaTerm gr d ms r rs (RecType lbls) = do - ((ms',r'),ass) <- mapAccumM (\(ms,r) (lbl,ty) -> case lbl of - LVar j -> return ((ms,r),(lbl,(Just ty,TSymVar d j))) - lbl -> do (ms',r',t) <- type2metaTerm gr d ms r rs ty - return ((ms',r'),(lbl,(Just ty,t)))) - (ms,r) lbls - return (ms',r',R ass) -type2metaTerm gr d ms r rs (Table p q) - | count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q - return (ms',r+(r'-r),T (TTyped p) [(PW,t)]) - | null (collectParams q) - = do let pv = varX (length rs+1) - (ms',delta,t) <- - fixST $ \(~(_,delta,_)) -> - do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q - return (ms',r'-r,t) - return (ms',r+delta*count,T (TTyped p) [(PV pv,t)]) - | otherwise = do ((ms',r'),ts) <- mapAccumM (\(ms,r) _ -> do (ms',r',t) <- type2metaTerm gr d ms r rs q - return ((ms',r'),t)) - (ms,r) [0..count-1] - return (ms',r+(r'-r),V p ts) + apply d ms s [] t args = (ms,s,t,reverse args) + apply d ms s ((_,_,ty):ctxt) t args = + let (ms',s',_,t2,params) = type2metaTerm sgr d ms s 0 [] ty [] + in apply (d+1) ms' s' ctxt (App t t2) (params:args) + +type2fields :: SourceGrammar -> Type -> [String] +type2fields gr = type2fields PP.empty where - collectParams (QC q) = [q] - collectParams (Table _ t) = collectParams t - collectParams t = collectOp collectParams t + type2fields d (Sort s) | s == cStr = [show d] + type2fields d (RecType lbls) = + concatMap (\(lbl,_,ty) -> type2fields (d <+> pp lbl) ty) lbls + type2fields d (Table p q) = + let Ok ts = allParamValues gr p + in concatMap (\t -> type2fields (d <+> ppTerm Unqualified 5 t) q) ts + type2fields d _ = [] - count = case allParamValues gr p of - Ok ts -> length ts + +mkLinDefault :: SourceGrammar -> Type -> Check Term +mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ + where + mkDefField ty = + case ty of + Table p t -> do t' <- mkDefField t + let T _ cs = mkWildCases t' + return $ T (TWild p) cs + Sort s | s == cStr -> return (Vr varStr) + QC p -> case allParamValues gr ty of + Ok [] -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p) + Ok (v:_) -> return v + Bad msg -> fail msg + RecType r -> do + let (ls,_,ts) = unzip3 r + ts <- mapM mkDefField ts + return $ R (zipWith assign ls ts) + _ | Just _ <- isTypeInts ty -> return $ EInt 0 -- exists in all as first val + _ -> checkError ("a field in a linearization type cannot be" <+> ty) + +mkLinReference :: SourceGrammar -> Type -> Check Term +mkLinReference gr typ = do + mb_term <- mkRefField typ (Vr varStr) + return (Abs Explicit varStr (fromMaybe Empty mb_term)) + where + mkRefField ty trm = + case ty of + Table pty ty -> do ps <- allParamValues gr pty + case ps of + [] -> fail (render ("no parameter values given to type" <+> pty)) + (p:ps) -> mkRefField ty (S trm p) + Sort s | s == cStr -> return (Just trm) + QC p -> return Nothing + RecType rs -> traverse rs trm + _ | Just _ <- isTypeInts ty -> return Nothing + _ -> fail (render ("a field in a linearization type cannot be" <+> typ)) + + traverse [] trm = return Nothing + traverse ((l,_,ty):rs) trm = do res <- mkRefField ty (P trm l) + case res of + Just trm -> return (Just trm) + Nothing -> traverse rs trm + + +type2metaTerm :: SourceGrammar -> Int -> MetaVars -> Choice -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> [(Value,Type)] -> (MetaVars,Choice,Int,Term,[(Value,Type)]) +type2metaTerm gr d ms s r rs (Sort srt) params | srt == cStr = (ms,s,r+1,TSymCat d r rs,params) +type2metaTerm gr d ms s r rs (RecType lbls) params = + let ((ms',s',r',params'),ass) = + mapAccumL (\(ms,s,r,params) (lbl,_,ty) -> case lbl of + LVar j -> ((ms,s,r,params),(lbl,(Just ty,TSymVar d j))) + lbl -> let (ms',s',r',t,params') = type2metaTerm gr d ms s r rs ty params + in ((ms',s',r',params'),(lbl,(Just ty,t)))) + (ms,s,r,params) lbls + in (ms',s',r',R ass,params') +type2metaTerm gr d ms s r rs (Table p q) params + | count == 1 = let (ms',s',r',t,params') = type2metaTerm gr d ms s r rs q params + in (ms',s',r+(r'-r),T (TTyped p) [(PV identW,t)],params') + | otherwise = let pv = varX (length rs+1) + (ms',s',r',t,params') = type2metaTerm gr d ms s r ((delta,(pv,p)):rs) q params + delta = r'-r + in (ms',s',r+delta*count,T (TTyped p) [(PV pv,t)],params') + where + count = case countParamValues gr p of + Ok c -> c Bad msg -> error msg -type2metaTerm gr d ms r rs ty@(QC q) = do +type2metaTerm gr d ms c r rs ty@(QC q) params = let i = Map.size ms + 1 - tnk <- newSTRef (Narrowing i ty) - return (Map.insert i tnk ms,r,Meta i) -type2metaTerm gr d ms r rs ty - | Just n <- isTypeInts ty = do + (c1,c2) = split c + in (Map.insert i (Narrowing c1 ty) ms,c2,r,Meta i,(VMeta i [],ty):params) +type2metaTerm gr d ms c r rs ty params + | Just n <- isTypeInts ty = let i = Map.size ms + 1 - tnk <- newSTRef (Narrowing i ty) - return (Map.insert i tnk ms,r,Meta i) + (c1,c2) = split c + in (Map.insert i (Narrowing c1 ty) ms,c2,r,Meta i,(VMeta i [],ty):params) -flatten (VR as) (RecType lbls) st = do - foldM collect st lbls - where - collect st (lbl,ty) = - case lookup lbl as of - Just tnk -> do v <- force tnk - flatten v ty st - Nothing -> evalError ("Missing value for label" <+> pp lbl $$ - "among" <+> hsep (punctuate (pp ',') (map fst as))) -flatten v@(VT _ env cs) (Table p q) st = do - ts <- getAllParamValues p - foldM collect st ts - where - collect st t = do - tnk <- newThunk [] t - let v0 = VS v tnk [] - v <- patternMatch v0 (map (\(p,t) -> (env,[p],[tnk],t)) cs) - flatten v q st -flatten (VV _ tnks) (Table _ q) st = do - foldM collect st tnks - where - collect st tnk = do - v <- force tnk - flatten v q st -flatten v (Sort s) (lins,params) | s == cStr = do - deepForce v - return (v:lins,params) -flatten v ty@(QC q) (lins,params) = do - deepForce v - return (lins,(v,ty):params) -flatten v ty (lins,params) - | Just n <- isTypeInts ty = do deepForce v - return (lins,(v,ty):params) - | otherwise = evalError (pp (showValue v)) -deepForce (VR as) = mapM_ (\(lbl,v) -> force v >>= deepForce) as -deepForce (VApp q tnks) = mapM_ (\tnk -> force tnk >>= deepForce) tnks -deepForce (VC v1 v2) = deepForce v1 >> deepForce v2 -deepForce (VAlts def alts) = do deepForce def - mapM_ (\(v,_) -> deepForce v) alts -deepForce (VSymCat d r rs) = mapM_ (\(_,(tnk,_)) -> force tnk >>= deepForce) rs -deepForce _ = return () - -str2lin (VApp q []) - | q == (cPredef, cBIND) = return [SymBIND] - | q == (cPredef, cNonExist) = return [SymNE] - | q == (cPredef, cSOFT_BIND) = return [SymSOFT_BIND] - | q == (cPredef, cSOFT_SPACE) = return [SymSOFT_SPACE] - | q == (cPredef, cCAPIT) = return [SymCAPIT] - | q == (cPredef, cALL_CAPIT) = return [SymALL_CAPIT] -str2lin (VStr s) = return [SymKS s] -str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs - return [SymCat d (LParam r (order rs))] +breakDown g ms s r rs v (Sort sort) fn0 fn + | sort == cStr = + let fn' = do params <- fn0 + v <- force v + return (r,rs,v,params) + <|> + do fn + in return (ms,r+1,fn0,fn') +breakDown g ms s r rs v (RecType lbls) fn0 fn = traverse ms r rs lbls fn0 fn where - compute r' [] = return (r',[]) - compute r' ((cnt',(tnk,ty)):tnks) = do - v <- force tnk - (r, rs, cnt) <- param2int v ty - (r',rs') <- compute r' tnks - return (r*cnt'+r',combine cnt' rs rs') -str2lin (VSymVar d r) = return [SymVar d r] -str2lin VEmpty = return [] -str2lin (VC v1 v2) = liftM2 (++) (str2lin v1) (str2lin v2) -str2lin v0@(VAlts def alts) - = do def <- str2lin def - alts <- forM alts $ \(v1,v2) -> do - lin <- str2lin v1 - ss <- to_strs v2 - return (lin,ss) - return [SymKP def alts] + traverse ms r rs [] fn0 fn = return (ms,r,fn0,fn) + traverse ms r rs ((lbl,_,ty):lbls) fn0 fn = do (ms,r,fn0,fn) <- breakDown g ms s r rs (project v) ty fn0 fn + traverse ms r rs lbls fn0 fn + where + project (VR as) = case lookup lbl as of + Nothing -> error (render ("Missing value for label" <+> pp lbl $$ + "in" <+> ppValue Unqualified 0 (VR as))) + Just v -> v + project (VFV c fvs) = VFV c (fmap project fvs) + project (VMeta i vs) = VSusp i (\v -> project (apply g v vs)) [] + project (VSusp i k vs)= VSusp i (\v -> project (apply g (k v) vs)) [] + project (VError msg) = VError msg + project v = VP v lbl [] +breakDown g ms c r rs v (Table p q) fn0 fn = do + let i = Map.size ms + 1 + v2 = VMeta i [] + v0 = VS v v2 [] + (c1,c2) = split c + Gl gr _ _ = g + cnt <- countParamValues gr p + (ms,r',fn0,fn) <- mfix $ \(~(_,r',_,_)) -> + breakDown g (Map.insert i (Narrowing c1 p) ms) c2 r ((r'-r,(v2,p)):rs) (select v0 v v2) q fn0 fn + return (ms,r+(r'-r)*cnt,fn0,fn) + where + select v0 (VT _ env s cs) v2 = patternMatch g s v0 (map (\(p,t) -> (env,[p],[v2],t)) cs) + select v0 (VV vty tvs) v2 = vtableSelect g v0 vty tvs v2 [] + select v0 (VFV i fvs) v2 = VFV i (fmap (\v1 -> select v0 v1 v2) fvs) + select v0 (VMeta i vs) v2 = VSusp i (\v -> select v0 (apply g v vs) v2) [] + select v0 (VSusp i k vs) v2 = VSusp i (\v -> select v0 (apply g (k v) vs) v2) [] + select v0 (VError msg) v2 = VError msg + select v0 v1 v2 = v0 +breakDown g ms s r rs v ty@(QC q) fn0 fn = + let fn0' = do params <- fn0 + v <- force v + return ((v,ty):params) + fn' = do (r,rs,v',res_params) <- fn + v <- force v + return (r,rs,v',(v,ty):res_params) + in return (ms,r,fn0',fn') +breakDown g ms s r rs v ty@(App (Q q) _) fn0 fn = + let fn0' = do params <- fn0 + v <- force v + return ((v,ty):params) + fn' = do (r,rs,v',res_params) <- fn + v <- force v + return (r,rs,v',(v,ty):res_params) + in return (ms,r,fn0',fn') + +force (VStr s) = return (VStr s) +force (VInt n) = return (VInt n) +force (VFlt d) = return (VFlt d) +force (VSymCat d r rs) = do + rs <- mapM force_ rs + return (VSymCat d r rs) + where + force_ (factor, (v, ty)) = do + v <- force v + return (factor, (v, ty)) +force (VApp q vs) = do + vs <- mapM force vs + return (VApp q vs) +force (VAlts def alts) = do + def <- force def + alts <- mapM force_ alts + return (VAlts def alts) + where + force_ (x,y) = do + x <- force x + y <- force y + return (x,y) +force VEmpty = return VEmpty +force (VC v1 v2) = do + v1 <- force v1 + v2 <- force v2 + return (VC v1 v2) +force (VMeta i vs) = do + vs <- mapM force vs + return (VMeta i vs) +force (VSusp i k vs) = do + vs <- mapM force vs + st <- getMeta i + v <- case st of + Narrowing c ty -> do v <- chooseMetaValue c ty + setMeta i (Bound undefined v) + return v + Bound _ v -> return v + g <- globals + force (apply g (k v) vs) +force (VStrs vs) = do + vs <- mapM force vs + return (VStrs vs) +force (VR as) = do + as <- mapM (\(l,v) -> fmap ((,) l) (force v)) as + return (VR as) +force v@(VPatt _ _ _) = return v +force (VFV c vs) = do + v <- variants c (unvariants vs) + force v +force (VError msg) = compileError msg +force v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v) + + +flatten subst (VStr s) = return (subst,[SymKS s]) +flatten subst (VSymCat d r rs) = do + (subst,lin_index) <- params2int' subst r rs + return (subst,[SymCat d lin_index]) +flatten subst (VApp (m,id) []) + | m == cPredef && id == cBIND = return (subst,[SymBIND]) + | m == cPredef && id == cSOFT_BIND = return (subst,[SymSOFT_BIND]) + | m == cPredef && id == cSOFT_SPACE = return (subst,[SymSOFT_SPACE]) + | m == cPredef && id == cNonExist = return (subst,[SymNE]) + | m == cPredef && id == cCAPIT = return (subst,[SymCAPIT]) + | m == cPredef && id == cALL_CAPIT = return (subst,[SymALL_CAPIT]) +flatten subst v0@(VAlts def alts) = do + (subst,def) <- flatten subst def + (subst,alts) <- mapAccumM (\subst (alt,ps) -> do + (subst,alt) <- flatten subst alt + ps <- to_strs ps + return (subst,(alt,ps))) + subst + alts + return (subst,[SymKP def alts]) where to_strs (VStrs vs) = mapM to_str vs to_strs (VPatt _ _ p) = from_patt p @@ -244,50 +336,94 @@ str2lin v0@(VAlts def alts) from_patt (PChars cs) = return (map (:[]) cs) from_patt _ = fail - fail = evalError ("Complex patterns are not supported in:" $$ nest 2 (pp (showValue v0))) -str2lin v = do t <- value2term False [] v - evalError ("the string:" <+> ppTerm Unqualified 0 t $$ - "cannot be evaluated at compile time.") + fail = compileError ("Complex patterns are not supported in:" $$ nest 2 (ppValue Unqualified 0 v0)) +flatten subst VEmpty = return (subst,[]) +flatten subst (VC v1 v2) = do + (subst,s1) <- flatten subst v1 + (subst,s2) <- flatten subst v2 + return (subst,s1++s2) +flatten subst (VSusp i k vs) = do + st <- getMeta i + v <- case st of + Narrowing c ty -> do v <- chooseMetaValue c ty + setMeta i (Bound undefined v) + return v + Bound _ v -> return v + g <- globals + flatten subst (apply g (k v) vs) +flatten subst (VFV c vs) = do + v <- variants c (unvariants vs) + flatten subst v +flatten subst (VError msg) = compileError msg +flatten subst v = compileError ("Cannot evaluate" <+> ppValue Unqualified 0 v <+> "to a string") -param2int (VR as) (RecType lbls) = compute lbls + +params2int subst rs = do + (subst,r,rs,_) <- compute subst rs + return (subst,LParam r (order rs)) where - compute [] = return (0,[],1) - compute ((lbl,ty):lbls) = do + compute subst [] = return (subst,0,[],1) + compute subst ((v,ty):params) = do + (subst, r, rs, cnt ) <- param2int subst v ty + (subst, r',rs',cnt') <- compute subst params + return (subst, r*cnt'+r',combine cnt' rs rs',cnt*cnt') + +params2int' subst r0 rs = do + (subst,r,rs) <- compute subst rs + return (subst,LParam (r0+r) (order rs)) + where + compute subst [] = return (subst,0,[]) + compute subst ((cnt',(v,ty)):params) = do + (subst, r, rs, cnt) <- param2int subst v ty + (subst, r',rs') <- compute subst params + return (subst,r*cnt'+r',combine cnt' rs rs') + +param2int subst (VR as) (RecType lbls) = compute subst lbls + where + compute subst [] = return (subst,0,[],1) + compute subst ((lbl,_,ty):lbls) = do case lookup lbl as of - Just tnk -> do v <- force tnk - (r, rs ,cnt ) <- param2int v ty - (r',rs',cnt') <- compute lbls - return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt') - Nothing -> evalError ("Missing value for label" <+> pp lbl $$ - "among" <+> hsep (punctuate (pp ',') (map fst as))) -param2int (VApp q tnks) ty = do - (r , ctxt,cnt ) <- getIdxCnt q - (r',rs', cnt') <- compute ctxt tnks - return (r+r',rs',cnt) + Just v -> do (subst, r, rs ,cnt ) <- param2int subst v ty + (subst, r',rs',cnt') <- compute subst lbls + return (subst,r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt') + Nothing -> compileError ("Missing value for label" <+> pp lbl $$ + "among" <+> hsep (punctuate (pp ',') (map fst as))) +param2int subst (VApp q vs) ty = do + ( r , ctxt,cnt ) <- getIdxCnt q + (subst,r',rs', cnt') <- compute subst ctxt vs + return (subst,r+r',rs',cnt) where - getIdxCnt q = do - (_,ResValue (L _ ty) idx) <- getInfo q - let (ctxt,QC p) = typeFormCnc ty - (_,ResParam _ (Just (_,cnt))) <- getInfo p - return (idx,ctxt,cnt) - - compute [] [] = return (0,[],1) - compute ((_,_,ty):ctxt) (tnk:tnks) = do - v <- force tnk - (r, rs ,cnt ) <- param2int v ty - (r',rs',cnt') <- compute ctxt tnks - return (r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt') -param2int (VInt n) ty - | Just max <- isTypeInts ty= return (fromIntegral n,[],fromIntegral max+1) -param2int (VMeta tnk _) ty = do - tnk_st <- getRef tnk - case tnk_st of - Evaluated _ v -> param2int v ty - Narrowing j ty -> do ts <- getAllParamValues ty - return (0,[(1,j-1)],length ts) -param2int v ty = do t <- value2term True [] v - evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$ - "cannot be evaluated at compile time.") + compute subst [] [] = return (subst,0,[],1) + compute subst ((_,_,ty):ctxt) (v:vs) = do + (subst, r, rs ,cnt ) <- param2int subst v ty + (subst, r',rs',cnt') <- compute subst ctxt vs + return (subst,r*cnt'+r',combine' cnt rs cnt' rs',cnt*cnt') +param2int subst (VInt n) ty + | Just max <- isTypeInts ty= return (subst,fromIntegral n,[],fromIntegral max+1) +param2int subst (VMeta i _) ty = do + st <- getMeta i + case st of + Narrowing c ty -> do count <- getCnt ty + case Map.lookup i subst of + Just v -> return (subst,0,[(1,v)],count) + Nothing -> let v = Map.size subst + subst' = Map.insert i v subst + in return (subst',0,[(1,v)],count) + Bound _ v -> param2int subst v ty +param2int subst (VSusp i k vs) ty = do + st <- getMeta i + v <- case st of + Narrowing c ty -> do v <- chooseMetaValue c ty + setMeta i (Bound undefined v) + return v + Bound _ v -> return v + g <- globals + param2int subst (apply g (k v) vs) ty +param2int subst (VFV c vs) ty = do + v <- variants c (unvariants vs) + param2int subst v ty +param2int subst v ty = compileError ("the parameter:" <+> ppValue Unqualified 0 v $$ + "cannot be evaluated at compile time.") combine' 1 rs 1 rs' = [] combine' 1 rs cnt' rs' = rs' @@ -302,63 +438,101 @@ combine cnt' ((r,pv):rs) ((r',pv'):rs') = EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs') GT -> ( r',pv') : combine cnt' ((r,pv):rs) rs' + +type ChoiceMap = Map.Map Choice Int +type MetaVars = Map.Map Int MetaState + +newtype GenM a = GenM {unGen :: forall r . Globals -> (a -> ChoiceMap -> MetaVars -> r -> Check r) -> ChoiceMap -> MetaVars -> r -> Check r} + +instance Functor GenM where + fmap f (GenM m) = GenM (\g k -> m g (k . f)) + +instance Applicative GenM where + pure x = GenM (\g k -> k x) + (GenM f) <*> (GenM h) = GenM (\g k -> f g (\fn -> h g (\x -> k (fn x)))) + +instance Alternative GenM where + empty = GenM (\g k svs ms r -> pure r) + (GenM f) <|> (GenM h) = GenM (\g k svs ms r -> f g k svs ms r >>= h g k svs ms) + +instance Monad GenM where + (GenM f) >>= h = GenM (\g k -> f g (\x -> case h x of {GenM h -> h g k})) + +instance MonadFail GenM where + fail msg = GenM (\_ _ _ _ _ -> fail msg) + +runGenM g ms r (GenM f) = f g (\x svs ms xs -> pure (x:xs)) Map.empty ms r + +compileError d = GenM (\_ _ _ _ _ -> checkError d) + +globals = GenM $ \g k -> k g + +variants :: Choice -> [a] -> GenM a +variants c xs = GenM (\g k svs ms r -> + case Map.lookup c svs of + Just j -> k (xs !! j) svs ms r + Nothing -> foldM (\r (j,x) -> k x (Map.insert c j svs) ms r) r (zip [0..] xs)) + +newMeta c ty = GenM $ \_ k svs ms -> + let i = Map.size ms + 1 + in k i svs (Map.insert i (Narrowing c ty) ms) + +getMeta i = GenM $ \_ k svs ms r -> + case Map.lookup i ms of + Just v -> k v svs ms r + Nothing -> checkError (pp "Meta variable" <+> ppMeta i <+> "is not defined") + +setMeta i st = GenM $ \_ k svs ms -> + k () svs (Map.insert i st ms) + +getCnt ty = GenM $ \(Gl gr _ _) k svs ms r -> + case countParamValues gr ty of + Ok c -> k c svs ms r + Bad msg -> checkError (pp msg) + +getIdxCnt q = GenM $ \(Gl gr _ _) k svs ms r -> + case lookupOrigInfo gr q of + Ok (_,ResValue (L _ ty) idx) -> + let (ctxt,QC p) = typeFormCnc ty + in case lookupOrigInfo gr p of + Ok (_,ResParam _ (Just (_,cnt))) -> k (idx,ctxt,cnt) svs ms r + Bad msg -> checkError (pp msg) + Bad msg -> checkError (pp msg) + +chooseMetaValue :: Choice -> Type -> GenM Value +chooseMetaValue s ptyp = GenM $ \g@(Gl gr _ _) k svs ms r -> + case ptyp of + _ | Just n <- isTypeInts ptyp -> foldM (\r i -> k (VInt i) svs ms r) r [0..n] + QC c -> do (mod,info) <- lookupOrigInfo gr c + case info of + ResParam (Just ps) _ -> mkValue mod k svs ms r 0 (unLoc ps) + _ -> checkError (ppQIdent Qualified c <+> "has no parameter values defined") + Q c -> lookupResDef gr c >>= \ty -> unGen (chooseMetaValue s ty) g k svs ms r + RecType lbls -> unGen (mapAccumM mkField s lbls >>= \(_,lbls) -> return (VR lbls)) g k svs ms r + _ -> checkError ("cannot find parameter values for" <+> ptyp) + where + mkValue mod k svs ms r idx [] = return r + mkValue mod k svs ms r idx ((id,ctxt):ps) = do + let (ms',args) = mkVars ms s ctxt + r <- k (VApp (mod,id) args) (Map.insert s idx svs) ms' r + mkValue mod k svs ms r (idx+1) ps + + mkVars ms c [] = (ms,[]) + mkVars ms c ((_,_,ty):ctxt) = + let i = Map.size ms + 1 + (c1,c2) = split c + (ms',args) = mkVars (Map.insert i (Narrowing c1 ty) ms) c2 ctxt + in (ms',VMeta i []:args) + + mkField c (l,_,ty) = do + let (c1,c2) = split c + v <- chooseMetaValue c1 ty + return (c2,(l,v)) + +order :: Ord a => [(a,b)] -> [(a,b)] order = sortBy (\(r1,_) (r2,_) -> compare r2 r1) mapAccumM f a [] = return (a,[]) mapAccumM f a (x:xs) = do (a, y) <- f a x (a,ys) <- mapAccumM f a xs return (a,y:ys) - -type2fields :: SourceGrammar -> Type -> [String] -type2fields gr = type2fields empty - where - type2fields d (Sort s) | s == cStr = [show d] - type2fields d (RecType lbls) = - concatMap (\(lbl,ty) -> type2fields (d <+> pp lbl) ty) lbls - type2fields d (Table p q) = - let Ok ts = allParamValues gr p - in concatMap (\t -> type2fields (d <+> ppTerm Unqualified 5 t) q) ts - type2fields d _ = [] - -mkLinDefault :: SourceGrammar -> Type -> Check Term -mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ - where - mkDefField ty = - case ty of - Table p t -> do t' <- mkDefField t - let T _ cs = mkWildCases t' - return $ T (TWild p) cs - Sort s | s == cStr -> return (Vr varStr) - QC p -> case lookupParamValues gr p of - Ok [] -> checkError ("no parameter values given to type" <+> ppQIdent Qualified p) - Ok (v:_) -> return v - Bad msg -> fail msg - RecType r -> do - let (ls,ts) = unzip r - ts <- mapM mkDefField ts - return $ R (zipWith assign ls ts) - _ | Just _ <- isTypeInts ty -> return $ EInt 0 -- exists in all as first val - _ -> checkError ("a field in a linearization type cannot be" <+> ty) - -mkLinReference :: SourceGrammar -> Type -> Check Term -mkLinReference gr typ = do - mb_term <- mkRefField typ (Vr varStr) - return (Abs Explicit varStr (fromMaybe Empty mb_term)) - where - mkRefField ty trm = - case ty of - Table pty ty -> case allParamValues gr pty of - Ok [] -> checkError ("no parameter values given to type" <+> pty) - Ok (p:ps) -> mkRefField ty (S trm p) - Bad msg -> fail msg - Sort s | s == cStr -> return (Just trm) - QC p -> return Nothing - RecType rs -> traverse rs trm - _ | Just _ <- isTypeInts ty -> return Nothing - _ -> checkError ("a field in a linearization type cannot be" <+> typ) - - traverse [] trm = return Nothing - traverse ((l,ty):rs) trm = do res <- mkRefField ty (P trm l) - case res of - Just trm -> return (Just trm) - Nothing -> traverse rs trm diff --git a/src/compiler/api/GF/Compile/GrammarToCanonical.hs b/src/compiler/api/GF/Compile/GrammarToCanonical.hs index 94dcd0387..b00060a9d 100644 --- a/src/compiler/api/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/api/GF/Compile/GrammarToCanonical.hs @@ -9,7 +9,7 @@ import GF.Grammar import GF.Grammar.Lookup(allOrigInfos,lookupOrigInfo) import GF.Infra.Option(Options,noOptions) import GF.Infra.CheckM -import GF.Compile.Compute.Concrete2 +import GF.Compile.Compute import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe(mapMaybe,fromMaybe) @@ -36,7 +36,6 @@ abstract2canonical absname gr = do mopens = [], mexdeps = [], msrc = "", - mseqs = Nothing, jments = Map.fromList infos }) @@ -74,7 +73,6 @@ concretes2canonical opts absname gr = do mopens = [], mexdeps = [], msrc = "", - mseqs = Nothing, jments = Map.empty } @@ -83,7 +81,7 @@ type QSet = Set.Set (ModuleName,Ident) -- | Generate Canonical GF for the given concrete module. concrete2canonical :: Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check (QSet,Module) concrete2canonical gr absname cncname modinfo = do - let g = Gl gr (stdPredef g) + let g = Gl gr (stdPredef g) False infos <- mapM (convInfo g) (allOrigInfos gr cncname) let pts = Set.unions (map fst infos) return (pts, @@ -96,17 +94,16 @@ concrete2canonical gr absname cncname modinfo = do mopens = [], mexdeps = [], msrc = "", - mseqs = Nothing, jments = Map.fromList (mapMaybe snd infos) })) where - convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mb_prods) = do + convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mpmcfg) = do typ <- normalForm g typ let pts = paramTypes typ - return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mb_prods)) - convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mb_prods) = do + return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mpmcfg)) + convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mpmcfg) = do def <- normalForm g (eta_expand def ctx) - return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mb_prods)) + return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mpmcfg)) convInfo g _ = return (Set.empty,Nothing) eta_expand t [] = t @@ -114,7 +111,7 @@ concrete2canonical gr absname cncname modinfo = do eta_expand t ((Explicit,x,_):ctx) = Abs Explicit x (eta_expand (App t (Vr x)) ctx) -paramTypes (RecType fs) = Set.unions (map (paramTypes.snd) fs) +paramTypes (RecType fs) = Set.unions (map (\(_,_,t)->paramTypes t) fs) paramTypes (Table t1 t2) = Set.union (paramTypes t1) (paramTypes t2) paramTypes (App tf ta) = Set.union (paramTypes tf) (paramTypes ta) paramTypes (Sort _) = Set.empty diff --git a/src/compiler/api/GF/Compile/GrammarToPGF.hs b/src/compiler/api/GF/Compile/GrammarToPGF.hs index a0854d297..0eb3ee2e3 100644 --- a/src/compiler/api/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/api/GF/Compile/GrammarToPGF.hs @@ -57,18 +57,17 @@ grammar2PGF opts mb_pgf gr am probs = do createConcrete (mi2i cm) $ do let cflags = err (const noOptions) mflags (lookupModule gr cm) sequence_ [setConcreteFlag name value | (name,value) <- optionsPGF cflags] - let infos = ( Seq.fromList [Left [SymCat 0 (LParam 0 [])]] - , let id_prod = Production [] [PArg [] (LParam 0 [])] (LParam 0 []) [0] - prods = ([id_prod],[id_prod]) - in [(cInt, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods)) - ,(cString,CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods)) - ,(cFloat, CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just prods)) + let infos = ( let z = LParam 0 [] + id_rule = Rule [] z [z] z [SymCat 0 z] + rules = ([id_rule],[id_rule]) + in [((cm,cInt), CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules)) + ,((cm,cString),CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules)) + ,((cm,cFloat), CncCat (Just (noLoc GM.defLinType)) Nothing Nothing Nothing (Just rules)) ] ) - : prepareSeqTbls (Look.allOrigInfos gr cm) - infos <- processInfos createCncCats infos - infos <- processInfos createCncFuns infos - return () + ++ Look.allOrigInfos gr cm + mapM_ createCncCats infos + mapM_ createCncFuns infos return pgf where aflags = err (const noOptions) mflags (lookupModule gr am) @@ -83,13 +82,13 @@ grammar2PGF opts mb_pgf gr am probs = do ((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c] funs = [(f', mkType [] ty, arity, bcode, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) | - ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs, - let arity = mkArity ma mdef ty, - let bcode = mkDef gr arity mdef, + ((m,f),AbsFun (Just (L _ ty)) mdef) <- adefs, + let arity = mkArity mdef ty, + let bcode = mkDef gr mdef, let f' = i2i f] funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++)) - [(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _ _ _) <- adefs, + [(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _) <- adefs, let (_,(_,cat),_) = GM.typeForm ty, let f' = i2i f] where @@ -100,38 +99,19 @@ grammar2PGF opts mb_pgf gr am probs = do 0 -> 0 n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n) - prepareSeqTbls infos = - (map addSeqTable . Map.toList . Map.fromListWith (++)) - [(m,[(c,info)]) | ((m,c),info) <- infos] - where - addSeqTable (m,infos) = - case lookupModule gr m of - Ok mi -> case mseqs mi of - Just seqs -> (fmap Left seqs,infos) - Nothing -> (Seq.empty,[]) - Bad msg -> error msg - - processInfos f [] = return [] - processInfos f ((seqtbl,infos):rest) = do - seqtbl <- foldM f seqtbl infos - rest <- processInfos f rest - return ((seqtbl,infos):rest) - - createCncCats seqtbl (c,CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do - seqtbl <- createLincat (i2i c) (type2fields gr ty) lindefs linrefs seqtbl + createCncCats ((_,c),CncCat (Just (L _ ty)) _ _ mprn (Just (lindefs,linrefs))) = do + createLincat (i2i c) (type2fields gr ty) lindefs linrefs case mprn of Nothing -> return () Just (L _ prn) -> setPrintName (i2i c) (unwords (term2tokens prn)) - return seqtbl - createCncCats seqtbl _ = return seqtbl + createCncCats _ = return () - createCncFuns seqtbl (f,CncFun _ _ mprn (Just prods)) = do - seqtbl <- createLin (i2i f) prods seqtbl + createCncFuns ((_,f),CncFun _ _ mprn (Just rules)) = do + createLin (i2i f) rules case mprn of Nothing -> return () Just (L _ prn) -> setPrintName (i2i f) (unwords (term2tokens prn)) - return seqtbl - createCncFuns seqtbl _ = return seqtbl + createCncFuns _ = return () term2tokens (K tok) = [tok] term2tokens (C t1 t2) = term2tokens t1 ++ term2tokens t2 @@ -173,7 +153,6 @@ mkPatt scope p = A.PV x -> (x:scope,C.PVar (i2i x)) A.PAs x p -> let (scope',p') = mkPatt scope p in (x:scope',C.PAs (i2i x) p') - A.PW -> ( scope,C.PWild) A.PInt i -> ( scope,C.PLit (C.LInt (fromIntegral i))) A.PFloat f -> ( scope,C.PLit (C.LFlt f)) A.PString s -> ( scope,C.PLit (C.LStr s)) @@ -188,13 +167,12 @@ mkContext scope hyps = mapAccumL (\scope (bt,x,ty) -> let ty' = mkType scope ty then ( scope,(bt,i2i x,ty')) else (x:scope,(bt,i2i x,ty'))) scope hyps -mkDef gr arity (Just eqs) = generateByteCode gr arity eqs -mkDef gr arity Nothing = [] +mkDef gr (Just (arity,eqs)) = generateByteCode gr arity eqs +mkDef gr Nothing = [] -mkArity (Just a) _ ty = a -- known arity, i.e. defined function -mkArity Nothing (Just _) ty = 0 -- defined function with no arity - must be an axiom -mkArity Nothing _ ty = let (ctxt, _, _) = GM.typeForm ty -- constructor - in length ctxt +mkArity (Just (a,_)) ty = a -- known arity, i.e. defined function +mkArity Nothing ty = let (ctxt, _, _) = GM.typeForm ty -- constructor + in length ctxt {- genCncCats gr am cm cdefs = mkCncCats 0 cdefs where diff --git a/src/compiler/api/GF/Compile/Rename.hs b/src/compiler/api/GF/Compile/Rename.hs index 6015f3a7a..a4e908e06 100644 --- a/src/compiler/api/GF/Compile/Rename.hs +++ b/src/compiler/api/GF/Compile/Rename.hs @@ -30,7 +30,6 @@ module GF.Compile.Rename ( import GF.Infra.Ident import GF.Infra.CheckM import GF.Grammar.Grammar -import GF.Grammar.Values import GF.Grammar.Predef import GF.Grammar.Lookup import GF.Grammar.Macros @@ -87,7 +86,7 @@ renameIdentTerm' env@(act,imps) t0 = -- this facility is mainly for BWC with GF1: you need not import PredefAbs predefAbs c s - | isPredefCat c = return (Q (cPredefAbs,c)) + | isPredefCat c = return (QC (cPredefAbs,c)) | otherwise = checkError s ident alt c = @@ -106,7 +105,8 @@ renameIdentTerm' env@(act,imps) t0 = info2status :: Maybe ModuleName -> Ident -> Info -> Term info2status mq c i = case i of - AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq c + AbsCat _ -> maybe Con (curry QC) mq c + AbsFun _ Nothing -> maybe Con (curry QC) mq c ResValue _ _ -> maybe Con (curry QC) mq c ResParam _ _ -> maybe Con (curry QC) mq c AnyInd True m -> maybe Con (const (curry QC m)) mq c @@ -159,7 +159,7 @@ renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info renameInfo cwd status (m,mi) i info = case info of AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco) - AbsFun pty pa ptr poper -> liftM4 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr) (return poper) + AbsFun pty ptr -> liftM2 AbsFun (renTerm pty) (renMaybe (\(a,eqs) -> fmap ((,) a) (mapM (renLoc (renEquation status)) eqs)) ptr) ResOper pty ptr -> liftM2 ResOper (renTerm pty) (renTerm ptr) ResOverload os tysts -> liftM (ResOverload os) (mapM (renPair (renameTerm status [])) tysts) ResParam (Just pp) m -> do @@ -218,6 +218,13 @@ renameTerm env vars = ren vars where _ -> return i liftM (T i') $ mapM (renCase vs) cs + RecType rs -> do + rs <- forM rs $ \(l,deps,t) -> do + t <- renameTerm env (deps++vs) t + let deps' = L.intersect deps (freeVars vs t) + return (l,deps',t) + return (RecType rs) + Let (x,(m,a)) b -> do m' <- case m of Just ty -> liftM Just $ ren vs ty @@ -255,6 +262,11 @@ renameTerm env vars = ren vars where return (p',t') renpatt = renamePattern env + freeVars xs (Abs _ x e) = freeVars (x:xs) e + freeVars xs (Vr x) + | not (elem x xs) = [x] + freeVars xs e = collectOp (freeVars xs) e + -- | vars not needed in env, since patterns always overshadow old vars renamePattern :: Status -> Patt -> Check (Patt,[Ident]) renamePattern env patt = @@ -293,7 +305,8 @@ renamePattern env patt = _ -> checkError ("not a pattern macro" <+> ppPatt Qualified 0 patt) return (PM c', []) - PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of + PV x | x /= identW + -> checks [ renid' (Vr x) >>= \t' -> case t' of QC c -> return (PP c [],[]) _ -> checkError (pp "not a constructor") , return (patt, [x]) @@ -327,6 +340,10 @@ renamePattern env patt = (p',vs) <- renp p return (PAs x p', x:vs) + PImplArg p -> do + (p,vs) <- renp p + return (PImplArg p, vs) + _ -> return (patt,[]) renid = renameIdentTerm env diff --git a/src/compiler/api/GF/Compile/SubExOpt.hs b/src/compiler/api/GF/Compile/SubExOpt.hs index 09ec3e568..6b9d908b9 100644 --- a/src/compiler/api/GF/Compile/SubExOpt.hs +++ b/src/compiler/api/GF/Compile/SubExOpt.hs @@ -31,6 +31,7 @@ import qualified GF.Grammar.Macros as C import GF.Data.ErrM(fromErr) import Control.Monad.State.Strict(State,evalState,get,put) +import Data.Maybe(isJust) import Data.Map (Map) import qualified Data.Map as Map @@ -136,6 +137,6 @@ operIdent :: Int -> Ident operIdent i = identC (operPrefix `prefixRawIdent` (rawIdentS (show i))) --- isOperIdent :: Ident -> Bool -isOperIdent id = isPrefixOf operPrefix (ident2raw id) +isOperIdent id = isJust (isPrefixOf operPrefix (ident2raw id)) operPrefix = rawIdentS ("A''") diff --git a/src/compiler/api/GF/Compile/Tags.hs b/src/compiler/api/GF/Compile/Tags.hs index 8b2e2c312..db3323a8e 100644 --- a/src/compiler/api/GF/Compile/Tags.hs +++ b/src/compiler/api/GF/Compile/Tags.hs @@ -28,8 +28,8 @@ getLocalTags x (m,mi) = where getLocations :: Info -> [(String,String,String)] getLocations (AbsCat mb_ctxt) = maybe (loc "cat") mb_ctxt - getLocations (AbsFun mb_type _ mb_eqs _) = maybe (ltype "fun") mb_type ++ - maybe (list (loc "def")) mb_eqs + getLocations (AbsFun mb_type mb_eqs) = maybe (ltype "fun") mb_type ++ + maybe (list (loc "def") . snd) mb_eqs getLocations (ResParam mb_params _) = maybe (loc "param") mb_params getLocations (ResValue mb_type _) = ltype "param-value" mb_type getLocations (ResOper mb_type mb_def) = maybe (ltype "oper-type") mb_type ++ diff --git a/src/compiler/api/GF/Compile/TerminationCheck.hs b/src/compiler/api/GF/Compile/TerminationCheck.hs new file mode 100644 index 000000000..07de1991a --- /dev/null +++ b/src/compiler/api/GF/Compile/TerminationCheck.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE BangPatterns #-} +module GF.Compile.TerminationCheck where + +import GF.Grammar +import Debug.Trace + +callGraph m c (ps,t) = + let (_,xs) = foldl (\(i,xs) p -> (i+1,patts i EQ xs p)) (0,[]) ps + cs = calls m 0 xs t [] [] + in trace (show (c,cs)) $ return () + +patts i ord xs (PP _ ps) = foldl (patts i LT) xs ps +patts i ord xs (PV x) + | x /= identW = (x,(i,ord)):xs +patts i ord xs (PR as) = foldl (\xs (_,p) -> patts i ord xs p) xs as +patts i ord xs (PT ty p) = patts i ord xs p +patts i ord xs (PAs x p) = patts i ord ((x,(i,ord)):xs) p +patts i ord xs (PImplArg p) = patts i ord xs p +patts i ord xs (PSeq _ _ p1 _ _ p2) = patts i LT (patts i LT xs p1) p2 +patts i ord xs _ = xs + + +calls m i xs (App t1 t2) args cs = + let args' = case t2 of + Vr x -> case lookup x xs of + Just (j,ord) -> (i,j,ord):args + Nothing -> args + _ -> args + in calls m (i+1) xs t1 args' (calls m 0 xs t2 [] cs) +calls m i xs (Q (m',q)) args cs + | m == m' = + let args' = [(i-i'-1,j,ord) | (i',j,ord) <- args] + in (q,args') : cs +calls m i xs _ args cs = cs + + +matmul a b = + sum [(i,k,mul ord1 ord2) | (i ,j,ord1) <- a + , (j',k,ord2) <- b + , j==j' + ] + [] + where + sum [] ys = ys + sum (x@(i,k,ord) : xs) ys = sum xs (accumulate ys) + where + accumulate [] = [x] + accumulate (y@(i',k',ord') : ys) + | i==i' && k==k' = let !sum = add ord ord' + in (i',k',sum):ys + | otherwise = y : accumulate ys + + add LT LT = LT + add LT EQ = LT + add LT GT = LT + add EQ LT = LT + add EQ EQ = EQ + add EQ GT = EQ + add GT LT = LT + add GT EQ = EQ + add GT GT = GT + + mul LT LT = LT + mul LT EQ = LT + mul LT GT = GT + mul EQ LT = LT + mul EQ EQ = EQ + mul EQ GT = GT + mul GT LT = GT + mul GT EQ = GT + mul GT GT = GT diff --git a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/api/GF/Compile/TypeCheck.hs similarity index 74% rename from src/compiler/api/GF/Compile/TypeCheck/Concrete.hs rename to src/compiler/api/GF/Compile/TypeCheck.hs index d85972e95..f4d31bac0 100644 --- a/src/compiler/api/GF/Compile/TypeCheck/Concrete.hs +++ b/src/compiler/api/GF/Compile/TypeCheck.hs @@ -1,16 +1,22 @@ {-# LANGUAGE RankNTypes, CPP, TupleSections, LambdaCase #-} -module GF.Compile.TypeCheck.Concrete ( checkLType, checkLType', inferLType, inferLType' ) where +module GF.Compile.TypeCheck + ( checkLType, checkLType' + , inferLType, inferLType' + , checkContext + , checkDef + ) where -- The code here is based on the paper: -- Simon Peyton Jones, Dimitrios Vytiniotis, Stephanie Weirich. -- Practical type inference for arbitrary-rank types. -- 14 September 2011 -import GF.Grammar hiding (Env, VGen, VApp, VRecType, ppValue) +import Prelude hiding ((<>)) +import GF.Grammar import GF.Grammar.Lookup import GF.Grammar.Predef import GF.Grammar.Lockfield -import GF.Compile.Compute.Concrete2 +import GF.Compile.Compute import GF.Infra.CheckM import GF.Data.ErrM ( Err(Ok, Bad) ) import Control.Applicative(Applicative(..),(<|>)) @@ -58,6 +64,37 @@ inferLType' t = do t <- zonkTerm [] t return (t,vty) +checkContext :: Globals -> Context -> Check Context +checkContext g ctxt = do + res <- runEvalM g $ check [] unit ctxt + case res of + [tty] -> return tty + _ -> checkError (pp "Encountered variants while type checking") + where + check scope c [] = return [] + check scope c ((bt,x,ty):ctxt) = do + let (c1,c23) = split c + (c2,c3) = split c23 + (ty,_) <- tcRho scope c1 ty (Just vtypeType) + ty <- zonkTerm (scopeVars scope) ty + g <- globals + ctxt <- check ((x,eval g (scopeEnv scope) c2 ty []):scope) c3 ctxt + return ((bt,x,ty):ctxt) + +checkDef :: Globals -> QIdent -> Type -> Equation -> Check Equation +checkDef g q ty (ps,t) = do + let (c1,c23) = split unit + (c2,c3) = split c23 + res <- runEvalM g $ do + (scope,ps,_,ty) <- tcPattApp [] c1 (eval g [] c2 ty []) ps + (scope,ps) <- mapAccumM zonkPatt scope ps + (t,_) <- tcRho scope c3 t (Just ty) + t <- zonkTerm (scopeVars scope) t + return (ps,t) + case res of + [eq] -> return eq + _ -> checkError (pp "Encountered variants while type checking") + inferSigma :: Scope -> Choice -> Term -> EvalM (Term,Sigma) inferSigma scope s t = do -- GEN1 (t,ty) <- tcRho scope s t Nothing @@ -66,13 +103,13 @@ inferSigma scope s t = do -- GEN1 let forall_tvs = res_tvs \\ env_tvs quantify scope t forall_tvs ty -vtypeInt = VApp poison (cPredef,cInt) [] -vtypeFloat = VApp poison (cPredef,cFloat) [] +vtypeInt = VApp (cPredef,cInt) [] +vtypeFloat = VApp (cPredef,cFloat) [] vtypeStr = VSort cStr vtypeStrs = VSort cStrs vtypeType = VSort cType vtypePType = VSort cPType -vtypeMarkup= VApp poison (cPredef,cMarkup) [] +vtypeMarkup= VApp (cPredef,cMarkup) [] tcRho :: Scope -> Choice -> Term -> Maybe Rho -> EvalM (Term, Rho) tcRho scope s t@(EInt i) mb_ty = instSigma scope s t (VInts i True) mb_ty -- INT @@ -98,7 +135,9 @@ tcRho scope c (Abs bt var body) Nothing = do -- ABS1 in return (Abs bt var body, (VProd bt v arg_ty body_ty)) else return (Abs bt var body, (VProd bt identW arg_ty body_ty)) where - check m n st (VApp c f vs) = foldM (check m n) st vs + check m n st (VApp f vs) = foldM (check m n) st vs + check m n st (VPAP c f vs) = foldM (check m n) st vs + check m n st (VConst f vs) = foldM (check m n) st vs check m n st (VMeta i vs) = do state <- getMeta i case state of @@ -194,15 +233,15 @@ tcRho scope c (Typed body ann_ty) mb_ty = do -- ANNOT let v_ann_ty = eval g (scopeEnv scope) c2 ann_ty [] (body,_) <- tcRho scope c3 body (Just v_ann_ty) instSigma scope c4 (Typed body ann_ty) v_ann_ty mb_ty -tcRho scope c (FV ts) mb_ty = do +tcRho scope c (FV ts) mb_ty = concreteOnly "Variants" $ do (ts,ty) <- tcUnifying scope c ts mb_ty return (FV ts, ty) tcRho scope s t@(Sort _) mb_ty = do instSigma scope s t vtypeType mb_ty -tcRho scope c t@(RecType rs) Nothing = do - (rs,mb_ty) <- tcRecTypeFields scope c [] rs Nothing +tcRho scope c t@(RecType rs) Nothing = concreteOnly "Record types" $ do + (rs,mb_ty) <- tcRecTypeFields scope c rs Nothing return (RecType rs,fromMaybe vtypePType mb_ty) -tcRho scope c t@(RecType rs) (Just ty) = do +tcRho scope c t@(RecType rs) (Just ty) = concreteOnly "Record types" $ do (scope,f,ty') <- skolemise scope ty case ty' of VSort s @@ -214,9 +253,9 @@ tcRho scope c t@(RecType rs) (Just ty) = do ty -> do ty <- value2termM False (scopeVars scope) ty evalError ("The record type" <+> ppTerm Unqualified 0 t $$ "cannot be of type" <+> ppTerm Unqualified 0 ty) - (rs,mb_ty) <- tcRecTypeFields scope c [] rs (Just ty') + (rs,mb_ty) <- tcRecTypeFields scope c rs (Just ty') return (f (RecType rs),ty) -tcRho scope s t@(Table p res) mb_ty = do +tcRho scope s t@(Table p res) mb_ty = concreteOnly "Tables" $ do let (s1,s23) = split s (s2,s3) = split s23 (p, p_ty) <- tcRho scope s1 p (Just vtypePType) @@ -239,7 +278,7 @@ tcRho scope c (S t p) mb_ty = do (t,t_ty) <- tcRho scope c1 t (Just t_ty) (p,_) <- tcRho scope c2 p (Just p_ty) return (S t p, res_ty) -tcRho scope c (T tt ps) Nothing = do -- ABS1/AABS1 for tables +tcRho scope c (T tt ps) Nothing = concreteOnly "Tables" $ do -- ABS1/AABS1 for tables let (c1,c2) = split c mb_p_ty <- case tt of TRaw -> return Nothing @@ -250,7 +289,7 @@ tcRho scope c (T tt ps) Nothing = do -- ABS1/AABS1 for (ps,p_ty,res_ty) <- tcCases scope c2 ps mb_p_ty Nothing p_ty_t <- value2termM True [] p_ty return (T (TTyped p_ty_t) ps, VTable p_ty res_ty) -tcRho scope c (T tt ps) (Just ty) = do -- ABS2/AABS2 for tables +tcRho scope c (T tt ps) (Just ty) = concreteOnly "Tables" $ do -- ABS2/AABS2 for tables let (c12,c34) = split c (c3,c4) = split c34 (scope,f,ty') <- skolemise scope ty @@ -265,7 +304,7 @@ tcRho scope c (T tt ps) (Just ty) = do -- ABS2/AABS2 for (ps,p_ty,res_ty) <- tcCases scope c3 ps (Just p_ty) (Just res_ty) p_ty_t <- value2termM True (scopeVars scope) p_ty return (f (T (TTyped p_ty_t) ps), VTable p_ty res_ty) -tcRho scope c (V p_ty ts) Nothing = do +tcRho scope c (V p_ty ts) Nothing = concreteOnly "Tables" $ do let (c1,c2,c3,c4) = split4 c (p_ty, _) <- tcRho scope c1 p_ty (Just vtypeType) i <- newResiduation scope @@ -278,7 +317,7 @@ tcRho scope c (V p_ty ts) Nothing = do ts <- mapCM go c2 ts g <- globals return (V p_ty ts, VTable (eval g (scopeEnv scope) c3 p_ty []) res_ty) -tcRho scope c (V p_ty0 ts) (Just ty) = do +tcRho scope c (V p_ty0 ts) (Just ty) = concreteOnly "Tables" $ do let (c1,c2,c3,c4) = split4 c (scope,f,ty') <- skolemise scope ty (p_ty, res_ty) <- unifyTbl scope ty' @@ -288,16 +327,16 @@ tcRho scope c (V p_ty0 ts) (Just ty) = do unify scope p_ty p_vty0 ts <- mapCM (\c t -> fmap fst $ tcRho scope c t (Just res_ty)) c3 ts return (V p_ty0 ts, VTable p_ty res_ty) -tcRho scope c (R rs) Nothing = do +tcRho scope c (R rs) Nothing = concreteOnly "Records" $ do lttys <- inferRecFields scope c [] rs rs <- mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys return (R rs, VRecType [(l,True,ty) | (l,t,ty) <- lttys] False ) -tcRho scope c (R rs) (Just ty) = do +tcRho scope c (R rs) (Just ty) = concreteOnly "Records" $ do (scope,f,ty') <- skolemise scope ty case ty' of - (VRecType ltys _)->do lttys <- checkRecFields scope c [] rs ltys + (VRecType ltys _)->do lttys <- checkRecFields scope c rs [] ltys rs <- mapM (\(l,t,ty) -> value2termM True (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys return ((f . R) rs, VRecType [(l,True,ty) | (l,t,ty) <- lttys] False @@ -314,12 +353,12 @@ tcRho scope c (P t l) mb_ty = do return (VMeta i []) (t,t_ty) <- tcRho scope c t (Just (VRecType [(l,True,l_ty)] True)) return (P t l,l_ty) -tcRho scope c (C t1 t2) mb_ty = do +tcRho scope c (C t1 t2) mb_ty = concreteOnly "String operations" $ do let (c1,c2,c3,c4) = split4 c (t1,t1_ty) <- tcRho scope c1 t1 (Just vtypeStr) (t2,t2_ty) <- tcRho scope c2 t2 (Just vtypeStr) instSigma scope c3 (C t1 t2) vtypeStr mb_ty -tcRho scope c (Glue t1 t2) mb_ty = do +tcRho scope c (Glue t1 t2) mb_ty = concreteOnly "String operations" $ do let (c1,c2,c3,c4) = split4 c (t1,t1_ty) <- tcRho scope c1 t1 (Just vtypeStr) (t2,t2_ty) <- tcRho scope c2 t2 (Just vtypeStr) @@ -333,7 +372,7 @@ tcRho scope c t@(ExtR t1 t2) mb_ty = (t1,ty1@(VRecType ltys1 ext)) <- tcRho scope c1 t1 (Just (VRecType [field | field@(l,_,_) <- ltys, not (elem l ll2)] ext)) let (scope',proj1,wrap) = access scope t1 ty1 - lttys2 <- checkRecFields scope' c2 [] rs [field | field@(l,_,_) <- ltys, elem l ll2] + lttys2 <- checkRecFields scope' c2 rs [] [field | field@(l,_,_) <- ltys, elem l ll2] let proj2 l = case [(Nothing,t) | (l',t,_) <- lttys2, l'==l] of [] -> Nothing @@ -365,7 +404,7 @@ tcRho scope c t@(ExtR t1 t2) mb_ty = ) access scope (RecType rs) ty = (scope - ,\l -> fmap ((,) Nothing) (lookup l rs) + ,\l -> fmap ((,) Nothing) (lookup3 l rs) ,id ) access scope t@(Vr x) ty @@ -415,8 +454,8 @@ tcRho scope c t@(ExtR t1 t2) mb_ty = tcRho scope c (ELin cat t) mb_ty = do -- this could be done earlier, i.e. in the parser tcRho scope c (ExtR t (R [(lockLabel cat,(Just (RecType []),R []))])) mb_ty tcRho scope c (ELincat cat t) mb_ty = do -- this could be done earlier, i.e. in the parser - tcRho scope c (ExtR t (RecType [(lockLabel cat,RecType [])])) mb_ty -tcRho scope c (Alts t ss) mb_ty = do + tcRho scope c (ExtR t (RecType [(lockLabel cat,[],RecType [])])) mb_ty +tcRho scope c (Alts t ss) mb_ty = concreteOnly "String operations" $ do let (c1,c2,c3,c4) = split4 c (t,_) <- tcRho scope c1 t (Just vtypeStr) ss <- mapCM (\c (t1,t2) -> do @@ -426,36 +465,36 @@ tcRho scope c (Alts t ss) mb_ty = do return (t1,t2)) c2 ss instSigma scope c3 (Alts t ss) vtypeStr mb_ty -tcRho scope c (Strs ss) mb_ty = do +tcRho scope c (Strs ss) mb_ty = concreteOnly "String operations" $ do let (c1,c2) = split c ss <- mapCM (\c t -> do (t,_) <- tcRho scope c t (Just vtypeStr) return t) c1 ss instSigma scope c2 (Strs ss) vtypeStrs mb_ty -tcRho scope c (EPattType ty) mb_ty = do +tcRho scope c (EPattType ty) mb_ty = concreteOnly "Pattern types" $ do let (c1,c2) = split c (ty, _) <- tcRho scope c1 ty (Just vtypeType) instSigma scope c2 (EPattType ty) vtypeType mb_ty -tcRho scope c t@(EPatt _ _ p) mb_ty = do +tcRho scope c t@(EPatt _ _ p) mb_ty = concreteOnly "Patterns" $ do (scope,f,mb_ty) <- case mb_ty of Nothing -> return (scope,id,Nothing) Just ty -> do (scope,f,ty) <- skolemise scope ty case ty of VPattType ty -> return (scope,f,Just ty) _ -> evalError (ppTerm Unqualified 0 t <+> "must be of pattern type but" <+> ppTerm Unqualified 0 t <+> "is expected") - (_,ty) <- tcPatt scope c p mb_ty + (_,p,_,ty) <- tcPatt scope c p mb_ty (min,max,p) <- measurePatt p return (f (EPatt min max p), VPattType ty) -tcRho scope c (Markup tag attrs children) mb_ty = do +tcRho scope c (Markup tag attrs children) mb_ty = concreteOnly "Markups" $ do let (c1,c2,c3,c4) = split4 c attrs <- mapCM (\c (id,t) -> do (t,_) <- tcRho scope c t Nothing return (id,t)) c1 attrs - res <- mapCM (\c child -> tcRho scope c child Nothing) c2 children - instSigma scope c3 (Markup tag attrs (map fst res)) vtypeMarkup mb_ty + res <- mapCM (\c (L loc child) -> fmap (L loc . fst) (tcRho scope c child Nothing)) c2 children + instSigma scope c3 (Markup tag attrs res) vtypeMarkup mb_ty tcRho scope c (Reset ctl mb_ct t qid) mb_ty - | ctl == cConcat || ctl == cConcat' = do + | ctl == cConcat || ctl == cConcat' = concreteOnly "Control operators" $ do let (c1,c23) = split c (c2,c3 ) = split c23 (t,_) <- tcRho scope c1 t Nothing @@ -464,7 +503,7 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty return (Just ct) Nothing -> return Nothing instSigma scope c2 (Reset ctl mb_ct t qid) vtypeMarkup mb_ty - | ctl == cOne = do + | ctl == cOne = concreteOnly "Control operators" $ do let (c1,c2) = split c (t,ty) <- tcRho scope c1 t mb_ty (mb_ct,ty) <- case mb_ct of @@ -472,7 +511,7 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty return (Just ct,ty) Nothing -> return (Nothing,ty) return (Reset ctl mb_ct t qid,ty) - | ctl == cSelect = do + | ctl == cSelect = concreteOnly "Control operators" $ do let (c1,c2) = split c ty <- case mb_ty of Just ty -> return ty @@ -487,7 +526,20 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty Nothing -> evalError (pp "[select: .. | ..] requires an integer argument") (t,_) <- tcRho scope c1 t (Just rec_ty) return (Reset ctl mb_ct t qid,ty) - | ctl == cDefault = do + | ctl == cFilter = concreteOnly "Control operators" $ do + ty <- case mb_ty of + Just ty -> return ty + Nothing -> do i <- newResiduation scope + return (VMeta i []) + let rec_ty = VRecType [ (ident2label cp1, True, ty) + , (ident2label cp2, True, VApp (cPredef,cBool) []) + ] False + case mb_ct of + Just ct -> evalError (pp "[filter | ..] cannot take an argument") + Nothing -> return () + (t,_) <- tcRho scope c t (Just rec_ty) + return (Reset ctl mb_ct t qid,ty) + | ctl == cDefault = concreteOnly "Control operators" $ do let (c1,c2) = split c (t,ty) <- tcRho scope c1 t mb_ty (mb_ct,ty) <- case mb_ct of @@ -495,7 +547,7 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty return (Just ct,ty) Nothing -> evalError (pp "[list: .. | ..] requires an argument") return (Reset ctl mb_ct t qid,ty) - | ctl == cList = do + | ctl == cList = concreteOnly "Control operators" $ do do let (c1,c2) = split c mb_ct <- case mb_ct of Just ct -> do (ct,ty) <- tcRho scope c1 ct Nothing @@ -503,9 +555,9 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty Nothing -> evalError (pp "[list: .. | ..] requires an argument") (t,ty) <- tcRho scope c2 t mb_ty case ty of - VApp c qid [] -> return (Reset ctl mb_ct t (Just qid), ty) - _ -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty) - | ctl == cLen = do + VApp qid [] -> return (Reset ctl mb_ct t (Just qid), ty) + _ -> evalError (pp "Needs atomic type"<+>ppValue Unqualified 0 ty) + | ctl == cLen = concreteOnly "Control operators" $ do do let (c1,c2) = split c (t,_) <- tcRho scope c1 t Nothing case mb_ct of @@ -516,8 +568,16 @@ tcRho scope c (Reset ctl mb_ct t qid) mb_ty (ct,_) <- tcRho scope c2 ct (Just (VProd Explicit identW vtypeInt res_ty)) return (Reset ctl (Just ct) t Nothing, res_ty) Nothing -> instSigma scope c2 (Reset ctl Nothing t Nothing) vtypeInt mb_ty - | otherwise = evalError (pp "Operator" <+> pp ctl <+> pp "is not defined") -tcRho scope s (Opts n cs) mb_ty = do + | ctl == cConst = concreteOnly "Control operators" $ do + let (c1,c2) = split c + (t,_) <- tcRho scope c1 t Nothing + (mb_ct,ty) <- case mb_ct of + Just ct -> do (ct,ty) <- tcRho scope c2 ct mb_ty + return (Just ct,ty) + Nothing -> evalError (pp "[list: .. | ..] requires an argument") + return (Reset ctl mb_ct t qid,ty) + | otherwise = concreteOnly "Control operators" $ evalError (pp "Operator" <+> pp ctl <+> pp "is not defined") +tcRho scope s (Opts n cs) mb_ty = concreteOnly "Options" $ do let (s1,s2,s3) = split3 s (n,_) <- tcRho scope s1 n Nothing (ls,_) <- tcUnifyingMaybe scope s2 (fst <$> cs) Nothing @@ -525,6 +585,12 @@ tcRho scope s (Opts n cs) mb_ty = do return (Opts n (zip ls ts), ty) tcRho scope s t _ = unimplemented ("tcRho "++show t) +concreteOnly msg f = do + (Gl _ _ isAbstract) <- globals + if isAbstract + then evalError (pp (msg ++ " are not supported in the abstract syntax")) + else f + evalCodomain :: Ident -> Value -> Value -> EvalM Value evalCodomain x v (VClosure env c ty) = do g <- globals @@ -565,15 +631,15 @@ tcUnifyingMaybe scope c ts mb_ty = do tcCases scope c [] (Just p_ty) (Just res_ty) = return ([],p_ty,res_ty) tcCases scope c ((p,t):cs) mb_p_ty mb_res_ty = do let (c1,c2,c3,c4) = split4 c - (scope',p_ty) <- tcPatt scope c1 p mb_p_ty + (scope',p,_,p_ty) <- tcPatt scope c1 p mb_p_ty (t,res_ty) <- tcRho scope' c2 t mb_res_ty (cs,p_ty,res_ty) <- tcCases scope c3 cs (Just p_ty) (Just res_ty) (_,_,p) <- measurePatt p return ((p,t):cs,p_ty,res_ty) tcApp scope c t0 (App fun arg) args mb_ty = tcApp scope c t0 fun (arg:args) mb_ty -- APP -tcApp scope c t0 t@(Q id) args mb_ty = resolveOverloads scope c t0 id args mb_ty -- VAR (global) -tcApp scope c t0 t@(QC id) args mb_ty = resolveOverloads scope c t0 id args mb_ty -- VAR (global) +tcApp scope c t0 t@(Q q) args mb_ty = resolveOverloads scope c t0 q args mb_ty -- VAR (global) +tcApp scope c t0 t@(QC q) args mb_ty = resolveOverloads scope c t0 q args mb_ty -- VAR (global) tcApp scope c t0 t args mb_ty = do let (c1,c23) = split c let (c2,c3) = split c23 @@ -587,8 +653,8 @@ reapply1 scope c fun fun_ty ((ImplArg arg):args) = do -- Implicit arg case let (c1,c2,c3,c4) = split4 c (bt, x, arg_ty, res_ty) <- unifyFun scope fun_ty unless (bt == Implicit) $ - evalError (ppTerm Unqualified 0 (App fun (ImplArg arg)) <+> - "is an implicit argument application, but no implicit argument is expected") + evalError (ppTerm Unqualified 0 (ImplArg arg) <+> + "is an unexpected implicit argument") (arg,_) <- tcRho scope c1 arg (Just arg_ty) g <- globals res_ty <- evalCodomain x (eval g (scopeEnv scope) c2 arg []) res_ty @@ -604,22 +670,29 @@ reapply1 scope c fun fun_ty (arg:args) = do -- Explicit arg (fallthrough) case resolveOverloads :: Scope -> Choice -> Term -> QIdent -> [Term] -> Maybe Rho -> EvalM (Term,Rho) resolveOverloads scope c t0 q args mb_ty = do - g@(Gl gr _) <- globals - case lookupOverloadTypes gr q of - Bad msg -> evalError (pp msg) - Ok [(t,ty)] -> do let (c1,c23) = split c - (c2,c3) = split c23 - (t,ty) <- reapply1 scope c1 t (eval g [] c2 ty []) args - instSigma scope c3 t ty mb_ty - Ok ttys -> do let (c1,c23) = split c - (c2,c3) = split c23 - sz <- checkpoint - arg_tys <- mapCM (checkArg g) c1 args - let v_ttys = mapC (\c (t,ty) -> (t,eval g [] c ty [])) c2 ttys - try sz - (\(fun,fun_ty) -> reapply2 scope c3 fun fun_ty arg_tys mb_ty) - (\ttys -> fmap (\(ts,ty) -> (mkFV ts,ty)) (snd (minimum g ttys))) - v_ttys + g@(Gl gr _ isAbstract) <- globals + if isAbstract + then case lookupAbsType gr q of + Bad msg -> evalError (pp msg) + Ok (t,ty) -> do let (c1,c23) = split c + (c2,c3) = split c23 + (t,ty) <- reapply1 scope c1 t (eval g [] c2 ty []) args + instSigma scope c3 t ty mb_ty + else case lookupOverloadTypes gr q of + Bad msg -> evalError (pp msg) + Ok [(t,ty)] -> do let (c1,c23) = split c + (c2,c3) = split c23 + (t,ty) <- reapply1 scope c1 t (eval g [] c2 ty []) args + instSigma scope c3 t ty mb_ty + Ok ttys0 -> do let (c1,c23) = split c + (c2,c3) = split c23 + sz <- checkpoint + arg_tys <- mapCM (checkArg g) c1 args + let v_ttys = mapC (\c (t,ty) -> (t,eval g [] c ty [])) c2 ttys0 + try sz + (\(fun,fun_ty) -> reapply2 scope c3 fun fun_ty arg_tys mb_ty) + (\ttys -> fmap (\(ts,ty) -> (mkFV ts,ty)) (snd (minimum g ttys0 arg_tys ttys))) + v_ttys where checkArg g c (ImplArg arg) = do let (c1,c2) = split c @@ -635,12 +708,22 @@ resolveOverloads scope c t0 q args mb_ty = do mkFV [t] = t mkFV ts = FV ts - minimum g [] = (maxBound,err) + minimum g ttys0 arg_tys [] = (maxBound,err) where - err = evalError (pp "Overload resolution failed") - minimum g (tty@(t,ty):ttys) = + err = evalError ("no overload instance in the term" $$ + nest 4 (pp (foldl App (Q q) args)) $$ + (case mb_ty of + Just vty -> pp "with value type" $$ + nest 4 (ppValue Unqualified 0 vty) + Nothing -> empty) $$ + "and argument types" $$ + nest 4 (fsep (punctuate (pp ',') [ppValue Terse 0 ty | (_,_,ty) <- arg_tys])) $$ + "among alternatives" $$ + nest 4 (vcat [pp (snd q) <+> pp ':' <+> ppTerm Terse 0 ty | (_,ty) <- ttys0])) + + minimum g ttys0 arg_tys (tty@(t,ty):ttys) = let a = arity ty - (a',res) = minimum g ttys + (a',res) = minimum g ttys0 arg_tys ttys in case compare a a' of GT -> (a',res) EQ -> (a',join t ty res) @@ -678,136 +761,146 @@ reapply2 scope c fun fun_ty ((arg,arg_v,arg_ty):args) mb_ty = do -- Explicit arg res_ty <- evalCodomain x arg_v res_ty reapply2 scope c (App fun arg) res_ty args mb_ty -tcPatt scope c PW Nothing = do +tcPatt scope c p@(PV x) Nothing = do i <- newResiduation scope - return (scope,VMeta i []) -tcPatt scope c PW (Just ty0) = - return (scope,ty0) -tcPatt scope c (PV x) Nothing = do - i <- newResiduation scope - let ty = VMeta i [] - return ((x,ty):scope,ty) -tcPatt scope c (PV x) (Just ty) = - return ((x,ty):scope,ty) + if x == identW + then return (scope,p,Nothing,VMeta i []) + else do let v = VGen (length scope) [] + ty = VMeta i [] + scope' = (x,ty):scope + expandPattScope scope' + return (scope',p,Just v,ty) +tcPatt scope c p@(PV x) (Just ty) = + if x == identW + then return (scope,p,Nothing,ty) + else do let v = VGen (length scope) [] + scope' = (x,ty):scope + expandPattScope scope' + return (scope',p,Just v,ty) tcPatt scope c (PP q ps) mb_ty = do - g@(Gl gr _) <- globals - ty <- case lookupResType gr q of + g@(Gl gr _ isAbstract) <- globals + ty <- case (if isAbstract then lookupFunType else lookupResType) gr q of Ok ty -> return ty Bad msg -> evalError (pp msg) - let go scope c ty [] = return (scope,ty) - go scope c ty (p:ps) = do (_,_,arg_ty,res_ty) <- unifyFun scope ty - let (c1,c2) = split c - (scope,arg_ty) <- tcPatt scope c1 p (Just arg_ty) - go scope c2 res_ty ps let (c1,c2) = split c - (scope,res_ty) <- go scope c1 (eval g [] c2 ty []) ps + (scope,ps,mb_vs,res_ty) <- tcPattApp scope c1 (eval g [] c2 ty []) ps case mb_ty of Just ty -> unify scope ty res_ty Nothing -> return () - return (scope,res_ty) + return (scope,PP q ps,fmap (VApp q) mb_vs,res_ty) tcPatt scope c p@(PInt i) mb_ty = case mb_ty of Just ty0@(VInts n ext) - | i <= n -> return (scope,ty0) - | ext -> return (scope,VInts i ext) + | i <= n -> return (scope,p,Just (VInt i),ty0) + | ext -> return (scope,p,Just (VInt i),VInts i ext) | otherwise -> evalError ("Ints" <+> i <+> "is not a subtype of" <+> ppValue Unqualified 0 ty0) Just ty0@(VMeta k vs) -> do mv <- getMeta k case mv of Bound scope1 v -> do g <- globals - (scope,ty) <- tcPatt scope c p (Just (apply g v vs)) + (scope,p,mb_v,ty) <- tcPatt scope c p (Just (apply g v vs)) setMeta k (Bound scope1 ty) - return (scope,ty0) + return (scope,p,mb_v,ty0) Residuation scope1 -> do setMeta k (Bound scope1 (VInts i True)) - return (scope,ty0) - Nothing -> return (scope,VInts i True) + return (scope,p,Just (VInt i),ty0) + Nothing -> return (scope,p,Just (VInt i),VInts i True) _ -> evalError (pp "An integer must have an Int or Ints n type") -tcPatt scope c (PString s) mb_ty = do +tcPatt scope c p@(PString s) mb_ty = do case mb_ty of Just ty -> unify scope ty vtypeStr Nothing -> return () - return (scope,vtypeStr) + return (scope,p,Just (VStr s),vtypeStr) tcPatt scope c PChar mb_ty = do case mb_ty of Just ty -> unify scope ty vtypeStr Nothing -> return () - return (scope,vtypeStr) -tcPatt scope c (PChars cs) mb_ty = do + return (scope,PChar,Nothing,vtypeStr) +tcPatt scope c p@(PChars cs) mb_ty = do case mb_ty of Just ty -> unify scope ty vtypeStr Nothing -> return () - return (scope,vtypeStr) -tcPatt scope c (PSeq _ _ p1 _ _ p2) mb_ty = do + return (scope,p,Nothing,vtypeStr) +tcPatt scope c (PSeq min1 max1 p1 min2 max2 p2) mb_ty = do case mb_ty of Just ty -> unify scope ty vtypeStr Nothing -> return () let (c1,c2) = split c - (scope,_) <- tcPatt scope c1 p1 (Just vtypeStr) - (scope,_) <- tcPatt scope c2 p2 (Just vtypeStr) - return (scope,vtypeStr) -tcPatt scope c (PRep _ _ p) mb_ty = do + (scope,p1,v1,_) <- tcPatt scope c1 p1 (Just vtypeStr) + (scope,p2,v2,_) <- tcPatt scope c2 p2 (Just vtypeStr) + return (scope,PSeq min1 max1 p1 min2 max2 p2,liftM2 VGlue v1 v2,vtypeStr) +tcPatt scope c (PRep min max p') mb_ty = do case mb_ty of Just ty -> unify scope ty vtypeStr Nothing -> return () - tcPatt scope c p (Just vtypeStr) + (scope,p',_,ty) <- tcPatt scope c p' (Just vtypeStr) + return (scope,PRep min max p',Nothing,ty) tcPatt scope c (PAs x p) mb_ty = do ty <- case mb_ty of Just ty -> return ty Nothing -> do i <- newResiduation scope return (VMeta i []) - tcPatt ((x,ty):scope) c p (Just ty) + let v = VGen (length scope) [] + (scope,p',mb_v,ty) <- tcPatt ((x,ty):scope) c p (Just ty) + return (scope,PAs x p',mb_v `mplus` Just v,ty) +tcPatt scope c p@(PTilde t) (Just ty) = do + i <- newResiduation scope + return (scope, p, Just (VMeta i []), ty) tcPatt scope c p@(PR rs) mb_ty = case mb_ty of - Just (VRecType ltys ext) -> check scope c rs ltys ext + Just (VRecType ltys ext) -> do + (scope,lps,mb_lvs,ty) <- check scope c rs ltys ext + return (scope, PR lps, fmap VR mb_lvs, ty) Just ty0@(VMeta i vs) -> do mv <- getMeta i case mv of Bound scope1 v -> do g <- globals - (scope,ty) <- tcPatt scope c p (Just (apply g v vs)) + (scope,p,v,ty) <- tcPatt scope c p (Just (apply g v vs)) setMeta i (Bound scope1 ty) - return (scope,ty0) + return (scope,p,v,ty0) Residuation scope1 -> - do (scope,ltys) <- infer scope c rs + do (scope,lps,mb_lvs,ltys) <- infer scope c rs setMeta i (Bound scope1 (VRecType ltys True)) - return (scope,ty0) - Nothing ->do (scope,ltys) <- infer scope c rs - return (scope,VRecType ltys True) + return (scope,PR lps,fmap VR mb_lvs,ty0) + Nothing ->do (scope,lps,mb_lvs,ltys) <- infer scope c rs + return (scope,PR lps,fmap VR mb_lvs,VRecType ltys True) _ -> evalError (pp "An record must have an record type") where - check scope c [] ltys ext = return (scope,VRecType ltys ext) + check scope c [] ltys ext = return (scope,[],Just [],VRecType ltys ext) check scope c ((l,p):rs) ltys ext = case lookup3 l ltys of Just ty -> do let (c1,c2) = split c - (scope,ty) <- tcPatt scope c1 p (Just ty) - check scope c2 rs (update3 l True ty ltys) ext + (scope,p,mb_v,ty) <- tcPatt scope c1 p (Just ty) + (scope,lps,mb_lvs,ty) <- check scope c2 rs (update3 l True ty ltys) ext + return (scope,(l,p):lps,liftM2 (\v lvs -> (l,v):lvs) mb_v mb_lvs,ty) Nothing | ext -> do let (c1,c2) = split c - (scope,ty) <- tcPatt scope c1 p Nothing - check scope c2 rs (ltys++[(l,True,ty)]) ext + (scope,p,mb_v,ty) <- tcPatt scope c1 p Nothing + (scope,lps,mb_lvs,ty) <- check scope c2 rs (ltys++[(l,True,ty)]) ext + return (scope,(l,p):lps,liftM2 (\v lvs -> (l,v):lvs) mb_v mb_lvs,ty) | otherwise -> do ty <- value2termM False (scopeVars scope) (VRecType ltys ext) evalError (pp "Label" <+> pp l <+> " is not defined in the type of the pattern:" $$ nest 4 (ppTerm Unqualified 0 ty)) - infer scope c [] = return (scope,[]) + infer scope c [] = return (scope,[],Just [],[]) infer scope c ((l,p):rs) = do let (c1,c2) = split c - (scope,ty) <- tcPatt scope c1 p Nothing - (scope,ltys) <- infer scope c2 rs - return (scope,(l,True,ty):ltys) + (scope,p,mb_v,ty) <- tcPatt scope c1 p Nothing + (scope,lps,mb_lvs,ltys) <- infer scope c2 rs + return (scope,(l,p):lps,liftM2 (\v lvs -> (l,v):lvs) mb_v mb_lvs,(l,True,ty):ltys) tcPatt scope c (PNeg p) mb_ty = do - (_,ty) <- tcPatt scope c p mb_ty - return (scope, ty) + (_,p,_,ty) <- tcPatt scope c p mb_ty + return (scope, PNeg p, Nothing, ty) tcPatt scope c (PAlt p1 p2) mb_ty = do let (c1,c2) = split c - (_,ty) <- tcPatt scope c1 p1 mb_ty - (_,ty) <- tcPatt scope c2 p2 (Just ty) - return (scope,ty) -tcPatt scope c (PM q) mb_ty = do - g@(Gl gr _) <- globals + (_,p1,v1,ty) <- tcPatt scope c1 p1 mb_ty + (_,p2,v2,ty) <- tcPatt scope c2 p2 (Just ty) + return (scope,PAlt p1 p2,Nothing,ty) +tcPatt scope c p@(PM q) mb_ty = do + g@(Gl gr _ _) <- globals ty <- case lookupResType gr q of Ok ty -> return ty Bad msg -> evalError (pp msg) @@ -817,10 +910,58 @@ tcPatt scope c (PM q) mb_ty = do case mb_ty of Just ty0 -> unify scope ty0 vty Nothing -> return () - return (scope,vty) + return (scope,p,Nothing,vty) ty -> evalError ("Pattern type expected but " <+> pp ty <+> " found.") tcPatt scope c p ty = unimplemented ("tcPatt "++show p) + +tcPattApp scope c ty [] = return (scope,[],Just [],ty) +tcPattApp scope c (VProd Implicit x arg_ty res_ty) (p:ps) = do + let (c1,c2) = split c + (scope,p,ps,mb_v,arg_ty) <- + case p of + PImplArg p -> do (scope,p,mb_v,arg_ty) <- tcPatt scope c1 p (Just arg_ty) + return (scope,p,ps,mb_v,arg_ty) + _ -> do i <- newResiduation scope + return (scope,PTilde (Meta i),p:ps,Just (VMeta i []),arg_ty) + case res_ty of + VClosure env c t + -> do v <- case mb_v of + Just v -> return v + Nothing -> evalError (pp "Pattern" <+> ppPatt Unqualified 0 p <+> pp "cannot be used width a dependent function") + g <- globals + (scope,ps,mb_vs,res_ty) <- tcPattApp scope c2 (eval g ((x,v):env) c t []) ps + return (scope,PImplArg p:ps,liftM2 (:) mb_v mb_vs,res_ty) + res_ty -> do (scope,ps,mb_vs,res_ty) <- tcPattApp scope c2 res_ty ps + return (scope,PImplArg p:ps,liftM2 (:) mb_v mb_vs,res_ty) +tcPattApp scope c (VProd Explicit x arg_ty res_ty) (p:ps) = do + case p of + PImplArg _ -> + evalError (ppPatt Unqualified 0 p <+> + "is an unexpected implicit argument") + _ -> return () + let (c1,c2) = split c + (scope,p,mb_v,arg_ty) <- tcPatt scope c1 p (Just arg_ty) + case res_ty of + VClosure env c t + -> do v <- case mb_v of + Just v -> return v + Nothing -> evalError (pp "Pattern" <+> ppPatt Unqualified 0 p <+> pp "cannot be used width a dependent function") + g <- globals + (scope,ps,mb_vs,res_ty) <- tcPattApp scope c2 (eval g ((x,v):env) c t []) ps + return (scope,p:ps,liftM2 (:) mb_v mb_vs,res_ty) + res_ty -> do (scope,ps,mb_vs,res_ty) <- tcPattApp scope c2 res_ty ps + return (scope,p:ps,liftM2 (:) mb_v mb_vs,res_ty) +tcPattApp scope c ty ps = + evalError ("Cannot check patterns" <+> hsep (map (ppPatt Unqualified 10) ps) $$ + "against type" <+> ppValue Unqualified 0 ty) + +expandPattScope scope = EvalM (\g k state r msgs -> + k () state{metaVars=fmap expand (metaVars state)} r msgs) + where + expand (Bound scope v) = Bound scope v + expand (Residuation _) = Residuation scope + measurePatt p = case p of PM q -> do g <- globals @@ -835,7 +976,8 @@ measurePatt p = return (min,max,PT t p') PAs x p -> do (min,max,p) <- measurePatt p case p of - PW -> return (0,Nothing,PV x) + PV y | y == identW + -> return (0,Nothing,PV x) _ -> return (min,max,PAs x p) PImplArg p -> do (min,max,p') <- measurePatt p return (min,max,PImplArg p') @@ -853,13 +995,16 @@ measurePatt p = -> do (min1,max1,p1) <- measurePatt p1 (min2,max2,p2) <- measurePatt p2 case (p1,p2) of - (PW, PW ) -> return (0,Nothing,PW) + (PV x, PV y ) + | x == identW && y == identW + -> return (0,Nothing,PV identW) (PString s1,PString s2) -> return (min1+min2,liftM2 (+) max1 max2,PString (s1++s2)) _ -> return (min1+min2,liftM2 (+) max1 max2,PSeq min1 max1 p1 min2 max2 p2) PRep _ _ p -> do (minp,maxp,p) <- measurePatt p case p of - PW -> return (0,Nothing,PW) - PChar -> return (0,Nothing,PW) + PV x | x == identW + -> return (0,Nothing,PV x) + PChar -> return (0,Nothing,PV identW) _ -> return (0,Nothing,PRep minp maxp p) PChar -> return (1,Just 1,p) PChars _ -> return (1,Just 1,p) @@ -874,26 +1019,35 @@ inferRecFields scope c ls ((l,t):lts) lts <- inferRecFields scope c2 (l:ls) lts return (lt:lts) -checkRecFields scope c ls [] ltys - | null ltys = return [] - | otherwise = evalError ("Missing fields:" <+> hsep [l | (l,_,_) <- ltys]) -checkRecFields scope c ls ((l,t):lts) ltys - | elem l ls = evalError ("Repeated definition for field" <+> l) - | otherwise = - case takeIt l ltys of - (Just ty,ltys) -> do let (c1,c2) = split c - ltty <- tcRecField scope c1 l t (Just ty) - lttys <- checkRecFields scope c2 ls lts ltys - return (ltty : lttys) - (Nothing,ltys) -> do evalWarn ("Discarded field:" <+> l) - lttys <- checkRecFields scope c ls lts ltys - return lttys -- ignore the field +checkRecFields scope c lts env [] = do + unless (null lts) $ + evalWarn ("Discarded fields:" <+> hsep [l | (l,_) <- lts]) + return [] +checkRecFields scope c lts env ((l,_,ty):ltys) = + case takeIt l lts of + ([], lts) -> evalError ("Missing field" <+> l) + ([t],lts) -> do g <- globals + let (c1,c23) = split c + (c2,c3) = split c23 + env' = (label2ident l,eval g (scopeEnv scope) c3 (snd t) []):env + ltty <- tcRecField scope c1 l t (Just (uncover g env ty)) + lttys <- checkRecFields scope c2 lts env' ltys + return (ltty : lttys) + (_, lts) -> evalError ("Multiple definitions for field" <+> l) where - takeIt l1 [] = (Nothing, []) - takeIt l1 (lty@(l2,_,ty):ltys) - | l1 == l2 = (Just ty,ltys) - | otherwise = let (mb_ty,ltys') = takeIt l1 ltys - in (mb_ty,lty:ltys') + takeIt l1 [] = ([],[]) + takeIt l1 (lt@(l2,t):lts) + | l1 == l2 = let (ts,lts') = takeIt l1 lts + in (t:ts,lts') + | otherwise = let (ts,lts') = takeIt l1 lts + in (ts,lt:lts') + + uncover g env' (VClosure env c (Abs b x ty)) = case lookup x env' of + Just v -> uncover g env' (VClosure ((x,v):env) c ty) + Nothing -> error "Missing field" + uncover g env' (VClosure env c ty) = eval g env c ty [] + uncover g _ v = v + tcRecField scope c l (mb_ann_ty,t) mb_ty = do (t,ty) <- case mb_ann_ty of @@ -906,22 +1060,28 @@ tcRecField scope c l (mb_ann_ty,t) mb_ty = do Nothing -> tcRho scope c t mb_ty return (l,t,ty) -tcRecTypeFields scope c ls [] mb_ty = return ([],mb_ty) -tcRecTypeFields scope c ls ((l,ty):rs) mb_ty - | elem l ls = evalError ("Repeated definition for field" <+> l) - | otherwise = do - let (c1,c2) = split c - (ty,sort) <- tcRho scope c1 ty mb_ty - mb_ty <- case sort of - VSort s - | s == cType -> return (Just sort) - | s == cPType -> return mb_ty - VMeta _ _ -> return mb_ty - _ -> do sort <- value2termM False (scopeVars scope) sort - evalError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$ - "cannot be of type" <+> ppTerm Unqualified 0 sort) - (rs,mb_ty) <- tcRecTypeFields scope c2 (l:ls) rs mb_ty - return ((l,ty):rs,mb_ty) +tcRecTypeFields scope c rs mb_ty = go c [] rs [] mb_ty + where + go c ls [] env mb_ty = return ([],mb_ty) + go c ls ((l,deps,ty):rs) env mb_ty + | elem l ls = evalError ("Multiple definitions for field" <+> l) + | otherwise = do + let (c1,c23) = split c + (c2,c3) = split c23 + + let scope' = [x | x@(l,vty) <- env, l `elem` deps]++scope + (ty,sort) <- tcRho scope' c1 ty mb_ty + mb_ty <- case sort of + VSort s + | s == cType -> return (Just sort) + | s == cPType -> return mb_ty + VMeta _ _ -> return mb_ty + _ -> do sort <- value2termM False (scopeVars scope) sort + evalError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$ + "cannot be of type" <+> ppTerm Unqualified 0 sort) + g <- globals + (rs,mb_ty) <- go c2 (l:ls) rs ((label2ident l, eval g (scopeEnv scope) c3 ty []):scope) mb_ty + return ((l,deps,ty):rs,mb_ty) -- | Invariant: if the third argument is (Just rho), -- then rho is in weak-prenex form @@ -933,9 +1093,9 @@ instSigma scope s t ty1 (Just ty2) = do -- INST2 -- | Invariant: the second argument is in weak-prenex form subsCheckRho :: Scope -> Term -> Sigma -> Rho -> EvalM (Term,Sigma,Rho) -subsCheckRho scope t ty1@(VApp _ p1 []) ty2 -- for backwards compatibility +subsCheckRho scope t ty1@(VApp p1 []) ty2 -- for backwards compatibility | p1 == (cPredef,cErrorType) = return (t,ty1,ty2) -subsCheckRho scope t ty1 ty2@(VApp _ p2 []) -- for backwards compatibility +subsCheckRho scope t ty1 ty2@(VApp p2 []) -- for backwards compatibility | p2 == (cPredef,cErrorType) = return (t,ty1,ty2) subsCheckRho scope t ty1@(VMeta i vs1) ty2@(VMeta j vs2) | i == j = do sequence_ (zipWith (unify scope) vs1 vs2) @@ -1012,9 +1172,9 @@ subsCheckRho scope t (VTable p1 r1) rho2 = do -- Rule TABLE subsCheckTbl scope t p1 r1 p2 r2 subsCheckRho scope t ty1@(VSort s1) ty2@(VSort s2) -- Rule PTYPE | s1 == cPType && s2 == cType = return (t,ty1,ty2) -subsCheckRho scope t ty1@(VApp _ p _) ty2@(VInts _ _) -- This is not correct but nextPrec in the RGL relies on it. - | p == (cPredef,cInt) = return (t,ty1,ty2) -- Should be only a temporary hack. -subsCheckRho scope t ty1@(VInts _ _) ty2@(VApp _ p _) -- Rule INT1 +subsCheckRho scope t ty1@(VApp p _) ty2@(VInts _ _) -- This is not correct but nextPrec in the RGL relies on it. + | p == (cPredef,cInt) = return (t,ty1,ty2) -- Should be only a temporary hack. +subsCheckRho scope t ty1@(VInts _ _) ty2@(VApp p _) -- Rule INT1 | p == (cPredef,cInt) = return (t,ty1,ty2) subsCheckRho scope t ty1@(VInts n1 ext1) ty2@(VInts n2 ext2) -- Rule INT2 | n1 <= n2 = return (t,ty1,ty2) @@ -1053,21 +1213,35 @@ subsCheckRho scope t ty1@(VRecType rs1 ext1) ty2@(VRecType rs2 ext2) = do - is_selection _ = False is_trivial x _ = False - mkField scope l (mb_ty,t) (Just ty1) ty2 = do - (t,ty1,ty2) <- subsCheckRho scope t ty1 ty2 - return ((l, (mb_ty,t)), (l, True, ty1)) - mkField scope l (mb_ty,t) Nothing ty2 - | isLockLabel l = return ((l, (Just (RecType []),R [])), (l, True, ty2)) - | otherwise = return ((l, (mb_ty,t)), (l, True, ty2)) + mkField scope l (mb_ty,t_proj) (Just ty1) ty2 = do + g <- globals + (t,ty1,ty2) <- subsCheckRho scope t_proj (uncover g ty1) ty2 + return ((l, (mb_ty,t_proj)), (l, True, ty1)) + where + uncover g (VClosure env c (Abs b x ty)) = let (c1,c2) = split c + v = eval g (scopeEnv scope) c2 (P t (ident2label x)) [] + in uncover g (VClosure ((x,v):env) c1 ty) + uncover g (VClosure env c ty) = eval g env c ty [] + uncover g v = v + + mkField scope l (mb_ty,t_proj) Nothing ty2 = + case isLockLabel l of + Just _ -> return ((l, (Just (RecType []),R [])), (l, True, ty2)) + Nothing -> return ((l, (mb_ty,t_proj)), (l, True, ty2)) (scope,mkProj,wrap) <- mkAccess scope t let fields = [(l,o2,ty2,lookup3 l rs1) | (l,o2,ty2) <- rs2] - case [l | (l,_,_,Nothing) <- fields, not ext1 && not (isLockLabel l)] of + case [l | (l,_,_,Nothing) <- fields, not ext1] of [] -> return () + [field] -> evalError ("In the term" <+> pp t $$ + "there is no value for field" <+> field <> + case isLockLabel field of + Just cat -> ", try wrapping with lin"<+>pp cat + Nothing -> empty) missing -> evalError ("In the term" <+> pp t $$ "there are no values for fields:" <+> hsep missing) - rs <- sequence [mkField scope l t mb_ty1 ty2 | (l,_,ty2,mb_ty1) <- fields, Just t <- [mkProj l]] + rs <- sequence [mkField scope l t_proj mb_ty1 ty2 | (l,_,ty2,mb_ty1) <- fields, Just t_proj <- [mkProj l]] return (wrap (R (map fst rs)),VRecType (foldl (\rs (_,(l,o,ty)) -> update3 l o ty rs) rs1 rs) ext2,ty2) subsCheckRho scope t ty1 (VFV c (VarFree vs)) = do ty2 <- variants c vs @@ -1162,9 +1336,9 @@ subtype scope (Just (VProd Explicit x a1 r1)) (VProd Explicit y a2 r2) a <- supertype scope (Just a1) a2 r <- subtype scope (Just r1) r2 return (VProd Explicit identW a r) -subtype scope (Just (VApp _ p1 [])) ty2 -- for backwards compatibility +subtype scope (Just (VApp p1 [])) ty2 -- for backwards compatibility | p1 == (cPredef,cErrorType) = return ty2 -subtype scope (Just ty1) (VApp _ p2 []) -- for backwards compatibility +subtype scope (Just ty1) (VApp p2 []) -- for backwards compatibility | p2 == (cPredef,cErrorType) = return ty1 subtype scope Nothing ty = return ty subtype scope (Just ctr) ty = do @@ -1196,9 +1370,9 @@ supertype scope (Just (VProd Explicit x a1 r1)) (VProd Explicit y a2 r2) a <- subtype scope (Just a1) a2 r <- supertype scope (Just r1) r2 return (VProd Explicit identW a r) -supertype scope (Just (VApp _ p1 [])) ty2 -- for backwards compatibility +supertype scope (Just (VApp p1 [])) ty2 -- for backwards compatibility | p1 == (cPredef,cErrorType) = return ty2 -supertype scope (Just ty1) (VApp _ p2 []) -- for backwards compatibility +supertype scope (Just ty1) (VApp p2 []) -- for backwards compatibility | p2 == (cPredef,cErrorType) = return ty1 supertype scope Nothing ty = return ty supertype scope (Just ctr) ty = do @@ -1238,7 +1412,11 @@ unifyTbl scope tau = do unify scope tau (VTable arg res) return (arg,res) -unify scope (VApp c1 f1 vs1) (VApp c2 f2 vs2) +unify scope (VApp f1 vs1) (VApp f2 vs2) + | f1 == f2 = sequence_ (zipWith (unify scope) vs1 vs2) +unify scope (VPAP c1 f1 vs1) (VPAP c2 f2 vs2) + | f1 == f2 = sequence_ (zipWith (unify scope) vs1 vs2) +unify scope (VConst f1 vs1) (VConst f2 vs2) | f1 == f2 = sequence_ (zipWith (unify scope) vs1 vs2) unify scope (VMeta i vs1) (VMeta j vs2) | i == j = sequence_ (zipWith (unify scope) vs1 vs2) @@ -1283,8 +1461,8 @@ unify scope (VStr s1) (VStr s2) | s1 == s2 = return () unify scope VEmpty VEmpty = return () unify scope v1 v2 = - evalError ("Cannot unify:" <+> ppValue Qualified 0 v1 $$ - " with:" <+> ppValue Qualified 0 v2) + evalError ("Cannot unify:" <+> ppValue Unqualified 0 v1 $$ + " with:" <+> ppValue Unqualified 0 v2) -- | Invariant: tv1 is a flexible type variable @@ -1302,7 +1480,9 @@ occursCheck scope' i0 scope v = n = length scope in check m n v where - check m n (VApp c f vs) = mapM_ (check m n) vs + check m n (VApp f vs) = mapM_ (check m n) vs + check m n (VPAP c f vs) = mapM_ (check m n) vs + check m n (VConst f vs) = mapM_ (check m n) vs check m n (VMeta i vs) | i0 == i = do ty1 <- value2termM False (scopeVars scope) (VMeta i vs) ty2 <- value2termM False (scopeVars scope) v @@ -1411,9 +1591,15 @@ quantify scope t tvs ty = do where bind scope (i, meta_id, name) = setMeta meta_id (Bound scope (VGen i [])) - check m n xs (VApp c f vs) = do + check m n xs (VApp f vs) = do (xs,vs) <- mapAccumM (check m n) xs vs - return (xs,VApp c f vs) + return (xs,VApp f vs) + check m n xs (VPAP c f vs) = do + (xs,vs) <- mapAccumM (check m n) xs vs + return (xs,VPAP c f vs) + check m n xs (VConst f vs) = do + (xs,vs) <- mapAccumM (check m n) xs vs + return (xs,VConst f vs) check m n xs (VMeta i vs) = do s <- getMeta i case s of @@ -1501,13 +1687,6 @@ quantify scope t tvs ty = do check m n xs v@(VInts _ _) = return (xs,v) check m n xs v = unimplemented ("check "++show (ppValue Unqualified 5 v)) - mapAccumM :: Monad m => (a -> b -> m (a,c)) -> a -> [b] -> m (a,[c]) - mapAccumM f s [] = return (s,[]) - mapAccumM f s (x:xs) = do - (s,y) <- f s x - (s,ys) <- mapAccumM f s xs - return (s,y:ys) - allBinders :: [Ident] -- a,b,..z, a1, b1,... z1, a2, b2,... allBinders = [ identS [x] | x <- ['a'..'z'] ] ++ [ identS (x : show i) | i <- [1 :: Integer ..], x <- ['a'..'z']] @@ -1532,6 +1711,13 @@ update3 l o v (r@(l',_,_):rs) | l == l' = (l,o,v) : rs | otherwise = r : update3 l o v rs +mapAccumM :: Monad m => (a -> b -> m (a,c)) -> a -> [b] -> m (a,[c]) +mapAccumM f s [] = return (s,[]) +mapAccumM f s (x:xs) = do + (s,y) <- f s x + (s,ys) <- mapAccumM f s xs + return (s,y:ys) + newVar :: Scope -> Ident newVar scope = head [x | i <- [1..], let x = identS ('v':show i), @@ -1563,7 +1749,9 @@ getMetaVars sc_tys = foldM (\acc (scope,ty) -> go acc ty) [] sc_tys case res of Bound _ v -> go acc v _ -> foldM go (m:acc) args - go acc (VApp c f args) = foldM go acc args + go acc (VApp f args) = foldM go acc args + go acc (VPAP c f args) = foldM go acc args + go acc (VConst f args) = foldM go acc args go acc (VFV c vs) = foldM go acc (unvariants vs) go acc (VInts _ _) = return acc go acc (VPattType v) = go acc v @@ -1588,6 +1776,30 @@ zonkTerm xs (Meta i) = do _ -> return (Meta i) zonkTerm xs t = composOp (zonkTerm xs) t +zonkPatt :: Scope -> Patt -> EvalM (Scope,Patt) +zonkPatt scope (PP q ps) = do + (scope,ps) <- mapAccumM zonkPatt scope ps + return (scope, PP q ps) +zonkPatt scope (PImplArg p) = do + (scope,p) <- zonkPatt scope p + return (scope, PImplArg p) +zonkPatt scope (PTilde t) = + case t of + Meta i -> do st <- getMeta i + case st of + Bound _ v -> do t <- (zonkTerm xs =<< value2termM False xs v) + return (scope, PTilde t) + Residuation _ + -> do let v = mkFreshVar xs (identS "v") + scope' = (v,undefined):scope + setMeta i (Bound scope' (VGen (length scope) [])) + return (scope', PV v) + t -> do t <- zonkTerm xs t + return (scope, PTilde t) + where + xs = scopeVars scope +zonkPatt scope p = return (scope,p) + zonkValue :: Value -> EvalM Value zonkValue (VProd bt x ty1 ty2) = do ty1 <- zonkValue ty1 diff --git a/src/compiler/api/GF/Compile/TypeCheck/Abstract.hs b/src/compiler/api/GF/Compile/TypeCheck/Abstract.hs deleted file mode 100644 index c76660259..000000000 --- a/src/compiler/api/GF/Compile/TypeCheck/Abstract.hs +++ /dev/null @@ -1,82 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : TypeCheck --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/09/15 16:22:02 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.16 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly. - checkContext, - checkTyp, - checkDef, - checkConstrs, - ) where - -import GF.Data.Operations - -import GF.Infra.CheckM -import GF.Grammar -import GF.Grammar.Lookup -import GF.Grammar.Unify ---import GF.Compile.Refresh ---import GF.Compile.Compute.Abstract -import GF.Compile.TypeCheck.TC - -import GF.Text.Pretty ---import Control.Monad (foldM, liftM, liftM2) - --- | invariant way of creating TCEnv from context -initTCEnv gamma = - (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) - --- interface to TC type checker - -type2val :: Type -> Val -type2val = VClos [] - -cont2exp :: Context -> Term -cont2exp c = mkProd c eType [] -- to check a context - -cont2val :: Context -> Val -cont2val = type2val . cont2exp - --- some top-level batch-mode checkers for the compiler - -justTypeCheck :: SourceGrammar -> Term -> Val -> Err Constraints -justTypeCheck gr e v = do - (_,constrs0) <- checkExp (grammar2theory gr) (initTCEnv []) e v - (constrs1,_) <- unifyVal constrs0 - return $ filter notJustMeta constrs1 - -notJustMeta (c,k) = case (c,k) of - (VClos g1 (Meta m1), VClos g2 (Meta m2)) -> False - _ -> True - -grammar2theory :: SourceGrammar -> Theory -grammar2theory gr (m,f) = case lookupFunType gr m f of - Ok t -> return $ type2val t - Bad s -> case lookupCatContext gr m f of - Ok cont -> return $ cont2val cont - _ -> Bad s - -checkContext :: SourceGrammar -> Context -> [Message] -checkContext st = checkTyp st . cont2exp - -checkTyp :: SourceGrammar -> Type -> [Message] -checkTyp gr typ = err (\x -> [pp x]) ppConstrs $ justTypeCheck gr typ vType - -checkDef :: SourceGrammar -> Fun -> Type -> Equation -> [Message] -checkDef gr (m,fun) typ eq = err (\x -> [pp x]) ppConstrs $ do - (b,cs) <- checkBranch (grammar2theory gr) (initTCEnv []) eq (type2val typ) - (constrs,_) <- unifyVal cs - return $ filter notJustMeta constrs - -checkConstrs :: SourceGrammar -> Cat -> [Ident] -> [String] -checkConstrs gr cat _ = [] ---- check constructors! diff --git a/src/compiler/api/GF/Compile/TypeCheck/TC.hs b/src/compiler/api/GF/Compile/TypeCheck/TC.hs deleted file mode 100644 index e06c5b5a9..000000000 --- a/src/compiler/api/GF/Compile/TypeCheck/TC.hs +++ /dev/null @@ -1,324 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : TC --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/02 20:50:19 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.11 $ --- --- Thierry Coquand's type checking algorithm that creates a trace ------------------------------------------------------------------------------ - -module GF.Compile.TypeCheck.TC ( - AExp(..), - Theory, - checkExp, - inferExp, - checkBranch, - eqVal, - whnf - ) where - -import GF.Data.Operations -import GF.Grammar -import GF.Grammar.Predef - -import Control.Monad ---import Data.List (sortBy) -import Data.Maybe -import GF.Text.Pretty - -data AExp = - AVr Ident Val - | ACn QIdent Val - | AType - | AInt Integer - | AFloat Double - | AStr String - | AMeta MetaId Val - | ALet (Ident,(Val,AExp)) AExp - | AApp AExp AExp Val - | AAbs Ident Val AExp - | AProd Ident AExp AExp --- -- | AEqs [([Exp],AExp)] --- not used - | ARecType [ALabelling] - | AR [AAssign] - | AP AExp Label Val - | AGlue AExp AExp - | AData Val - deriving (Eq,Show) - -type ALabelling = (Label, AExp) -type AAssign = (Label, (Val, AExp)) - -type Theory = QIdent -> Err Val - -lookupConst :: Theory -> QIdent -> Err Val -lookupConst th f = th f - -lookupVar :: Env -> Ident -> Err Val -lookupVar g x = maybe (Bad (render ("unknown variable" <+> x))) return $ lookup x ((identW,VClos [] (Meta 0)):g) --- wild card IW: no error produced, ?0 instead. - -type TCEnv = (Int,Env,Env) - ---emptyTCEnv :: TCEnv ---emptyTCEnv = (0,[],[]) - -whnf :: Val -> Err Val -whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug - case v of - VApp u w -> do - u' <- whnf u - w' <- whnf w - app u' w' - VClos env e -> eval env e - _ -> return v - -app :: Val -> Val -> Err Val -app u v = case u of - VClos env (Abs _ x e) -> eval ((x,v):env) e - _ -> return $ VApp u v - -eval :: Env -> Term -> Err Val -eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ - case e of - Vr x -> lookupVar env x - Q c -> return $ VCn c - QC c -> return $ VCn c ---- == Q ? - Sort c -> return $ VType --- the only sort is Type - App f a -> join $ liftM2 app (eval env f) (eval env a) - RecType xs -> do xs <- mapM (\(l,e) -> eval env e >>= \e -> return (l,e)) xs - return (VRecType xs) - _ -> return $ VClos env e - -eqVal :: Int -> Val -> Val -> Err [(Val,Val)] -eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ - do - w1 <- whnf u1 - w2 <- whnf u2 - let v = VGen k - case (w1,w2) of - (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2) - (VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) -> - eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2) - (VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) -> - liftM2 (++) - (eqVal k (VClos env1 a1) (VClos env2 a2)) - (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)) - (VGen i _, VGen j _) -> return [(w1,w2) | i /= j] - (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j] - --- thus ignore qualifications; valid because inheritance cannot - --- be qualified. Simplifies annotation. AR 17/3/2005 - _ -> return [(w1,w2) | w1 /= w2] --- invariant: constraints are in whnf - -checkType :: Theory -> TCEnv -> Term -> Err (AExp,[(Val,Val)]) -checkType th tenv e = checkExp th tenv e vType - -checkExp :: Theory -> TCEnv -> Term -> Val -> Err (AExp, [(Val,Val)]) -checkExp th tenv@(k,rho,gamma) e ty = do - typ <- whnf ty - let v = VGen k - case e of - Meta m -> return $ (AMeta m typ,[]) - - Abs _ x t -> case typ of - VClos env (Prod _ y a b) -> do - a' <- whnf $ VClos env a --- - (t',cs) <- checkExp th - (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) - return (AAbs x a' t', cs) - _ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ)) - - Let (x, (mb_typ, e1)) e2 -> do - (val,e1,cs1) <- case mb_typ of - Just typ -> do (_,cs1) <- checkType th tenv typ - val <- eval rho typ - (e1,cs2) <- checkExp th tenv e1 val - return (val,e1,cs1++cs2) - Nothing -> do (e1,val,cs) <- inferExp th tenv e1 - return (val,e1,cs) - (e2,cs2) <- checkExp th (k,rho,(x,val):gamma) e2 typ - return (ALet (x,(val,e1)) e2, cs1++cs2) - - Prod _ x a b -> do - testErr (typ == vType) "expected Type" - (a',csa) <- checkType th tenv a - (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b - return (AProd x a' b', csa ++ csb) - - R xs -> - case typ of - VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of - [] -> return () - ls -> fail (render ("no value given for label:" <+> fsep (punctuate ',' ls))) - r <- mapM (checkAssign th tenv ys) xs - let (xs,css) = unzip r - return (AR xs, concat css) - _ -> Bad (render ("record type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ)) - - P r l -> do (r',cs) <- checkExp th tenv r (VRecType [(l,typ)]) - return (AP r' l typ,cs) - - Glue x y -> do cs1 <- eqVal k valAbsFloat typ - (x,cs2) <- checkExp th tenv x typ - (y,cs3) <- checkExp th tenv y typ - return (AGlue x y,cs1++cs2++cs3) - _ -> checkInferExp th tenv e typ - -checkInferExp :: Theory -> TCEnv -> Term -> Val -> Err (AExp, [(Val,Val)]) -checkInferExp th tenv@(k,_,_) e typ = do - (e',w,cs1) <- inferExp th tenv e - cs2 <- eqVal k w typ - return (e',cs1 ++ cs2) - -inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)]) -inferExp th tenv@(k,rho,gamma) e = case e of - Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x - Q (m,c) | m == cPredefAbs && isPredefCat c - -> return (ACn (m,c) vType, vType, []) - | otherwise -> mkAnnot (ACn (m,c)) $ noConstr $ lookupConst th (m,c) - QC c -> mkAnnot (ACn c) $ noConstr $ lookupConst th c ---- - EInt i -> return (AInt i, valAbsInt, []) - EFloat i -> return (AFloat i, valAbsFloat, []) - K i -> return (AStr i, valAbsString, []) - Sort _ -> return (AType, vType, []) - RecType xs -> do r <- mapM (checkLabelling th tenv) xs - let (xs,css) = unzip r - return (ARecType xs, vType, concat css) - Let (x, (mb_typ, e1)) e2 -> do - (val1,e1,cs1) <- case mb_typ of - Just typ -> do (_,cs1) <- checkType th tenv typ - val <- eval rho typ - (e1,cs2) <- checkExp th tenv e1 val - return (val,e1,cs1++cs2) - Nothing -> do (e1,val,cs) <- inferExp th tenv e1 - return (val,e1,cs) - (e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2 - return (ALet (x,(val1,e1)) e2, val2, cs1++cs2) - App f t -> do - (f',w,csf) <- inferExp th tenv f - typ <- whnf w - case typ of - VClos env (Prod _ x a b) -> do - (a',csa) <- checkExp th tenv t (VClos env a) - b' <- whnf $ VClos ((x,VClos rho t):env) b - return $ (AApp f' a' b', b', csf ++ csa) - _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ)) - _ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e)) - -checkLabelling :: Theory -> TCEnv -> Labelling -> Err (ALabelling, [(Val,Val)]) -checkLabelling th tenv (lbl,typ) = do - (atyp,cs) <- checkType th tenv typ - return ((lbl,atyp),cs) - -checkAssign :: Theory -> TCEnv -> [(Label,Val)] -> Assign -> Err (AAssign, [(Val,Val)]) -checkAssign th tenv@(k,rho,gamma) typs (lbl,(Just typ,exp)) = do - (atyp,cs1) <- checkType th tenv typ - val <- eval rho typ - cs2 <- case lookup lbl typs of - Nothing -> return [] - Just val0 -> eqVal k val val0 - (aexp,cs3) <- checkExp th tenv exp val - return ((lbl,(val,aexp)),cs1++cs2++cs3) -checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do - case lookup lbl typs of - Nothing -> do (aexp,val,cs) <- inferExp th tenv exp - return ((lbl,(val,aexp)),cs) - Just val -> do (aexp,cs) <- checkExp th tenv exp val - return ((lbl,(val,aexp)),cs) - -checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)]) -checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ - chB tenv' ps' ty - where - - (ps',_,rho2,k') = ps2ts k ps - tenv' = (k, rho2++rho, gamma) ---- k' ? - (k,rho,gamma) = tenv - - chB tenv@(k,rho,gamma) ps ty = case ps of - p:ps2 -> do - typ <- whnf ty - case typ of - VClos env (Prod _ y a b) -> do - a' <- whnf $ VClos env a - (p', sigma, binds, cs1) <- checkP tenv p y a' - let tenv' = (length binds, sigma ++ rho, binds ++ gamma) - ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b) - return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt - _ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ)) - [] -> do - (e,cs) <- checkExp th tenv t ty - return (([],e),cs) - checkP env@(k,rho,gamma) t x a = do - (delta,cs) <- checkPatt th env t a - let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]] - return (VClos sigma t, sigma, delta, cs) - - ps2ts k = foldr p2t ([],0,[],k) - p2t p (ps,i,g,k) = case p of - PW -> (Meta i : ps, i+1,g,k) - PV x -> (Vr x : ps, i, upd x k g,k+1) - PAs x p -> p2t p (ps,i,g,k) - PString s -> (K s : ps, i, g, k) - PInt n -> (EInt n : ps, i, g, k) - PFloat n -> (EFloat n : ps, i, g, k) - PP c xs -> (mkApp (Q c) xss : ps, j, g',k') - where (xss,j,g',k') = foldr p2t ([],i,g,k) xs - PImplArg p -> p2t p (ps,i,g,k) - PTilde t -> (t : ps, i, g, k) - _ -> error $ render ("undefined p2t case" <+> ppPatt Unqualified 0 p <+> "in checkBranch") - - upd x k g = (x, VGen k x) : g --- hack to recognize pattern variables - - -checkPatt :: Theory -> TCEnv -> Term -> Val -> Err (Binds,[(Val,Val)]) -checkPatt th tenv exp val = do - (aexp,_,cs) <- checkExpP tenv exp val - let binds = extrBinds aexp - return (binds,cs) - where - extrBinds aexp = case aexp of - AVr i v -> [(i,v)] - AApp f a _ -> extrBinds f ++ extrBinds a - _ -> [] -- no other cases are possible - ---- ad hoc, to find types of variables - checkExpP tenv@(k,rho,gamma) exp val = case exp of - Meta m -> return $ (AMeta m val, val, []) - Vr x -> return $ (AVr x val, val, []) - EInt i -> return (AInt i, valAbsInt, []) - EFloat i -> return (AFloat i, valAbsFloat, []) - K s -> return (AStr s, valAbsString, []) - - Q c -> do - typ <- lookupConst th c - return $ (ACn c typ, typ, []) - QC c -> do - typ <- lookupConst th c - return $ (ACn c typ, typ, []) ---- - App f t -> do - (f',w,csf) <- checkExpP tenv f val - typ <- whnf w - case typ of - VClos env (Prod _ x a b) -> do - (a',_,csa) <- checkExpP tenv t (VClos env a) - b' <- whnf $ VClos ((x,VClos rho t):env) b - return $ (AApp f' a' b', b', csf ++ csa) - _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ)) - _ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp)) - --- auxiliaries - -noConstr :: Err Val -> Err (Val,[(Val,Val)]) -noConstr er = er >>= (\v -> return (v,[])) - -mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)]) -mkAnnot a ti = do - (v,cs) <- ti - return (a v, v, cs) diff --git a/src/compiler/api/GF/Compile/Update.hs b/src/compiler/api/GF/Compile/Update.hs index 67688f279..b29fde5f9 100644 --- a/src/compiler/api/GF/Compile/Update.hs +++ b/src/compiler/api/GF/Compile/Update.hs @@ -82,7 +82,7 @@ extendModule cwd gr (name,m) -- | rebuilding instance + interface, and "with" modules, prior to renaming. -- AR 24/10/2003 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule -rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs js_)) = +rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ js_)) = checkInModule cwd mi NoLoc empty $ do ---- deps <- moduleDeps ms @@ -119,7 +119,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs j else MSIncomplete unless (stat' == MSComplete || stat == MSIncomplete) (checkError ("module" <+> i <+> "remains incomplete")) - ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext + ModInfo mt0 _ fs me' _ ops0 _ fpath js <- lookupModule gr ext let ops1 = nub $ ops_ ++ -- N.B. js has been name-resolved already [OQualif i j | (i,j) <- ops] ++ @@ -135,7 +135,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ mseqs j js let js1 = Map.union js0 js_ let med1= nub (ext : infs ++ insts ++ med_) - return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ mseqs js1 + return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ js1 return (i,mi') @@ -174,14 +174,14 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme (b,n') = case info of ResValue _ _ -> (True,n) ResParam _ _ -> (True,n) - AbsFun _ _ Nothing _ -> (True,n) + AbsFun _ Nothing -> (True,n) AnyInd b k -> (b,k) _ -> (False,n) ---- canonical in Abs globalizeLoc fpath i = case i of AbsCat mc -> AbsCat (fmap gl mc) - AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper + AbsFun mt md -> AbsFun (fmap gl mt) (fmap (\(a,eqs) -> (a,fmap gl eqs)) md) ResParam mt mv -> ResParam (fmap gl mt) mv ResValue t i -> ResValue (gl t) i ResOper mt m -> ResOper (fmap gl mt) (fmap gl m) @@ -200,8 +200,8 @@ unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info unifyAnyInfo m i j = case (i,j) of (AbsCat mc1, AbsCat mc2) -> liftM AbsCat (unifyMaybeL mc1 mc2) - (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) -> - liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs + (AbsFun mt1 md1, AbsFun mt2 md2) -> + liftM2 AbsFun (unifyMaybeL mt1 mt2) (unifAbsDefs md1 md2) -- adding defs (ResParam mt1 mv1, ResParam mt2 mv2) -> liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2) @@ -214,7 +214,7 @@ unifyAnyInfo m i j = case (i,j) of liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2) (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) -> - liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2) + liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2) (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) -> liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2) @@ -229,10 +229,7 @@ unifyAnyInfo m i j = case (i,j) of unifyMaybeL :: Eq a => Maybe (L a) -> Maybe (L a) -> Err (Maybe (L a)) unifyMaybeL = unifyMaybeBy unLoc -unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int) -unifAbsArrity = unifyMaybe - -unifAbsDefs :: Maybe [L Equation] -> Maybe [L Equation] -> Err (Maybe [L Equation]) -unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys)) -unifAbsDefs Nothing Nothing = return Nothing -unifAbsDefs _ _ = fail "" +unifAbsDefs :: Maybe (Int,[L Equation]) -> Maybe (Int,[L Equation]) -> Err (Maybe (Int,[L Equation])) +unifAbsDefs (Just (_,xs)) (Just (_,ys)) = return (Just (0,xs ++ ys)) +unifAbsDefs Nothing Nothing = return Nothing +unifAbsDefs _ _ = fail "" diff --git a/src/compiler/api/GF/Compiler.hs b/src/compiler/api/GF/Compiler.hs index d046063c8..b352d586e 100644 --- a/src/compiler/api/GF/Compiler.hs +++ b/src/compiler/api/GF/Compiler.hs @@ -1,7 +1,7 @@ module GF.Compiler (mainGFC, writeGrammar, writeOutputs) where import PGF2 -import PGF2.Transactions +import PGF2.Transactions hiding (Rule(..)) import GF.Compile as S(batchCompile,link,srcAbsName) import GF.CompileInParallel as P(parallelBatchCompile) import GF.Compile.Export @@ -11,11 +11,10 @@ import GF.Compile.CFGtoPGF import GF.Compile.GetGrammar import GF.Grammar.BNFC import GF.Grammar.CFG -import GF.Grammar.Grammar +import GF.Grammar.Grammar hiding (Rule(..)) import GF.Grammar.JSON(grammar2json) import GF.Grammar.Printer(TermPrintQual(..),ppModule) ---import GF.Infra.Ident(showIdent) import GF.Infra.UseIO import GF.Infra.Option import GF.Infra.CheckM diff --git a/src/compiler/api/GF/Data/Operations.hs b/src/compiler/api/GF/Data/Operations.hs index 539b77c8f..ffd860976 100644 --- a/src/compiler/api/GF/Data/Operations.hs +++ b/src/compiler/api/GF/Data/Operations.hs @@ -35,9 +35,6 @@ module GF.Data.Operations ( prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes, numberedParagraphs, prConjList, prIfEmpty, wrapLines, - -- ** Topological sorting - topoTest, topoTest2, - -- ** Misc readIntArg, iterFix, chunks, @@ -53,7 +50,6 @@ import Control.Monad (liftM,liftM2) --,ap import Control.Monad.Fix import GF.Data.ErrM -import GF.Data.Relation import qualified Control.Monad.Fail as Fail infixr 5 +++ @@ -188,26 +184,6 @@ wrapLines n s@(c:cs) = l = length w _ -> s -- give up!! --- | Topological sorting with test of cyclicity -topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]] -topoTest = topologicalSort . mkRel' - --- | Topological sorting with test of cyclicity, new version /TH 2012-06-26 -topoTest2 :: Ord a => [(a,[a])] -> Either [[a]] [[a]] -topoTest2 g0 = maybe (Right cycles) Left (tsort g) - where - g = g0++[(n,[])|n<-nub (concatMap snd g0)\\map fst g0] - - cycles = findCycles (mkRel' g) - - tsort nes = - case partition (null.snd) nes of - ([],[]) -> Just [] - ([],_) -> Nothing - (ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest] - where leaves = map fst ns - - -- | Fix point iterator (for computing e.g. transitive closures or reachability) iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a] iterFix more start = iter start start diff --git a/src/compiler/api/GF/Data/XML.hs b/src/compiler/api/GF/Data/XML.hs index cd9b18339..a1a8aa4af 100644 --- a/src/compiler/api/GF/Data/XML.hs +++ b/src/compiler/api/GF/Data/XML.hs @@ -4,7 +4,7 @@ -- -- Utilities for creating XML documents. ---------------------------------------------------------------------- -module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML, parseXML) where +module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, showsNospaceXML, bottomUpXML, parseXML) where import Data.Char(isSpace) import Numeric (readHex) @@ -38,6 +38,17 @@ showsXML = showsX 0 where (Empty) -> id ind i = showString ("\n" ++ replicate (2*i) ' ') +showsNospaceXML :: XML -> ShowS +showsNospaceXML x = case x of + (Data s) -> showString (escape s) + (ETag t as) -> showChar '<' . showString t . showsAttrs as . showString "/>" + (Tag t as cs) -> + showChar '<' . showString t . showsAttrs as . showChar '>' . + concatS (map showsNospaceXML cs) . + showString "' + (Comment c) -> showString "" + (Empty) -> id + showsAttrs :: [Attr] -> ShowS showsAttrs = concatS . map (showChar ' ' .) . map showsAttr diff --git a/src/compiler/api/GF/Grammar.hs b/src/compiler/api/GF/Grammar.hs index 9c55dfffc..044e00033 100644 --- a/src/compiler/api/GF/Grammar.hs +++ b/src/compiler/api/GF/Grammar.hs @@ -14,7 +14,6 @@ module GF.Grammar ( module GF.Grammar.Grammar, - module GF.Grammar.Values, module GF.Grammar.Macros, module GF.Grammar.Parser, module GF.Grammar.Printer, @@ -23,7 +22,6 @@ module GF.Grammar ) where import GF.Grammar.Grammar -import GF.Grammar.Values import GF.Grammar.Macros import GF.Grammar.Parser import GF.Grammar.Printer diff --git a/src/compiler/api/GF/Grammar/Analyse.hs b/src/compiler/api/GF/Grammar/Analyse.hs index 64a7fa4d4..29a054748 100644 --- a/src/compiler/api/GF/Grammar/Analyse.hs +++ b/src/compiler/api/GF/Grammar/Analyse.hs @@ -27,7 +27,7 @@ stripSourceGrammar sgr = mGrammar [(i, m{jments = Map.map stripInfo (jments m)}) stripInfo :: Info -> Info stripInfo i = case i of AbsCat _ -> i - AbsFun mt mi me mb -> AbsFun mt mi Nothing mb + AbsFun mt me -> AbsFun mt Nothing ResParam mp mt -> ResParam mp Nothing ResValue lt _ -> i ---- ResOper mt md -> ResOper mt Nothing @@ -87,9 +87,9 @@ sizeTerm t = case t of Table a c -> 1 + sizeTerm a + sizeTerm c ExtR a c -> 1 + sizeTerm a + sizeTerm c R r -> 1 + sum [1 + sizeTerm a | (_,(_,a)) <- r] -- label counts as 1, type ignored - RecType r -> 1 + sum [1 + sizeTerm a | (_,a) <- r] -- label counts as 1 + RecType r -> 1 + sum [1 + sizeTerm a | (_,_,a) <- r] -- label counts as 1 P t i -> 2 + sizeTerm t - T _ cc -> 1 + sum [1 + sizeTerm (patt2term p) + sizeTerm v | (p,v) <- cc] + T _ cc -> 1 + sum [1 + sizePatt p + sizeTerm v | (p,v) <- cc] V ty cc -> 1 + sizeTerm ty + sum [1 + sizeTerm v | v <- cc] Let (x,(mt,a)) b -> 2 + maybe 0 sizeTerm mt + sizeTerm a + sizeTerm b C s1 s2 -> 1 + sizeTerm s1 + sizeTerm s2 @@ -99,13 +99,25 @@ sizeTerm t = case t of Strs tt -> 1 + sum (map sizeTerm tt) _ -> 1 +sizePatt :: Patt -> Int +sizePatt p = case p of + PC c pp -> 1 + sum (map sizePatt pp) + PP c pp -> 1 + sum (map sizePatt pp) + PR r -> 1 + sum [sizePatt p | (l,p) <- r] + PT _ p -> sizePatt p + PAs _ p -> sizePatt p + PSeq _ _ a _ _ b -> 1 + sizePatt a + sizePatt b + PAlt a b -> 1 + sizePatt a + sizePatt b + PRep _ _ a-> 1 + sizePatt a + PNeg a -> 1 + sizePatt a + _ -> 1 -- the size of a judgement sizeInfo :: Info -> Int sizeInfo i = case i of AbsCat (Just (L _ co)) -> 1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] - AbsFun mt mi me mb -> 1 + msize mt + - sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es] + AbsFun mt me -> 1 + msize mt + + sum [sum (map sizePatt ps) + sizeTerm t | Just (_,es) <- [me], L _ (ps,t) <- es] ResParam mp mt -> 1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps] ResValue _ _ -> 0 diff --git a/src/compiler/api/GF/Grammar/Binary.hs b/src/compiler/api/GF/Grammar/Binary.hs index 1c1960076..83e17ff29 100644 --- a/src/compiler/api/GF/Grammar/Binary.hs +++ b/src/compiler/api/GF/Grammar/Binary.hs @@ -23,7 +23,6 @@ import GF.Infra.UseIO(MonadIO(..)) import GF.Grammar.Grammar import PGF2(Literal(..)) -import PGF2.Transactions(Symbol(..)) -- Please change this every time when the GFO format is changed gfoVersion = "GF05" @@ -33,9 +32,9 @@ instance Binary Grammar where get = fmap mGrammar get instance Binary ModuleInfo where - put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,mseqs mi,jments mi) - get = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get - return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments) + put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi) + get = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,jments) <- get + return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc jments) instance Binary ModuleType where put MTAbstract = putWord8 0 @@ -100,13 +99,13 @@ instance Binary PArg where put (PArg x y) = put (x,y) get = get >>= \(x,y) -> return (PArg x y) -instance Binary Production where - put (Production ps args res rules) = put (ps,args,res,rules) - get = get >>= \(ps,args,res,rules) -> return (Production ps args res rules) +instance Binary Rule where + put (Rule v w x y z) = put (v,w,x,y,z) + get = get >>= \(v,w,x,y,z) -> return (Rule v w x y z) instance Binary Info where put (AbsCat x) = putWord8 0 >> put x - put (AbsFun w x y z) = putWord8 1 >> put (w,x,y,z) + put (AbsFun x y) = putWord8 1 >> put (x,y) put (ResParam x y) = putWord8 2 >> put (x,y) put (ResValue x y) = putWord8 3 >> put (x,y) put (ResOper x y) = putWord8 4 >> put (x,y) @@ -117,7 +116,7 @@ instance Binary Info where get = do tag <- getWord8 case tag of 0 -> get >>= \x -> return (AbsCat x) - 1 -> get >>= \(w,x,y,z) -> return (AbsFun w x y z) + 1 -> get >>= \(x,y) -> return (AbsFun x y) 2 -> get >>= \(x,y) -> return (ResParam x y) 3 -> get >>= \(x,y) -> return (ResValue x y) 4 -> get >>= \(x,y) -> return (ResOper x y) @@ -225,7 +224,6 @@ instance Binary Patt where put (PC x y) = putWord8 0 >> put (x,y) put (PP x y) = putWord8 1 >> put (x,y) put (PV x) = putWord8 2 >> put x - put (PW) = putWord8 3 put (PR x) = putWord8 4 >> put x put (PString x) = putWord8 5 >> put x put (PInt x) = putWord8 6 >> put x @@ -247,7 +245,6 @@ instance Binary Patt where 0 -> get >>= \(x,y) -> return (PC x y) 1 -> get >>= \(x,y) -> return (PP x y) 2 -> get >>= \x -> return (PV x) - 3 -> return (PW) 4 -> get >>= \x -> return (PR x) 5 -> get >>= \x -> return (PString x) 6 -> get >>= \x -> return (PInt x) @@ -369,7 +366,7 @@ decodeModuleHeader :: MonadIO io => FilePath -> io (VersionTagged Module) decodeModuleHeader = liftIO . fmap (fmap conv) . decodeFile' where conv (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) = - (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty) + (m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Map.empty) encodeModule :: MonadIO io => FilePath -> SourceModule -> io () encodeModule fpath mo = liftIO $ encodeFile fpath (Tagged mo) diff --git a/src/compiler/api/GF/Grammar/Grammar.hs b/src/compiler/api/GF/Grammar/Grammar.hs index 1a4f2ed3a..29eae938f 100644 --- a/src/compiler/api/GF/Grammar/Grammar.hs +++ b/src/compiler/api/GF/Grammar/Grammar.hs @@ -65,7 +65,7 @@ module GF.Grammar.Grammar ( Location(..), L(..), unLoc, noLoc, ppLocation, ppL, -- ** PMCFG - LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..) + LIndex,LVar,LParam(..),PArg(..),Symbol(..),Rule(..) ) where import GF.Infra.Ident @@ -75,8 +75,9 @@ import GF.Infra.Location import GF.Data.Operations import PGF2(BindType(..),PGF) -import PGF2.Transactions(SeqId,LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..)) +import PGF2.Transactions(LIndex,LVar,LParam(..),PArg(..),Symbol(..),Rule(..)) +import Data.Graph import Data.Array.IArray(Array) import Data.Array.Unboxed(UArray) import qualified Data.Map as Map @@ -103,7 +104,6 @@ data ModuleInfo mopens :: [OpenSpec], mexdeps :: [ModuleName], msrc :: FilePath, - mseqs :: Maybe (Seq.Seq [Symbol]), jments :: Map.Map Ident Info } | ModPGF { @@ -277,10 +277,11 @@ isCompleteModule m = mstatus m == MSComplete && mtype m /= MTInterface -- | all abstract modules sorted from least to most dependent allAbstracts :: Grammar -> [ModuleName] -allAbstracts gr = - case topoTest [(i,extends m) | (i,m) <- modules gr, mtype m == MTAbstract] of - Left is -> is - Right cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles)) +allAbstracts gr = + let scc = stronglyConnComp [(mn,mn,extends mo) | (mn,mo) <- modules gr, mtype mo == MTAbstract] + in case [mns | CyclicSCC mns <- scc] of + [] -> [mn | AcyclicSCC mn <- scc] + cycles -> error $ render ("Cyclic abstract modules:" <+> vcat (map hsep cycles)) -- | the last abstract in dependency order (head of list) greatestAbstract :: Grammar -> Maybe ModuleName @@ -322,8 +323,8 @@ allConcreteModules gr = -- and indirection to module (/INDIR/) data Info = -- judgements in abstract syntax - AbsCat (Maybe (L Context)) -- ^ (/ABS/) context of a category - | AbsFun (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool) -- ^ (/ABS/) type, arrity and definition of a function + AbsCat (Maybe (L Context)) -- ^ (/ABS/) context of a category + | AbsFun (Maybe (L Type)) (Maybe (Int,[L Equation])) -- ^ (/ABS/) type, arrity and definition of a function -- judgements in resource | ResParam (Maybe (L [Param])) (Maybe ([Term],Int)) -- ^ (/RES/) The second argument is list of all possible values @@ -336,12 +337,12 @@ data Info = | ResOverload [ModuleName] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited -- judgements in concrete syntax - | CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe ([Production],[Production])) -- ^ (/CNC/) lindef ini'zed, - | CncFun (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) type info added at 'TC' + | CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe ([Rule],[Rule])) -- ^ (/CNC/) lindef ini'zed, + | CncFun (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [Rule]) -- ^ (/CNC/) type info added at 'TC' -- indirection to module Ident | AnyInd Bool ModuleName -- ^ (/INDIR/) the 'Bool' says if canonical - deriving Show + deriving (Eq,Show) type Type = Term type Cat = QIdent @@ -396,7 +397,7 @@ data Term = | FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@ - | Markup Ident [(Ident,Term)] [Term] + | Markup Ident [(Ident,Term)] [L Term] | Reset Ident (Maybe Term) Term (Maybe QIdent) | Alts Term [(Term, Term)] -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@ @@ -409,8 +410,7 @@ data Term = data Patt = PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@ | PP QIdent [Patt] -- ^ package constructor pattern: @P.C p1 ... pn@ @P.C@ - | PV Ident -- ^ variable pattern: @x@ - | PW -- ^ wild card pattern: @_@ + | PV Ident -- ^ variable pattern: @x@ or wild card @_@ | PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete | PString String -- ^ string literal pattern: @\"foo\"@ -- only abstract | PInt Integer -- ^ integer literal pattern: @12@ -- only abstract @@ -462,8 +462,8 @@ type Hypo = (BindType,Ident,Type) -- (x:A) (_:A) A ({x}:A) type Context = [Hypo] -- (x:A)(y:B) (x,y:A) (_,_:A) type Equation = ([Patt],Term) -type Labelling = (Label, Type) -type Assign = (Label, (Maybe Type, Term)) +type Labelling = (Label, [Ident], Type) +type Assign = (Label, (Maybe Type, Term)) type Option = (Maybe Term, Term) type Case = (Patt, Term) --type Cases = ([Patt], Term) diff --git a/src/compiler/api/GF/Grammar/JSON.hs b/src/compiler/api/GF/Grammar/JSON.hs index 0ca49e15f..fe6b657d3 100644 --- a/src/compiler/api/GF/Grammar/JSON.hs +++ b/src/compiler/api/GF/Grammar/JSON.hs @@ -34,11 +34,11 @@ info2json (AbsCat mb_ctxt) = case mb_ctxt of Nothing -> makeObj [] Just (L _ ctxt) -> makeObj [("context", showJSON (map hypo2json ctxt))] -info2json (AbsFun mb_ty mb_arity mb_eqs _) = +info2json (AbsFun mb_ty mb_eqs) = (makeObj . catMaybes) [ fmap (\(L _ ty) -> ("abstype",term2json ty)) mb_ty - , fmap (\a -> ("arity",showJSON a)) mb_arity - , fmap (\eqs -> ("equations",showJSON (map (\(L _ eq) -> equation2json eq) eqs))) mb_eqs + , fmap (\(a,_) -> ("arity",showJSON a)) mb_eqs + , fmap (\(_,eqs) -> ("equations",showJSON (map (\(L _ eq) -> equation2json eq) eqs))) mb_eqs ] info2json (ResParam mb_params _) = makeObj [("params", case mb_params of @@ -102,7 +102,7 @@ term2json (Prod bt v t1 t2) = makeObj [("implicit", showJSON (bt==Implicit)), (" term2json (Typed t ty) = makeObj [("term", term2json t), ("type", term2json ty)] term2json (Example t s) = makeObj [("term", term2json t), ("example", showJSON s)] term2json (RecType lbls) = makeObj [("rectype", makeObj (map toRow lbls))] - where toRow (l,t) = (showLabel l, term2json t) + where toRow (l,_,t) = (showLabel l, term2json t) term2json (R lbls) = makeObj [("record", makeObj (map toRow lbls))] where toRow (l,(_,t)) = (showLabel l, term2json t) term2json (P t proj) = makeObj [("project", term2json t), ("label", showJSON (showLabel proj))] @@ -126,7 +126,7 @@ term2json (ELin id t) = makeObj [("lin",showJSON id), ("term",term2json t)] term2json (FV ts) = makeObj [("variants",showJSON (map term2json ts))] term2json (Markup tag attrs children) = makeObj [ ("tag",showJSON tag) , ("attrs",showJSON (map (\(attr,val) -> (showJSON attr,term2json val)) attrs)) - , ("children",showJSON (map term2json children)) + , ("children",showJSON (map (term2json . unLoc) children)) ] term2json (Reset ctl ct t qid) = makeObj ([("ctl",showJSON ctl)]++maybe [] (\t->[("ct",term2json t)]) ct++[("term",term2json t), ("qid",showJSON qid)]) @@ -177,14 +177,14 @@ json2term o = Vr <$> o!:"vr" <|> FV <$> (o!:"variants" >>= mapM json2term) <|> Markup <$> (o!:"tag") <*> (o!:"attrs" >>= mapM (\(attr,val) -> fmap ((,)attr) (json2term val))) <*> - (o!:"children" >>= mapM json2term) + (o!:"children" >>= mapM (fmap noLoc . json2term)) <|> Reset <$> o!:"ctl" <*> fmap Just (o!<"ct") <*> o!<"term" <*> o!:"qid" <|> Reset <$> o!:"ctl" <*> pure Nothing <*> o!<"term" <*> o!:"qid" <|> Alts <$> (o!<"def") <*> (o!:"alts" >>= mapM (\(x,y) -> liftM2 (,) (json2term x) (json2term y))) <|> Strs <$> (o!:"strs" >>= mapM json2term) where fromRow (lbl, jsvalue) = do value <- json2term jsvalue - return (readLabel lbl,value) + return (readLabel lbl,[],value) fromRow' (lbl, jsvalue) = do value <- json2term jsvalue return (readLabel lbl,(Nothing,value)) @@ -198,7 +198,6 @@ json2term o = Vr <$> o!:"vr" patt2json (PC id ps) = makeObj [("pc",showJSON id),("args",showJSON (map patt2json ps))] patt2json (PP (mn,id) ps) = makeObj [("mod",showJSON mn),("pc",showJSON id),("args",showJSON (map patt2json ps))] patt2json (PV id) = makeObj [("pv",showJSON id)] -patt2json PW = makeObj [("wildcard",showJSON True)] patt2json (PR lbls) = makeObj (("record", showJSON True) : map toRow lbls) where toRow (l,t) = (showLabel l, patt2json t) patt2json (PString s) = showJSON s @@ -231,7 +230,6 @@ json2patt :: JSValue -> Result Patt json2patt o = PP <$> (liftM2 (\mn id -> (mn,id)) (o!:"mod") (o!:"pc")) <*> (o!:"args" >>= mapM json2patt) <|> PC <$> (o!:"pc") <*> (o!:"args" >>= mapM json2patt) <|> PV <$> (o!:"pv") - <|> (o!:"wildcard" >>= guard >> return PW) <|> (const PR) <$> (o!:"record" >>= guard) <*> mapM fromRow (assocsJSObject o) <|> PString <$> readJSON o <|> PInt <$> readJSON o diff --git a/src/compiler/api/GF/Grammar/Lockfield.hs b/src/compiler/api/GF/Grammar/Lockfield.hs index 53e58a3ad..da2056d67 100644 --- a/src/compiler/api/GF/Grammar/Lockfield.hs +++ b/src/compiler/api/GF/Grammar/Lockfield.hs @@ -14,37 +14,35 @@ -- AR 8\/2\/2005 detached from 'compile/MkResource' ----------------------------------------------------------------------------- -module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where +module GF.Grammar.Lockfield (lock, lockLabel, isLockLabel) where import GF.Infra.Ident +import GF.Grammar.Predef import GF.Grammar.Grammar -import GF.Grammar.Macros import GF.Data.Operations(ErrorMonad,Err(..)) -lockRecType :: ErrorMonad m => Ident -> Type -> m Type -lockRecType c t@(RecType rs) = - let lab = lockLabel c in - return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"] - then t --- don't add an extra copy of lock field, nor predef cats - else RecType (rs ++ [(lockLabel c, RecType [])]) -lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])] - -unlockRecord :: Monad m => Ident -> Term -> m Term -unlockRecord c ft = do - let (xs,t) = termFormCnc ft - let lock = R [(lockLabel c, (Just (RecType []),R []))] - case plusRecord t lock of - Ok t' -> return $ mkAbs xs t' - _ -> return $ mkAbs xs (ExtR t lock) +lock :: Ident -> Term -> Term +lock c t@(RecType rs) = + let lbl = lockLabel c + in if elem lbl [l | (l,_,_)<-rs] || elem c [cString,cInt] + then t --- don't add an extra copy of lock field, nor predef cats + else RecType (rs ++ [(lbl, [], RecType [])]) +lock c t@(R rs) = + let lbl = lockLabel c + in if elem lbl (map fst rs) + then t + else R (rs ++ [(lbl, (Just (RecType []),R []))]) +lock c (Abs b x t) = Abs b x (lock c t) +lock c (FV ts) = FV (map (lock c) ts) +lock c t = t lockLabel :: Ident -> Label lockLabel c = LIdent $! prefixRawIdent lockPrefix (ident2raw c) -isLockLabel :: Label -> Bool +isLockLabel :: Label -> Maybe RawIdent isLockLabel l = case l of LIdent c -> isPrefixOf lockPrefix c - _ -> False - + _ -> Nothing lockPrefix = rawIdentS "lock_" diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs index 30d581c72..09c5ac53b 100644 --- a/src/compiler/api/GF/Grammar/Lookup.hs +++ b/src/compiler/api/GF/Grammar/Lookup.hs @@ -23,9 +23,10 @@ module GF.Grammar.Lookup ( lookupResType, lookupOverload, lookupOverloadTypes, - lookupParamValues, allParamValues, + countParamValues, lookupAbsDef, + lookupAbsType, lookupLincat, lookupFunType, lookupCatContext, @@ -45,10 +46,6 @@ import GF.Text.Pretty import qualified Data.Map as Map import qualified PGF2 --- whether lock fields are added in reuse -lock c = lockRecType c -- return -unlock c = unlockRecord c -- return - -- to look up a constant etc in a search tree --- why here? AR 29/5/2008 lookupIdent :: ErrorMonad m => Ident -> Map.Map Ident b -> m b lookupIdent c t = @@ -77,7 +74,8 @@ lookupIdentInfo (m,ModPGF{mpgf=pgf}) i = appHypos [] xs t es = foldl (appExpr xs) t es appHypos ((bt, v, ty):hypos) xs t es = - let x = identS v in Prod bt x (cnvType xs ty) (appHypos hypos (x:xs) t es) + let x = if v == "_" then identW else identS v + in Prod bt x (cnvType xs ty) (appHypos hypos (x:xs) t es) appExpr xs t e = App t (cnvExpr xs e) @@ -101,7 +99,7 @@ lookupQIdentInfo gr (m,c) = do lookupResDef :: ErrorMonad m => Grammar -> QIdent -> m Term lookupResDef gr (m,c) - | isPredefCat c = lock c defLinType + | isPredefCat c = return (lock c defLinType) | otherwise = look m c where look m c = do @@ -109,10 +107,10 @@ lookupResDef gr (m,c) case info of ResOper _ (Just (L _ t)) -> return t ResOper _ Nothing -> return (Q (m,c)) - CncCat (Just (L _ ty)) _ _ _ _ -> lock c ty - CncCat _ _ _ _ _ -> lock c defLinType + CncCat (Just (L _ ty)) _ _ _ _ -> return (lock c ty) + CncCat _ _ _ _ _ -> return (lock c defLinType) - CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr + CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> return (lock cat tr) CncFun _ (Just (L _ tr)) _ _ -> return tr AnyInd _ n -> look n c @@ -128,9 +126,8 @@ lookupResType gr (m,c) = do -- used in reused concrete CncCat _ _ _ _ _ -> return typeType - CncFun (Just (_,cat,cont,val)) _ _ _ -> do - val' <- lock cat val - return $ mkProd cont val' [] + CncFun (Just (args,cat,cont,val)) _ _ _ -> + return $ (mkFunType (zipWith (\cat (_,_,ty) -> lock cat ty) args cont) (lock cat val)) AnyInd _ n -> lookupResType gr (n,c) ResParam _ _ -> return typePType ResValue (L _ t) _ -> return t @@ -145,8 +142,7 @@ lookupOverloadTypes gr id@(m,c) = do -- used in reused concrete CncCat _ _ _ _ _ -> ret typeType CncFun (Just (_,cat,cont,val)) _ _ _ -> do - val' <- lock cat val - ret $ mkProd cont val' [] + ret $ mkProd cont (lock cat val) [] ResParam _ _ -> ret typePType ResValue (L _ t) _ -> ret t ResOverload os tysts -> do @@ -186,39 +182,57 @@ allOrigInfos gr m = fromErr [] $ do ModInfo{jments=jments} -> return [((m,c),i) | (c,_) <- Map.toList jments, Ok (m,i) <- [lookupOrigInfo gr (m,c)]] _ -> return [] -lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term] -lookupParamValues gr c = do - (_,info) <- lookupOrigInfo gr c - case info of - ResParam _ (Just (pvs,_)) -> return pvs - _ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined") - allParamValues :: ErrorMonad m => Grammar -> Type -> m [Term] -allParamValues cnc ptyp = +allParamValues gr ptyp = case ptyp of _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]] - QC c -> lookupParamValues cnc c - Q c -> lookupResDef cnc c >>= allParamValues cnc + QC c -> do (_,info) <- lookupOrigInfo gr c + case info of + ResParam _ (Just (pvs,_)) -> return pvs + _ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined") + Q c -> lookupResDef gr c >>= allParamValues gr RecType r -> do - let (ls,tys) = unzip $ sortByFst r - tss <- mapM (allParamValues cnc) tys + let (ls,lls,tys) = unzip3 $ sortByLbl r + tss <- mapM (allParamValues gr) tys return [R (zipAssign ls ts) | ts <- sequence tss] Table pt vt -> do - pvs <- allParamValues cnc pt - vvs <- allParamValues cnc vt + pvs <- allParamValues gr pt + vvs <- allParamValues gr vt return [V pt ts | ts <- sequence (replicate (length pvs) vvs)] _ -> raise (render ("cannot find parameter values for" <+> ptyp)) where -- to normalize records and record types - sortByFst = sortBy (\ x y -> compare (fst x) (fst y)) + sortByLbl = sortBy (\(l1,_,_) (l2,_,_) -> compare l1 l2) -lookupAbsDef :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m (Maybe Int,Maybe [Equation]) -lookupAbsDef gr m c = errIn (render ("looking up absdef of" <+> c)) $ do - info <- lookupQIdentInfo gr (m,c) +countParamValues :: ErrorMonad m => Grammar -> Type -> m Int +countParamValues gr ptyp = + case ptyp of + _ | Just n <- isTypeInts ptyp -> return (fromIntegral n+1) + QC c -> do (_,info) <- lookupOrigInfo gr c + case info of + ResParam _ (Just (_,cnt)) -> return cnt + _ -> raise $ render (ppQIdent Qualified c <+> "has no parameter values defined") + Q c -> lookupResDef gr c >>= countParamValues gr + RecType r -> do + let (ls,lls,tys) = unzip3 $ sortByLbl r + cs <- mapM (countParamValues gr) tys + return (product cs) + Table pt vt -> do + pc <- countParamValues gr pt + vc <- countParamValues gr vt + return (vc ^ pc) + _ -> raise (render ("cannot find parameter values for" <+> ptyp)) + where + -- to normalize records and record types + sortByLbl = sortBy (\(l1,_,_) (l2,_,_) -> compare l1 l2) + +lookupAbsDef :: ErrorMonad m => Grammar -> QIdent -> m (Maybe (Int,[Equation])) +lookupAbsDef gr q@(m,c) = errIn (render ("looking up absdef of" <+> c)) $ do + info <- lookupQIdentInfo gr q case info of - AbsFun _ a d _ -> return (a,fmap (map unLoc) d) - AnyInd _ n -> lookupAbsDef gr n c - _ -> return (Nothing,Nothing) + AbsFun a d -> return (fmap (\(a,eqs) -> (a,map unLoc eqs)) d) + AnyInd _ n -> lookupAbsDef gr (n,c) + _ -> return Nothing lookupLincat :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed? @@ -230,13 +244,31 @@ lookupLincat gr m c = do _ -> raise (render (c <+> "has no linearization type in" <+> m)) -- | this is needed at compile time -lookupFunType :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Type -lookupFunType gr m c = do - info <- lookupQIdentInfo gr (m,c) +lookupAbsType :: ErrorMonad m => Grammar -> QIdent -> m (Term,Type) +lookupAbsType gr q@(m,c) + | m == cPredefAbs = + if elem c [cInt,cFloat,cString] + then return (QC q,typeType) + else no_type + | otherwise = do + info <- lookupQIdentInfo gr q + case info of + AbsCat (Just (L _ co)) -> return (QC q,mkProd co typeType []) + AbsFun (Just (L _ t)) Nothing -> return (QC q,t) + AbsFun (Just (L _ t)) (Just _) -> return (Q q,t) + AnyInd _ n -> lookupAbsType gr (n,c) + _ -> no_type + where + no_type = raise (render ("cannot find type of" <+> c)) + +-- | this is needed at compile time +lookupFunType :: ErrorMonad m => Grammar -> QIdent -> m Type +lookupFunType gr q@(m,c) = do + info <- lookupQIdentInfo gr q case info of - AbsFun (Just (L _ t)) _ _ _ -> return t - AnyInd _ n -> lookupFunType gr n c - _ -> raise (render ("cannot find type of" <+> c)) + AbsFun (Just (L _ t)) _ -> return t + AnyInd _ n -> lookupFunType gr (n,c) + _ -> raise (render ("cannot find type of" <+> c)) -- | this is needed at compile time lookupCatContext :: ErrorMonad m => Grammar -> ModuleName -> Ident -> m Context @@ -260,18 +292,14 @@ allOpers gr = ] where typesIn info = case info of - AbsFun (Just ltyp) _ _ _ -> [ltyp] + AbsFun (Just ltyp) _ -> [ltyp] ResOper (Just ltyp) _ -> [ltyp] ResValue ltyp _ -> [ltyp] ResOverload _ tytrs -> [ltyp | (ltyp,_) <- tytrs] CncFun (Just (_,i,ctx,typ)) _ _ _ -> - [L NoLoc (mkProdSimple ctx (lock' i typ))] + [L NoLoc (mkProdSimple ctx (lock i typ))] _ -> [] - lock' i typ = case lock i typ of - Ok t -> t - _ -> typ - --- not for dependent types allOpersTo :: Grammar -> Type -> [(QIdent,Type,Location)] allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where diff --git a/src/compiler/api/GF/Grammar/Macros.hs b/src/compiler/api/GF/Grammar/Macros.hs index 56b755178..21c3e1cc0 100644 --- a/src/compiler/api/GF/Grammar/Macros.hs +++ b/src/compiler/api/GF/Grammar/Macros.hs @@ -28,10 +28,12 @@ import GF.Grammar.Printer import Control.Monad.Identity(Identity(..)) import qualified Data.Traversable as T(mapM) import qualified Data.Map as Map -import Control.Monad (liftM, liftM2, liftM3) -import Data.List (sortBy,nub) +import Control.Monad (liftM, liftM2, liftM3, forM) +import Data.List (nub) +import Data.Maybe (fromMaybe) import Data.Monoid -import GF.Text.Pretty(render,(<+>),hsep,fsep) +import Data.Graph +import GF.Text.Pretty(render,(<+>),($$),hsep,fsep,vcat,nest) import qualified Control.Monad.Fail as Fail -- ** Functions for constructing and analysing source code terms. @@ -179,6 +181,9 @@ mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))] mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv)) where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v) +mapLabellingM :: Monad m => (Term -> m c) -> [Labelling] -> m [(Label,[Ident],c)] +mapLabellingM f = mapM (\(l,deps,t) -> f t >>= \t -> return (l,deps,t)) + mapAttrs :: Monad m => (Term -> m c) -> [(Ident,Term)] -> m [(Ident,c)] mapAttrs f [] = return [] mapAttrs f ((id,t):as) = do t <- f t @@ -193,7 +198,7 @@ mkRecord :: (Int -> Label) -> [Term] -> Term mkRecord = mkRecordN 0 mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type -mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs] +mkRecTypeN int lab typs = RecType [(lab i, [], t) | (i,t) <- zip [int..] typs] mkRecType :: (Int -> Label) -> [Type] -> Type mkRecType = mkRecTypeN 0 @@ -260,7 +265,7 @@ tuple2record :: [Term] -> [Assign] tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts] tuple2recordType :: [Term] -> [Labelling] -tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts] +tuple2recordType ts = [(tupleLabel i,[],t) | (i,t) <- zip [1..] ts] tuple2recordPatt :: [Patt] -> [(Label,Patt)] tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts] @@ -277,7 +282,7 @@ mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod --plusRecType :: Type -> Type -> Err Type plusRecType t1 t2 = case (t1, t2) of (RecType r1, RecType r2) -> case - filter (`elem` (map fst r1)) (map fst r2) of + filter (`elem` [l | (l,_,_) <- r1]) [l | (l,_,_) <- r2] of [] -> return (RecType (r1 ++ r2)) ls -> raise $ render ("clashing labels" <+> hsep ls) _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2) @@ -293,7 +298,7 @@ plusRecord t1 t2 = -- | default linearization type defLinType :: Type -defLinType = RecType [(theLinLabel, typeStr)] +defLinType = RecType [(theLinLabel, [], typeStr)] -- | refreshing variables mkFreshVar :: [Ident] -> Ident -> Ident @@ -308,83 +313,6 @@ mkFreshVar olds x = mkFreshVarX :: [Ident] -> Ident -> Ident mkFreshVarX olds x = if (elem x olds) then (varX (maximum ((-1) : (map varIndex olds)) + 1)) else x --- *** Term and pattern conversion - -term2patt :: Term -> Err Patt -term2patt trm = case termForm trm of - Ok ([], Vr x, []) | x == identW -> return PW - | otherwise -> return (PV x) - Ok ([], Con c, aa) -> do - aa' <- mapM term2patt aa - return (PC c aa') - Ok ([], QC c, aa) -> do - aa' <- mapM term2patt aa - return (PP c aa') - - Ok ([], Q c, []) -> do - return (PM c) - - Ok ([], R r, []) -> do - let (ll,aa) = unzipR r - aa' <- mapM term2patt aa - return (PR (zip ll aa')) - Ok ([],EInt i,[]) -> return $ PInt i - Ok ([],EFloat i,[]) -> return $ PFloat i - Ok ([],K s, []) -> return $ PString s - ---- encodings due to excessive use of term-patt convs. AR 7/1/2005 - Ok ([], Cn id, [Vr a,b]) | id == cAs -> do - b' <- term2patt b - return (PAs a b') - Ok ([], Cn id, [a]) | id == cNeg -> do - a' <- term2patt a - return (PNeg a') - Ok ([], Cn id, [a]) | id == cRep -> do - a' <- term2patt a - return (PRep 0 Nothing a') - Ok ([], Cn id, []) | id == cRep -> do - return PChar - Ok ([], Cn id,[K s]) | id == cChars -> do - return $ PChars s - Ok ([], Cn id, [a,b]) | id == cSeq -> do - a' <- term2patt a - b' <- term2patt b - return (PSeq 0 Nothing a' 0 Nothing b') - Ok ([], Cn id, [a,b]) | id == cAlt -> do - a' <- term2patt a - b' <- term2patt b - return (PAlt a' b') - - Ok ([], Cn c, []) -> do - return (PMacro c) - - _ -> Bad $ render ("no pattern corresponds to term" <+> ppTerm Unqualified 0 trm) - -patt2term :: Patt -> Term -patt2term pt = case pt of - PV x -> Vr x - PW -> Vr identW --- not parsable, should not occur - PMacro c -> Cn c - PM c -> Q c - - PC c pp -> mkApp (Con c) (map patt2term pp) - PP c pp -> mkApp (QC c) (map patt2term pp) - - PR r -> R [assign l (patt2term p) | (l,p) <- r] - PT _ p -> patt2term p - PInt i -> EInt i - PFloat i -> EFloat i - PString s -> K s - - PAs x p -> appCons cAs [Vr x, patt2term p] --- an encoding - PChar -> appCons cChar [] --- an encoding - PChars s -> appCons cChars [K s] --- an encoding - PSeq _ _ a _ _ b -> appCons cSeq [(patt2term a), (patt2term b)] --- an encoding - PAlt a b -> appCons cAlt [(patt2term a), (patt2term b)] --- an encoding - PRep _ _ a-> appCons cRep [(patt2term a)] --- an encoding - PNeg a -> appCons cNeg [(patt2term a)] --- an encoding - - -- *** Almost compositional -- | to define compositional term functions @@ -401,7 +329,7 @@ composOp co trm = S c a -> liftM2 S (co c) (co a) Table a c -> liftM2 Table (co a) (co c) R r -> liftM R (mapAssignM co r) - RecType r -> liftM RecType (mapPairsM co r) + RecType r -> liftM RecType (mapLabellingM co r) P t i -> liftM2 P (co t) (return i) ExtR a c -> liftM2 ExtR (co a) (co c) Opts t os -> liftM2 Opts (co t) (mapM (\(t1,t2) -> liftM2 (,) (maybe (return Nothing) (liftM Just . co) t1) (co t2)) os) @@ -418,7 +346,7 @@ composOp co trm = ELincat c ty -> liftM (ELincat c) (co ty) ELin c ty -> liftM (ELin c) (co ty) ImplArg t -> liftM ImplArg (co t) - Markup t as cs -> liftM2 (Markup t) (mapAttrs co as) (mapM co cs) + Markup t as cs -> liftM2 (Markup t) (mapAttrs co as) (mapM (mapM co) cs) Reset ctl ct t qid->liftM2 (\mb_ct t->Reset ctl ct t qid) (maybe (pure Nothing) (fmap Just . co) ct) (co t) Typed t ty -> liftM2 Typed (co t) (co ty) _ -> return trm -- covers K, Vr, Cn, Sort, EPatt @@ -452,8 +380,8 @@ collectOp co trm = case trm of Table a c -> co a <> co c ExtR a c -> co a <> co c Opts t os -> co t <> mconcatMap (\(a,b) -> maybe mempty co a <> co b) os - R r -> mconcatMap (\ (_,(mt,a)) -> maybe mempty co mt <> co a) r - RecType r -> mconcatMap (co . snd) r + R r -> mconcatMap (\(_,(mt,a)) -> maybe mempty co mt <> co a) r + RecType r -> mconcatMap (\(_,_,t) -> co t) r P t i -> co t T _ cc -> mconcatMap (co . snd) cc -- not from patterns --- nor from type annot V _ cc -> mconcatMap co cc --- nor from type annot @@ -466,7 +394,7 @@ collectOp co trm = case trm of Strs tt -> mconcatMap co tt ELincat _ t -> co t ELin _ t -> co t - Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap co cs + Markup t as cs -> mconcatMap (co.snd) as <> mconcatMap (co . unLoc) cs Reset _ ct t _-> maybe mempty co ct <> co t _ -> mempty -- covers K, Vr, Cn, Sort @@ -524,58 +452,55 @@ changeTableType co i = case i of TWild ty -> co ty >>= return . TWild _ -> return i --- | normalize records and record types; put s first - -sortRec :: [(Label,a)] -> [(Label,a)] -sortRec = sortBy ordLabel where - ordLabel (r1,_) (r2,_) = - case (showIdent (label2ident r1), showIdent (label2ident r2)) of - ("s",_) -> LT - (_,"s") -> GT - (s1,s2) -> compare s1 s2 - -- *** Dependencies -- | dependency check, detecting circularities and returning topo-sorted list -allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])] +allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,Info,[Ident])] allDependencies ism b = - [(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b] + [(f, i, nub (deps i)) | (f,i) <- Map.toList b] where opersIn t = case t of Q (n,c) | ism n -> [c] QC (n,c) | ism n -> [c] + EPatt _ _ p -> opersInPatt p + T _ cs -> mconcatMap (\(p,t) -> opersInPatt p ++ opersIn t) cs _ -> collectOp opersIn t + + constrsIn t = case t of + QC (n,c) | ism n -> [c] + _ -> collectOp constrsIn t + + opersInPatt p = case p of + PP (n,c) ps -> (if ism n then (:)c else id) + (concatMap opersInPatt ps) + PTilde t -> opersIn t + PM (n,c) | ism n -> [c] + _ -> collectPattOp opersInPatt p + opty (Just (L _ ty)) = opersIn ty opty _ = [] - pts i = case i of - ResOper pty pt -> [pty,pt] - ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts] - ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont] - CncCat pty _ _ _ _ -> [pty] - CncFun _ pt _ _ -> [pt] ---- (Maybe (Ident,(Context,Type)) - AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual - AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co] + + deps i = case i of + ResOper pty pt -> opty pty ++ opty pt + ResOverload _ tyts -> concat [opersIn ty ++ opersIn tr | (L _ ty,L _ tr) <- tyts] + ResParam (Just (L loc ps)) _ -> concat [opersIn t | (_,cont) <- ps, (_,_,t) <- cont] + CncCat pty _ _ _ _ -> opty pty + CncFun _ pt _ _ -> opty pt + AbsFun pty peqs -> opty pty ++ concat [concatMap opersInPatt ps++constrsIn t | L _ (ps,t) <- maybe [] snd peqs] + AbsCat (Just (L loc co)) -> concat [opersIn ty | (_,_,ty) <- co] _ -> [] topoSortJments :: ErrorMonad m => SourceModule -> m [(Ident,Info)] topoSortJments (m,mi) = do - is <- either - return - (\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc)))) - (topoTest (allDependencies (==m) (jments mi))) - return (reverse [(i,info) | i <- is, Just info <- [Map.lookup i (jments mi)]]) - -topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]] -topoSortJments2 (m,mi) = do - iss <- either - return - (\cyc -> raise (render ("circular definitions:" - <+> fsep (head cyc)))) - (topoTest2 (allDependencies (==m) (jments mi))) - return - [[(i,info) | i<-is,Just info<-[Map.lookup i (jments mi)]] | is<-iss] - + let sccs = stronglyConnComp (map toNode (allDependencies (==m) (jments mi))) + cycles = [map fst jmts | CyclicSCC jmts <- sccs] + case cycles of + [] -> return [jmt | AcyclicSCC jmt <- sccs] + _ -> raise (render ("circular definitions:" $$ + nest 3 (vcat (map fsep cycles)))) + where + toNode (id,info,deps) = ((id,info),id,deps) mkStrs p = case p of PAlt a b -> do diff --git a/src/compiler/api/GF/Grammar/Parser.y b/src/compiler/api/GF/Grammar/Parser.y index b46b17a4f..373d19ccd 100644 --- a/src/compiler/api/GF/Grammar/Parser.y +++ b/src/compiler/api/GF/Grammar/Parser.y @@ -135,14 +135,14 @@ ModDef (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) } jments <- mapM (checkInfoType mtype) jments defs <- buildAnyTree id jments - return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs) } + return (id, ModInfo mtype mstat opts extends with opens [] "" defs) } ModHeader :: { SourceModule } ModHeader : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ; (mtype,id) = $2 ; (extends,with,opens) = $4 } - in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) } + in (id, ModInfo mtype mstat noOptions extends with opens [] "" Map.empty) } ComplMod :: { ModuleStatus } ComplMod @@ -253,19 +253,18 @@ CatDef FunDef :: { [(Ident,Info)] } FunDef - : Posn ListIdent ':' Exp Posn { [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing (Just []) (Just True)) | fun <- $2] } + : Posn ListIdent ':' Exp Posn { [(fun, AbsFun (Just (mkL $1 $5 $4)) (Just (0,[]))) | fun <- $2] } DefDef :: { [(Ident,Info)] } DefDef - : Posn LhsNames '=' Exp Posn { [(f, AbsFun Nothing (Just 0) (Just [mkL $1 $5 ([],$4)]) Nothing) | f <- $2] } - | Posn LhsName ListPatt '=' Exp Posn { [($2,AbsFun Nothing (Just (length $3)) (Just [mkL $1 $6 ($3,$5)]) Nothing)] } + : Posn LhsNames '=' Exp Posn { [(f, AbsFun Nothing (Just (0,[mkL $1 $5 ([],$4)]))) | f <- $2] } + | Posn LhsName ListPatt '=' Exp Posn { [($2,AbsFun Nothing (Just (0,[mkL $1 $6 ($3,$5)])))] } DataDef :: { [(Ident,Info)] } DataDef : Posn Ident '=' ListDataConstr Posn { ($2, AbsCat Nothing) : - [(fun, AbsFun Nothing Nothing Nothing (Just True)) | fun <- $4] } - | Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), AbsCat Nothing) : - [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing Nothing (Just True)) | fun <- $2] } + [(fun, AbsFun Nothing Nothing) | fun <- $4] } + | Posn ListIdent ':' Exp Posn { [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing) | fun <- $2] } ParamDef :: { [(Ident,Info)] } ParamDef @@ -294,6 +293,9 @@ FlagDef : Posn Ident '=' Ident Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ showIdent $4] of Ok x -> return x Bad msg -> failLoc $1 msg } + | Posn Ident '=' String Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ $4] of + Ok x -> return x + Bad msg -> failLoc $1 msg } | Posn Ident '=' Double Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ show $4] of Ok x -> return x Bad msg -> failLoc $1 msg } @@ -381,18 +383,20 @@ LhsNames : LhsName { [$1] } | LhsName ',' LhsNames { $1 : $3 } -LocDef :: { [(Ident, Maybe Type, Maybe Term)] } +LocDef :: { [(Ident, Bool, Maybe Type, Maybe Term)] } LocDef - : ListIdent ':' Exp { [(lab,Just $3,Nothing) | lab <- $1] } - | ListIdent '=' Exp { [(lab,Nothing,Just $3) | lab <- $1] } - | ListIdent ':' Exp '=' Exp { [(lab,Just $3,Just $5) | lab <- $1] } + : '$' Ident ':' Exp { [($2,True,Just $4,Nothing)] } + | ListIdent ':' Exp { [(lab,False,Just $3,Nothing) | lab <- $1] } + | ListIdent '=' Exp { [(lab,False,Nothing,Just $3) | lab <- $1] } + | ListIdent ':' Exp '=' Exp { [(lab,False,Just $3,Just $5) | lab <- $1] } -LocMarkupDef :: { [(Ident, Maybe Type, Maybe Term)] } +LocMarkupDef :: { [(Ident, Bool, Maybe Type, Maybe Term)] } LocMarkupDef - : ListIdent '=' Tag { [(lab,Nothing,Just $3) | lab <- $1] } - | ListIdent ':' Exp '=' Tag { [(lab,Just $3,Just $5) | lab <- $1] } + : '$' Ident '=' Tag { [($2,False,Nothing,Just $4)] } + | ListIdent '=' Tag { [(lab,False,Nothing,Just $3) | lab <- $1] } + | ListIdent ':' Exp '=' Tag { [(lab,False,Just $3,Just $5) | lab <- $1] } -ListLocDef :: { [(Ident, Maybe Type, Maybe Term)] } +ListLocDef :: { [(Ident, Bool, Maybe Type, Maybe Term)] } ListLocDef : {- empty -} { [] } | LocDef { $1 } @@ -443,8 +447,8 @@ Exp3 | 'table' Exp6 '{' ListCase '}' { T (TTyped $2) $4 } | 'table' Exp6 '[' ListExp ']' { V $2 $4 } | Exp3 '*' Exp4 { case $1 of - RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),$3)]) - t -> RecType [(tupleLabel 1,$1), (tupleLabel 2,$3)] } + RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),[],$3)]) + t -> RecType [(tupleLabel 1,[],$1), (tupleLabel 2,[],$3)] } | Exp3 '**' Exp4 { ExtR $1 $3 } | Exp4 { $1 } @@ -479,9 +483,9 @@ Exp5 Exp6 :: { Term } Exp6 - : Ident { Vr $1 } + : Ident { Vr $1 } | Sort { Sort $1 } - | String { K $1 } + | String { words2term (words $1) } | Integer { EInt $1 } | Double { EFloat $1 } | '?' { Meta 0 } @@ -531,7 +535,7 @@ Patt3 | '[' String ']' { PChars $2 } | '#' Ident { PMacro $2 } | '#' ModuleName '.' Ident { PM ($2,$4) } - | '_' { PW } + | '_' { PV identW } | Ident { PV $1 } | ModuleName '.' Ident { PP ($1,$3) [] } | Integer { PInt $1 } @@ -714,9 +718,11 @@ ERHS3 :: { ERHS } | '(' ERHS0 ')' { $2 } NLG :: { Map.Map Ident Info } - : ListNLGDef { Map.fromList $1 } - | Posn Exp Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) } - | Posn ListMarkup2 Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 (mkMarkup $2)))) } + : ListNLGDef { Map.fromList $1 } + | Posn Exp Posn { Map.singleton (identS "main") (ResOper Nothing (Just (mkL $1 $3 $2))) } + | ListMarkup2 { case (head $1,last $1) of + (L (Local l1 _) _, L (Local _ l2) _) -> Map.singleton (identS "main") (ResOper Nothing (Just (L (Local l1 l2) (mkMarkup $1)))) + } ListNLGDef :: { [(Ident,Info)] } ListNLGDef @@ -730,10 +736,10 @@ NLGDef | Posn LhsName ListArg '=' ListMarkup2 Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing (Just (mkL $1 $6 (mkAbs $3 (mkMarkup $5))))] } | Posn LhsNames ':' Exp '=' ListMarkup2 Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 (mkMarkup $6)))] } -Markup :: { Term } +Markup :: { L Term } Markup - : Tag { $1 } - | Exp ';' { $1 } + : Posn Tag Posn { mkL $1 $3 $2 } + | Posn Exp Posn ';' { mkL $1 $3 $2 } Tag :: { Term } Tag @@ -742,12 +748,12 @@ Tag else fail ("Unmatched closing tag " ++ showIdent $1) } | '' { Markup $1 $2 [] } -ListMarkup :: { [Term] } +ListMarkup :: { [L Term] } : { [] } - | Exp { [$1] } + | Posn Exp Posn { [mkL $1 $3 $2] } | Markup ListMarkup { $1 : $2 } -ListMarkup2 :: { [Term] } +ListMarkup2 :: { [L Term] } : Markup { [$1] } | Markup ListMarkup2 { $1 : $2 } @@ -790,8 +796,8 @@ listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund] consId = mkConsId id catd = (listId, AbsCat (Just (L loc cont'))) - nilfund = (baseId, AbsFun (Just (L loc niltyp)) Nothing Nothing (Just True)) - consfund = (consId, AbsFun (Just (L loc constyp)) Nothing Nothing (Just True)) + nilfund = (baseId, AbsFun (Just (L loc niltyp)) Nothing) + consfund = (consId, AbsFun (Just (L loc constyp)) Nothing) cont' = [(b,mkId x i,ty) | (i,(b,x,ty)) <- zip [0..] cont] xs = map (\(b,x,t) -> Vr x) cont' @@ -803,20 +809,23 @@ listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund] mkId x i = if x == identW then (varX i) else x -tryLoc (c,mty,Just e) = return (c,(mty,e)) -tryLoc (c,_ ,_ ) = fail ("local definition of" +++ showIdent c +++ "without value") +tryLoc (c,False,mty,Just e) = return (c,(mty,e)) +tryLoc (c,True ,_ ,_ ) = fail ("Scoped record label " +++ showIdent c +++ "outside of a record") +tryLoc (c,_ ,_ ,_ ) = fail ("local definition of" +++ showIdent c +++ "without value") mkR [] = return $ RecType [] --- empty record always interpreted as record type mkR fs@(f:_) = case f of - (lab,Just ty,Nothing) -> mapM tryRT fs >>= return . RecType - _ -> mapM tryR fs >>= return . R + (lab,_,Just ty,Nothing) -> tryRT [] fs >>= return . RecType + _ -> mapM tryR fs >>= return . R where - tryRT (lab,Just ty,Nothing) = return (ident2label lab,ty) - tryRT (lab,_ ,_ ) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?! + tryRT deps [] = return [] + tryRT deps ((lab,scoped,Just ty,Nothing):fs) = do fs <- tryRT (if scoped then lab:deps else deps) fs + return ((ident2label lab,deps,ty):fs) + tryRT deps ((lab,_ ,_ ,_ ):fs) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?! - tryR (lab,mty,Just t) = return (ident2label lab,(mty,t)) - tryR (lab,_ ,_ ) = fail $ "illegal record field" +++ showIdent lab + tryR (lab,False,mty,Just t) = return (ident2label lab,(mty,t)) + tryR (lab,_ ,_ ,_ ) = fail $ "illegal record field" +++ showIdent lab mkOverload pdt pdf@(Just (L loc df)) = case appForm df of @@ -844,12 +853,12 @@ isOverloading t = checkInfoType mt jment@(id,info) = case info of AbsCat pcont -> ifAbstract mt (locPerh pcont) - AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde) + AbsFun pty pde -> ifAbstract mt (locPerh pty ++ maybe [] (locAll.snd) pde) CncCat pty pd pr ppn _->ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh pr ++ locPerh ppn) CncFun _ pd ppn _ -> ifConcrete mt (locPerh pd ++ locPerh ppn) ResParam pparam _ -> ifResource mt (locPerh pparam) ResValue ty _ -> ifResource mt (locL ty) - ResOper pty pt -> ifOper mt pty pt + ResOper pty pt -> ifResource mt (locPerh pty ++ locPerh pt) ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs]) where locPerh = maybe [] locL @@ -870,9 +879,6 @@ checkInfoType mt jment@(id,info) = ifResource MTInterface locs = return jment ifResource MTResource locs = return jment ifResource _ locs = illegal locs - - ifOper MTAbstract pty pt = return (id,AbsFun pty (fmap (const 0) pt) (Just (maybe [] (\(L l t) -> [L l ([],t)]) pt)) (Just False)) - ifOper _ pty pt = return jment mkAlts cs = case cs of _:_ -> do @@ -889,7 +895,11 @@ mkAlts cs = case cs of mkL :: Posn -> Posn -> x -> L x mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x -mkMarkup [t] = t +mkMarkup [t] = unLoc t mkMarkup ts = Markup identW [] ts +words2term [] = Empty +words2term [w] = K w +words2term (w:ws) = C (K w) (words2term ws) + } diff --git a/src/compiler/api/GF/Grammar/Predef.hs b/src/compiler/api/GF/Grammar/Predef.hs index f807d762a..90062c27a 100644 --- a/src/compiler/api/GF/Grammar/Predef.hs +++ b/src/compiler/api/GF/Grammar/Predef.hs @@ -25,6 +25,7 @@ cFloat = identS "Float" cString = identS "String" cInts = identS "Ints" cPBool = identS "PBool" +cBool = identS "Bool" cErrorType = identS "Error" cOverload = identS "overload" cNonExist = identS "nonExist" @@ -40,6 +41,8 @@ isPredefCat c = elem c [cInt,cString,cFloat] cPTrue = identS "PTrue" cPFalse = identS "PFalse" +cTrue = identS "True" +cFalse = identS "False" cLength = identS "length" cDrop = identS "drop" cTake = identS "take" @@ -66,23 +69,11 @@ cConcat = identS "concat" cConcat' = identS "concat'" cOne = identS "one" cSelect = identS "select" +cFilter = identS "filter" cDefault = identS "default" cList = identS "list" cLen = identS "len" +cConst = identS "const" cp1 = identS "p1" cp2 = identS "p2" - --- * Hacks: dummy identifiers used in various places. --- Not very nice! - -cMeta = identS "?" -cAs = identS "@" -cChar = identS "?" -cChars = identS "[]" -cSeq = identS "+" -cAlt = identS "|" -cRep = identS "*" -cNeg = identS "-" -cCNC = identS "CNC" -cConflict = identS "#conflict" diff --git a/src/compiler/api/GF/Grammar/Printer.hs b/src/compiler/api/GF/Grammar/Printer.hs index 9a6283e49..88754abd0 100644 --- a/src/compiler/api/GF/Grammar/Printer.hs +++ b/src/compiler/api/GF/Grammar/Printer.hs @@ -16,26 +16,23 @@ module GF.Grammar.Printer , ppParams , ppTerm , ppPatt - , ppValue , ppBind - , ppConstrs , ppQIdent , ppMeta + , ppLVar , getAbs ) where import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import PGF2(Literal(..),pgfFilePath) -import PGF2.Transactions(SeqId) import GF.Infra.Ident import GF.Infra.Option -import GF.Grammar.Values import GF.Grammar.Predef import GF.Grammar.Grammar import GF.Text.Pretty import Data.Maybe (isNothing) -import Data.List (intersperse) +import Data.List (intersperse, nub) import Data.Foldable (toList) import qualified Data.Map as Map import qualified Data.Sequence as Seq @@ -49,11 +46,10 @@ instance Pretty Grammar where pp = vcat . map (ppModule Qualified) . modules ppModule :: TermPrintQual -> SourceModule -> Doc -ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) = +ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) = hdr $$ nest 2 (ppOptions opts $$ - vcat (map (ppJudgement q) (Map.toList jments)) $$ - maybe empty (ppSequences q) mseqs) $$ + vcat (map (ppJudgement q) (Map.toList jments))) $$ ftr where hdr = complModDoc <+> modTypeDoc <+> '=' <+> @@ -92,22 +88,21 @@ ppOptions opts = "flags" $$ nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts]) -ppJudgement q (id, AbsCat pcont ) = +ppJudgement q (id, AbsCat pcont) = "cat" <+> id <+> (case pcont of Just (L _ cont) -> hsep (map (ppDecl q) cont) Nothing -> empty) <+> ';' -ppJudgement q (id, AbsFun ptype _ pexp poper) = +ppJudgement q (id, AbsFun ptype pexp) = let kind | isNothing pexp = "data" - | poper == Just False = "oper" | otherwise = "fun" in (case ptype of Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';' Nothing -> empty) $$ (case pexp of - Just [] -> empty - Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs] + Just (_,[]) -> empty + Just (_,eqs) -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs] Nothing -> empty) ppJudgement q (id, ResParam pparams _) = "param" <+> id <+> @@ -142,9 +137,9 @@ ppJudgement q (id, CncCat mtyp pdef pref pprn mpmcfg) = Nothing -> empty) $$ (case (mtyp,mpmcfg,q) of (Just (L _ typ),Just (lindefs,linrefs),Internal) - -> "pmcfg" <+> '{' $$ - nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs) $$ - vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$ + -> "rules" <+> '{' $$ + nest 2 (vcat (map (ppPmcfgRule (identS "lindef") [cString] id) lindefs)) $$ + nest 2 (vcat (map (ppPmcfgRule (identS "linref") [id] cString) linrefs)) $$ '}' _ -> empty) ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) = @@ -157,7 +152,7 @@ ppJudgement q (id, CncFun mtyp pdef pprn mpmcfg) = Nothing -> empty) $$ (case (mtyp,mpmcfg,q) of (Just (args,res,_,_),Just rules,Internal) - -> "pmcfg" <+> '{' $$ + -> "rules" <+> '{' $$ nest 2 (vcat (map (ppPmcfgRule id args res) rules)) $$ '}' _ -> empty) @@ -166,20 +161,22 @@ ppJudgement q (id, AnyInd cann mid) = Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';' _ -> empty -ppPmcfgRule id arg_cats res_cat (Production vars args res seqids) = - pp id <+> (':' <+> - (if null vars - then empty - else "∀{" <> hsep (punctuate ',' [ppLVar v <> '<' <> m | (v,m) <- vars]) <> '}' <+> '.') <+> - ppPmcfgCat res_cat res <+> "->" <+> - brackets (hcat (intersperse (pp ',') (zipWith ppPArg arg_cats args))) <+> '=' <+> - brackets (hcat (intersperse (pp ',') (map ppSeqId seqids)))) - ppPArg cat (PArg _ p) = ppPmcfgCat cat p ppPmcfgCat :: Ident -> LParam -> Doc ppPmcfgCat cat p = pp cat <> parens (ppLParam p) +ppPmcfgRule id arg_cats res_cat (Rule quantifiers res args lin_idx seq) = + ppQuantifiers (zip [0..] quantifiers) <+> + ppCat res_cat res <+> "->" <+> pp id <> brackets (hcat (punctuate ',' (zipWith ppCat arg_cats args))) <> ';' <+> ppLParam lin_idx <+> ':' <+> hsep (map ppSymbol seq) + where + ppCat id value = pp id <> parens (ppLParam value) + + ppQuantifiers [] = empty + ppQuantifiers qs = pp '{' <> hsep (punctuate (pp ',') (map ppQuantifier qs)) <> pp '}' + + ppQuantifier (var,range) = ppLVar var <> pp '<' <> pp (range::Int) + instance Pretty Term where pp = ppTerm Unqualified 0 ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e) @@ -244,12 +241,13 @@ ppTerm q d (R xs) = braces (fsep (punctuate ';' [l <+> fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty}, '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs])) ppTerm q d (RecType xs) - | q == Terse = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of + | q == Terse = case [cat | (l,_,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of [cat] -> pp cat _ -> doc | otherwise = doc where - doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs])) + deps = nub [ident2label dep | (_,deps,_) <- xs, dep <- deps] + doc = braces (fsep (punctuate ';' [(if l `elem` deps then pp '$' else empty) <> l <+> ':' <+> ppTerm q 0 t | (l,bound,t) <- xs])) ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>' ppTerm q d (ImplArg e) = braces (ppTerm q 0 e) ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t) @@ -294,7 +292,6 @@ ppPatt q d (PChar) = pp '?' ppPatt q d (PChars s) = brackets (str s) ppPatt q d (PMacro id) = '#' <> id ppPatt q d (PM id) = '#' <> ppQIdent q id -ppPatt q d PW = pp '_' ppPatt q d (PV id) = pp id ppPatt q d (PInt n) = pp n ppPatt q d (PFloat f) = pp f @@ -303,22 +300,6 @@ ppPatt q d (PR xs) = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 ppPatt q d (PImplArg p) = braces (ppPatt q 0 p) ppPatt q d (PTilde t) = prec d 2 ('~' <> ppTerm q 6 t) -ppValue :: TermPrintQual -> Int -> Val -> Doc -ppValue q d (VGen i x) = x <> "{-" <> i <> "-}" ---- latter part for debugging -ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v) -ppValue q d (VCn (_,c)) = pp c -ppValue q d (VClos env e) = case e of - Meta _ -> ppTerm q d e <> ppEnv env - _ -> ppTerm q d e ---- ++ prEnv env ---- for debugging -ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs])) -ppValue q d VType = pp "Type" - -ppConstrs :: Constraints -> [Doc] -ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w)) - -ppEnv :: Env -> Doc -ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e) - str s = doubleQuotes (pp (foldr showLitChar "" s)) where showLitChar c @@ -326,13 +307,9 @@ str s = doubleQuotes (pp (foldr showLitChar "" s)) | c > '\DEL' = showChar c | otherwise = GHC.Show.showLitChar c -ppDecl q (_,id,typ) - | id == identW = ppTerm q 3 typ - | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ) - -ppDDecl q (_,id,typ) - | id == identW = ppTerm q 6 typ - | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ) +ppDecl q (bt,id,typ) + | id == identW = ppTerm q 5 typ + | otherwise = parens (ppBind (bt,id) <+> ':' <+> ppTerm q 0 typ) ppQIdent :: TermPrintQual -> QIdent -> Doc ppQIdent q (m,id) = @@ -360,30 +337,18 @@ ppBind (Implicit,v) = braces v ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps)) -ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt) +ppParam q (id,cxt) = id <+> hsep (map (ppDecl q) cxt) ppMarkupAttr q (id,e) = id <> pp '=' <> ppTerm q 5 e -ppMarkupChildren q [t] = ppTerm q 0 t -ppMarkupChildren q (t:ts) = +ppMarkupChildren q [L _ t] = ppTerm q 0 t +ppMarkupChildren q (L _ t:ts) = (case t of Markup {} -> ppTerm q 0 t _ -> ppTerm q 0 t <> ';') $$ ppMarkupChildren q ts -ppSeqId :: SeqId -> Doc -ppSeqId seqid = 'S' <> pp seqid - -ppSequences q seqs - | Seq.null seqs || q /= Internal = empty - | otherwise = "sequences" <+> '{' $$ - nest 2 (vcat (zipWith ppSeq [0..] (toList seqs))) $$ - '}' - where - ppSeq seqid seq = - ppSeqId seqid <+> ":=" <+> hsep (map ppSymbol seq) - commaPunct f ds = (hcat (punctuate "," (map f ds))) prec d1 d2 doc @@ -398,8 +363,6 @@ getAbs e = ([],e) getCTable :: Term -> ([Ident], Term) getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e in (v:vs,e') -getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e - in (identW:vs,e') getCTable e = ([],e) getLet :: Term -> ([LocalDef], Term) diff --git a/src/compiler/api/GF/Grammar/Unify.hs b/src/compiler/api/GF/Grammar/Unify.hs deleted file mode 100644 index 3a7f0edef..000000000 --- a/src/compiler/api/GF/Grammar/Unify.hs +++ /dev/null @@ -1,115 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Unify --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:31 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- (c) Petri Mäenpää & Aarne Ranta, 1998--2001 --- --- brute-force adaptation of the old-GF program AR 21\/12\/2001 --- --- the only use is in 'TypeCheck.splitConstraints' ------------------------------------------------------------------------------ - -module GF.Grammar.Unify (unifyVal) where - -import GF.Grammar -import GF.Data.Operations - -import GF.Text.Pretty -import Data.List (partition) - -unifyVal :: Constraints -> Err (Constraints,MetaSubst) -unifyVal cs0 = do - let (cs1,cs2) = partition notSolvable cs0 - let (us,vs) = unzip cs2 - let us' = map val2term us - let vs' = map val2term vs - let (ms,cs) = unifyAll (zip us' vs') [] - return (cs1 ++ [(VClos [] t, VClos [] u) | (t,u) <- cs], - [(m, VClos [] t) | (m,t) <- ms]) - where - notSolvable (v,w) = case (v,w) of -- don't consider nonempty closures - (VClos (_:_) _,_) -> True - (_,VClos (_:_) _) -> True - _ -> False - -type Unifier = [(MetaId, Term)] -type Constrs = [(Term, Term)] - -unifyAll :: Constrs -> Unifier -> (Unifier,Constrs) -unifyAll [] g = (g, []) -unifyAll ((a@(s, t)) : l) g = - let (g1, c) = unifyAll l g - in case unify s t g1 of - Ok g2 -> (g2, c) - _ -> (g1, a : c) - -unify :: Term -> Term -> Unifier -> Err Unifier -unify e1 e2 g = - case (e1, e2) of - (Meta s, t) -> do - tg <- subst_all g t - let sg = maybe e1 id (lookup s g) - if (sg == Meta s) then extend g s tg else unify sg tg g - (t, Meta s) -> unify e2 e1 g - (Q (_,a), Q (_,b)) | (a == b) -> return g ---- qualif? - (QC (_,a), QC (_,b)) | (a == b)-> return g ---- - (Vr x, Vr y) | (x == y) -> return g - (Abs _ x b, Abs _ y c) -> do let c' = substTerm [x] [(y,Vr x)] c - unify b c' g - (App c a, App d b) -> case unify c d g of - Ok g1 -> unify a b g1 - _ -> Bad (render ("fail unify" <+> ppTerm Unqualified 0 e1)) - (RecType xs,RecType ys) | xs == ys -> return g - _ -> Bad (render ("fail unify" <+> ppTerm Unqualified 0 e1)) - -extend :: Unifier -> MetaId -> Term -> Err Unifier -extend g s t | (t == Meta s) = return g - | occCheck s t = Bad (render ("occurs check" <+> ppTerm Unqualified 0 t)) - | True = return ((s, t) : g) - -subst_all :: Unifier -> Term -> Err Term -subst_all s u = - case (s,u) of - ([], t) -> return t - (a : l, t) -> do - t' <- (subst_all l t) --- successive substs - why ? - return $ substMetas [a] t' - -substMetas :: [(MetaId,Term)] -> Term -> Term -substMetas subst trm = case trm of - Meta x -> case lookup x subst of - Just t -> t - _ -> trm - _ -> composSafeOp (substMetas subst) trm - -substTerm :: [Ident] -> Substitution -> Term -> Term -substTerm ss g c = case c of - Vr x -> maybe c id $ lookup x g - App f a -> App (substTerm ss g f) (substTerm ss g a) - Abs b x t -> let y = mkFreshVarX ss x in - Abs b y (substTerm (y:ss) ((x, Vr y):g) t) - Prod b x a t -> let y = mkFreshVarX ss x in - Prod b y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) t) - _ -> c - -occCheck :: MetaId -> Term -> Bool -occCheck s u = case u of - Meta v -> s == v - App c a -> occCheck s c || occCheck s a - Abs _ x b -> occCheck s b - _ -> False - -val2term :: Val -> Term -val2term v = case v of - VClos g e -> substTerm [] (map (\(x,v) -> (x,val2term v)) g) e - VApp f c -> App (val2term f) (val2term c) - VCn c -> Q c - VGen i x -> Vr x - VRecType xs -> RecType (map (\(l,v) -> (l,val2term v)) xs) - VType -> typeType diff --git a/src/compiler/api/GF/Grammar/Values.hs b/src/compiler/api/GF/Grammar/Values.hs deleted file mode 100644 index c8fcb3945..000000000 --- a/src/compiler/api/GF/Grammar/Values.hs +++ /dev/null @@ -1,57 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Values --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:32 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Grammar.Values ( - -- ** Values used in TC type checking - Val(..), Env, - -- ** Annotated tree used in editing - Binds, Constraints, MetaSubst, - -- ** For TC - valAbsInt, valAbsFloat, valAbsString, vType, - isPredefCat, - eType, - ) where - -import GF.Infra.Ident -import GF.Grammar.Grammar -import GF.Grammar.Predef - --- values used in TC type checking - -data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VRecType [(Label,Val)] | VType | VClos Env Term - deriving (Eq,Show) - -type Env = [(Ident,Val)] - -type Binds = [(Ident,Val)] -type Constraints = [(Val,Val)] -type MetaSubst = [(MetaId,Val)] - - --- for TC - -valAbsInt :: Val -valAbsInt = VCn (cPredefAbs, cInt) - -valAbsFloat :: Val -valAbsFloat = VCn (cPredefAbs, cFloat) - -valAbsString :: Val -valAbsString = VCn (cPredefAbs, cString) - -vType :: Val -vType = VType - -eType :: Term -eType = Sort cType diff --git a/src/compiler/api/GF/Infra/Ident.hs b/src/compiler/api/GF/Infra/Ident.hs index e202512f4..86f64b6b6 100644 --- a/src/compiler/api/GF/Infra/Ident.hs +++ b/src/compiler/api/GF/Infra/Ident.hs @@ -26,10 +26,10 @@ module GF.Infra.Ident (-- ** Identifiers ) where import qualified Data.ByteString.UTF8 as UTF8 -import qualified Data.ByteString.Char8 as BS(append,isPrefixOf) +import qualified Data.ByteString.Char8 as BS(append,isPrefixOf,drop,length) -- Limit use of BS functions to the ones that work correctly on -- UTF-8-encoded bytestrings! -import Data.Char(isDigit) +import Data.Char(chr) import Data.Binary(Binary(..)) import Text.JSON hiding (Result(..)) import GF.Text.Pretty @@ -75,7 +75,9 @@ rawIdentC = Id showRawIdent = unpack . rawId2utf8 prefixRawIdent (Id x) (Id y) = Id (BS.append x y) -isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y +isPrefixOf (Id x) (Id y) + | BS.isPrefixOf x y = Just (Id (BS.drop (BS.length x) y)) + | otherwise = Nothing instance Binary Ident where put id = put (ident2utf8 id) @@ -102,7 +104,26 @@ ident2raw = Id . ident2utf8 showIdent :: Ident -> String showIdent i = unpack $! ident2utf8 i -instance Pretty Ident where pp = pp . showIdent +instance Pretty Ident where + pp id + | valid_ident s = pp s + | otherwise = pp (escape s) + where + s = showIdent id + + valid_ident s = + case s of + [] -> False + (c:cs) -> elem c ident_first && all (flip elem ident_rest) cs + where + l = ['a'..'z']++['A'..'Z']++[chr 192..chr 214]++[chr 216..chr 246]++[chr 248..chr 255] + ident_first = '_':l + ident_rest = ident_first ++ ['0'..'9'] ++ ['\''] + + escape s = "\'"++concatMap slash s++"\'" + where + slash '\'' = "\\'" + slash c = [c] instance Pretty RawIdent where pp = pp . showRawIdent diff --git a/src/compiler/api/GF/Infra/Location.hs b/src/compiler/api/GF/Infra/Location.hs index 1d9a41ab6..d153d651f 100644 --- a/src/compiler/api/GF/Infra/Location.hs +++ b/src/compiler/api/GF/Infra/Location.hs @@ -14,10 +14,14 @@ data Location deriving (Show,Eq,Ord) -- | Attaching location information -data L a = L Location a deriving Show +data L a = L Location a deriving (Show, Eq, Ord) instance Functor L where fmap f (L loc x) = L loc (f x) +instance Foldable L where foldr f b (L loc x) = f x b + +instance Traversable L where traverse f (L loc x) = pure (L loc) <*> f x + unLoc :: L a -> a unLoc (L _ x) = x diff --git a/src/compiler/api/GF/Infra/Option.hs b/src/compiler/api/GF/Infra/Option.hs index 0f902f723..992c9596d 100644 --- a/src/compiler/api/GF/Infra/Option.hs +++ b/src/compiler/api/GF/Infra/Option.hs @@ -107,7 +107,6 @@ data OutputFormat = FmtPGFPretty | FmtSLF | FmtRegExp | FmtFA - | FmtLR deriving (Eq,Ord) data SISRFormat = @@ -492,8 +491,7 @@ outputFormatsExpl = (("vxml", FmtVoiceXML),"Voice XML based on abstract syntax"), (("slf", FmtSLF),"SLF speech recognition format"), (("regexp", FmtRegExp),"regular expression"), - (("fa", FmtFA),"finite automaton in graphviz format"), - (("lr", FmtLR),"LR(0) automaton for PMCFG in graphviz format") + (("fa", FmtFA),"finite automaton in graphviz format") ] instance Show OutputFormat where diff --git a/src/compiler/api/GF/Interactive.hs b/src/compiler/api/GF/Interactive.hs index 895229d94..18071b16a 100644 --- a/src/compiler/api/GF/Interactive.hs +++ b/src/compiler/api/GF/Interactive.hs @@ -13,9 +13,8 @@ import GF.Command.Help(helpCommand) import GF.Command.Abstract import GF.Command.Parse(readCommandLine,pCommand,readTransactionCommand) import GF.Compile.Rename(renameSourceTerm) -import GF.Compile.TypeCheck.Concrete(inferLType) -import qualified GF.Compile.Compute.Concrete as O(normalForm,stdPredef,Globals(..)) -import GF.Compile.Compute.Concrete2(stdPredef,Globals(..)) +import GF.Compile.TypeCheck(inferLType) +import GF.Compile.Compute(stdPredef,normalForm,Globals(..)) import GF.Compile.GeneratePMCFG(pmcfgForm,type2fields) import GF.Data.Operations (Err(..)) import GF.Data.Utilities(whenM,repeatM) @@ -301,9 +300,9 @@ transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do mb_fields <- getCategoryFields cat case mb_fields of Just fields -> case runCheck (compileLinTerm sgr mo f mb_t (type2term mo ty)) of - Ok ((prods,seqtbl,fields'),_) + Ok ((rules,fields'),_) | fields == fields' -> do - (if is_alter then alterLin else createLin) f prods seqtbl + (if is_alter then alterLin else createLin) f rules return () | otherwise -> fail "The linearization categories in the resource and the compiled grammar does not match" Bad msg -> fail msg @@ -316,21 +315,20 @@ transactionCommand (CreateLin opts f mb_t is_alter) pgf mb_txnid = do hypos compileLinTerm sgr mo f mb_t ty = do + let g = Gl sgr (stdPredef g) False (t,ty) <- case mb_t of Just t -> do t <- renameSourceTerm sgr mo (Typed t ty) - let g = Gl sgr (stdPredef g) + (t,ty) <- inferLType g t return (t,ty) Nothing -> case lookupResDef sgr (mo,identS f) of Ok t -> do ty <- renameSourceTerm sgr mo ty - ty <- O.normalForm (O.Gl sgr O.stdPredef) ty + ty <- normalForm g ty return (t,ty) Bad msg -> fail msg let (ctxt,res_ty) = typeFormCnc ty - (prods,seqs) <- pmcfgForm sgr t ctxt res_ty Map.empty - return (prods,mapToSequence seqs,type2fields sgr res_ty) - where - mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m))) + rules <- pmcfgForm g t ctxt res_ty + return (rules,type2fields sgr res_ty) transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do sgr <- getGrammar @@ -339,14 +337,14 @@ transactionCommand (CreateLincat opts c mb_t) pgf mb_txnid = do Just mo -> return mo lang <- optLang pgf opts case runCheck (compileLincatTerm sgr mo mb_t) of - Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ())) + Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] >> return ())) return () Bad msg -> fail msg where compileLincatTerm sgr mo mb_t = do t <- case mb_t of Just t -> do t <- renameSourceTerm sgr mo t - let g = Gl sgr (stdPredef g) + let g = Gl sgr (stdPredef g) False (t,_) <- inferLType g t return t Nothing -> case lookupResDef sgr (mo,identS c) of diff --git a/src/compiler/api/GF/Server/PGFService.hs b/src/compiler/api/GF/Server/PGFService.hs index 9fe00963c..80ef0dc34 100644 --- a/src/compiler/api/GF/Server/PGFService.hs +++ b/src/compiler/api/GF/Server/PGFService.hs @@ -144,7 +144,7 @@ pgfCommand qsem command q (t,pgf) = -- Without caching parse results: parse' cat start mlimit ((from,concr),input) = - case PGF2.parse concr cat (init input) of + case PGF2.parse concr cat input of ParseOk ts -> return (Right (maybe id take mlimit (drop start ts))) ParseFailed _ tok -> return (Left tok) ParseIncomplete -> return (Left "") diff --git a/src/compiler/api/GF/Server/SimpleEditor/Convert.hs b/src/compiler/api/GF/Server/SimpleEditor/Convert.hs index 04b8f8876..48e40edd7 100644 --- a/src/compiler/api/GF/Server/SimpleEditor/Convert.hs +++ b/src/compiler/api/GF/Server/SimpleEditor/Convert.hs @@ -70,7 +70,7 @@ convAbsJment (cats,funs) (name,jment) = fail "category with context" let cat = convId name return (cat:cats,funs) - AbsFun (Just lt) _ oeqns _ -> do unless (null (maybe [] id oeqns)) $ + AbsFun (Just lt) oeqns -> do unless (null (maybe [] snd oeqns)) $ fail "function with equations" let f = convId name typ <- convType (unLoc lt) @@ -150,7 +150,7 @@ jmentList = sortBy (compare `on` (jmentLocation.snd)) . Map.toList jmentLocation jment = case jment of AbsCat ctxt -> fmap loc ctxt - AbsFun ty _ _ _ -> fmap loc ty + AbsFun ty _ -> fmap loc ty ResParam ops _ -> fmap loc ops CncCat ty _ _ _ _ ->fmap loc ty ResOper ty rhs -> fmap loc rhs `mplus` fmap loc ty diff --git a/src/compiler/api/GF/Speech/CFGToFA.hs b/src/compiler/api/GF/Speech/CFGToFA.hs index 08b966354..a905c0c48 100644 --- a/src/compiler/api/GF/Speech/CFGToFA.hs +++ b/src/compiler/api/GF/Speech/CFGToFA.hs @@ -20,7 +20,6 @@ import GF.Grammar.CFG --import GF.Infra.Ident (Ident) import GF.Data.Graph ---import GF.Data.Relation import GF.Speech.FiniteState --import GF.Speech.CFG diff --git a/src/compiler/api/GF/Term.hs b/src/compiler/api/GF/Term.hs deleted file mode 100644 index 0b2bd2626..000000000 --- a/src/compiler/api/GF/Term.hs +++ /dev/null @@ -1,12 +0,0 @@ -module GF.Term (renameSourceTerm, - Globals(..), ConstValue(..), EvalM, stdPredef, - Value(..), showValue, Thunk, newThunk, newEvaluatedThunk, - evalError, evalWarn, - inferLType, inferLType', checkLType, checkLType', - normalForm, normalFlatForm, normalStringForm, - unsafeIOToEvalM, force - ) where - -import GF.Compile.Rename -import GF.Compile.Compute.Concrete -import GF.Compile.TypeCheck.Concrete diff --git a/src/compiler/gf.cabal b/src/compiler/gf.cabal index e79a7fdad..db3e9c6ae 100644 --- a/src/compiler/gf.cabal +++ b/src/compiler/gf.cabal @@ -76,7 +76,6 @@ library GF.Interactive GF.Compiler GF.Grammar - GF.Term GF.Compile GF.CompileInParallel GF.Data.ErrM @@ -105,8 +104,7 @@ library GF.Command.TreeOperations GF.Compile.CFGtoPGF GF.Compile.CheckGrammar - GF.Compile.Compute.Concrete - GF.Compile.Compute.Concrete2 + GF.Compile.Compute GF.Compile.ExampleBased GF.Compile.Export GF.Compile.GenerateBC @@ -124,9 +122,8 @@ library GF.Compile.SubExOpt GF.Compile.Tags GF.Compile.ToAPI - GF.Compile.TypeCheck.Abstract - GF.Compile.TypeCheck.Concrete - GF.Compile.TypeCheck.TC + GF.Compile.TypeCheck + GF.Compile.TerminationCheck GF.Compile.Update GF.Data.BacktrackM GF.Data.Graph @@ -149,8 +146,6 @@ library GF.Grammar.Predef GF.Grammar.Printer GF.Grammar.ShowTerm - GF.Grammar.Unify - GF.Grammar.Values GF.Grammar.JSON GF.Infra.Concurrency GF.Infra.Dependencies diff --git a/src/compiler/www/gfse/editor.js b/src/compiler/www/gfse/editor.js index 8284096d1..8c20c94fd 100644 --- a/src/compiler/www/gfse/editor.js +++ b/src/compiler/www/gfse/editor.js @@ -1172,12 +1172,10 @@ function add_open(g,ci) { var b=common_modules[i]; add_module(b,b) } - if (gfwordnet.languages.indexOf("Parse"+conc.langcode) >= 0) { - for(var i in wordnet_modules) { - var b=wordnet_modules[i]; - add_module(b,b+conc.langcode) - } - } + for(var i in wordnet_modules) { + var b=wordnet_modules[i]; + add_module(b,b+conc.langcode) + } if(list.length>0) { var file=element("file"); clear(file) @@ -1477,9 +1475,6 @@ function wordnet_search(g,input) { langs: {}, langs_list: [] }; - if (gfwordnet.languages.indexOf(selection.current) < 0) { - return; - } var start = input.selectionStart; var end = input.selectionEnd; if (start == end) { @@ -1517,11 +1512,9 @@ function wordnet_search(g,input) { for (var i=0; i < g.concretes.length; i++) { var code = g.concretes[i].langcode; var name = "Parse"+code; - if (gfwordnet.languages.indexOf(name) >= 0) { - selection.langs[name] = {name: langname[code], index: index}; - selection.langs_list.push(name); - index++; - } + selection.langs[name] = {name: langname[code], index: index}; + selection.langs_list.push(name); + index++; } selection.isEqual = function(other) { if (other.langs_list.length != this.langs_list.length) diff --git a/src/compiler/www/js/gftranslate.js b/src/compiler/www/js/gftranslate.js index dc280f6eb..03b063782 100644 --- a/src/compiler/www/js/gftranslate.js +++ b/src/compiler/www/js/gftranslate.js @@ -7,8 +7,9 @@ gftranslate.jsonurl="/robust/Parse.ngf" gftranslate.grammar="Parse" // the name of the grammar gftranslate.documented_classes= - ["N", "N2", "N3", "A", "A2", "V", "V2", "VV", "VS", "VQ", "VA", "V3", "V2V", - "V2S", "V2Q", "V2A", "Adv", "Prep"] + ["N", "N2", "N3", "PN", "LN", "GN", "SN", "A", "A2", + "V", "V2", "VV", "VS", "VQ", "VA", "V3", "V2V", + "V2S", "V2Q", "V2A", "Adv", "AdV", "AdA", "AdN", "Prep"] gftranslate.call=function(querystring,cont,errcont) { http_get_json(gftranslate.jsonurl+querystring,cont,errcont) @@ -99,7 +100,7 @@ gftranslate.get_languages=function(cont,errcont) { else { gftranslate.waiting.push({cont:cont,errcont:errcont}) if(gftranslate.waiting.length<2) - gftranslate.call("?command=grammar",init2,init2error) + gftranslate.call("",init2,init2error) } } diff --git a/src/compiler/www/js/langcode.js b/src/compiler/www/js/langcode.js index 7907d3ce6..68477c0b4 100644 --- a/src/compiler/www/js/langcode.js +++ b/src/compiler/www/js/langcode.js @@ -16,16 +16,21 @@ var languages = } var ls // [ISO-639-2 code "/"] language name ":" ISO 639-1 code - ls=["Afrikaans:af","Amharic:am","Arabic:ar","Bulgarian:bg","Catalan:ca", - "Chinese:zh","Czech:cs","Danish:da","Dutch:nl","English:en", - "Estonian:et","Finnish:fi","French:fr","German:de","Greek:el", - "Hebrew:he","Hindi:hi","Ina/Interlingua:ia", - "Icelandic:is","Gle/Irish:ga","Italian:it","Jpn/Japanese:ja", - "Latin:la","Lav/Latvian:lv","Mlt/Maltese:mt","Mongolian:mn", - "Nepali:ne","Norwegian:nb","Pes/Persian:fa","Polish:pl", - "Portuguese:pt","Pnb/Punjabi:pa", - "Ron/Romanian:ro","Russian:ru","Snd/Sindhi:sd","Spanish:es", - "Swedish:sv","Thai:th","Turkish:tr","Urdu:ur"] + ls=["Afrikaans:af","Sqi/Albanian:sq","Amharic:am","Arabic:ar", + "Hye/Armenian:hy","Eus/Basque/eu","Bel/Belarusian:be","Bulgarian:bg", + "Catalan:ca","Chinese:zh","Czech:cs","Danish:da", + "Dutch:nl","English:en","Estonian:et","Fao/Faroese:fo", + "Finnish:fi","French:fr","Gla/Gaelic:gd","German:de", + "Greek:el","Hebrew:he","Hindi:hi","Hungarian:hu", + "Icelandic:is","Ina/Interlingua:ia","Gle/Irish:ga","Italian:it", + "Jpn/Japanese:ja","Kazakh:kk","Korean:ko","Latin:la", + "Lav/Latvian:lv","Mkd/Macedonian:mk","Mlt/Maltese:mt","Mongolian:mn", + "Nepali:ne","Norwegian Bokmål:nb","Nno/Norwegian Nynorsk:nn","Pes/Persian:fa", + "Polish:pl","Portuguese:pt","Pnb/Punjabi:pa","Ron/Romanian:ro", + "Russian:ru","Scots:sco","Slv/Slovenian:sl","Somali:so", + "Snd/Sindhi:sd","Spanish:es","Swahili:sw","Swedish:sv", + "Thai:th","Turkish:tr","Ukrainian:uk","Urdu:ur", + "Zulu:zu"] // GF uses nonstd 3-letter codes? Pes/Persian:fa, Pnb/Punjabi:pa return map(lang1,ls) }() diff --git a/src/compiler/www/js/wc.js b/src/compiler/www/js/wc.js index 2c938eedb..a35a54e74 100644 --- a/src/compiler/www/js/wc.js +++ b/src/compiler/www/js/wc.js @@ -2,8 +2,6 @@ /* --- Wide Coverage Translation Demo web app ------------------------------- */ var wc={} -wc.selected_cnls=[] // list of grammar names -wc.cnls={} // maps grammars names to {pgf_online:...,grammar_info:{...}} wc.f=document.forms[0] wc.o=element("output") wc.e=element("extra") @@ -44,7 +42,6 @@ wc.save=function() { wc.local.put("to",f.to.value) wc.local.put("input",f.input.value) wc.local.put("colors",f.colors.checked) - wc.local.put("cnls",wc.selected_cnls) } } @@ -55,7 +52,6 @@ wc.load=function() { f.from.value=wc.local.get("from",f.from.value) f.to.value=wc.local.get("to",f.to.value) f.colors.checked=wc.local.get("colors",f.colors.checked) - wc.selected_cnls=wc.local.get("cnls",wc.selected_cnls) wc.colors() wc.delayed_translate() } @@ -125,13 +121,19 @@ wc.translate=function(redo) { function show_inflections(lins) { if(wc.e2) wc.e2.innerHTML=lins[0].text } - function get_inflections() { - var tree="MkDocument+%22%22+(Inflection"+wcls+"+"+w+")+%22%22" + function get_inflections(glosses) { + if (glosses.length == 0) { + glosses = [""] + } + var tree="MkDocument+(NoDefinition+%22"+glosses[0]+"%22)+(Inflection"+wcls+"+"+w+")+%22%22" var l=gftranslate.grammar+f.to.value - gftranslate.call("?command=c-linearize&to="+l+"&tree="+tree,show_inflections) + gftranslate.call("?command=linearize&to="+l+"&tree="+tree,show_inflections) } + function get_gloss() { + ajax_http_post_querystring_json("https://cloud.grammaticalframework.org/wordnet/SenseService.fcgi","gloss_id="+w,get_inflections); + } var wn=wrap_class("span","inflect",text(w)) - if(wc.e2) wn.onclick=get_inflections + if(wc.e2) wn.onclick=get_gloss return wn } function word(w) { @@ -239,37 +241,7 @@ wc.translate=function(redo) { gftranslate.translate(text,f.from.value,wc.languages || f.to.value,i,count,step3) } function step2(text) { trans(text,0,10) } - function step2cnl(text,ix) { - function step3cnl(results) { - var trans=results[0].translations - if(trans && trans.length>=1) { - for(var i=0;i input { float: right; } Colors -
diff --git a/src/runtime/c/configure.ac b/src/runtime/c/configure.ac index c9a1a2f07..31eec4173 100644 --- a/src/runtime/c/configure.ac +++ b/src/runtime/c/configure.ac @@ -2,6 +2,7 @@ AC_INIT(Portable Grammar Format library, 3.0-pre, http://www.grammaticalframework.org/, libpgf) AC_PREREQ(2.58) +LT_INIT([]) AC_CONFIG_AUX_DIR([scripts]) AC_CONFIG_MACRO_DIR([m4]) diff --git a/src/runtime/c/pgf/compute.cxx b/src/runtime/c/pgf/compute.cxx new file mode 100644 index 000000000..4e03ead11 --- /dev/null +++ b/src/runtime/c/pgf/compute.cxx @@ -0,0 +1,142 @@ +#include "data.h" +#include "compute.h" + +PgfExpr PgfEvalExpr::eabs(PgfBindType bind_type, PgfText *name, PgfExpr body) +{ + if (stack != NULL) { + ExprNode *tmp; + tmp = stack->next; + stack->next = env; + env = stack; + stack = tmp; + return m->match_expr(this, body); + } else { + return 0; + } +} + +PgfExpr PgfEvalExpr::eapp(PgfExpr fun, PgfExpr arg) +{ + ExprNode node; + node.e = arg; + node.value = 0; + node.next = stack; + stack = &node; + PgfExpr e = m->match_expr(this, fun); + if (node.value != 0) { + //u->free_ref(node.value); + } + return e; +} + +PgfExpr PgfEvalExpr::elit(PgfLiteral lit) +{ + lit = m->match_lit(this, lit); + PgfExpr e = u->elit(lit); + u->free_ref(lit); + return e; +} + +PgfExpr PgfEvalExpr::emeta(PgfMetaId meta_id) +{ + return apply(u->emeta(meta_id)); +} + +PgfExpr PgfEvalExpr::efun(PgfText *name) +{ + return apply(u->efun(name)); +} + +PgfExpr PgfEvalExpr::evar(int index) +{ + ExprNode *node = env; + while (index > 0) { + if (node == NULL) { + err->type = PGF_EXN_PGF_ERROR; + err->msg = strdup("Unbounded variable"); + return 0; + } + node = node->next; + } + + if (node == NULL) { + err->type = PGF_EXN_PGF_ERROR; + err->msg = strdup("Unbounded variable"); + return 0; + } + return apply(force(node)); +} + +PgfExpr PgfEvalExpr::etyped(PgfExpr expr, PgfType ty) +{ + return m->match_expr(this, expr); +} + +PgfExpr PgfEvalExpr::eimplarg(PgfExpr expr) +{ + return m->match_expr(this, expr); +} + +PgfLiteral PgfEvalExpr::lint(size_t size, uintmax_t *val) +{ + return u->lint(size, val); +} + +PgfLiteral PgfEvalExpr::lflt(double val) +{ + return u->lflt(val); +} + +PgfLiteral PgfEvalExpr::lstr(PgfText *val) +{ + return u->lstr(val); +} + +PgfType PgfEvalExpr::dtyp(size_t n_hypos, PgfTypeHypo *hypos, + PgfText *name, + size_t n_exprs, PgfExpr *exprs) +{ + return 0; +} + +void PgfEvalExpr::free_ref(object x) +{ + return u->free_ref(x); +} + +PgfExpr PgfEvalExpr::force(ExprNode *node) +{ + if (node->value == 0) { + PgfEvalExpr eval(pgf,m,u,env,err); + node->value = m->match_expr(&eval, node->e); + } + return node->value; +} + +PgfExpr PgfEvalExpr::apply(PgfExpr e) +{ + while (stack != NULL) { + PgfExpr arg = force(stack); + if (arg == 0) { + u->free_ref(e); + return 0; + } + + PgfExpr app = u->eapp(e,arg); + u->free_ref(e); + e = app; + stack = stack->next; + } + return e; +} + +PgfEvalExpr::PgfEvalExpr(ref pgf, + PgfMarshaller *m, PgfUnmarshaller *u, + ExprNode *env, + PgfExn *err) +{ + this->m = m; + this->u = u; + this->stack = NULL; + this->env = env; +} diff --git a/src/runtime/c/pgf/compute.h b/src/runtime/c/pgf/compute.h new file mode 100644 index 000000000..51171fc61 --- /dev/null +++ b/src/runtime/c/pgf/compute.h @@ -0,0 +1,69 @@ +#ifndef COMPUTE_H +#define COMPUTE_H + +class PGF_INTERNAL_DECL PgfEvalExpr : public PgfUnmarshaller +{ + ref pgf; + PgfMarshaller *m; + PgfUnmarshaller *u; + PgfExn *err; + + struct Value { + Value *next; // chain for garabage collection + }; + + struct VThunk : Value { + PgfExpr e; + }; + + struct VApp : Value { + ref lin; + Value *args[]; + }; + + struct VMeta : Value { + PgfMetaId id; + Value *args[]; + }; + + struct VClosure : Value { + PgfExpr e; + }; + + struct ExprNode { + PgfExpr e; + PgfExpr value; + ExprNode *next; + }; + + ExprNode *stack; + ExprNode *env; + + virtual PgfExpr eabs(PgfBindType bind_type, PgfText *name, PgfExpr body); + virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg); + virtual PgfExpr elit(PgfLiteral lit); + virtual PgfExpr emeta(PgfMetaId meta_id); + virtual PgfExpr efun(PgfText *name); + virtual PgfExpr evar(int index); + virtual PgfExpr etyped(PgfExpr expr, PgfType ty); + virtual PgfExpr eimplarg(PgfExpr expr); + virtual PgfLiteral lint(size_t size, uintmax_t *val); + virtual PgfLiteral lflt(double val); + virtual PgfLiteral lstr(PgfText *val); + + virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos, + PgfText *name, + size_t n_exprs, PgfExpr *exprs); + virtual void free_ref(object x); + + PgfExpr force(ExprNode *node); + PgfExpr apply(PgfExpr e); + +public: + PgfEvalExpr(ref pgf, + PgfMarshaller *m, PgfUnmarshaller *u, + ExprNode *env, + PgfExn *err); +}; + +#endif // COMPUTE_H diff --git a/src/runtime/c/pgf/data.cxx b/src/runtime/c/pgf/data.cxx index 982db8de2..5c7492bd5 100644 --- a/src/runtime/c/pgf/data.cxx +++ b/src/runtime/c/pgf/data.cxx @@ -40,8 +40,12 @@ void PgfConcr::release(ref concr) namespace_release(concr->cflags); namespace_release(concr->lins); namespace_release(concr->lincats); - phrasetable_release(concr->phrasetable); namespace_release(concr->printnames); + phrasetable_release(concr->phrasetable1); + phrasetable_release(concr->phrasetable2); + phrasetable_release(concr->phrasetable3); + phrasetable_release(concr->phrasetable4); + epsilontable_release(concr->epsilontable); PgfDB::free(concr, concr->name.size+1); } @@ -52,17 +56,10 @@ void PgfConcrLincat::release(ref lincat) } vector>::release(lincat->fields); - for (size_t i = 0; i < lincat->args.size(); i++) { - PgfLParam::release(lincat->args[i].param); + for (ref rule : lincat->rules) { + PgfConcrRule::release(rule); } - vector::release(lincat->args); - - for (ref res : lincat->res) { - PgfPResult::release(res); - } - vector>::release(lincat->res); - - vector>::release(lincat->seqs); + vector>::release(lincat->rules); PgfDB::free(lincat, lincat->name.size+1); } @@ -72,16 +69,9 @@ void PgfLParam::release(ref param) PgfDB::free(param, param->n_terms*sizeof(param->terms[0])); } -void PgfPResult::release(ref res) +static void symbols_release(vector syms) { - if (res->vars != 0) - vector::release(res->vars); - PgfDB::free(res, res->param.n_terms*sizeof(res->param.terms[0])); -} - -void PgfSequence::release(ref seq) -{ - for (PgfSymbol sym : seq->syms) { + for (PgfSymbol sym : syms) { switch (ref::get_tag(sym)) { case PgfSymbolCat::tag: { auto sym_cat = ref::untagged(sym); @@ -103,9 +93,11 @@ void PgfSequence::release(ref seq) } case PgfSymbolKP::tag: { auto sym_kp = ref::untagged(sym); - PgfSequence::release(sym_kp->default_form); + symbols_release(sym_kp->default_form); + vector::release(sym_kp->default_form); for (size_t i = 0; i < sym_kp->alts.size(); i++) { - PgfSequence::release(sym_kp->alts[i].form); + symbols_release(sym_kp->alts[i].form); + vector::release(sym_kp->alts[i].form); for (size_t j = 0; j < sym_kp->alts[i].prefixes.size(); j++) { text_db_release(sym_kp->alts[i].prefixes[j]); } @@ -124,22 +116,31 @@ void PgfSequence::release(ref seq) throw pgf_error("Unknown symbol tag"); } } - inline_vector::release(&PgfSequence::syms, seq); +} + +void PgfConcrRule::release(ref rule) +{ + vector::release(rule->ranges); + + PgfLParam::release(rule->res); + + for (ref arg : rule->args) { + PgfLParam::release(arg); + } + vector>::release(rule->args); + + PgfLParam::release(rule->lin_idx); + + symbols_release(rule->syms.as_vector()); + inline_vector::release(&PgfConcrRule::syms, rule); } void PgfConcrLin::release(ref lin) { - for (size_t i = 0; i < lin->args.size(); i++) { - PgfLParam::release(lin->args[i].param); + for (ref rule : lin->rules) { + PgfConcrRule::release(rule); } - vector::release(lin->args); - - for (ref res : lin->res) { - PgfPResult::release(res); - } - vector>::release(lin->res); - - vector>::release(lin->seqs); + vector>::release(lin->rules); PgfDB::free(lin, lin->name.size+1); } diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index 99ee8a427..f3870fefb 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -87,9 +87,9 @@ struct PgfConcr; #include "text.h" #include "vector.h" #include "namespace.h" -#include "phrasetable.h" #include "probspace.h" #include "expr.h" +#include "intervalmap.h" struct PGF_INTERNAL_DECL PgfFlag { PgfLiteral value; @@ -146,21 +146,8 @@ struct PGF_INTERNAL_DECL PgfPArg { ref param; }; -struct PGF_INTERNAL_DECL PgfPResult { - vector vars; - PgfLParam param; - - static void release(ref res); -}; - typedef object PgfSymbol; -struct PGF_INTERNAL_DECL PgfSequence { - inline_vector syms; - - static void release(ref seq); -}; - struct PGF_INTERNAL_DECL PgfSequenceBackref { object container; size_t seq_index; @@ -189,7 +176,7 @@ struct PGF_INTERNAL_DECL PgfSymbolKS { }; struct PGF_INTERNAL_DECL PgfAlternative { - ref form; + vector form; /**< The form of this variant as a list of tokens. */ vector> prefixes; @@ -199,7 +186,7 @@ struct PGF_INTERNAL_DECL PgfAlternative { struct PGF_INTERNAL_DECL PgfSymbolKP { static const uint8_t tag = 4; - ref default_form; + vector default_form; inline_vector alts; }; @@ -227,15 +214,24 @@ struct PGF_INTERNAL_DECL PgfSymbolALLCAPIT { static const uint8_t tag = 10; }; +struct PGF_INTERNAL_DECL PgfConcrRule { + vector ranges; + ref res; + object container; + vector> args; + ref lin_idx; + inline_vector syms; + + static void release(ref seq); +}; + struct PGF_INTERNAL_DECL PgfConcrLincat { static const uint8_t tag = 0; ref abscat; size_t n_lindefs; - vector args; - vector> res; - vector> seqs; + vector> rules; vector> fields; PgfText name; @@ -249,9 +245,7 @@ struct PGF_INTERNAL_DECL PgfConcrLin { ref absfun; ref lincat; - vector args; - vector> res; - vector> seqs; + vector> rules; PgfText name; @@ -267,143 +261,19 @@ struct PGF_INTERNAL_DECL PgfConcrPrintname { #define containerof(T,field,p) (T*) (((char*) p)-offsetof(T,field)) -struct PGF_INTERNAL_DECL PgfLCEdge { - struct { - ref lincat; - struct { - size_t i0; - term& operator[](int i) { - PgfLCEdge *edge = containerof(PgfLCEdge,from.value,this); - return edge->terms[i]; - } - size_t size() { - PgfLCEdge *edge = containerof(PgfLCEdge,from.value,this); - return edge->from.lin_idx.n_offset; - } - } value; - struct { - size_t i0; - size_t n_offset; - term& operator[](int i) { - PgfLCEdge *edge = containerof(PgfLCEdge,from.lin_idx,this); - return edge->terms[n_offset+i]; - } - size_t size() { - PgfLCEdge *edge = containerof(PgfLCEdge,from.lin_idx,this); - return edge->to.value.n_offset-n_offset; - } - } lin_idx; - } from; - - struct { - ref lincat; - struct { - size_t i0; - size_t n_offset; - term& operator[](int i) { - PgfLCEdge *edge = containerof(PgfLCEdge,to.value,this); - return edge->terms[n_offset+i]; - } - size_t size() { - PgfLCEdge *edge = containerof(PgfLCEdge,to.value,this); - return edge->to.lin_idx.n_offset-n_offset; - } - } value; - struct { - size_t i0; - size_t n_offset; - term& operator[](int i) { - PgfLCEdge *edge = containerof(PgfLCEdge,to.lin_idx,this); - return edge->terms[n_offset+i]; - } - size_t size() { - PgfLCEdge *edge = containerof(PgfLCEdge,to.lin_idx,this); - return edge->n_terms-n_offset; - } - } lin_idx; - } to; - - struct { - size_t n_vars; - PgfVariableRange& operator[](int i) { - PgfLCEdge *edge = containerof(PgfLCEdge,vars,this); - return ((PgfVariableRange*)(((term*) (edge+1))+edge->n_terms))[i]; - } - size_t size() { - return n_vars; - } - } vars; - - size_t n_terms; - term terms[]; - - static ref alloc(size_t n_terms1, size_t n_terms2, size_t n_terms3, size_t n_terms4, size_t n_vars) { - auto edge = PgfDB::malloc((n_terms1+n_terms2+n_terms3+n_terms4)*sizeof(term)+n_vars*sizeof(PgfVariableRange)); - edge->from.lin_idx.n_offset = n_terms1; - edge->to.value.n_offset = n_terms1+n_terms2; - edge->to.lin_idx.n_offset = n_terms1+n_terms2+n_terms3; - edge->n_terms = n_terms1+n_terms2+n_terms3+n_terms4; - edge->vars.n_vars = n_vars; - return edge; - } -}; - -struct PGF_INTERNAL_DECL PgfLRShift { - size_t next_state; - ref lincat; - size_t r; -}; - -struct PGF_INTERNAL_DECL PgfLRShiftKS { - size_t next_state; - ref seq; - size_t sym_idx; -}; - -struct PgfLRReduceArg; - -struct PGF_INTERNAL_DECL PgfLRProduction { - ref lin; - size_t index; - vector> args; -}; - -struct PGF_INTERNAL_DECL PgfLRReduceArg { - static const uint8_t tag = 2; - - size_t id; - size_t n_prods; - PgfLRProduction prods[]; -}; - -struct PGF_INTERNAL_DECL PgfLRReduce { - object lin_obj; - size_t seq_idx; - size_t depth; - - struct Arg { - ref arg; - size_t stk_idx; - }; - - vector args; -}; - -struct PGF_INTERNAL_DECL PgfLRState { - vector shifts; - vector tokens; - size_t next_bind_state; - vector reductions; -}; +#include "phrasetable.h" struct PGF_INTERNAL_DECL PgfConcr { Namespace cflags; Namespace lins; Namespace lincats; - PgfPhrasetable phrasetable; + PgfPhrasetable phrasetable1; // suspended on token + PgfPhrasetable phrasetable2; // suspended on lincat + PgfPhrasetable phrasetable3; // suspended on ccat + PgfPhrasetable phrasetable4; // suspended on bind + PgfEpsilontable epsilontable; Namespace printnames; - - vector lrtable; + PgfMetaId last_fid; PgfText name; diff --git a/src/runtime/c/pgf/expr.cxx b/src/runtime/c/pgf/expr.cxx index 2827b3bf6..4ea5851d8 100644 --- a/src/runtime/c/pgf/expr.cxx +++ b/src/runtime/c/pgf/expr.cxx @@ -111,26 +111,30 @@ PgfType PgfDBMarshaller::match_type(PgfUnmarshaller *u, PgfType ty) PgfExpr PgfDBUnmarshaller::eabs(PgfBindType bind_type, PgfText *name, PgfExpr body) { + body = m->match_expr(this, body); ref eabs = PgfDB::malloc(name->size+1); eabs->bind_type = bind_type; - eabs->body = m->match_expr(this, body); + eabs->body = body; memcpy(&eabs->name, name, sizeof(PgfText)+name->size+1); return eabs.tagged(); } PgfExpr PgfDBUnmarshaller::eapp(PgfExpr fun, PgfExpr arg) { + fun = m->match_expr(this, fun); + arg = m->match_expr(this, arg); ref eapp = PgfDB::malloc(); - eapp->fun = m->match_expr(this, fun); - eapp->arg = m->match_expr(this, arg); + eapp->fun = fun; + eapp->arg = arg; return eapp.tagged(); } PgfExpr PgfDBUnmarshaller::elit(PgfLiteral lit) { + lit = m->match_lit(this, lit); ref elit = PgfDB::malloc(); - elit->lit = m->match_lit(this, lit); + elit->lit = lit; return elit.tagged(); } @@ -158,16 +162,19 @@ PgfExpr PgfDBUnmarshaller::evar(int index) PgfExpr PgfDBUnmarshaller::etyped(PgfExpr expr, PgfType ty) { + expr = m->match_expr(this, expr); + ty = m->match_type(this, ty); ref etyped = PgfDB::malloc(); - etyped->expr = m->match_expr(this, expr); - etyped->type = m->match_type(this, ty); + etyped->expr = expr; + etyped->type = ty; return etyped.tagged(); } PgfExpr PgfDBUnmarshaller::eimplarg(PgfExpr expr) { + expr = m->match_expr(this, expr); ref eimpl = current_db->malloc(); - eimpl->expr = m->match_expr(this, expr); + eimpl->expr = expr; return eimpl.tagged(); } diff --git a/src/runtime/c/pgf/intervalmap.h b/src/runtime/c/pgf/intervalmap.h new file mode 100644 index 000000000..59020fb76 --- /dev/null +++ b/src/runtime/c/pgf/intervalmap.h @@ -0,0 +1,467 @@ +#ifndef INTERVAL_MAP_H +#define INTERVAL_MAP_H + +typedef std::pair interval_t; + +template +class PGF_INTERNAL_DECL interval_map { + const static size_t DELTA = 3; + const static size_t RATIO = 2; + + struct Node { + size_t sz; + size_t start, end, max; + + Node *left; + Node *right; + + V value; + + Node(size_t start, size_t end) + { + this->sz = 1; + this->start = start; + this->end = end; + this->max = end; + this->left = NULL; + this->right = NULL; + memset(&value, 0, sizeof(value)); + } + }; + + Node *root; + + static + Node *insert(Node *node, size_t start, size_t end, Node **target) + { + if (node == NULL) { + node = new Node(start, end); + *target = node; + return node; + } + + int cmp; + if (start < node->start) + cmp = -1; + else if (start > node->start) + cmp = 1; + else if (end < node->end) + cmp = -1; + else if (end > node->end) + cmp = 1; + else + cmp = 0; + + if (cmp < 0) { + Node *left = insert(node->left, start, end, target); + node = upd_node(node,left,node->right); + return balanceL(node); + } else if (cmp > 0) { + Node *right = insert(node->right, start, end, target); + node = upd_node(node,node->left,right); + return balanceR(node); + } else { + *target = node; + return node; + } + } + + static size_t size(Node *node) + { + if (node == 0) + return 0; + return node->sz; + } + + static + Node *upd_node(Node *node, Node *left, Node *right) + { + node->sz = 1+size(left)+size(right); + node->max = std::max((left == NULL) ? node->end : left->max, + (right == NULL) ? node->end : right->max); + node->left = left; + node->right = right; + return node; + } + + static + Node *balanceL(Node *node) + { + if (node->right == NULL) { + if (node->left == NULL) { + return node; + } else { + if (node->left->left == NULL) { + if (node->left->right == NULL) { + return node; + } else { + Node *left_right = node->left->right; + Node *left = upd_node(node->left,NULL,NULL); + Node *right = upd_node(node,NULL,NULL); + return upd_node(left_right, + left, + right); + } + } else { + if (node->left->right == 0) { + Node *left = node->left; + Node *right = upd_node(node,NULL,NULL); + return upd_node(left, + left->left, + right); + } else { + if (node->left->right->sz < RATIO * node->left->left->sz) { + Node *left = node->left; + Node *right = + upd_node(node, + left->right, + NULL); + return upd_node(left, + left->left, + right); + } else { + Node *left_right = node->left->right; + Node *left = + upd_node(node->left, + node->left->left, + left_right->left); + Node *right = + upd_node(node, + left_right->right, + NULL); + return upd_node(left_right, + left, + right); + } + } + } + } + } else { + if (node->left == NULL) { + return node; + } else { + if (node->left->sz > DELTA*node->right->sz) { + if (node->left->right->sz < RATIO*node->left->left->sz) { + Node *left = node->left; + Node *right = + upd_node(node, + left->right, + node->right); + return upd_node(left, + left->left, + right); + } else { + Node *left_right = node->left->right; + Node *left = + upd_node(node->left, + node->left->left, + left_right->left); + Node *right = + upd_node(node, + left_right->right, + node->right); + return upd_node(left_right, + left, + right); + } + } else { + return node; + } + } + } + } + + static + Node *balanceR(Node *node) + { + if (node->left == NULL) { + if (node->right == NULL) { + return node; + } else { + if (node->right->left == NULL) { + if (node->right->right == NULL) { + return node; + } else { + Node *right = node->right; + Node *left = + upd_node(node, + NULL, + NULL); + return upd_node(right, + left, + right->right); + } + } else { + if (node->right->right == NULL) { + Node *right_left = node->right->left; + Node *right = + upd_node(node->right,NULL,NULL); + Node *left = + upd_node(node,NULL,NULL); + return upd_node(right_left, + left, + right); + } else { + if (node->right->left->sz < RATIO * node->right->right->sz) { + Node *right = node->right; + Node *left = + upd_node(node, + NULL, + right->left); + return upd_node(right, + left, + right->right); + } else { + Node *right_left = node->right->left; + Node *right = + upd_node(node->right, + right_left->right, + node->right->right); + Node *left = + upd_node(node, + NULL, + right_left->left); + return upd_node(right_left, + left, + right); + } + } + } + } + } else { + if (node->right == NULL) { + return node; + } else { + if (node->right->sz > DELTA*node->left->sz) { + if (node->right->left->sz < RATIO*node->right->right->sz) { + Node *right = node->right; + Node *left = + upd_node(node, + node->left, + right->left); + return upd_node(right, + left, + right->right); + } else { + Node *right_left = node->right->left; + Node *right = + upd_node(node->right, + right_left->right, + node->right->right); + Node *left = + upd_node(node, + node->left, + right_left->left); + return upd_node(right_left, + left, + right); + } + } else { + return node; + } + } + } + } + +public: + interval_map() { + root = NULL; + } + + V &operator[](interval_t interval) + { + Node *node; + this->root = insert(this->root, interval.first, interval.second, &node); + return node->value; + } + + V *lookup(interval_t interval) + { + return lookup(this->root, interval.first, interval.second); + } + + size_t size() + { + return size(root); + } + + class iterator { + struct Parent { + Node *node; + Parent *next; + }; + + Parent *spine; + + public: + iterator() { + spine = NULL; + } + + iterator(Node *node) { + spine = NULL; + while (node != NULL) { + Parent *parent = new Parent; + parent->node = node; + parent->next = spine; + spine = parent; + node = node->left; + } + } + + bool operator ==(const iterator other) const { + return this->spine == other.spine; + } + + bool operator !=(const iterator other) const { + return this->spine != other.spine; + } + + std::pair operator *() const { + return std::pair + (interval_t(spine->node->start,spine->node->end) + ,spine->node->value + ); + } + + void operator ++() { + Parent *parent = spine->next; + Node *node = spine->node->right; + delete spine; + spine = parent; + + while (node != NULL) { + parent = new Parent; + parent->node = node; + parent->next = spine; + spine = parent; + node = node->left; + } + } + + ~iterator() { + while (spine != NULL) { + Parent *parent = spine->next; + delete spine; + spine = parent; + } + } + }; + + iterator begin() const { + return iterator(root); + } + + iterator end() const { + return iterator(); + } + + class Overlaps { + Node *root; + interval_t i; + + public: + class iterator { + struct Parent { + Node *node; + Parent *next; + }; + + Parent *spine; + size_t start, end; + + public: + iterator() { + spine = NULL; + } + + iterator(Node *node, size_t start, size_t end) { + this->start = start; + this->end = end; + + spine = NULL; + for (;;) { + Parent *parent; + while (node != NULL && start <= node->max) { + parent = new Parent; + parent->node = node; + parent->next = spine; + spine = parent; + node = node->left; + } + + if (spine == NULL || (start <= spine->node->end && end >= spine->node->start)) + return; + + parent = spine->next; + node = spine->node->right; + delete spine; + spine = parent; + } + } + + bool operator ==(const iterator other) const { + return this->spine == other.spine; + } + + bool operator !=(const iterator other) const { + return this->spine != other.spine; + } + + std::pair operator *() const { + return std::pair + (interval_t(spine->node->start,spine->node->end) + ,spine->node->value + ); + } + + void operator ++() { + for (;;) { + Parent *parent = spine->next; + Node *node = spine->node->right; + delete spine; + spine = parent; + + while (node != NULL && start <= node->max) { + parent = new Parent; + parent->node = node; + parent->next = spine; + spine = parent; + node = node->left; + } + + if (spine == NULL || (start <= spine->node->end && end >= spine->node->start)) + return; + } + } + + ~iterator() { + while (spine != NULL) { + Parent *parent = spine->next; + delete spine; + spine = parent; + } + } + }; + + Overlaps(Node *root, interval_t i) { + this->root = root; + this->i = i; + } + + iterator begin() const { + return iterator(root,i.first,i.second); + } + + iterator end() const { + return iterator(); + } + }; + + Overlaps overlaps(interval_t interval) + { + return Overlaps(this->root, interval); + } +}; + +#endif diff --git a/src/runtime/c/pgf/linearizer.cxx b/src/runtime/c/pgf/linearizer.cxx index 8591bc718..4dfe84201 100644 --- a/src/runtime/c/pgf/linearizer.cxx +++ b/src/runtime/c/pgf/linearizer.cxx @@ -2,6 +2,44 @@ #include "printer.h" #include "linearizer.h" +bool PgfLinearizer::Item::instantiate(ref lparam,size_t value) +{ + if (value < lparam->i0) + return false; + value -= lparam->i0; + + for (size_t j = 0; j < lparam->n_terms; j++) { + term t = lparam->terms[j]; + if (vars[t.var] > 0) { + if (value < vars[t.var]-1) + return false; + value -= vars[t.var]-1; + } + } + + for (size_t j = 0; j < lparam->n_terms; j++) { + term t = lparam->terms[j]; + if (vars[t.var] == 0) { + size_t v_val = value / t.factor; + if (v_val >= rule->ranges[t.var]) + return false; + vars[t.var] = v_val + 1; + value %= t.factor; + } + } + + return (value == 0); +} + +size_t PgfLinearizer::Item::eval(ref lparam) +{ + size_t value = lparam->i0; + for (size_t i = 0; i < lparam->n_terms; i++) { + value += lparam->terms[i].factor * (vars[lparam->terms[i].var]-1); + } + return value; +} + PgfLinearizer::TreeNode::TreeNode(PgfLinearizer *linearizer) { this->next = linearizer->prev; @@ -11,8 +49,6 @@ PgfLinearizer::TreeNode::TreeNode(PgfLinearizer *linearizer) this->fid = 0; this->value = 0; - this->var_count = 0; - this->var_values= NULL; this->n_hoas_vars = 0; this->hoas_vars = NULL; @@ -20,19 +56,18 @@ PgfLinearizer::TreeNode::TreeNode(PgfLinearizer *linearizer) linearizer->prev = this; } -void PgfLinearizer::TreeNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r) +bool PgfLinearizer::TreeNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r) { TreeNode *arg = args; while (d > 0) { arg = arg->next_arg; - if (arg == 0) + if (arg == NULL) break; d--; } - if (arg == 0) + if (arg == NULL) throw pgf_error("Missing argument"); - size_t lindex = eval_param(r); - arg->linearize(out, linearizer, lindex); + return arg->linearize(out, linearizer, r); } void PgfLinearizer::TreeNode::linearize_var(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r) @@ -52,20 +87,24 @@ void PgfLinearizer::TreeNode::linearize_var(PgfLinearizationOutputIface *out, Pg out->symbol_token(linearizer->printer.get_text()); } -void PgfLinearizer::TreeNode::linearize_seq(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, ref seq) +bool PgfLinearizer::TreeNode::linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector syms) { - for (size_t i = 0; i < seq->syms.size(); i++) { - PgfSymbol sym = seq->syms[i]; + for (size_t i = 0; i < syms.size(); i++) { + PgfSymbol sym = syms[i]; switch (ref::get_tag(sym)) { case PgfSymbolCat::tag: { auto sym_cat = ref::untagged(sym); - linearize_arg(out, linearizer, sym_cat->d, &sym_cat->r); + size_t r = item->eval(ref::from_ptr(&sym_cat->r)); + if (!linearize_arg(out, linearizer, sym_cat->d, r)) + return false; break; } case PgfSymbolLit::tag: { auto sym_lit = ref::untagged(sym); - linearize_arg(out, linearizer, sym_lit->d, &sym_lit->r); + size_t r = item->eval(ref::from_ptr(&sym_lit->r)); + if (!linearize_arg(out, linearizer, sym_lit->d, r)) + return false; break; } case PgfSymbolVar::tag: { @@ -133,6 +172,7 @@ void PgfLinearizer::TreeNode::linearize_seq(PgfLinearizationOutputIface *out, Pg PreStack *pre = new PreStack(); pre->next = linearizer->pre_stack; pre->node = this; + pre->item = item; pre->sym_kp = sym_kp; pre->bind = false; pre->capit = CAPIT_NONE; @@ -167,125 +207,77 @@ void PgfLinearizer::TreeNode::linearize_seq(PgfLinearizationOutputIface *out, Pg break; } } -} -size_t PgfLinearizer::TreeNode::eval_param(PgfLParam *param) -{ - size_t value = param->i0; - for (size_t j = 0; j < param->n_terms; j++) { - size_t factor = param->terms[j].factor; - size_t var = param->terms[j].var; - - if (var < var_count && var_values[var] != (size_t) -1) { - value += factor * var_values[var]; - } else { - throw pgf_error("Unbound variable in resolving a linearization"); - } - } - return value; + return true; } PgfLinearizer::TreeLinNode::TreeLinNode(PgfLinearizer *linearizer, ref lin) : TreeNode(linearizer) { - this->lin = lin; - this->lin_index = 0; + this->lin = lin; + this->rule_index = 0; + this->items = new Item*[lin->lincat->fields.size()](); } bool PgfLinearizer::TreeLinNode::resolve(PgfLinearizer *linearizer) { - vector hypos = lin->absfun->type->hypos; - size_t n_args = lin->args.size() / lin->res.size(); - - while (lin_index < lin->res.size()) { - size_t offset = lin_index*n_args; - - ref pres = lin->res[lin_index]; - - // Unbind all variables - for (size_t j = 0; j < var_count; j++) { - var_values[j] = (size_t) -1; - } + while (rule_index < lin->rules.size()) { + Item *item = new (lin->rules[rule_index]) Item(); + item->rule = lin->rules[rule_index]; int i = 0; TreeNode *arg = args; while (arg != NULL) { - ref parg = lin->args.elem(offset+i); - arg->check_category(linearizer, &hypos[i].type->name); + if (!item->instantiate(item->rule->args[i], arg->value)) + goto next; - if (arg->value < parg->param->i0) - break; + arg = arg->next_arg; i++; + } - size_t value = arg->value - parg->param->i0; - for (size_t j = 0; j < parg->param->n_terms; j++) { - size_t factor = parg->param->terms[j].factor; - size_t var = parg->param->terms[j].var; - size_t var_value; - - if (var < var_count && var_values[var] != (size_t) -1) { - // The variable already has a value - var_value = var_values[var]; - } else { - // The variable is not assigned yet - var_value = value / factor; - - // find the range for the variable - size_t range = 0; - for (size_t k = 0; k < pres->vars.size(); k++) { - ref var_range = pres->vars.elem(k); - if (var_range->var == var) { - range = var_range->range; - break; - } - } - if (range == 0) - throw pgf_error("Unknown variable in resolving a linearization"); - - if (var_value >= range) - break; - - // Assign the variable; - if (var >= var_count) { - var_values = (size_t*) - realloc(var_values, (var+1)*sizeof(size_t)); - while (var_count < var) { - var_values[var_count++] = (size_t) -1; - } - var_count++; - } - var_values[var] = var_value; - } - - value -= var_value * factor; + { + size_t max_value = 1; + for (size_t i = 0; i < item->vars.size(); i++) { + if (item->vars[i] == 0) + max_value *= item->rule->ranges[i]; } - if (value != 0) - break; + for (size_t value = 0; value < max_value; value++) { + Item *new_item = new (item) Item; - arg = arg->next_arg; - i++; + size_t v = value; + for (size_t i = 0; i < new_item->vars.size(); i++) { + if (new_item->vars[i] == 0) { + size_t range = new_item->rule->ranges[i]; + new_item->vars[i] = (v % range)+1; + v = v / range; + } + } + + size_t lin_idx = new_item->eval(new_item->rule->lin_idx); + items[lin_idx] = new_item; + + this->value = new_item->eval(new_item->rule->res); + } } + next: + delete item; - lin_index++; - - if (arg == NULL) { - value = eval_param(&pres->param); - return true; - } + rule_index++; } - lin_index = 0; - return false; + return true; } -void PgfLinearizer::TreeLinNode::check_category(PgfLinearizer *linearizer, PgfText *cat) +bool PgfLinearizer::TreeLinNode::check_category(PgfLinearizer *linearizer, PgfText *cat) { - if (textcmp(&lin->absfun->type->name, cat) != 0) - throw pgf_error("An attempt to linearize an expression which is not type correct"); + return (textcmp(&lin->absfun->type->name, cat) == 0); } -void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex) +bool PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex) { + if (items[lindex] == NULL) + return false; + PgfText *cat = &lin->absfun->type->name; PgfText *field = &*lin->lincat->fields[lindex]; @@ -302,9 +294,9 @@ void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, Pgf linearizer->pre_stack->bracket_stack = bracket; } - size_t n_seqs = lin->seqs.size() / lin->res.size(); - ref seq = lin->seqs[(lin_index-1)*n_seqs + lindex]; - linearize_seq(out, linearizer, seq); + if (!linearize_item(out, linearizer, + items[lindex],items[lindex]->rule->syms.as_vector())) + return false; if (linearizer->pre_stack == NULL) out->end_phrase(cat, fid, field, &lin->name); @@ -318,6 +310,8 @@ void PgfLinearizer::TreeLinNode::linearize(PgfLinearizationOutputIface *out, Pgf bracket->fun = &lin->name; linearizer->pre_stack->bracket_stack = bracket; } + + return true; } ref PgfLinearizer::TreeLinNode::get_lincat(PgfLinearizer *linearizer) @@ -325,11 +319,22 @@ ref PgfLinearizer::TreeLinNode::get_lincat(PgfLinearizer *linear return namespace_lookup(linearizer->concr->lincats, &lin->absfun->type->name); } +PgfLinearizer::TreeLinNode::~TreeLinNode() +{ + size_t n_fields = lin->lincat->fields.size(); + for (size_t i = 0; i < n_fields; i++) { + if (items[i] != NULL) + delete items[i]; + } + delete[] items; +}; + PgfLinearizer::TreeLindefNode::TreeLindefNode(PgfLinearizer *linearizer, PgfText *fun, PgfText *literal) : TreeNode(linearizer) { this->lincat = 0; - this->lin_index = 0; + this->rule_index= 0; + this->items = NULL; this->fun = fun; this->literal = literal; @@ -355,73 +360,106 @@ PgfLinearizer::TreeLindefNode::TreeLindefNode(PgfLinearizer *linearizer, PgfText bool PgfLinearizer::TreeLindefNode::resolve(PgfLinearizer *linearizer) { - if (lincat == 0) { - return (lin_index = !lin_index); - } else { - ref pres = lincat->res[lin_index]; - value = eval_param(&pres->param); - lin_index++; - if (lin_index <= lincat->n_lindefs) - return true; - lin_index = 0; - return false; + if (lincat == 0) + return true; + + while (rule_index < lincat->n_lindefs) { + ref rule = lincat->rules[rule_index]; + Item *item = new (rule) Item(); + item->rule = rule; + + size_t max_value = 1; + for (size_t i = 0; i < item->vars.size(); i++) { + if (item->vars[i] == 0) + max_value *= item->rule->ranges[i]; + } + + for (size_t value = 0; value < max_value; value++) { + Item *new_item = new (item) Item; + + size_t v = value; + for (size_t i = 0; i < new_item->vars.size(); i++) { + if (new_item->vars[i] == 0) { + size_t range = new_item->rule->ranges[i]; + new_item->vars[i] = (v % range)+1; + v = v / range; + } + } + + size_t lin_idx = new_item->eval(new_item->rule->lin_idx); + items[lin_idx] = new_item; + + this->value = new_item->eval(new_item->rule->res); + } + delete item; + + rule_index++; } + + return true; } -void PgfLinearizer::TreeLindefNode::check_category(PgfLinearizer *linearizer, PgfText *cat) +bool PgfLinearizer::TreeLindefNode::check_category(PgfLinearizer *linearizer, PgfText *cat) { lincat = namespace_lookup(linearizer->concr->lincats, cat); - if (lincat == 0) - throw pgf_error("Cannot find a lincat for a category"); + if (lincat != 0) + this->items = new Item*[lincat->fields.size()](); + return true; } -void PgfLinearizer::TreeLindefNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r) +bool PgfLinearizer::TreeLindefNode::linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r) { linearizer->flush_pre_stack(out, literal); out->symbol_token(literal); TreeNode *arg = args; while (arg != NULL) { - arg->linearize(out,linearizer,0); + if (!arg->linearize(out,linearizer,0)) + return false; arg = arg->next_arg; } + return true; } -void PgfLinearizer::TreeLindefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex) +bool PgfLinearizer::TreeLindefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex) { - if (lincat != 0) { - PgfText *field = &*lincat->fields[lindex]; - if (linearizer->pre_stack == NULL) - out->begin_phrase(&lincat->name, fid, field, fun); - else { - BracketStack *bracket = new BracketStack(); - bracket->next = linearizer->pre_stack->bracket_stack; - bracket->begin = true; - bracket->fid = fid; - bracket->cat = &lincat->name; - bracket->field = field; - bracket->fun = fun; - linearizer->pre_stack->bracket_stack = bracket; - } - - ref seq = lincat->seqs[(lin_index-1)*lincat->fields.size() + lindex]; - linearize_seq(out, linearizer, seq); - - if (linearizer->pre_stack == NULL) - out->end_phrase(&lincat->name, fid, field, fun); - else { - BracketStack *bracket = new BracketStack(); - bracket->next = linearizer->pre_stack->bracket_stack; - bracket->begin = false; - bracket->fid = fid; - bracket->cat = &lincat->name; - bracket->field = field; - bracket->fun = fun; - linearizer->pre_stack->bracket_stack = bracket; - } - } else { - linearize_arg(out, linearizer, 0, NULL); + if (lincat==0) { + return linearize_arg(out, linearizer, 0, 0); } + + PgfText *cat = &lincat->name; + PgfText *field = &*lincat->fields[lindex]; + + if (linearizer->pre_stack == NULL) + out->begin_phrase(cat, fid, field, linearizer->wild); + else { + BracketStack *bracket = new BracketStack(); + bracket->next = linearizer->pre_stack->bracket_stack; + bracket->begin = true; + bracket->fid = fid; + bracket->cat = cat; + bracket->field = field; + bracket->fun = linearizer->wild; + linearizer->pre_stack->bracket_stack = bracket; + } + + if (!linearize_item(out, linearizer, + items[lindex],items[lindex]->rule->syms.as_vector())) + return false; + + if (linearizer->pre_stack == NULL) + out->end_phrase(cat, fid, field, linearizer->wild); + else { + BracketStack *bracket = new BracketStack(); + bracket->next = linearizer->pre_stack->bracket_stack; + bracket->begin = false; + bracket->fid = fid; + bracket->cat = cat; + bracket->field = field; + bracket->fun = linearizer->wild; + linearizer->pre_stack->bracket_stack = bracket; + } + return true; } ref PgfLinearizer::TreeLindefNode::get_lincat(PgfLinearizer *linearizer) @@ -429,11 +467,27 @@ ref PgfLinearizer::TreeLindefNode::get_lincat(PgfLinearizer *lin return lincat; } +PgfLinearizer::TreeLindefNode::~TreeLindefNode() +{ + if (lincat && items != NULL) { + size_t n_fields = lincat->fields.size(); + for (size_t i = 0; i < n_fields; i++) { + if (items[i] != NULL) + delete items[i]; + } + delete[] items; + } + + free(fun); + free(literal); +}; + PgfLinearizer::TreeLinrefNode::TreeLinrefNode(PgfLinearizer *linearizer, TreeNode *root) : TreeNode(linearizer) { args = root; - lin_index=0; + rule_index=0; + item = NULL; } bool PgfLinearizer::TreeLinrefNode::resolve(PgfLinearizer *linearizer) @@ -441,83 +495,56 @@ bool PgfLinearizer::TreeLinrefNode::resolve(PgfLinearizer *linearizer) TreeNode *root = args; ref lincat = root->get_lincat(linearizer); if (lincat == 0) - return (lin_index = !lin_index); + return (rule_index = !rule_index); - while (lincat->n_lindefs+lin_index < lincat->res.size()) { - // Unbind all variables - for (size_t j = 0; j < var_count; j++) { - var_values[j] = (size_t) -1; + while (rule_index < lincat->rules.size()) { + Item *item = new (lincat->rules[lincat->n_lindefs+rule_index]) Item(); + item->rule = lincat->rules[lincat->n_lindefs+rule_index]; + + if (!item->instantiate(item->rule->args[0], root->value)) { + rule_index++; + continue; } - ref pres = lincat->res[lincat->n_lindefs+lin_index]; - ref parg = lincat->args.elem(lincat->n_lindefs+lin_index); + size_t max_value = 1; + for (size_t i = 0; i < item->vars.size(); i++) { + if (item->vars[i] == 0) + max_value *= item->rule->ranges[i]; + } - if (root->value < parg->param->i0) - break; - - size_t value = root->value - parg->param->i0; - for (size_t j = 0; j < parg->param->n_terms; j++) { - size_t factor = parg->param->terms[j].factor; - size_t var = parg->param->terms[j].var; - size_t var_value; - - if (var < var_count && var_values[var] != (size_t) -1) { - // The variable already has a value - var_value = var_values[var]; - } else { - // The variable is not assigned yet - var_value = value / factor; - - // find the range for the variable - size_t range = 0; - for (size_t k = 0; k < pres->vars.size(); k++) { - ref var_range = pres->vars.elem(k); - if (var_range->var == var) { - range = var_range->range; - break; - } + for (size_t value = 0; value < max_value; value++) { + size_t v = value; + for (size_t i = 0; i < item->vars.size(); i++) { + if (item->vars[i] == 0) { + size_t range = item->rule->ranges[i]; + item->vars[i] = v % range; + v = v / range; } - if (range == 0) - throw pgf_error("Unknown variable in resolving a linearization"); - - if (var_value >= range) - break; - - // Assign the variable; - if (var >= var_count) { - var_values = (size_t*) - realloc(var_values, (var+1)*sizeof(size_t)); - while (var_count < var) { - var_values[var_count++] = (size_t) -1; - } - var_count++; - } - var_values[var] = var_value; } - value -= var_value * factor; + this->item = new (item) Item; + this->value = item->eval(this->item->rule->res); } + delete item; - lin_index++; - if (value == 0) { - value = eval_param(&pres->param); - return true; - } + break; } - lin_index = 0; - return false; + if (item == NULL) { + rule_index = 0; + return false; + } + + return true; } -void PgfLinearizer::TreeLinrefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex) +bool PgfLinearizer::TreeLinrefNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex) { ref lincat = args->get_lincat(linearizer); if (lincat != 0) { - size_t i = lincat->n_lindefs*lincat->fields.size() + (lin_index-1); - ref seq = lincat->seqs[i]; - linearize_seq(out, linearizer, seq); + return linearize_item(out, linearizer, item, item->rule->syms.as_vector()); } else { - args->linearize(out, linearizer, lindex); + return args->linearize(out, linearizer, lindex); } } @@ -526,6 +553,11 @@ ref PgfLinearizer::TreeLinrefNode::get_lincat(PgfLinearizer *lin return 0; } +PgfLinearizer::TreeLinrefNode::~TreeLinrefNode() +{ + delete item; +} + PgfLinearizer::TreeLitNode::TreeLitNode(PgfLinearizer *linearizer, ref lincat, PgfText *lit) : TreeNode(linearizer) { @@ -533,13 +565,12 @@ PgfLinearizer::TreeLitNode::TreeLitNode(PgfLinearizer *linearizer, refliteral = lit; } -void PgfLinearizer::TreeLitNode::check_category(PgfLinearizer *linearizer, PgfText *cat) +bool PgfLinearizer::TreeLitNode::check_category(PgfLinearizer *linearizer, PgfText *cat) { - if (textcmp(&lincat->name, cat) != 0) - throw pgf_error("An attempt to linearize an expression which is not type correct"); + return (textcmp(&lincat->name, cat) == 0); } -void PgfLinearizer::TreeLitNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex) +bool PgfLinearizer::TreeLitNode::linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex) { PgfText *field = NULL; if (lincat != 0) { @@ -553,6 +584,8 @@ void PgfLinearizer::TreeLitNode::linearize(PgfLinearizationOutputIface *out, Pgf out->symbol_token(literal); if (lincat != 0) out->end_phrase(&lincat->name, fid, field, linearizer->wild); + + return true; } ref PgfLinearizer::TreeLitNode::get_lincat(PgfLinearizer *linearizer) @@ -570,6 +603,7 @@ PgfLinearizer::PgfLinearizer(PgfPrintContext *ctxt, ref concr, PgfMars this->args = NULL; this->capit = CAPIT_NONE; this->pre_stack = NULL; + this->type_error = false; this->wild = (PgfText*) malloc(sizeof(PgfText)+2); this->wild->size = 1; this->wild->text[0] = '_'; @@ -609,6 +643,10 @@ PgfLinearizer::~PgfLinearizer() bool PgfLinearizer::resolve() { + if (type_error) { + throw pgf_error("An attempt to linearize an expression which is not type correct"); + } + for (;;) { if (!prev || prev->resolve(this)) { if (next == NULL) @@ -663,14 +701,14 @@ void PgfLinearizer::flush_pre_stack(PgfLinearizationOutputIface *out, PgfText *t ref alt = pre->sym_kp->alts.elem(i); for (ref prefix : alt->prefixes) { if (cmp(token, &(*prefix))) { - pre->node->linearize_seq(out, this, alt->form); + pre->node->linearize_item(out, this, pre->item, alt->form); goto done; } } } } - pre->node->linearize_seq(out, this, pre->sym_kp->default_form); + pre->node->linearize_item(out, this, pre->item, pre->sym_kp->default_form); done: if (pre->bracket_stack != NULL) @@ -739,9 +777,19 @@ PgfExpr PgfLinearizer::emeta(PgfMetaId meta) PgfExpr PgfLinearizer::efun(PgfText *name) { ref lin = namespace_lookup(concr->lins, name); - if (lin != 0) + if (lin != 0) { + TreeNode *node = args; + size_t i = 0; + vector hypos = lin->absfun->type->hypos; + while (node != NULL) { + if (!node->check_category(this, &hypos[i].type->name)) { + type_error = true; + } + node = node->next_arg; i++; + } + return (PgfExpr) new TreeLinNode(this, lin); - else { + } else { printer.puts("["); printer.efun(name); printer.puts("]"); diff --git a/src/runtime/c/pgf/linearizer.h b/src/runtime/c/pgf/linearizer.h index f72224f0d..7fb99a5ab 100644 --- a/src/runtime/c/pgf/linearizer.h +++ b/src/runtime/c/pgf/linearizer.h @@ -26,6 +26,48 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller { ref concr; PgfMarshaller *m; + struct Item { + ref rule; + + struct { + size_t &operator[](int i) { + Item *item = containerof(Item,vars,this); + return ((size_t*) (item+1))[i]; + } + size_t size() { + Item *item = containerof(Item,vars,this); + return item->rule->ranges.size(); + } + } vars; + + void *operator new(size_t sz, ref rule) + { + size_t sz2 = rule->ranges.size()*sizeof(size_t); + Item *new_item = (Item *) malloc(sz+sz2); + memset(new_item, 0, sz+sz2); + return new_item; + } + + void *operator new(size_t sz, Item *item) + { + size_t sz2 = item->vars.size()*sizeof(size_t); + Item *new_item = (Item *) malloc(sz+sz2); + memcpy(new_item, item, sz+sz2); + return new_item; + } + + void operator delete(void *p) + { + free(p); + } + + Item() { + } + + bool instantiate(ref lparam,size_t value); + size_t eval(ref lparam); + }; + struct TreeNode { TreeNode *next; TreeNode *next_arg; @@ -34,58 +76,60 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller { int fid; size_t value; - size_t var_count; - size_t *var_values; size_t n_hoas_vars; PgfText **hoas_vars; TreeNode(PgfLinearizer *linearizer); virtual bool resolve(PgfLinearizer *linearizer) { return true; }; - virtual void check_category(PgfLinearizer *linearizer, PgfText *cat)=0; - virtual void linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r); + virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat)=0; + virtual bool linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r); virtual void linearize_var(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r); - virtual void linearize_seq(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, ref seq); - virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)=0; - size_t eval_param(PgfLParam *param); + virtual bool linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector syms); + virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)=0; virtual ref get_lincat(PgfLinearizer *linearizer)=0; - virtual ~TreeNode() { free(var_values); free(hoas_vars); }; + virtual ~TreeNode() { free(hoas_vars); }; }; struct TreeLinNode : public TreeNode { ref lin; - size_t lin_index; + size_t rule_index; + Item **items; TreeLinNode(PgfLinearizer *linearizer, ref lin); virtual bool resolve(PgfLinearizer *linearizer); - virtual void check_category(PgfLinearizer *linearizer, PgfText *cat); - virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex); + virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat); + virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex); virtual ref get_lincat(PgfLinearizer *linearizer); + virtual ~TreeLinNode(); }; struct TreeLindefNode : public TreeNode { ref lincat; - size_t lin_index; + size_t rule_index; + Item **items; PgfText *fun; PgfText *literal; TreeLindefNode(PgfLinearizer *linearizer, PgfText *fun, PgfText *lit); virtual bool resolve(PgfLinearizer *linearizer); - virtual void check_category(PgfLinearizer *linearizer, PgfText *cat); - virtual void linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, PgfLParam *r); - virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex); + virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat); + virtual bool linearize_arg(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t d, size_t r); + virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex); virtual ref get_lincat(PgfLinearizer *linearizer); - ~TreeLindefNode() { free(fun); free(literal); }; + ~TreeLindefNode(); }; struct TreeLinrefNode : public TreeNode { - size_t lin_index; + size_t rule_index; + Item *item; TreeLinrefNode(PgfLinearizer *linearizer, TreeNode *root); virtual bool resolve(PgfLinearizer *linearizer); - virtual void check_category(PgfLinearizer *linearizer, PgfText *cat) {}; - virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex); + virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat) { return true; }; + virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex); virtual ref get_lincat(PgfLinearizer *linearizer); + ~TreeLinrefNode(); }; struct TreeLitNode : public TreeNode { @@ -93,8 +137,8 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller { PgfText *literal; TreeLitNode(PgfLinearizer *linearizer, ref lincat, PgfText *lit); - virtual void check_category(PgfLinearizer *linearizer, PgfText *cat); - virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex); + virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat); + virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex); virtual ref get_lincat(PgfLinearizer *linearizer); ~TreeLitNode() { free(literal); }; }; @@ -102,8 +146,8 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller { struct TreeChunksNode : public TreeNode { TreeChunksNode(PgfLinearizer *linearizer); virtual bool resolve(PgfLinearizer *linearizer); - virtual void check_category(PgfLinearizer *linearizer, PgfText *cat); - virtual void linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex); + virtual bool check_category(PgfLinearizer *linearizer, PgfText *cat); + virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex); virtual ref get_lincat(PgfLinearizer *linearizer); }; @@ -129,6 +173,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller { struct PreStack { PreStack *next; TreeNode *node; + Item *item; ref sym_kp; bool bind; CapitState capit; @@ -138,6 +183,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller { PreStack *pre_stack; void flush_pre_stack(PgfLinearizationOutputIface *out, PgfText *token); + bool type_error; PgfText *wild; public: @@ -145,9 +191,11 @@ public: bool resolve(); void reverse_and_label(bool add_linref); - void linearize(PgfLinearizationOutputIface *out, size_t lindex) { - prev->linearize(out, this, lindex); + bool linearize(PgfLinearizationOutputIface *out, size_t lindex) { + if (!prev->linearize(out, this, lindex)) + return false; flush_pre_stack(out, NULL); + return true; } ref get_lincat() { return prev->get_lincat(this); diff --git a/src/runtime/c/pgf/parser.cxx b/src/runtime/c/pgf/parser.cxx index 261d53b3d..f367f7b09 100644 --- a/src/runtime/c/pgf/parser.cxx +++ b/src/runtime/c/pgf/parser.cxx @@ -1,2362 +1,1764 @@ #include "data.h" #include "printer.h" #include "parser.h" -#include +#include -//#define DEBUG_STATE_CREATION -//#define DEBUG_AUTOMATON //#define DEBUG_PARSER -//#define DEBUG_GENERATOR +//#define DEBUG_EXPRS -struct PgfLRTableMaker::CCat { - CCat *parent; - size_t lin_idx; - ref lincat; +PgfAbstractParser::PgfAbstractParser(ref concr) +{ + this->concr = concr; - size_t id; - bool productive; // true if it has non epsilon rules - std::vector items; // productive items - std::vector suspended; // items that can progress on epsilon - std::vector prods; // epsilon productions - - ref persistant; - - CCat(size_t id, CCat *parent, size_t lin_idx) { - this->parent = parent; - this->lin_idx = lin_idx; - this->lincat = (parent != NULL) ? parent->lincat : 0; - this->id = id; - this->productive = false; - this->persistant = 0; - } - - ref persist(); - - void suspend_item(Item *item); - void register_item(Item *item); - - ~CCat(); -}; - -#define container(T,field,p) ((T*) (((char*) p) - offsetof(T, field))) - -struct PgfLRTableMaker::Production { - ref lin; - size_t index; - - struct { - // After the Production there is an array of arguments - size_t count; - CCat *&operator [](int i) { - return ((CCat **) (container(Production,args,this)+1))[i]; - } - } args; - - struct { - // After the array of arguments there is an array of variables - size_t count; - size_t &operator [](int i) { - Production *prod = container(Production,vals,this); - return ((size_t *) (((CCat**) (prod+1)) + prod->args.count))[i]; - } - } vals; - - void *operator new(size_t size, Item *item); - - Production() { - // If there is no constructor, GCC will zero the object, - // while it has already been initialized in the new operator. - } - - void operator delete(void *p) { - free(p); - } -}; - -struct PgfLRTableMaker::Item { - size_t ref_cnt; // how many CCat:s contain the item? - CCat* ccat; - object lin_obj; - ref seq; - size_t seq_idx; - size_t sym_idx; - size_t stk_size; - - struct Arg { - CCat *ccat; - size_t stk_idx; - }; - - struct { - // After the Item there is an array of arguments - size_t count; - Arg &operator [](int i) const { - return ((Arg*) (container(Item,args,this)+1))[i]; - } - } args; - - struct { - // After the array of arguments there is an array of variables - size_t count; - size_t &operator [](int i) const { - Item *item = container(Item,vals,this); - return ((size_t *) (((Arg*) (item+1)) + item->args.count))[i]; - } - } vals; - - void *operator new(size_t size, CCat* ccat, ref lin, size_t seq_idx); - void *operator new(size_t size, ref lincat, size_t index); - void *operator new(size_t size, CCat* ccat, Production *prod, size_t lin_idx); - void *operator new(size_t size, Item *item, CCat *ccat); - void *operator new(size_t size, Item *item, size_t lin_idx); - void *operator new(size_t size, Item *item); - - Item() { - // If there is no constructor, GCC will zero the object, - // while it has already been initialized in the new operator. - } - - void operator delete(void *p) { - if (((Item *) p)->ref_cnt == 0) - free(p); - } -}; - -struct PgfLRTableMaker::CompareItem : std::less { - bool operator() (const Item *item1, const Item *item2) const { - if (item1->lin_obj < item2->lin_obj) - return true; - else if (item1->lin_obj > item2->lin_obj) - return false; - - if (item1->seq_idx < item2->seq_idx) - return true; - else if (item1->seq_idx > item2->seq_idx) - return false; - - if (item1->sym_idx < item2->sym_idx) - return true; - else if (item1->sym_idx > item2->sym_idx) - return false; - - for (size_t i = 0; i < item1->args.count; i++) { - if (item1->args[i].ccat < item2->args[i].ccat) - return true; - else if (item1->args[i].ccat > item2->args[i].ccat) - return false; - if (item1->args[i].stk_idx < item2->args[i].stk_idx) - return true; - else if (item1->args[i].stk_idx > item2->args[i].stk_idx) - return false; - } - - return false; - } -}; - -const PgfLRTableMaker::CompareItem PgfLRTableMaker::compare_item; - -ref PgfLRTableMaker::CCat::persist() { - if (persistant != 0) - return persistant; - - size_t n_prods = prods.size(); - persistant = PgfDB::malloc(n_prods*sizeof(PgfLRReduce)); - persistant->n_prods = n_prods; - for (size_t i = 0; i < n_prods; i++) { - Production *prod = prods[i]; - persistant->prods[i].lin = prod->lin; - persistant->prods[i].index = prod->index; - auto children = vector>::alloc(prod->args.count); - for (size_t j = 0; j < prod->args.count; j++) { - if (prod->args[j] == NULL) { - children[j] = 0; - } else { - ref child_arg = prod->args[j]->persist(); - children[j] = child_arg; - } - } - persistant->prods[i].args = children; - } - - return persistant; + this->current_state = NULL; + this->last_fid = concr->last_fid; } -void PgfLRTableMaker::CCat::suspend_item(Item *item) { - suspended.push_back(item); - if (item != NULL) - item->ref_cnt++; +void PgfAbstractParser::get_info(CCat *ccat, ref *prule, size_t **pvalues) +{ + if (ccat->epsilon == 0) { + Production *prod = ccat->prods[0]; + *prule = prod->rule; + *pvalues = &prod->vars[0]; + } else { + ref pitem = ccat->epsilon->items[0]; + *prule = pitem->rule; + *pvalues = &pitem->vars[0]; + } } -void PgfLRTableMaker::CCat::register_item(Item *item) { - items.push_back(item); item->ref_cnt++; +PgfAbstractParser::CCat *PgfAbstractParser::get_epsilon_ccat(PgfText *name, PgfMetaId fid) +{ + if (fid == 0) + return NULL; + + CCat *&ccat = epsilons[fid]; + if (ccat == NULL) { + ref arg = epsilontable_get(concr->epsilontable, + name, fid); + ccat = new CCat; + ccat->fid = arg->fid; + ccat->epsilon = arg; + ccat->cont = NULL; + ccat->state = NULL; + ccat->lin_idx = arg->lin_idx; + ccat->value = arg->value; + ccat->covered = true; + ccat->viterbi_prob = arg->viterbi_prob; + } + return ccat; } -PgfLRTableMaker::CCat::~CCat() { - for (Item *item : items) { - item->ref_cnt--; - delete item; - } - for (Item *item : suspended) { - item->ref_cnt--; - delete item; - } +PgfAbstractParser::CCat::~CCat() +{ for (Production *prod : prods) { delete prod; } + for (ExprState *estate : pending) { + delete estate; + } } -void *PgfLRTableMaker::Production::operator new(size_t size, Item *item) { - ref lin = ref::untagged(item->lin_obj); - - size_t n_fields = lin->seqs.size() / lin->res.size(); - size_t ex_size = sizeof(CCat*)*item->args.count+sizeof(size_t)*item->vals.count; - - Production *prod = (Production *) malloc(size+ex_size); - prod->lin = lin; - prod->index = item->seq_idx / n_fields; - prod->args.count = item->args.count; - prod->vals.count = item->vals.count; - - for (size_t i = 0; i < item->args.count; i++) { - prod->args[i] = item->args[i].ccat; - } - for (size_t i = 0; i < item->vals.count; i++) { - prod->vals[i] = item->vals[i]; - } - - return prod; -} - -void *PgfLRTableMaker::Item::operator new(size_t size, CCat* ccat, ref lin, size_t seq_idx) { - size_t n_args = lin->absfun->type->hypos.size(); - size_t n_fields = lin->seqs.size() / lin->res.size(); - ref res = lin->res[seq_idx / n_fields]; - size_t n_vars = res->vars.size(); - size_t ex_size = sizeof(Arg)*n_args+sizeof(size_t)*n_vars; - - Item *item = (Item *) malloc(size+ex_size); - item->ref_cnt = 0; - item->ccat = ccat; - item->lin_obj = lin.tagged(); - item->seq = lin->seqs[seq_idx]; - item->seq_idx = seq_idx; - item->sym_idx = 0; - item->stk_size = 0; - item->args.count = n_args; - item->vals.count = n_vars; - memset(item+1, 0, ex_size); - - return item; -} - -void *PgfLRTableMaker::Item::operator new(size_t size, ref lincat, size_t index) { - size_t n_args = 1; - ref res = lincat->res[lincat->n_lindefs+index]; - size_t n_vars = res->vars.size(); - size_t ex_size = sizeof(Arg)*n_args+sizeof(size_t)*n_vars; - - size_t seq_idx = - lincat->n_lindefs*lincat->fields.size() + index; - - Item *item = (Item *) malloc(size+ex_size); - item->ref_cnt = 0; - item->ccat = NULL; - item->lin_obj = lincat.tagged(); - item->seq = lincat->seqs[seq_idx]; - item->seq_idx = seq_idx; - item->sym_idx = 0; - item->stk_size = 0; - item->args.count = n_args; - item->vals.count = n_vars; - memset(item+1, 0, ex_size); - - return item; -} - -void *PgfLRTableMaker::Item::operator new(size_t size, CCat* ccat, Production *prod, size_t lin_idx) { - size_t n_fields = prod->lin->seqs.size() / prod->lin->res.size(); - ref res = prod->lin->res[prod->index]; - size_t ex_size = sizeof(Arg)*prod->args.count+sizeof(size_t)*prod->vals.count; - - Item *item = (Item *) malloc(size+ex_size); - item->ref_cnt = 0; - item->ccat = ccat; - item->lin_obj = prod->lin.tagged(); - item->seq_idx = prod->index*n_fields+lin_idx; - item->seq = prod->lin->seqs[item->seq_idx]; - item->sym_idx = 0; - item->stk_size = 0; - item->args.count = prod->args.count; - item->vals.count = prod->vals.count; - - for (size_t i = 0; i < item->args.count; i++) { - item->args[i].ccat = prod->args[i]; - item->args[i].stk_idx = 0; - } - for (size_t i = 0; i < item->vals.count; i++) { - item->vals[i] = prod->vals[i]; - } - - return item; -} - -void *PgfLRTableMaker::Item::operator new(size_t size, Item *item, CCat *ccat) { - size_t ex_size = sizeof(Arg)*item->args.count+sizeof(size_t)*item->vals.count; - - Item *new_item = (Item *) malloc(size+ex_size); - new_item->ref_cnt = 0; - new_item->ccat = item->ccat; - new_item->lin_obj = item->lin_obj; - new_item->seq = item->seq; - new_item->seq_idx = item->seq_idx; - new_item->sym_idx = item->sym_idx+1; - new_item->stk_size = item->stk_size; - new_item->args.count = item->args.count; - new_item->vals.count = item->vals.count; - memcpy(new_item+1,item+1,ex_size); - - ref scat = - ref::untagged(item->seq->syms[item->sym_idx]); - new_item->args[scat->d].ccat = ccat; - - return new_item; -} - -void *PgfLRTableMaker::Item::operator new(size_t size, Item *item, size_t lin_idx) { - size_t ex_size = sizeof(Arg)*item->args.count+sizeof(size_t)*item->vals.count; - - Item *new_item = (Item *) malloc(size+ex_size); - new_item->ref_cnt = 0; - new_item->ccat = item->ccat; - new_item->lin_obj = item->lin_obj; - new_item->seq = item->seq; - new_item->seq_idx = item->seq_idx; - new_item->sym_idx = item->sym_idx+1; - new_item->stk_size = item->stk_size; - new_item->args.count = item->args.count; - new_item->vals.count = item->vals.count; - memcpy(new_item+1,item+1,ex_size); - - ref scat = - ref::untagged(item->seq->syms[item->sym_idx]); - new_item->args[scat->d].stk_idx = ++new_item->stk_size; - - return new_item; -} - -void *PgfLRTableMaker::Item::operator new(size_t size, Item *item) { - size_t ex_size = sizeof(Arg)*item->args.count+sizeof(size_t)*item->vals.count; - - Item *new_item = (Item *) malloc(size+ex_size); - memcpy(new_item,item,size+ex_size); - new_item->ref_cnt = 0; - - return new_item; -} - -bool PgfLRTableMaker::CompareKey3::operator() (const Key3& k1, const Key3& k2) const { - size_t i = k1.second; - size_t j = k2.second; - for (;;) { - if (i >= k1.first->syms.size() || ref::get_tag(k1.first->syms[i]) != PgfSymbolKS::tag) - return (j < k2.first->syms.size() && ref::get_tag(k2.first->syms[j]) == PgfSymbolKS::tag); - - if (j >= k2.first->syms.size() || ref::get_tag(k2.first->syms[j]) != PgfSymbolKS::tag) - return false; - - auto symks1 = ref::untagged(k1.first->syms[i]); - auto symks2 = ref::untagged(k2.first->syms[j]); - - int res[2] = {0,0}; - texticmp(&symks1->token, &symks2->token, res); - if (res[0] < 0) - return true; - if (res[0] > 0) - return false; - - i++; j++; - } - - return false; -} - -struct PgfLRTableMaker::State { - size_t id; - std::vector items; // The seed items for this state - std::vector completed; // Completed items that will become reductions - std::map ccats1; - std::map ccats2; - std::map tokens; - State *bind_state; - - State() { - this->id = 0; - this->bind_state = NULL; - } - - ~State() { - for (Item *item : items) { - item->ref_cnt--; - delete item; - } - - for (Item *item : completed) { - item->ref_cnt--; - delete item; - } - } - - void push_item(Item *item) { - items.push_back(item); item->ref_cnt++; - push_heap(items.begin(), items.end(), compare_item); - } - - Item *pop_item() { - Item *item = items.back(); items.pop_back(); - item->ref_cnt--; - return item; - } -}; - -PgfLRTableMaker::PgfLRTableMaker(ref abstr, ref concr) +PgfAbstractParser::Cont::~Cont() { - this->abstr = abstr; - this->concr = concr; - this->ccat_id = 0; - this->state_id = 0; + for (auto it1 : suspended) { + for (auto it2 : it1.second) { + for (Item *item : it2.second) { + delete item; + } + } + } +} - PgfText *startcat = (PgfText *) - alloca(sizeof(PgfText)+9); - startcat->size = 8; - strcpy(startcat->text, "startcat"); - - ref flag = - namespace_lookup(abstr->aflags, startcat); - - ref lincat = 0; - if (flag != 0) { - switch (ref::get_tag(flag->value)) { - case PgfLiteralStr::tag: { - auto lstr = ref::untagged(flag->value); - - State *state = new State(); - - lincat = - namespace_lookup(concr->lincats, &lstr->val); - - MD5Context ctxt; - - for (size_t i = 0; i < lincat->res.size()-lincat->n_lindefs; i++) { - Item *item = new(lincat, i) Item; - - ctxt.update(item->lin_obj); - ctxt.update(item->seq_idx); - ctxt.update(item->sym_idx); - ctxt.update(item->args[0].ccat); - ctxt.update(item->args[0].stk_idx); - for (size_t i = 0; i < item->vals.count; i++) { - ctxt.update(item->vals[i]); +PgfAbstractParser::~PgfAbstractParser() +{ + State *state = current_state; + while (state != NULL) { + for (auto it1 : state->completed) { + /* for (auto it2 : it1) { + for (auto it3 : it2) { + delete it3; } - - state->push_item(item); - } - - MD5Digest digest; - ctxt.finalize(&digest); - - states[digest] = state; - todo.push(state); + }*/ } + for (auto it : state->conts1) { + delete it.second; } + for (auto it : state->conts2) { + delete it.second; + } + + State *next = state->next; + delete state; + state = next; } } -PgfLRTableMaker::~PgfLRTableMaker() +void PgfAbstractParser::process(Item *item, State *state) { - for (auto p : states) { - delete p.second; - } - - for (auto p : ccats1) { - delete p.second; - } - - for (auto p : ccats2) { - delete p.second; - } -} - -#if defined(DEBUG_STATE_CREATION) || defined(DEBUG_AUTOMATON) -void PgfLRTableMaker::print_production(CCat *ccat, Production *prod) -{ - PgfPrinter printer(NULL, 0, NULL); - - ref res = *vector_elem(prod->lin->res, prod->index); - if (res->vars != 0) { - printer.lvar_ranges(res->vars, &prod->vals[0]); - printer.puts(" "); - } - - ref type = prod->lin->absfun->type; - printer.nprintf(37, "?%zu -> ", ccat->id); - printer.puts(&prod->lin->name); - printer.nprintf(37, "/%zu[", prod->index); - PgfDBMarshaller m; - size_t args_start = type->hypos->len * prod->index; - for (size_t i = 0; i < type->hypos->len; i++) { - if (i > 0) - printer.puts(","); - - if (prod->args[i] == NULL) { - ref arg = vector_elem(prod->lin->args, args_start + i); - m.match_type(&printer, vector_elem(type->hypos, i)->type.as_object()); - printer.puts("("); - printer.lparam(arg->param); - printer.puts(")"); - } else { - printer.nprintf(32, "?%zu", prod->args[i]->id); - } - } - printer.puts("]\n"); - - PgfText *text = printer.get_text(); - fputs(text->text, stderr); - free(text); -} - -void PgfLRTableMaker::print_item(Item *item) -{ - PgfPrinter printer(NULL, 0, NULL); - - switch (ref::get_tag(item->lin_obj)) { - case PgfConcrLin::tag: { - auto lin = - ref::untagged(item->lin_obj); - - size_t index = item->seq_idx / lin->lincat->fields->len; - size_t r = item->seq_idx % lin->lincat->fields->len; - ref res = *vector_elem(lin->res, index); - if (res->vars != 0) { - printer.lvar_ranges(res->vars, &item->vals[0]); - printer.puts(" "); - } - - if (item->ccat->parent == NULL) { - printer.puts(&item->ccat->lincat->name); - printer.puts("("); - printer.lparam(ref::from_ptr(&res->param)); - printer.puts(") -> "); - } else { - printer.nprintf(32,"?%zu -> ",item->ccat->parent->id); - } - - printer.puts(&lin->name); - printer.nprintf(32, "/%zd[", index); - PgfDBMarshaller m; - ref type = lin->absfun->type; - size_t args_start = type->hypos->len * index; - for (size_t i = 0; i < type->hypos->len; i++) { - if (i > 0) - printer.puts(","); - - if (item->args[i].ccat == NULL) { - ref arg = vector_elem(lin->args, args_start + i); - m.match_type(&printer, vector_elem(type->hypos, i)->type.as_object()); - printer.puts("("); - printer.lparam(arg->param); - printer.puts(")"); - } else { - printer.nprintf(32, "?%zu", item->args[i].ccat->id); - } - if (item->args[i].stk_idx > 0) - printer.nprintf(32, "$%zd", item->args[i].stk_idx); - } - printer.nprintf(32, "]; %zu : ", r); - break; - } - case PgfConcrLincat::tag: { - auto lincat = - ref::untagged(item->lin_obj); - - size_t index = item->seq_idx - lincat->n_lindefs*lincat->fields->len; - ref res = *vector_elem(lincat->res, lincat->n_lindefs+index); - if (res->vars != 0) { - printer.lvar_ranges(res->vars, &item->vals[0]); - printer.puts(" "); - } - - printer.puts("linref "); - printer.puts(&lincat->name); - printer.nprintf(32, "/%zd[", index); - if (item->args[0].ccat == NULL) { - printer.puts(&lincat->name); - printer.puts("("); - printer.lparam(vector_elem(lincat->args, lincat->n_lindefs+index)->param); - printer.puts(")"); - } else { - printer.nprintf(32, "?%zu", item->args[0].ccat->id); - } - if (item->args[0].stk_idx > 0) - printer.nprintf(32, "$%zd", item->args[0].stk_idx); - printer.puts("]; 0 : "); - break; - } - } - - if (item->sym_idx == 0) - printer.puts(". "); - - for (size_t i = 0; i < item->seq->syms.len; i++) { - PgfSymbol sym = item->seq->syms.data[i]; - printer.symbol(sym); - - if (i+1 == item->sym_idx) - printer.puts(" . "); - } - printer.puts("\n"); - - PgfText *text = printer.get_text(); - fputs(text->text, stderr); - free(text); -} +#ifdef DEBUG_PARSER + print_item(item,state); #endif -void PgfLRTableMaker::process(State *state, Fold fold, Item *item) -{ -#if defined(DEBUG_STATE_CREATION) - if (fold == PROBE) - fprintf(stderr, "PROBE "); - else if (fold == INIT) - fprintf(stderr, "INIT "); - else if (fold == REPEAT) - fprintf(stderr, "REPEAT "); - print_item(item); -#endif - - if (item->sym_idx < item->seq->syms.size()) { - PgfSymbol sym = item->seq->syms[item->sym_idx]; - symbol(state, fold, item, sym); + if (item->dot < item->syms.size()) { + symbol(item,state,item->syms[item->dot]); + } else if (item->pre_alt > 0) { + item->dot = item->pre_dot+1; + item->pre_alt = 0; + item->pre_dot = 0; + item->syms = item->rule->syms.as_vector(); + process(item,state); } else { - complete(state, fold, item); + complete(item,state); } } -void PgfLRTableMaker::symbol(State *state, Fold fold, Item *item, PgfSymbol sym) +PGF_INTERNAL_DECL +int text_symbol_cmp(PgfTextSpot *spot, const uint8_t *end, + ref sym, bool case_sensitive); + +void PgfAbstractParser::symbol(Item *item, State *state, PgfSymbol sym) { switch (ref::get_tag(sym)) { case PgfSymbolCat::tag: { auto symcat = ref::untagged(sym); - switch (ref::get_tag(item->lin_obj)) { - case PgfConcrLin::tag: { - auto lin = - ref::untagged(item->lin_obj); - ref res = lin->res[item->seq_idx / lin->lincat->fields.size()]; - auto arg = item->args[symcat->d]; - if (arg.ccat != NULL) { - predict(state, fold, item, arg.ccat, res->vars, &symcat->r); - } else { - ref hypo = lin->absfun->type->hypos.elem(symcat->d); - predict(state, fold, item, ref::from_ptr(&hypo->type->name), res->vars, &symcat->r); + CCat *ccat = item->args[symcat->d]; + if (ccat == NULL) { + ref lincat = 0; + switch (ref::get_tag(item->rule->container)) { + case PgfConcrLin::tag: { + auto lin = ref::untagged(item->rule->container); + lincat = + namespace_lookup(concr->lincats, + &lin->absfun->type->hypos[symcat->d].type->name); + break; } - break; - } - case PgfConcrLincat::tag: { - auto lincat = - ref::untagged(item->lin_obj); - ref res = - lincat->res[lincat->n_lindefs + item->seq_idx - lincat->n_lindefs*lincat->fields.size()]; - auto arg = item->args[symcat->d]; - if (arg.ccat != NULL) { - predict(state, fold, item, arg.ccat, res->vars, &symcat->r); - } else { - predict(state, fold, item, ref::from_ptr(&lincat->name), res->vars, &symcat->r); + case PgfConcrLincat::tag: { + lincat = ref::untagged(item->rule->container); + break; } - break; - } + } + + if (lincat != 0) { + size_t n_suspended1 = state->conts1.size(); + Cont *&cont = state->conts1[lincat]; + if (cont == NULL) { + cont = new Cont; + cont->ccat = NULL; + cont->lincat = lincat; + cont->state = state; + } + + interval_t value_i = interval(item->rule, &item->vars[0], item->rule->args[symcat->d]); + interval_t lin_idx_i = interval(item->rule, &item->vars[0], ref::from_ptr(&symcat->r)); + + suspend(cont,item,n_suspended1 == 0,symcat,value_i,lin_idx_i); + } + } else { + interval_t value_i = interval(item->rule, &item->vars[0], item->rule->args[symcat->d]); + interval_t lin_idx_i = interval(item->rule, &item->vars[0], ref::from_ptr(&symcat->r)); + + // the following prevents infinite loops with epsilons + bool found = false; + CCat *prev_ccat = ccat; + while (prev_ccat != NULL && prev_ccat->cont != NULL && prev_ccat->cont->state == state) { + if (prev_ccat->value == value_i && prev_ccat->lin_idx == lin_idx_i) { + found = true; + break; + } + prev_ccat = prev_ccat->cont->ccat; + } + if (found) { + item->dot++; + state->push_item(item); + break; + } + + Cont *&cont = state->conts2[ccat]; + if (cont == NULL) { + cont = new Cont; + cont->ccat = ccat; + if (ccat->epsilon != 0) + cont->lincat = ccat->epsilon->lincat; + else + cont->lincat = ccat->cont->lincat; + cont->state = state; + } + + bool subsumed = false; + for (auto it1 : cont->suspended.overlaps(value_i)) { + if (it1.first.first <= value_i.first && it1.first.second >= value_i.second) { + for (auto it2 : it1.second.overlaps(lin_idx_i)) { + if (it2.first.first <= lin_idx_i.first && it2.first.second >= lin_idx_i.second) { + subsumed = true; + goto found; + } + } + } + } +found: + suspend(cont,item,!subsumed,symcat,value_i,lin_idx_i); } break; } case PgfSymbolKS::tag: { auto symks = ref::untagged(sym); - - size_t sym_idx_2 = item->sym_idx+1; - while (sym_idx_2 < item->seq->syms.size()) { - if (ref::get_tag(item->seq->syms[sym_idx_2]) != PgfSymbolKS::tag) - break; - sym_idx_2++; - } - - if (fold == PROBE) { - item->ccat->productive = true; - if (item->sym_idx > 0 || sym_idx_2 < item->seq->syms.size()) { - item->ccat->register_item(item); - } - } else { - auto &next_state = state->tokens[Key3(item->seq,item->sym_idx)]; - if (next_state == NULL) { - next_state = new State; - } - item = new (item) Item; - item->sym_idx = sym_idx_2; - item->stk_size++; - next_state->push_item(item); - } + symbol_token(item, state, symks); break; } case PgfSymbolKP::tag: { - if (fold == PROBE) { - item->ccat->productive = true; - item->ccat->register_item(item); - } else { - auto symkp = ref::untagged(sym); - Item *new_item1 = NULL; - Item *new_item2 = NULL; - for (size_t i = 0; i < symkp->alts.size(); i++) { - ref form = symkp->alts[i].form; - if (form->syms.size() == 0) { - if (!new_item1) { - new_item1 = new (item) Item; - new_item1->sym_idx++; - } - process(state, fold, new_item1); - } else { - auto &next_state = state->tokens[Key3(form,0)]; - if (next_state == NULL) { - next_state = new State; - } - if (!new_item2) { - new_item2 = new (item) Item; - new_item2->sym_idx++; - new_item2->stk_size++; - } - next_state->push_item(new_item2); - } - } + auto symkp = ref::untagged(sym); - ref form = symkp->default_form; - if (form->syms.size() == 0) { - if (!new_item1) { - new_item1 = new (item) Item; - new_item1->sym_idx++; - } - process(state, fold, new_item1); - } else { - auto &next_state = state->tokens[Key3(form,0)]; - if (next_state == NULL) { - next_state = new State; - } - if (!new_item2) { - new_item2 = new (item) Item; - new_item2->sym_idx++; - new_item2->stk_size++; - } - next_state->push_item(new_item2); - } + Item *new_item = new(item) Item; + new_item->pre_alt = 1; + new_item->pre_dot = item->dot; + new_item->dot = 0; + new_item->syms = symkp->default_form; + new_item->rule = item->rule; + new_item->inside_prob = item->inside_prob; + new_item->outside_prob = item->outside_prob; + process(new_item, state); - // If the items are not owned by anyone, we must delete them - if (new_item1 != NULL) - delete new_item1; - if (new_item2 != NULL) - delete new_item2; + for (size_t i = 0; i < symkp->alts.size(); i++) { + Item *new_item = new(item) Item; + new_item->pre_alt = i+2; + new_item->pre_dot = item->dot; + new_item->dot = 0; + new_item->syms = symkp->alts[i].form; + new_item->rule = item->rule; + new_item->inside_prob = item->inside_prob; + new_item->outside_prob = item->outside_prob; + process(new_item, state); } - } - case PgfSymbolBIND::tag: { - if (fold == PROBE) { - item->ccat->productive = true; - item->ccat->register_item(item); - } else { - if (state->bind_state == NULL) { - state->bind_state = new State; - } - item = new (item) Item; - item->sym_idx++; - item->stk_size++; - state->bind_state->push_item(item); - } - break; - } - case PgfSymbolSOFTBIND::tag: - case PgfSymbolSOFTSPACE::tag: { - if (fold == PROBE) { - item->ccat->productive = true; - item->ccat->register_item(item); - } else { - // SOFT_BIND && SOFT_SPACE also allow a space - Item *new_item = new (item) Item(); - new_item->sym_idx++; - process(state,fold,new_item); - delete new_item; - // Now we handle the case where there is no space. - if (state->bind_state == NULL) { - state->bind_state = new State; - } - new_item = new (item) Item(); - new_item->stk_size++; - state->bind_state->push_item(new_item); - delete new_item; - } - break; - } - case PgfSymbolCAPIT::tag: - case PgfSymbolALLCAPIT::tag: { - // We just ignore CAPIT && ALLCAPIT during parsing - item = new (item) Item(); item->sym_idx++; - process(state,fold,item); delete item; break; } + case PgfSymbolBIND::tag: + case PgfSymbolSOFTBIND::tag: + case PgfSymbolSOFTSPACE::tag: { + symbol_bind(item, state, sym); + break; + } + case PgfSymbolNE::tag: + delete item; + break; + case PgfSymbolCAPIT::tag: + case PgfSymbolALLCAPIT::tag: + item->dot++; + process(item, state); + break; } } -struct PGF_INTERNAL_DECL PgfVariableValue { - size_t range; - size_t factor; - size_t value; - size_t j; -}; - -template -void PgfLRTableMaker::predict(State *state, Fold fold, Item *item, T cat, - vector vars, PgfLParam *r) +void PgfAbstractParser::complete(Item *item, State *state) { - size_t index = r->i0; - size_t n_terms = 0; + switch (ref::get_tag(item->rule->container)) { + case PgfConcrLin::tag: { + auto lin = ref::untagged(item->rule->container); - PgfVariableValue *values = (PgfVariableValue *) - alloca(sizeof(PgfVariableValue)*r->n_terms); - for (size_t i = 0; i < r->n_terms; i++) - { - size_t var = r->terms[i].var; - for (size_t j = 0; j < vars.size(); j++) - { - ref range = vars.elem(j); - if (range->var == var) { - if (item->vals[j] == 0) { - values[n_terms].range = range->range; - values[n_terms].factor = r->terms[i].factor; - values[n_terms].value = 0; - values[n_terms].j = j; - n_terms++; + interval_t res = interval(item->rule, &item->vars[0], item->rule->res); + interval_t lin_idx = interval(item->rule, &item->vars[0], item->rule->lin_idx); + CCat *&ccat = state->completed[item->cont][res][lin_idx]; + if (ccat == NULL) { + ccat = new CCat; + ccat->fid = (++last_fid); + ccat->epsilon = 0; + ccat->cont = item->cont; + ccat->state = state; + ccat->lin_idx = lin_idx; + ccat->value = res; + ccat->covered = false; + ccat->viterbi_prob = item->inside_prob; + +#ifdef DEBUG_PARSER + { + PgfPrinter printer(NULL,0,NULL); + if (item->rule->ranges.size() > 0) { + printer.lvar_ranges(item->rule->ranges, &item->vars[0]); + printer.puts(" "); + } + printer.nprintf(64,"complete [%zd-%zd; ",item->cont->state->end.pos,state->start.pos); + if (ccat->cont->ccat == NULL) { + printer.efun(&ccat->cont->lincat->name); + printer.puts("("); + printer.lparam(item->rule->res); + printer.puts(")"); } else { - index += (item->vals[j]-1) * r->terms[i].factor; + printer.emeta(ccat->cont->ccat->fid); } - break; + printer.puts("; "); + printer.lparam(item->rule->lin_idx); + printer.puts("; "); + printer.emeta(ccat->fid); + printer.puts("]"); + PgfText *text = printer.get_text(); + fprintf(stderr, "%s\n", text->text); + free(text); } - } - } - - for (;;) { - Item *new_item = new (item) Item(); - for (size_t i = 0; i < n_terms; i++) { - new_item->vals[values[i].j] = values[i].value+1; +#endif } - predict(state, fold, new_item, cat, index); - - delete new_item; - - size_t i = n_terms; - while (i > 0) { - i--; - values[i].value++; - if (values[i].value < values[i].range) { - index += values[i].factor; - i++; - break; - } - - index -= (values[i].value-1) * values[i].factor; - values[i].value = 0; + auto prod = new(item) Production; + prod->rule = item->rule; + for (size_t i = 0; i < prod->args.size(); i++) { + if (prod->args[i] != NULL && prod->args[i] != ccat) + prod->args[i]->covered = true; } + ccat->prods.push_back(prod); - if (i == 0) { +#ifdef DEBUG_PARSER + print_prod(ccat, prod); +#endif + final_item(state, ccat, item, res, lin_idx); + + if (ccat->cont == NULL) break; - } - } -} -void PgfLRTableMaker::predict(State *state, Fold fold, Item *item, ref cat, size_t lin_idx) -{ - CCat *&ccat = ccats1[Key0(cat,lin_idx)]; - CCat *tmp = ccat; - if (tmp == NULL) { - ccat = new CCat(++ccat_id, NULL, lin_idx); - } - if (fold == PROBE) { - ccat->suspend_item(item); - } - if (tmp == NULL) { - std::function)> f = - [this,ccat](ref fun) { - predict(fun, ccat); - return true; - }; - probspace_iter(abstr->funs_by_cat, cat, f, false); - } else if (fold == PROBE && ccat->prods.size() > 0) { - Item *new_item = new(item,ccat) Item; - process(state,fold,new_item); - delete new_item; - } + if (ccat->prods.size() == 1) { + bu_predict(state, item->outside_prob, ccat); - if (fold == PROBE) { - if (item->ccat != NULL && ccat->productive) { - item->ccat->productive = true; - item->ccat->register_item(item); - } - } else { - if (ccat->productive) { - auto &next_state = state->ccats1[Key1(ccat->lincat,lin_idx)]; - if (next_state == NULL) { - next_state = new State; - } - next_state->push_item(new(item,lin_idx) Item); - - if (next_state->items.size() == 1) { - for (size_t i = 0; i < ccat->items.size(); i++) { - process(state, REPEAT, ccat->items[i]); + for (auto it1 : ccat->cont->suspended.overlaps(ccat->value)) { + for (auto it2 : it1.second.overlaps(ccat->lin_idx)) { + size_t n_items = it2.second.size(); + for (size_t i = 0; i < n_items; i++) { + Item *new_item = new (it2.second[i]) Item; + combine(state,new_item,ccat); + }; } } - } - - if (fold == INIT && ccat->prods.size() > 0) { - Item *new_item = new (item, ccat) Item; - process(state, fold, new_item); - delete new_item; - } - } -} - -void PgfLRTableMaker::predict(State *state, Fold fold, Item *item, CCat *ccat, size_t lin_idx) -{ - CCat *&new_ccat = ccats2[Key2(ccat,lin_idx)]; - CCat *tmp = new_ccat; - if (new_ccat == NULL) { - new_ccat = new CCat(++ccat_id, ccat, lin_idx); - } - if (fold == PROBE) { - new_ccat->suspend_item(item); - } - if (tmp == NULL) { - size_t n_prods = ccat->prods.size(); - for (size_t i = 0; i < n_prods; i++) { - Production *prod = ccat->prods[i]; - Item *item = new(new_ccat, prod, lin_idx) Item; - process(NULL, PROBE, item); - delete item; - } - } - - if (fold == PROBE) { - if (item->ccat != NULL && new_ccat->productive) { - item->ccat->productive = true; - item->ccat->register_item(item); - } - } else { - if (new_ccat->productive) { - auto &next_state = state->ccats2[Key2(new_ccat,lin_idx)]; - if (next_state == NULL) { - next_state = new State; - } - next_state->push_item(new(item,lin_idx) Item); - - if (next_state->items.size() == 1) { - for (size_t i = 0; i < new_ccat->items.size(); i++) { - process(state, REPEAT, new_ccat->items[i]); + } else { + State *next = state; + while (next != NULL) { + Cont *cont = next->conts2[ccat]; + if (cont != NULL) { + for (auto it1 : cont->suspended) { + for (auto it2 : it1.second) { + Item *item = it2.second[0]; + auto symcat = ref::untagged(item->syms[item->dot]); + td_predict(next,cont,prod,item,symcat); + } + } } + next = next->next; } } - if (fold == INIT && new_ccat->prods.size() > 0) { - Item *new_item = new (item, new_ccat) Item; - process(state, fold, new_item); - delete new_item; - } + break; } + case PgfConcrLincat::tag: { + auto lincat = ref::untagged(item->rule->container); + interval_t zero = {0,0}; + final_item(state, NULL, item, zero, zero); + break; + } + } + + delete item; } -void PgfLRTableMaker::predict(ref absfun, CCat *ccat) +#define ZERO_VALUES(rule) \ + ((size_t*) memset(alloca(rule->ranges.size()*sizeof(size_t)), 0, rule->ranges.size()*sizeof(size_t))) +#define CLONE_VALUES(rule,values) \ + ((size_t*) memcpy(alloca(rule->ranges.size()*sizeof(size_t)), values, rule->ranges.size()*sizeof(size_t))) + +bool PgfAbstractParser::instantiate(ref rule1, size_t *values1, ref lparam1, + ref rule2, size_t *values2, ref lparam2) { - ref lin = - namespace_lookup(concr->lins, &absfun->name); - - if (lin != 0) { - ccat->lincat = lin->lincat; - - size_t n_fields = lin->seqs.size() / lin->res.size(); - for (size_t i = 0; i < lin->res.size(); i++) { - size_t seq_idx = n_fields * i + ccat->lin_idx; - Item *item = new(ccat, lin, seq_idx) Item; - process(NULL, PROBE, item); - delete item; + size_t i01 = lparam1->i0; + for (size_t i = 0; i < lparam1->n_terms; i++) { + if (values1[lparam1->terms[i].var] > 0) { + i01 += lparam1->terms[i].factor * (values1[lparam1->terms[i].var]-1); } } -} -void PgfLRTableMaker::complete(State *state, Fold fold, Item *item) -{ - if (fold == PROBE) { - Production *prod = new(item) Production; - item->ccat->prods.push_back(prod); + size_t i02 = lparam2->i0; + for (size_t i = 0; i < lparam2->n_terms; i++) { + if (values2[lparam2->terms[i].var] > 0) { + i02 += lparam2->terms[i].factor * (values2[lparam2->terms[i].var]-1); + } + } -#if defined(DEBUG_STATE_CREATION) || defined(DEBUG_AUTOMATON) - print_production(item->ccat, prod); -#endif + if (i01 > i02) { + i01 -= i02; + i02 = 0; + } else { + i02 -= i01; + i01 = 0; + } - if (item->ccat->prods.size() == 1) { - // If this is the first epsilon production, - // resume the suspended items. - - // We don't use an iterator here since the vector suspended, - // may get updated in the recursion. - size_t n_susp = item->ccat->suspended.size(); - for (size_t i = 0; i < n_susp; i++) { - Item *susp = item->ccat->suspended[i]; - if (susp != NULL) { - Item *new_item = new (susp, item->ccat) Item; - process(state, PROBE, new_item); - delete new_item; - } + size_t i1 = 0, i2 = 0; + while (i1 < lparam1->n_terms || i2 < lparam2->n_terms) { + size_t scale1 = 0; + term t1 = {0,0}; + if (i1 < lparam1->n_terms) { + t1 = lparam1->terms[i1]; + if (values1[t1.var] > 0) { + i1++; + continue; } - } - } else { - state->completed.push_back(item); item->ref_cnt++; - -#if defined(DEBUG_AUTOMATON) - fprintf(stderr, "reduce "); - print_item(item); -#endif - } -} - -void PgfLRTableMaker::internalize_state(State *&state) -{ - MD5Context ctxt; - auto begin = state->items.begin(); - auto end = state->items.end(); - while (begin != end) { - Item *item = *(--end); - ctxt.update(item->lin_obj); - ctxt.update(item->seq_idx); - ctxt.update(item->sym_idx); - for (size_t i = 0; i < item->args.count; i++) { - ctxt.update(item->args[i].ccat); - ctxt.update(item->args[i].stk_idx); - } - for (size_t i = 0; i < item->vals.count; i++) { - ctxt.update(item->vals[i]); + scale1 = t1.factor * rule1->ranges[t1.var]; } - pop_heap(begin,end,compare_item); - } - - MD5Digest digest; - ctxt.finalize(&digest); - - State *&next_state = states[digest]; - if (next_state == NULL) { - next_state = state; - next_state->id = ++state_id; - todo.push(next_state); - } else { - delete state; - state = next_state; - } -} - -vector PgfLRTableMaker::make() -{ - while (!todo.empty()) { - State *state = todo.front(); todo.pop(); - -#if defined(DEBUG_AUTOMATON) || defined(DEBUG_STATE_CREATION) - fprintf(stderr, "--------------- state %ld ---------------\n", state->id); -#endif - - while (!state->items.empty()) { - Item *item = state->pop_item(); - -#if defined(DEBUG_AUTOMATON) && !defined(DEBUG_STATE_CREATION) - // The order in which we process the items should not matter, - // For debugging however it is useful to see them in the same order. - pop_heap(state->items.begin(),state->items.end(),compare_item); - print_item(item); -#endif - - process(state, INIT, item); - - delete item; + size_t scale2 = 0; + term t2 = {0,0}; + if (i2 < lparam2->n_terms) { + t2 = lparam2->terms[i2]; + if (values2[t2.var] > 0) { + i2++; + continue; + } + scale2 = t2.factor * rule2->ranges[t2.var]; } - for (auto &i : state->ccats1) { - internalize_state(i.second); -#if defined(DEBUG_AUTOMATON) - fprintf(stderr, "%s.%zu: state %ld\n", - i.first.first->name.text, i.first.second, i.second->id); -#endif - } - for (auto &i : state->ccats2) { - internalize_state(i.second); -#if defined(DEBUG_AUTOMATON) - fprintf(stderr, "%s.%zu: state %ld\n", - i.first.first->lincat->name.text, i.first.second, i.second->id); -#endif - } - for (auto &i : state->tokens) { - internalize_state(i.second); -#if defined(DEBUG_AUTOMATON) - PgfPrinter printer(NULL, 0, NULL); - size_t sym_idx = i.first.second; - ref seq = i.first.first; - while (sym_idx < seq->syms.len) { - PgfSymbol sym = seq->syms.data[sym_idx]; - if (ref::get_tag(sym) != PgfSymbolKS::tag) + if (scale1 > scale2) { + size_t min = (i02 / t1.factor); + size_t max = min; + while (i2 < lparam2->n_terms) { + t2 = lparam2->terms[i2]; + size_t f = t2.factor / t1.factor; + if (f == 0) break; - printer.symbol(sym); - sym_idx++; - } - printer.nprintf(64, ": state %ld\n", i.second->id); - PgfText *text = printer.get_text(); - fputs(text->text, stderr); - free(text); -#endif - } - if (state->bind_state != NULL) { - internalize_state(state->bind_state); -#if defined(DEBUG_AUTOMATON) - fprintf(stderr, "BIND: state %ld\n", state->bind_state->id); -#endif - } - - } - - vector lrtable = vector::alloc(states.size()); - for (auto v : states) { - State *state = v.second; - - size_t index = 0; - auto shifts = vector::alloc(state->ccats1.size()+state->ccats2.size()); - for (auto i : state->ccats1) { - ref shift = shifts.elem(index++); - shift->lincat = i.first.first; - shift->r = i.first.second; - shift->next_state = i.second->id; - } - for (auto i : state->ccats2) { - ref shift = shifts.elem(index++); - shift->lincat = i.first.first->lincat; - shift->r = i.first.second; - shift->next_state = i.second->id; - } - - vector tokens = 0; - if (state->tokens.size() > 0) { - size_t index = 0; - tokens = vector::alloc(state->tokens.size()); - for (auto i : state->tokens) { - ref shift = tokens.elem(index++); - shift->seq = i.first.first; - shift->sym_idx = i.first.second; - shift->next_state = i.second->id; - } - } - - size_t next_bind_state = 0; - if (state->bind_state != NULL) { - next_bind_state = state->bind_state->id; - } - - auto reductions = vector::alloc(state->completed.size()); - for (size_t i = 0; i < state->completed.size(); i++) { - Item *item = state->completed[i]; - ref reduction = reductions.elem(i); - reduction->lin_obj = item->lin_obj; - reduction->seq_idx = item->seq_idx; - reduction->depth = item->stk_size; - - auto args = vector::alloc(item->args.count); - for (size_t j = 0; j < item->args.count; j++) { - ref arg = 0; - if (item->args[j].ccat != NULL) { - arg = item->args[j].ccat->persist(); + if (values2[t2.var] == 0) { + max += f * (rule2->ranges[t2.var]-1); } - args[j].arg = arg; - args[j].stk_idx = item->args[j].stk_idx; + i2++; } - reduction->args = args; + i02 %= t1.factor; + + if (min >= rule1->ranges[t1.var]) + return false; + + if (min == max) { + if (values1[t1.var] == 0) + values1[t1.var] = min+1; + else if (values1[t1.var] != min+1) + return false; + } + + i1++; + } else { + size_t min = (i01 / t2.factor); + size_t max = min; + while (i1 < lparam1->n_terms) { + t1 = lparam1->terms[i1]; + size_t f = t1.factor / t2.factor; + if (f == 0) + break; + + if (values1[t1.var] == 0) { + max += f * (rule1->ranges[t1.var]-1); + } + i1++; + } + i01 %= t2.factor; + + if (min >= rule2->ranges[t2.var]) + return false; + + if (min == max) { + if (values2[t2.var] == 0) { + values2[t2.var] = min+1; + } else if (values2[t2.var] != min+1) + return false; + } + + i2++; } - - ref lrstate = lrtable.elem(state->id); - lrstate->shifts = shifts; - lrstate->tokens = tokens; - lrstate->next_bind_state = next_bind_state; - lrstate->reductions = reductions; } - return lrtable; + + return (i01 == i02); } -PgfLCTableMaker::PgfLCTableMaker(ref abstr, ref concr) +interval_t PgfAbstractParser::interval(ref rule, size_t *values, ref lparam) { - this->abstr = abstr; - this->concr = concr; + interval_t interval; + interval.first = lparam->i0; + interval.second = interval.first; + for (size_t i = 0; i < lparam->n_terms; i++) { + size_t var = lparam->terms[i].var; + if (values[var] == 0) { + interval.second += lparam->terms[i].factor * (rule->ranges[var]-1); + } else { + size_t value = lparam->terms[i].factor * (values[var]-1); + interval.first += value; + interval.second += value; + } + } + return interval; } -PgfLCTableMaker::~PgfLCTableMaker() +void PgfAbstractParser::combine(State *state, Item *item, CCat *ccat) { + PgfSymbol sym = item->rule->syms[item->dot]; + auto sym_cat = ref::untagged(sym); + + ref rule; + size_t *values; + get_info(ccat, &rule,&values); + values = CLONE_VALUES(rule, values); + + if (!instantiate(item->rule, &item->vars[0], item->rule->args[sym_cat->d], + rule, values, rule->res)) { + delete item; + return; + } + if (!instantiate(item->rule, &item->vars[0], ref::from_ptr(&sym_cat->r), + rule, values, rule->lin_idx)) { + delete item; + return; + } + + item->dot++; + if (item->args[sym_cat->d] != NULL) { + item->inside_prob -= item->args[sym_cat->d]->viterbi_prob; + } + item->args[sym_cat->d] = ccat; + item->inside_prob += ccat->viterbi_prob; + state->push_item(item); } -static bool edge_match(ref edge1, ref edge2) +bool PgfAbstractParser::ItemComparator::operator()(Item *item1, Item *item2) { - size_t sz1 = sizeof(PgfLCEdge) + sizeof(term)*edge1->n_terms + sizeof(PgfVariableRange)*edge1->vars.size(); - size_t sz2 = sizeof(PgfLCEdge) + sizeof(term)*edge2->n_terms + sizeof(PgfVariableRange)*edge2->vars.size(); - - if (sz1 != sz2) + if (item1->rule.as_object() < item2->rule.as_object()) + return true; + else if (item1->rule.as_object() > item2->rule.as_object()) return false; - return (memcmp(&*edge1,&*edge2,sz1) == 0); + + for (size_t j = 0; j < item1->args.size(); j++) { + if (item1->args[j] < item2->args[j]) + return true; + else if (item1->args[j] > item2->args[j]) + return false; + } + + return false; } -int comp (const void * elem1, const void * elem2) +void PgfAbstractParser::td_epsilon(State *state, Cont *cont, ref pitem, Item *xitem, ref symcat) { - int f = *((int*)elem1); - int s = *((int*)elem2); - if (f > s) return 1; - if (f < s) return -1; - return 0; + switch (ref::get_tag(pitem->rule->container)) { + case PgfConcrLin::tag: { + auto lin = ref::untagged(pitem->rule->container); + + for (ref rule : lin->rules) { + size_t *values1 = ZERO_VALUES(rule); + size_t *values2 = CLONE_VALUES(xitem->rule, &xitem->vars[0]); + if (!instantiate(rule, values1, rule->res, + xitem->rule, values2, xitem->rule->args[symcat->d])) { + continue; + } + if (!instantiate(rule, values1, rule->lin_idx, + xitem->rule, values2, ref::from_ptr(&symcat->r))) { + continue; + } + + size_t *values3 = CLONE_VALUES(pitem->rule, &pitem->vars[0]); + for (size_t i = 0; i < pitem->args.size(); i++) { + if (!instantiate(rule, values1, rule->args[i], + pitem->rule, values3, pitem->rule->args[i])) { + goto next; + } + } + + { + Item *item = new (rule) Item; + item->cont = cont; + item->dot = 0; + item->pre_alt = 0; + item->pre_dot = 0; + item->syms = rule->syms.as_vector(); + item->rule = rule; + item->inside_prob = lin->absfun->prob; + item->outside_prob = xitem->outside_prob+xitem->inside_prob-xitem->args[symcat->d]->viterbi_prob; + + size_t *values3 = CLONE_VALUES(pitem->rule, &pitem->vars[0]); + for (size_t i = 0; i < pitem->args.size(); i++) { + if (pitem->args[i] != 0) { + if (!instantiate(rule, &item->vars[0], rule->args[i], + pitem->rule, values3, pitem->rule->args[i])) { + delete item; + goto next; + } + + item->args[i] = get_epsilon_ccat(&lin->absfun->type->hypos[i].type->name,pitem->args[i]); + item->inside_prob += item->args[i]->viterbi_prob; + } + } + + auto res = cont->predicted.insert(item); + if (res.second) { + state->push_item(item); + } else { + delete item; + } + } +next:; + } + } + default:; + // should not happend + } } -void PgfLCTableMaker::rename(ref edge) +void PgfAbstractParser::td_predict(State *state, Cont *cont, Production *prod, Item *xitem, ref symcat) { - size_t next_var = 0; - std::map subst; - for (size_t i = 0; i < edge->n_terms; i++) { - auto it = subst.find(edge->terms[i].var); - if (it == subst.end()) { - subst[edge->terms[i].var] = next_var; - edge->terms[i].var = next_var++; + switch (ref::get_tag(prod->rule->container)) { + case PgfConcrLin::tag: { + auto lin = ref::untagged(prod->rule->container); + + for (ref rule : lin->rules) { + size_t *values1 = ZERO_VALUES(rule); + size_t *values2 = CLONE_VALUES(xitem->rule, &xitem->vars[0]); + if (!instantiate(rule, values1, rule->res, + xitem->rule, values2, xitem->rule->args[symcat->d])) { + continue; + } + + if (!instantiate(rule, values1, rule->lin_idx, + xitem->rule, values2, ref::from_ptr(&symcat->r))) { + continue; + } + + size_t *values3 = CLONE_VALUES(prod->rule, &prod->vars[0]); + for (size_t i = 0; i < rule->args.size(); i++) { + if (!instantiate(rule, values1, rule->args[i], + prod->rule, values3, prod->rule->args[i])) { + goto next; + } + } + + { + Item *item = new (rule) Item; + item->cont = cont; + item->dot = 0; + item->pre_alt = 0; + item->pre_dot = 0; + item->syms = rule->syms.as_vector(); + item->rule = rule; + item->inside_prob = lin->absfun->prob; + item->outside_prob = xitem->outside_prob+xitem->inside_prob-xitem->args[symcat->d]->viterbi_prob; + + size_t *values3 = CLONE_VALUES(prod->rule, &prod->vars[0]); + for (size_t i = 0; i < rule->args.size(); i++) { + if (!instantiate(rule, &item->vars[0], rule->args[i], + prod->rule, values3, prod->rule->args[i])) { + delete item; + goto next; + } + + item->args[i] = prod->args[i]; + if (item->args[i] != NULL) { + item->inside_prob += item->args[i]->viterbi_prob; + } + } + + auto res = cont->predicted.insert(item); + if (res.second) { + state->push_item(item); + } else { + delete item; + } + } + +next:; + } + } + default:; + // should not happend + } +} + +#ifdef DEBUG_PARSER +static +void print_symbols(PgfPrinter &printer, PgfConcrRule *rule, vector syms, size_t pre_alt, size_t pre_dot, size_t dot) +{ + for (size_t i = 0; i < syms.size(); i++) { + if (pre_alt == 0 && dot == i) { + printer.puts(" . "); + printer.symbol(syms[i]); + } else if (pre_alt > 0 && pre_dot == i) { + auto sym_kp = ref::untagged(rule->syms[pre_dot]); + + printer.puts("pre {"); + + if (pre_alt == 1) + print_symbols(printer, rule, syms, 0, 0, dot); + else + printer.symbols(sym_kp->default_form); + + for (size_t i = 0; i < sym_kp->alts.size(); i++) { + printer.puts("; "); + if (pre_alt-2 == i) + print_symbols(printer, rule, syms, 0, 0, dot); + else + printer.symbols(sym_kp->alts[i].form); + printer.puts(" /"); + for (size_t j = 0; j < sym_kp->alts[i].prefixes.size(); j++) { + printer.puts(" "); + printer.lstr(sym_kp->alts[i].prefixes[j]); + } + } + + printer.puts("}"); } else { - edge->terms[i].var = it->second; + printer.symbol(syms[i]); } } - - for (size_t i = 0; i < edge->vars.size(); i++) { - edge->vars[i].var = subst[edge->vars[i].var]; - } - qsort (&edge->vars[0], edge->vars.size(), sizeof(PgfVariableRange), comp); + if (pre_alt == 0 && dot >= syms.size()) + printer.puts(" . "); } -void PgfLCTableMaker::add_edge(ref edge) +void PgfAbstractParser::print_item(Item *item, State *state) { - bool found = false; - for (ref xedge : forwards[edge->from.lincat]) { - if (edge_match(edge,xedge)) { - found = true; - break; - } + PgfPrinter printer(NULL,0,NULL); + + printer.nprintf(32, "[%zd-%zd; ", (item->cont && item->cont->state) ? item->cont->state->end.pos : 0, state->start.pos); + + if (item->vars.size() > 0) { + printer.lvar_ranges(item->rule->ranges, &item->vars[0]); + printer.puts(" "); } - if (!found) { - print_edge(edge); - forwards[edge->from.lincat].push_back(edge); - backwards[edge->to.lincat].push_back(edge); - update_closure(edge); - } -} - -void PgfLCTableMaker::update_closure(ref edge) -{ - auto &incoming = backwards[edge->from.lincat]; - size_t n_incoming = incoming.size(); - for (size_t i = 0; i < n_incoming; i++) { - ref xedge = compute_unifier(incoming[i],edge); - if (xedge != 0) { - rename(xedge); - add_edge(xedge); - } - } - - auto &outgoing = forwards[edge->to.lincat]; - size_t n_outgoing = outgoing.size(); - for (size_t i = 0; i < n_outgoing; i++) { - ref xedge = compute_unifier(edge,outgoing[i]); - if (xedge != 0) { - rename(xedge); - add_edge(xedge); - } - } -} - -typedef std::pair> Param; -typedef std::map Subst; - -template -bool unifier_helper1(Subst &subst1, V &vars1, T &to, - Subst &subst2, V &vars2, F &from) -{ - size_t i01t = to.i0; - size_t i02f = from.i0; - - size_t i = 0, j = 0; - while (i < to.size() && j < from.size()) { - size_t factor1 = to[i].factor; - size_t range1 = 0; - for (size_t k = 0; k < vars1.size(); k++) { - if (vars1[k].var == to[i].var) { - range1 = vars1[k].range; - break; - } - } - size_t value1 = factor1*range1; - - size_t factor2 = from[j].factor; - size_t range2 = 0; - for (size_t k = 0; k < vars2.size(); k++) { - if (vars2[k].var == from[j].var) { - range2 = vars2[k].range; - break; - } - } - size_t value2 = factor2*range2; - - if (value1 > value2) { - size_t x = i02f / factor1; - if (x >= range1) - return false; - auto &s = subst1[to[i].var]; - s.first = i02f / factor1; - s.second.clear(); - i02f %= factor1; - while (j < from.size() && factor2 % factor1 == 0) { - size_t factor = factor2 / factor1; - s.second.emplace_back(); - s.second.back().factor=factor; - s.second.back().var=subst2[from[j].var].second[0].var; - j++; - factor2 = from[j].factor; - } - i++; + if (item->cont) { + if (item->cont->ccat == NULL) { + printer.efun(&item->cont->lincat->name); } else { - size_t x = i01t / factor2; - if (x >= range2) - return false; - auto &s = subst2[from[j].var]; - s.first = i01t / factor2; - s.second.clear(); - i01t %= factor2; - while (i < to.size() && factor1 % factor2 == 0) { - size_t factor = factor1 / factor2; - s.second.emplace_back(); - s.second.back().factor=factor; - s.second.back().var=subst1[to[i].var].second[0].var; - i++; - factor1 = to[i].factor; - } - j++; + printer.emeta(item->cont->ccat->fid); } + printer.puts("("); + printer.lparam(item->rule->res); + printer.puts(")"); } + printer.puts(" -> "); - while (i < to.size()) { - auto &s = subst1[to[i].var]; - size_t factor1 = to[i].factor; - s.first = i02f / factor1; - s.second.clear(); - i02f %= factor1; - i++; - } + switch (ref::get_tag(item->rule->container)) { + case PgfConcrLin::tag: { + auto lin = ref::untagged(item->rule->container); + printer.efun(&lin->name); - while (j < from.size()) { - auto &s = subst2[from[j].var]; - size_t factor2 = from[j].factor; - s.first = i01t / factor2; - s.second.clear(); - i01t %= factor2; - j++; - } - - return (i01t == i02f); -} - -template -void unifier_helper2(Subst &subst, std::map &vars, std::map &ranges, A &v, Param &p) -{ - for (size_t i = 0; i < v.size(); i++) { - auto &s = subst[v[i].var]; - size_t factor = v[i].factor; - p.first += factor * s.first; - for (term &t : s.second) { - p.second.emplace_back(); - p.second.back().factor = factor * t.factor; - p.second.back().var = t.var; - vars[t.var] = ranges[t.var]; - } - } -} - -ref PgfLCTableMaker::compute_unifier(ref edge1, ref edge2) -{ - std::map>> subst1, subst2; - std::map vars, ranges; - - size_t next_var = 0; - for (size_t i = 0; i < edge1->vars.size(); i++) { - ranges[next_var] = edge1->vars[i].range; - - auto &s = subst1[edge1->vars[i].var]; - s.second.emplace_back(); - s.second.back().factor = 1; - s.second.back().var = next_var++; - } - for (size_t i = 0; i < edge2->vars.size(); i++) { - ranges[next_var] = edge2->vars[i].range; - - auto &s = subst2[edge2->vars[i].var]; - s.second.emplace_back(); - s.second.back().factor = 1; - s.second.back().var = next_var++; - } - - if (!unifier_helper1(subst1, edge1->vars, edge1->to.value, - subst2, edge2->vars, edge2->from.value)) - return 0; - if (!unifier_helper1(subst1, edge1->vars, edge1->to.lin_idx, - subst2, edge2->vars, edge2->from.lin_idx)) - return 0; - - Param p1fv,p1fi,p2tv,p2ti; - p1fv.first = edge1->from.value.i0; - p1fi.first = edge1->from.lin_idx.i0; - p2tv.first = edge2->to.value.i0; - p2ti.first = edge2->to.lin_idx.i0; - - unifier_helper2(subst1, vars, ranges, edge1->from.value, p1fv); - unifier_helper2(subst1, vars, ranges, edge1->from.lin_idx, p1fi); - unifier_helper2(subst2, vars, ranges, edge2->to.value, p2tv); - unifier_helper2(subst2, vars, ranges, edge2->to.lin_idx, p2ti); - - ref edge = PgfLCEdge::alloc(p1fv.second.size(),p1fi.second.size(),p2tv.second.size(),p2ti.second.size(),vars.size()); - edge->from.lincat = edge1->from.lincat; - edge->from.value.i0 = p1fv.first; - for (size_t i = 0; i < p1fv.second.size(); i++) { - edge->from.value[i] = p1fv.second[i]; - } - edge->from.lin_idx.i0 = p1fi.first; - for (size_t i = 0; i < p1fi.second.size(); i++) { - edge->from.lin_idx[i] = p1fi.second[i]; - } - edge->to.lincat = edge2->to.lincat; - edge->to.value.i0 = p2tv.first; - for (size_t i = 0; i < p2tv.second.size(); i++) { - edge->to.value[i] = p2tv.second[i]; - } - edge->to.lin_idx.i0 = p2ti.first; - for (size_t i = 0; i < p2ti.second.size(); i++) { - edge->to.lin_idx[i] = p2ti.second[i]; - } - size_t i = 0; - for (auto it : vars) { - edge->vars[i].var = it.first; - edge->vars[i].range = it.second; - i++; - } -/* - if (strcmp(edge->to.lincat->name.text, "VP") == 0 && edge->to.value.i0 == 2 && edge->to.value.size() == 2) { - print_edge(edge1); - print_edge(edge2); - fprintf(stderr,"------------------\n"); - print_edge(edge); - fprintf(stderr,"\n"); - } -*/ - return edge; -} - -void PgfLCTableMaker::print_edge(ref edge) -{ - PgfPrinter printer(NULL, 0, NULL); - - if (edge->vars.size() > 0) { - printer.puts("{"); - for (size_t i = 0; i < edge->vars.size(); i++) { + printer.puts("["); + for (size_t i = 0; i < item->args.size(); i++) { if (i > 0) printer.puts(","); - printer.lvar(edge->vars[i].var); - printer.nprintf(32,"<%zu",edge->vars[i].range); - } - printer.puts("} "); - } - printer.efun(&edge->from.lincat->name); - printer.puts("("); - if (edge->from.value.i0 != 0 || edge->from.value.size() == 0) - printer.nprintf(32,"%ld",edge->from.value.i0); - for (size_t i = 0; i < edge->from.value.size(); i++) { - if (edge->from.value.i0 != 0 || i > 0) - printer.puts("+"); - if (edge->from.value[i].factor != 1) { - printer.nprintf(32,"%ld",edge->from.value[i].factor); - printer.puts("*"); - } - printer.lvar(edge->from.value[i].var); - } - printer.puts(","); - if (edge->from.lin_idx.i0 != 0 || edge->from.lin_idx.size() == 0) - printer.nprintf(32,"%ld",edge->from.lin_idx.i0); - for (size_t i = 0; i < edge->from.lin_idx.size(); i++) { - if (edge->from.lin_idx.i0 != 0 || i > 0) - printer.puts("+"); - if (edge->from.lin_idx[i].factor != 1) { - printer.nprintf(32,"%ld",edge->from.lin_idx[i].factor); - printer.puts("*"); - } - printer.lvar(edge->from.lin_idx[i].var); - } - printer.puts(") -> "); - - printer.efun(&edge->to.lincat->name); - printer.puts("("); - if (edge->to.value.i0 != 0 || edge->to.value.size() == 0) - printer.nprintf(32,"%ld",edge->to.value.i0); - for (size_t i = 0; i < edge->to.value.size(); i++) { - if (edge->to.value.i0 != 0 || i > 0) - printer.puts("+"); - if (edge->to.value[i].factor != 1) { - printer.nprintf(32,"%ld",edge->to.value[i].factor); - printer.puts("*"); - } - printer.lvar(edge->to.value[i].var); - } - printer.puts(","); - if (edge->to.lin_idx.i0 != 0 || edge->to.lin_idx.size() == 0) - printer.nprintf(32,"%ld",edge->to.lin_idx.i0); - for (size_t i = 0; i < edge->to.lin_idx.size(); i++) { - if (edge->to.lin_idx.i0 != 0 || i > 0) - printer.puts("+"); - if (edge->to.lin_idx[i].factor != 1) { - printer.nprintf(32,"%ld",edge->to.lin_idx[i].factor); - printer.puts("*"); - } - printer.lvar(edge->to.lin_idx[i].var); - } - printer.puts(")\n"); - - PgfText *text = printer.get_text(); - fputs(text->text, stderr); - free(text); -} - -vector PgfLCTableMaker::make() -{ - std::function)> f = - [this](ref lin) { - for (size_t seq_idx = 0; seq_idx < lin->seqs.size(); seq_idx++) { - size_t index = seq_idx / (lin->seqs.size() / lin->res.size()); - size_t n_args = (lin->args.size() / lin->res.size()); - ref res = lin->res[index]; - ref seq = lin->seqs[seq_idx]; - - if (seq->syms.size() > 0) { - PgfSymbol sym = seq->syms[0]; - switch (ref::get_tag(sym)) { - case PgfSymbolCat::tag: { - auto sym_cat = ref::untagged(sym); - size_t arg_idx = n_args * index + sym_cat->d; - ref arg = ref::from_ptr(&lin->args[arg_idx]); - - std::set vars; - for (size_t i = 0; i < res->param.n_terms; i++) { - vars.insert(res->param.terms[i].var); - } - for (size_t i = 0; i < arg->param->n_terms; i++) { - vars.insert(arg->param->terms[i].var); - } - for (size_t i = 0; i < sym_cat->r.n_terms; i++) { - vars.insert(sym_cat->r.terms[i].var); - } - - ref edge = - PgfLCEdge::alloc(res->param.n_terms,0,arg->param->n_terms,sym_cat->r.n_terms,vars.size()); - edge->from.lincat = lin->lincat; - edge->from.value.i0 = res->param.i0; - for (size_t i = 0; i < res->param.n_terms; i++) { - edge->from.value[i] = res->param.terms[i]; - } - edge->from.lin_idx.i0 = seq_idx % (lin->seqs.size() / lin->res.size()); - edge->to.lincat = - namespace_lookup(concr->lincats, &lin->absfun->type->hypos[sym_cat->d].type->name); - edge->to.value.i0 = arg->param->i0; - for (size_t i = 0; i < arg->param->n_terms; i++) { - edge->to.value[i] = arg->param->terms[i]; - } - edge->to.lin_idx.i0 = sym_cat->r.i0; - for (size_t i = 0; i < sym_cat->r.n_terms; i++) { - edge->to.lin_idx[i] = sym_cat->r.terms[i]; - } - size_t i = 0; - for (size_t var : vars) { - edge->vars[i].var = var; - for (size_t k = 0; k < res->vars.size(); k++) { - if (res->vars[k].var == var) { - edge->vars[i].range = res->vars[k].range; - break; - } - } - i++; - } - - rename(edge); - add_edge(edge); - } - break; - } - } + CCat *ccat = item->args[i]; + if (ccat == NULL) { + printer.efun(&lin->absfun->type->hypos[i].type->name); + } else { + printer.emeta(ccat->fid); } - return true; - }; - namespace_iter(concr->lins, f); - -/* for (auto it : forwards) { - for (ref edge : it.second) { - print_edge(edge); + printer.puts("("); + printer.lparam(item->rule->args[i]); + printer.puts(")"); } + printer.puts("]; "); + break; } -*/ - return 0; -} + case PgfConcrLincat::tag: { + auto lincat = ref::untagged(item->rule->container); + printer.puts("linref "); + printer.efun(&lincat->name); -struct PgfParser::Choice { - int fid; - std::vector prods; - std::vector states; - std::vector exprs; - - Choice(int fid) { - this->fid = fid; - } - - ~Choice(); -}; - -struct PgfParser::Production { - ref lin; - size_t index; - size_t n_args; - Choice *args[]; - - void *operator new(size_t size, ref lin, size_t index) { - size_t n_args = lin->args.size() / lin->res.size(); - Production *prod = (Production *) - malloc(size+sizeof(Choice*)*n_args); - prod->lin = lin; - prod->index = index; - prod->n_args = n_args; - for (size_t i = 0; i < n_args; i++) { - prod->args[i] = NULL; - } - return prod; - } - - Production() { - // If there is no constructor, GCC will zero the object, - // while it has already been initialized in the new operator. - } - - bool operator==(const Production& other) const { - if (lin != other.lin || index != other.index) - return false; - - for (size_t i = 0; i < n_args; i++) { - if (args[i] != other.args[i]) - return false; - } - - return true; - } - - void operator delete(void *p) { - free(p); - } -}; - -struct PgfParser::StackNode { - Stage *stage; - size_t state_id; - Choice *choice; - std::vector parents; - - StackNode(Stage *stage, size_t state_id) { - this->stage = stage; - this->state_id = state_id; - this->choice = NULL; - } -}; - -struct PgfParser::Stage { - Stage *next; - PgfTextSpot start; - PgfTextSpot end; - std::vector nodes; - - Stage(PgfTextSpot spot) { - next = NULL; - start = spot; - end = spot; - } - - ~Stage() { - for (StackNode *node : nodes) { - delete node; - } - } -}; - -struct PgfParser::ExprState { - prob_t prob; - - Choice *choice; - Production *prod; - size_t n_args; - PgfExpr expr; -}; - -struct PgfParser::ExprInstance { - PgfExpr expr; - prob_t prob; - - ExprInstance(PgfExpr expr, prob_t prob) { - this->expr = expr; - this->prob = prob; - } -}; - -PgfParser::Choice::~Choice() { - while (states.size() > 0) { - ExprState *state = states.back(); states.pop_back(); - delete state; - } - - for (Production *prod : prods) { - delete prod; - } -} - -#if defined(DEBUG_STATE_CREATION) || defined(DEBUG_AUTOMATON) || defined(DEBUG_PARSER) -void PgfParser::print_prod(Choice *choice, Production *prod) -{ - PgfPrinter printer(NULL, 0, m); - - printer.nprintf(32, "?%d -> ", choice->fid); - - ref type = prod->lin->absfun->type; - printer.puts(&prod->lin->name); - printer.nprintf(32,"/%zd[", prod->index); - PgfDBMarshaller m; - for (size_t i = 0; i < prod->n_args; i++) { - Choice *choice = prod->args[i]; - if (i > 0) - printer.puts(","); - if (choice == NULL) { - m.match_type(&printer, vector_elem(type->hypos, i)->type.as_object()); + printer.puts("["); + CCat *ccat = item->args[0]; + if (ccat == NULL) { + printer.efun(&lincat->name); + printer.puts("("); + printer.lparam(item->rule->args[0]); + printer.puts(")"); } else { - printer.nprintf(32, "?%d", choice->fid); + printer.emeta(ccat->fid); } + printer.puts("]; "); + break; } - printer.puts("]\n"); + } + + printer.lparam(item->rule->lin_idx); + printer.puts(" : "); + print_symbols(printer, item->rule, item->syms, item->pre_alt, item->pre_dot, item->dot); + printer.nprintf(40,"; %f+%f=%f]", item->inside_prob, item->outside_prob, item->inside_prob+item->outside_prob); PgfText *text = printer.get_text(); - fputs(text->text, stderr); + fprintf(stderr, "%s\n", text->text); free(text); } -void PgfParser::print_transition(StackNode *source, StackNode *target, Stage *stage, ref shift) +void PgfAbstractParser::print_prod(CCat *ccat, Production *prod) { - PgfPrinter printer(NULL, 0, m); - printer.nprintf(64, "state %ld --- ", source->state_id); - if (target->choice != 0) { - printer.nprintf(32, "?%d", target->choice->fid); - } else if (shift != 0) { - size_t sym_idx = shift->sym_idx; - ref seq = shift->seq; - while (sym_idx < seq->syms.len) { - PgfSymbol sym = seq->syms.data[sym_idx]; - if (ref::get_tag(sym) != PgfSymbolKS::tag) - break; - printer.symbol(sym); - sym_idx++; - } - } else { - printer.puts("BIND"); + PgfPrinter printer(NULL,0,NULL); + + if (prod->vars.size() > 0) { + printer.lvar_ranges(prod->rule->ranges, &prod->vars[0]); + printer.puts(" "); } - printer.nprintf(80, " ---> state %ld (position %zu-%zu, nodes %zu)\n", - target->state_id, - stage->start.pos, stage->end.pos, stage->nodes.size()); + + printer.emeta(ccat->fid); + printer.puts("("); + printer.lparam(prod->rule->res); + printer.puts(")"); + + printer.puts(" -> "); + + switch (ref::get_tag(prod->rule->container)) { + case PgfConcrLin::tag: { + auto lin = ref::untagged(prod->rule->container); + printer.efun(&lin->name); + + printer.puts("["); + for (size_t i = 0; i < prod->args.size(); i++) { + if (i > 0) + printer.puts(","); + + CCat *ccat = prod->args[i]; + if (ccat == NULL) { + printer.efun(&lin->absfun->type->hypos[i].type->name); + } else { + printer.emeta(ccat->fid); + } + printer.puts("("); + printer.lparam(prod->rule->args[i]); + printer.puts(")"); + } + printer.puts("]"); + break; + } + case PgfConcrLincat::tag: { + auto lincat = ref::untagged(prod->rule->container); + printer.puts("linref "); + printer.efun(&lincat->name); + + printer.puts("["); + CCat *ccat = prod->args[0]; + if (ccat == NULL) { + printer.efun(&lincat->name); + printer.puts("("); + printer.lparam(prod->rule->args[0]); + printer.puts(")"); + } else { + printer.emeta(ccat->fid); + } + printer.puts("]"); + break; + } + } + PgfText *text = printer.get_text(); - fputs(text->text, stderr); + fprintf(stderr, "%s\n", text->text); free(text); } #endif -PgfParser::PgfParser(ref concr, ref start, PgfText *sentence, bool case_sensitive, PgfMarshaller *m, PgfUnmarshaller *u) +PgfParser::PgfParser(ref concr, PgfText *sentence, bool case_sensitive, PgfMarshaller *m, PgfUnmarshaller *u) + : PgfAbstractParser(concr) { - this->concr = concr; - this->sentence = sentence; - this->case_sensitive = case_sensitive; this->m = m; this->u = u; - this->last_fid = 0; - this->top_choice = NULL; - this->top_choice_index = 0; - - PgfTextSpot spot; - spot.pos = 0; - spot.ptr = (uint8_t*) sentence->text; - - this->before = new Stage(spot); - this->after = NULL; - this->ahead = NULL; - - StackNode *node = new StackNode(before, 0); - this->before->nodes.push_back(node); + this->sentence = textdup(sentence); + this->end = (uint8_t *) (this->sentence->text+this->sentence->size); + this->case_sensitive = case_sensitive; } -bool PgfParser::shift(StackNode *parent, ref lincat, size_t r, Production *prod, - Stage *before, Stage *after) +PgfParser::~PgfParser() { - vector shifts = concr->lrtable[parent->state_id].shifts; - for (size_t i = 0; i < shifts.size(); i++) { - ref shift = shifts.elem(i); - if (lincat == shift->lincat && r == shift->r) { - StackNode *node = NULL; - for (StackNode *n : after->nodes) { - if (n->stage == before && n->state_id == shift->next_state) { - node = n; - break; - } - } - if (node == NULL) { - node = new StackNode(before, shift->next_state); - node->choice = new Choice(++last_fid); - dynamic.push_back(node->choice); - after->nodes.push_back(node); - } + free(sentence); - bool added = true; - for (Production *other : node->choice->prods) { - if (*prod == *other) { - added = false; - break; - } - } + State *state = current_state; + while (state != NULL) { + for (auto it1 : state->completed) { + for (auto it2 : it1.second) { + for (auto it3 : it2.second) { + if (it3.second->epsilon != 0) + continue; - if (added) { - node->choice->prods.push_back(prod); -#ifdef DEBUG_PARSER - print_prod(node->choice, prod); -#endif - } - - if (std::find(node->parents.begin(), node->parents.end(), parent) == node->parents.end()) { - node->parents.push_back(parent); -#ifdef DEBUG_PARSER - print_transition(parent,node,after,0); -#endif - } - - return added; - } - } - - return false; -} - -void PgfParser::shift(StackNode *parent, Stage *before) -{ - vector shifts = concr->lrtable[parent->state_id].tokens; - if (shifts != 0) { - const uint8_t *sent_end = (const uint8_t *) &sentence->text[sentence->size]; - for (size_t i = 0; i < shifts.size(); i++) { - ref shift = shifts.elem(i); - PgfTextSpot spot = before->end; - size_t sym_idx = shift->sym_idx; - int cmp = - text_sequence_cmp(&spot, sent_end, - shift->seq, &sym_idx, - case_sensitive, SM_PARTIAL); - if (cmp == 0) { - start_matches(&spot, NULL); - - StackNode *node = NULL; - for (StackNode *n : after->nodes) { - if (n->stage == before && n->state_id == shift->next_state) { - node = n; - break; + for (ExprState *estate : it3.second->pending) { + if (estate->expr != 0) + u->free_ref(estate->expr); + } + for (ExprProb &ep : it3.second->exprs) { + u->free_ref(ep.expr); } } - if (node == NULL) { - node = new StackNode(before, shift->next_state); - node->choice = NULL; - after->nodes.push_back(node); - } - - if (std::find(node->parents.begin(), node->parents.end(), parent) == node->parents.end()) { - node->parents.push_back(parent); -#ifdef DEBUG_PARSER - print_transition(parent,node,after,shift); -#endif - } - - end_matches(&spot, NULL); } } + + state = state->next; + } + + for (auto it1 : epsilons) { + for (ExprState *estate : it1.second->pending) { + if (estate->expr != 0) + u->free_ref(estate->expr); + } + for (ExprProb &ep : it1.second->exprs) { + u->free_ref(ep.expr); + } } } -void PgfParser::shift(StackNode *parent, Stage *before, Stage *after) +void PgfParser::bu_predict(PgfPhrasetable phrasetable, + State *state, prob_t outside_prob, + ptrdiff_t min, ptrdiff_t max) { - size_t next_bind_state = concr->lrtable[parent->state_id].next_bind_state; - if (next_bind_state != 0) { - StackNode *node = NULL; - for (StackNode *n : after->nodes) { - if (n->stage == before && n->state_id == next_bind_state) { - node = n; - break; - } - } - if (node == NULL) { - node = new StackNode(before, next_bind_state); - node->choice = NULL; - after->nodes.push_back(node); - } - - if (std::find(node->parents.begin(), node->parents.end(), parent) == node->parents.end()) { - node->parents.push_back(parent); -#ifdef DEBUG_PARSER - print_transition(parent,node,after,0); -#endif - } - } -} - -PgfParser::Choice *PgfParser::intersect_choice(Choice *choice1, Choice *choice2, intersection_map &im) -{ - if (choice1 == NULL) - return choice2; - if (choice2 == NULL) - return choice1; - if (choice1 == choice2) - return choice1; - - std::pair key(choice1,choice2); - auto it = im.find(key); - if (it != im.end()) { - return it->second; - } - - Choice *choice = new Choice(++last_fid); - dynamic.push_back(choice); - im[key] = choice; - for (Production *prod1 : choice1->prods) { - for (Production *prod2 : choice2->prods) { - if (prod1->lin == prod2->lin && prod1->index == prod2->index) { - Production *prod = new(prod1->lin,prod1->index) Production(); - choice->prods.push_back(prod); - - for (size_t i = 0; i < prod->n_args; i++) { - Choice *arg = intersect_choice(prod1->args[i],prod2->args[i],im); - if (arg == NULL) { - //delete choice; - return NULL; - } - prod->args[i] = arg; - } - -#ifdef DEBUG_PARSER - print_prod(choice, prod); -#endif - } - } - } - - return choice; -} - -void PgfParser::reduce(StackNode *parent, ref lin, ref red, - size_t n, std::vector &args, - Stage *before, Stage *after) -{ - if (n == 0) { - ref lincat = lin->lincat; - - size_t index = red->seq_idx / lincat->fields.size(); - size_t r = red->seq_idx % lincat->fields.size(); - Production *prod = new(lin,index) Production(); - - for (size_t i = 0; i < prod->n_args; i++) { - auto arg = red->args.elem(i); - - if (arg->stk_idx > 0) { - Choice *choice = args[red->depth-arg->stk_idx]; - if (choice != NULL) { - intersection_map im; - choice = intersect_choice(choice, prod->args[i], im); - if (choice == NULL) { - //delete prod; - return; - } - } - prod->args[i] = choice; - } - if (arg->arg != 0) { - Choice *choice = retrieve_choice(arg->arg); - if (choice != NULL) { - intersection_map im; - choice = intersect_choice(choice, prod->args[i], im); - if (choice == NULL) { - //delete prod; - return; - } - } - prod->args[i] = choice; - } - } - - if (!shift(parent, lincat, r, prod, before, after)) { - delete prod; - } + if (phrasetable == 0) return; - } - args.push_back(parent->choice); - for (auto node : parent->parents) { - reduce(node, lin, red, n-1, args, parent->stage, after); - } - args.pop_back(); -} + PgfTextSpot current = state->end; + int cmp = text_symbol_cmp(¤t,end,phrasetable->value.key,case_sensitive); + if (cmp < 0) { + bu_predict(phrasetable->left,state,outside_prob,min,max); + } else if (cmp > 0) { + ptrdiff_t len = current.ptr - state->end.ptr; -PgfParser::Choice *PgfParser::retrieve_choice(ref arg) -{ - if (arg == 0) - return NULL; + if (min <= len-1) + bu_predict(phrasetable->left,state,outside_prob,min,len-1); - Choice *&tmp = persistant[arg.tagged()]; - Choice *choice = tmp; - if (choice == NULL) { - tmp = new Choice(++last_fid); choice = tmp; - for (size_t i = 0; i < arg->n_prods; i++) { - Production *prod = new(arg->prods[i].lin, arg->prods[i].index) Production(); - for (size_t j = 0; j < prod->n_args; j++) { - auto child = arg->prods[i].args[j]; - prod->args[j] = retrieve_choice(child); - } - choice->prods.push_back(prod); -#ifdef DEBUG_PARSER - print_prod(choice, prod); -#endif - } - } - - return choice; -} - -void PgfParser::complete(StackNode *parent, ref lincat, size_t r, - size_t n, std::vector &args) -{ - if (n == 0) { - top_choice = args[0]; - return; - } - - args.push_back(parent->choice); - for (auto node : parent->parents) { - complete(node, lincat, r, n-1, args); - } - args.pop_back(); -} - -void PgfParser::reduce_all(StackNode *node) -{ - vector reductions = concr->lrtable[node->state_id].reductions; - for (size_t j = 0; j < reductions.size(); j++) { - ref red = reductions.elem(j); - switch (ref::get_tag(red->lin_obj)) { - case PgfConcrLin::tag: { - auto lin = - ref::untagged(red->lin_obj); - std::vector args; - reduce(node, lin, red, red->depth, args, before, before); - break; - } - case PgfConcrLincat::tag: { - auto lincat = - ref::untagged(red->lin_obj); - std::vector args; - if (before->end.pos == sentence->size) { - complete(node, lincat, red->seq_idx % lincat->fields.size(), red->depth, args); - } - } - } - } -} - -void PgfParser::space(PgfTextSpot *start, PgfTextSpot *end, PgfExn* err) -{ -#ifdef DEBUG_PARSER - fprintf(stderr, "------------------ position %zu-%zu ------------------\n", - start->pos, end->pos); -#endif - - while (ahead != NULL && ahead->start.pos <= start->pos) { - Stage *tmp = ahead->next; - ahead->next = before; - before = ahead; - ahead = tmp; - } - - before->end = *end; - - if (before->next != NULL && before->start.pos==before->end.pos) { - after = new Stage(*end); - after->next = before; - size_t i = 0; - while (i < before->nodes.size()) { - StackNode *node = before->nodes[i++]; - reduce_all(node); - shift(node, before, after); - } - before = after; - } - - size_t i = 0; - while (i < before->nodes.size()) { - StackNode *node = before->nodes[i++]; - reduce_all(node); - shift(node, before); - } -} - -void PgfParser::start_matches(PgfTextSpot *end, PgfExn* err) -{ - Stage **last = &ahead; after = *last; - while (after != NULL && after->start.pos < end->pos) { - last = &after->next; after = *last; - } - - if (after == NULL) { - *last = new Stage(*end); - after = *last; - } -} - -void PgfParser::match(ref lin, size_t seq_index, PgfExn* err) -{ - size_t index = seq_index / lin->lincat->fields.size(); - size_t r = seq_index % lin->lincat->fields.size(); - - for (StackNode *parent : before->nodes) { - Production *prod = new(lin,index) Production(); - if (!shift(parent, lin->lincat, r, prod, before, after)) { - delete prod; - } - } -} - -void PgfParser::end_matches(PgfTextSpot *end, PgfExn* err) -{ -} - -bool PgfParser::CompareExprState::operator() (const ExprState *state1, const ExprState *state2) const { - return state1->prob > state2->prob; -} - -void PgfParser::prepare() -{ - if (top_choice != NULL) - predict_expr_states(top_choice, 0); -} - -void PgfParser::predict_expr_states(Choice *choice, prob_t outside_prob) -{ - for (Production *prod : choice->prods) { - ExprState *state = new ExprState; - state->choice = choice; - state->prod = prod; - state->n_args = 0; - state->expr = u->efun(&prod->lin->name); - state->prob = outside_prob+prod->lin->absfun->prob; - exprs.push_back(state->expr); - queue.push(state); - } -} - -#ifdef DEBUG_GENERATOR -void PgfParser::print_expr_state_before(PgfPrinter *printer, ExprState *state) -{ - if (state->choice->states.size() > 0) { - ExprState *parent = state->choice->states[0]; - print_expr_state_before(printer, parent); - printer->puts(" ["); - } - m->match_expr(printer, state->expr); -} - -void PgfParser::print_expr_state_after(PgfPrinter *printer, ExprState *state) -{ - for (size_t i = state->n_args+1; i < state->prod->n_args; i++) { - if (state->prod->args[i] == NULL) - printer->puts(" ?"); - else - printer->nprintf(32, " ?%d", state->prod->args[i]->fid); - } - - if (state->choice->states.size() > 0) { - printer->puts("]"); - ExprState *parent = state->choice->states[0]; - print_expr_state_after(printer, parent); - } -} - -void PgfParser::print_expr_state(ExprState *state) -{ - PgfPrinter printer(NULL, 0, m); - - printer.nprintf(16, "[%f] ", state->prob); - print_expr_state_before(&printer, state); - if (state->n_args < state->prod->n_args) { - Choice *choice = state->prod->args[state->n_args]; - if (choice == NULL) - printer.puts(" ?"); - else - printer.nprintf(32, " ?%d", state->prod->args[state->n_args]->fid); - } - print_expr_state_after(&printer, state); - printer.puts("\n"); - - PgfText *text = printer.get_text(); - fputs(text->text, stderr); - free(text); -} -#endif - -bool PgfParser::process_expr_state(ExprState *state) -{ - if (state->n_args >= state->prod->n_args) { - complete_expr_state(state); - return true; - } - - Choice *choice = state->prod->args[state->n_args]; - if (choice == NULL) { - PgfExpr meta = u->emeta(0); - PgfExpr app = u->eapp(state->expr, meta); - exprs.push_back(app); - u->free_ref(meta); - state->expr = app; - state->n_args++; - queue.push(state); + if (len <= max) + bu_predict(phrasetable->right,state,outside_prob,len,max); } else { - choice->states.push_back(state); + ptrdiff_t len = current.ptr - state->end.ptr; - if (choice->states.size() == 1) { - predict_expr_states(choice, state->prob); - } else { - for (ExprInstance p : choice->exprs) { - combine_expr_state(state,p); + if (min <= len) + bu_predict(phrasetable->left,state,outside_prob,min,len); + + if (len > 0) { + for (size_t i = 0; i < phrasetable->value.n_items; i++) { + //std::map, bool> visited; + //if (!td_reachable(state, phrasetable->items[i], visited)) + // continue; + Item *item = bu_item(state, outside_prob, phrasetable->value.items[i]); + item->dot++; + + State *next_state = new_state(current,item->outside_prob+item->inside_prob); + next_state->push_item(item); } } + + if (len <= max) + bu_predict(phrasetable->right,state,outside_prob,len,max); + } +} + +void PgfParser::bu_predict(PgfPhrasetable phrasetable, + State *state, prob_t outside_prob) +{ + size_t n_items = 0; + vector> items = + phrasetable_lookup(concr->phrasetable4, + ref(0), + &n_items); + + State *next_state = state->next; + if (next_state == NULL || state->end.pos != next_state->start.pos) { + next_state = new State; + next_state->start = state->end; + next_state->end = state->end; + next_state->next = state->next; + next_state->needs_bind = false; + next_state->viterbi_prob = state->viterbi_prob; + state->next = next_state; } + for (size_t i = 0; i < n_items; i++) { + //std::map, bool> visited; + //if (!td_reachable(state, phrasetable->items[i], visited)) + // continue; + Item *item = bu_item(state, outside_prob, items[i]); + item->dot++; + next_state->push_item(item); + } +} + +void PgfParser::bu_predict(State *state, prob_t outside_prob, CCat *ccat) +{ + size_t n_items = 0; + vector> items = 0; + if (ccat->cont->ccat == NULL) { + items = phrasetable_lookup(concr->phrasetable2, + ccat->cont->lincat, + &n_items); + } else if (ccat->cont->ccat->epsilon != 0) { + items = phrasetable_lookup(concr->phrasetable3, + ccat->cont->ccat->epsilon, + &n_items); + } + + for (size_t i = 0; i < n_items; i++) { + //std::map, bool> visited; + //if (!td_reachable(ccat->cont->state, items[i], visited)) + // continue; + auto new_item = bu_item(ccat->cont->state, outside_prob, items[i]); + combine(state,new_item,ccat); + } +} + +bool PgfParser::td_reachable(State *state, ref pitem, + std::map, bool> &visited) +{ + switch (ref::get_tag(pitem->rule->container)) { + case PgfConcrLin::tag: { + auto lin = ref::untagged(pitem->rule->container); + + if (visited[lin->lincat]) + return false; + visited[lin->lincat] = true; + + auto it = state->conts1.find(lin->lincat); + if (it != state->conts1.end()) { + return true; + } + + size_t n_items = 0; + vector> items = + phrasetable_lookup(concr->phrasetable2, + lin->lincat, + &n_items); + for (size_t i = 0; i < n_items; i++) { + if (td_reachable(state, items[i], visited)) + return true; + } + break; + } + } return false; } -void PgfParser::complete_expr_state(ExprState *state) +PgfAbstractParser::Item *PgfParser::bu_item(State *state, prob_t outside_prob, ref pitem) { - Choice *choice = state->choice; + Item *item = NULL; - prob_t outside_prob; - if (choice == top_choice) - outside_prob = 0; - else - outside_prob = choice->states[0]->prob; + switch (ref::get_tag(pitem->rule->container)) { + case PgfConcrLin::tag: { + auto lin = ref::untagged(pitem->rule->container); - prob_t inside_prob = state->prob-outside_prob; - choice->exprs.emplace_back(state->expr,inside_prob); - for (ExprState *state : choice->states) { - combine_expr_state(state,choice->exprs.back()); + Cont *cont; + if (pitem->res == 0) { + Cont *&tmp = state->conts1[lin->lincat]; + if (tmp == NULL) { + tmp = new Cont; + tmp->ccat = NULL; + tmp->lincat = lin->lincat; + tmp->state = state; + } + cont = tmp; + } else { + CCat *ccat = get_epsilon_ccat(&lin->lincat->name,pitem->res); + Cont *&tmp = state->conts2[ccat]; + if (tmp == NULL) { + tmp = new Cont; + tmp->ccat = ccat; + tmp->lincat = lin->lincat; + tmp->state = state; + } + cont = tmp; + } + + item = new(pitem->rule) Item; + item->cont = cont; + item->pre_alt = pitem->pre_alt; + item->pre_dot = pitem->pre_dot; + item->dot = pitem->dot; + item->syms = pitem->rule->syms.as_vector(); + item->rule = pitem->rule; + item->inside_prob = lin->absfun->prob; + item->outside_prob = outside_prob; + + for (size_t i = 0; i < pitem->args.size(); i++) { + item->args[i] = 0; + if (pitem->args[i] != 0) { + item->args[i] = get_epsilon_ccat(&lin->absfun->type->hypos[i].type->name,pitem->args[i]); + item->inside_prob += item->args[i]->viterbi_prob; + } + } + break; + } + case PgfConcrLincat::tag: { + auto lincat = ref::untagged(pitem->rule->container); + + Cont *&cont = state->conts1[0]; + if (cont == NULL) { + cont = new Cont; + cont->ccat = NULL; + cont->lincat = 0; + cont->state = state; + } + + item = new(pitem->rule) Item; + item->cont = cont; + item->pre_alt = pitem->pre_alt; + item->pre_dot = pitem->pre_dot; + item->dot = pitem->dot; + item->syms = pitem->rule->syms.as_vector(); + item->rule = pitem->rule; + item->inside_prob = 0; + item->outside_prob = 0; + item->args[0] = 0; + break; + } + } + + if (item->pre_alt > 0) { + auto symkp = ref::untagged(item->syms[item->pre_dot]); + + if (item->pre_alt == 1) + item->syms = symkp->default_form; + else + item->syms = symkp->alts[item->pre_alt-2].form; + } + + memcpy(&item->vars[0], &pitem->vars[0], sizeof(size_t) * item->vars.size()); + return item; +} + +void PgfParser::make_chunks(State *state, std::vector &chunks, prob_t prob) +{ + if (state->completed.size() == 0) { + ExprState *estate = new(chunks.size()) ExprState; + estate->expr = u->emeta(0); + estate->prob = prob; + estate->hash = '?'; + estate->res = NULL; + estate->index = 0; + estate->n_args = chunks.size(); + for (size_t i = 0; i < estate->n_args; i++) { + estate->args[i] = chunks[estate->n_args-i-1]; + estate->prob += estate->args[i]->viterbi_prob; + } + queue.push_back(estate); + std::push_heap(queue.begin(), queue.end(), estate_comp); + } + + for (auto it1 : state->completed) { + for (auto it2 : it1.second) { + for (auto it3 : it2.second) { + CCat *ccat = it3.second; + if (!ccat->covered && ccat->cont->state != state) { + chunks.push_back(ccat); + make_chunks(ccat->cont->state, chunks, prob+ccat->cont->lincat->abscat->prob); + chunks.pop_back(); + } + } + } } } -void PgfParser::combine_expr_state(ExprState *state, ExprInstance &inst) +void PgfParser::prepare(ref start) { - PgfExpr app = u->eapp(state->expr, inst.expr); - exprs.push_back(app); +#ifdef DEBUG_PARSER + fprintf(stderr, "------------------------------------------\n"); +#endif - ExprState *app_state = new ExprState(); - app_state->prob = state->prob + inst.prob; - app_state->choice = state->choice; - app_state->prod = state->prod; - app_state->n_args = state->n_args+1; - app_state->expr = app; - queue.push(app_state); + PgfTextSpot start_spot = {0, (uint8_t *) sentence->text}; + State *state = new_state(start_spot, 0); + + for (size_t i = start->n_lindefs; i < start->rules.size(); i++) { + ref rule = start->rules[i]; + Item *item = new(rule) Item; + item->cont = NULL; + item->dot = 0; + item->pre_alt = 0; + item->pre_dot = 0; + item->syms = rule->syms.as_vector(); + item->rule = rule; + item->inside_prob = 0; + item->outside_prob = 0; + state->push_item(item); + } } PgfExpr PgfParser::fetch(PgfDB *db, prob_t *prob) { DB_scope scope(db, READER_SCOPE); - if (top_choice == NULL) - return 0; + bool first_fetch = (concr->last_fid == last_fid); for (;;) { - if (top_choice_index < top_choice->exprs.size()) { - auto inst = top_choice->exprs[top_choice_index++]; - *prob = inst.prob; - return inst.expr; + State *state = current_state; + prob_t min_prob = INFINITY; + State *min_state = NULL; + if (queue.size() > 0) { + min_prob = queue.front()->prob; } - if (queue.empty()) - return 0; - - ExprState *state = queue.top(); queue.pop(); -#ifdef DEBUG_GENERATOR - print_expr_state(state); -#endif - - if (process_expr_state(state)) { - delete state; + while (state != NULL) { + if (state->queue.size() > 0) { + Item *item = state->queue.front(); + prob_t delta = current_state->viterbi_prob - state->viterbi_prob; + prob_t prob = item->outside_prob + item->inside_prob + delta; + if (min_prob > prob) { + min_prob = prob; + min_state = state; + } + } + state = state->next; } + + if (min_state == NULL) + break; + + State *prev = current_state; + current_state = NULL; + while (current_state != min_state) { + State *next = prev->next; + prev->next = current_state; + current_state = prev; + prev = next; + } + + Item *item = current_state->pop_item(); + process(item,current_state); + + while (current_state != NULL) { + State *next = current_state->next; + current_state->next = prev; + prev = current_state; + current_state = next; + } + current_state = prev; } + if (first_fetch && queue.size() == 0) { + std::vector chunks; + make_chunks(current_state, chunks, 0); + } + + while (queue.size() > 0) { + ExprState *estate = queue.front(); + std::pop_heap(queue.begin(), queue.end(), estate_comp); + queue.pop_back(); + +#ifdef DEBUG_EXPRS + print_expr_state(m, estate); +#endif + + PgfExpr expr = process_expr(estate, prob); + if (expr != 0) + return expr; + } return 0; } -PgfParser::~PgfParser() +PgfExpr PgfParser::process_expr(ExprState *estate, prob_t *prob) { - while (before != NULL) { - Stage *tmp = before; - before = before->next; - delete tmp; + if (estate->index < estate->n_args) { + CCat *ccat = estate->args[estate->index]; + + if (ccat == NULL) { + ExprState *app_state = new(estate->n_args) ExprState; + app_state->expr = estate->expr ? u->eapp(estate->expr, u->emeta(0)) : u->emeta(0); + app_state->prob = estate->prob; + app_state->hash = estate->hash * 101 + '?'; + app_state->res = estate->res; + app_state->index = estate->index+1; + app_state->n_args = estate->n_args; + for (size_t i = 0; i < app_state->n_args; i++) { + app_state->args[i] = estate->args[i]; + } + queue.push_back(app_state); + std::push_heap(queue.begin(), queue.end(), estate_comp); + } else { + ccat->pending.push_back(estate); + + if (ccat->pending.size() == 1) { + if (ccat->epsilon != 0) { + for (size_t i = 0; i < ccat->epsilon->n_items; i++) { + ref pitem = ccat->epsilon->items[i]; + + auto lin = ref::untagged(pitem->rule->container); + + ExprState *new_estate = new(pitem->args.size()) ExprState; + new_estate->expr = u->efun(&lin->name); + new_estate->prob = estate->prob-ccat->viterbi_prob+lin->absfun->prob; + new_estate->hash = 0; + new_estate->res = ccat; + new_estate->index = 0; + new_estate->n_args = pitem->args.size(); + for (size_t i = 0; i < lin->name.size; i++) { + new_estate->hash = new_estate->hash * 101 + lin->name.text[i]; + } + for (size_t i = 0; i < new_estate->n_args; i++) { + new_estate->args[i] = NULL; + if (pitem->args[i] != 0) { + new_estate->args[i] = get_epsilon_ccat(&lin->absfun->type->hypos[i].type->name,pitem->args[i]); + new_estate->prob += new_estate->args[i]->viterbi_prob; + } + } + queue.push_back(new_estate); + std::push_heap(queue.begin(), queue.end(), estate_comp); + } + } else { + for (Production *prod : ccat->prods) { + auto lin = ref::untagged(prod->rule->container); + + ExprState *new_estate = new(prod->args.size()) ExprState; + new_estate->expr = u->efun(&lin->name); + new_estate->prob = estate->prob-ccat->viterbi_prob+lin->absfun->prob; + new_estate->hash = 0; + new_estate->res = ccat; + new_estate->index = 0; + new_estate->n_args = prod->args.size(); + for (size_t i = 0; i < lin->name.size; i++) { + new_estate->hash = new_estate->hash * 101 + lin->name.text[i]; + } + for (size_t i = 0; i < new_estate->n_args; i++) { + new_estate->args[i] = prod->args[i]; + if (prod->args[i] != NULL) { + new_estate->prob += prod->args[i]->viterbi_prob; + } + } + queue.push_back(new_estate); + std::push_heap(queue.begin(), queue.end(), estate_comp); + } + } + } else { + for (ExprProb ep : ccat->exprs) { + ExprState *app_state = new(estate->n_args) ExprState; + app_state->expr = estate->expr ? u->eapp(estate->expr, ep.expr) : ep.expr; + app_state->prob = estate->prob-ccat->viterbi_prob+ep.prob; + app_state->hash = estate->hash * 31 + ep.hash; + app_state->res = estate->res; + app_state->index = estate->index+1; + app_state->n_args= estate->n_args; + for (size_t i = 0; i < app_state->n_args; i++) { + app_state->args[i] = estate->args[i]; + } + queue.push_back(app_state); + std::push_heap(queue.begin(), queue.end(), estate_comp); + } + } + } + } else { + if (estate->res == NULL) { + *prob = estate->prob; + return estate->expr; + } + + prob_t prob = estate->prob - (estate->res->pending[0]->prob-estate->res->viterbi_prob); + for (size_t i = estate->res->exprs.size(); i > 0; i--) { + ExprProb &ep = estate->res->exprs[i-1]; + if (ep.prob != prob) + break; + if (ep.hash == estate->hash) + return 0; + } + + estate->res->exprs.emplace_back(estate->expr, prob, estate->hash); + for (ExprState *parent : estate->res->pending) { + ExprState *app_state = new(parent->n_args) ExprState; + app_state->expr = parent->expr ? u->eapp(parent->expr, estate->expr) : estate->expr; + app_state->prob = parent->prob-estate->res->viterbi_prob+prob; + app_state->hash = parent->hash * 31 + estate->hash; + app_state->res = parent->res; + app_state->index = parent->index+1; + app_state->n_args= parent->n_args; + for (size_t i = 0; i < app_state->n_args; i++) { + app_state->args[i] = parent->args[i]; + } + queue.push_back(app_state); + std::push_heap(queue.begin(), queue.end(), estate_comp); + } + } + return 0; +} + +PgfAbstractParser::State *PgfParser::new_state(const PgfTextSpot &start, prob_t viterbi_prob) +{ + State **prev = ¤t_state; + State *state = current_state; + while (state != NULL && state->start.ptr <= start.ptr) { + if (state->start.ptr == start.ptr) + return state; + prev = &state->next; + state = state->next; } - while (ahead != NULL) { - Stage *tmp = ahead; - ahead = ahead->next; - delete tmp; + state = new State; + state->start = start; + state->end = start; + state->viterbi_prob = viterbi_prob; + state->next = *prev; + *prev = state; + + while (state->end.ptr < end) { + const uint8_t *ptr = state->end.ptr; + uint32_t ucs = pgf_utf8_decode(&ptr); + if (!pgf_utf8_is_space(ucs)) + break; + state->end.pos++; + state->end.ptr = ptr; } - for (auto it : persistant) { - delete it.second; - } + state->needs_bind = (state->start.pos > 0 && state->start.pos == state->end.pos); - for (Choice *choice : dynamic) { - delete choice; - } + return state; +} - for (PgfExpr expr : exprs) { - u->free_ref(expr); - } +void PgfParser::symbol_token(Item *item, State *state, ref symks) +{ + PgfTextSpot next = state->end; + if (text_symbol_cmp(&next,end,symks,case_sensitive) != 0) + return; - while (!queue.empty()) { - ExprState *state = queue.top(); queue.pop(); - delete state; + State *next_state = new_state(next, item->inside_prob+item->outside_prob); + + item->dot++; + process(item, next_state); +} + +void PgfParser::symbol_bind(Item *item, State *state, PgfSymbol sym) +{ + if (state->needs_bind) { + State *next_state = state->next; + if (next_state == NULL || state->end.pos != next_state->start.pos) { + next_state = new State; + next_state->start = state->end; + next_state->end = state->end; + next_state->next = state->next; + next_state->needs_bind = false; + next_state->viterbi_prob = state->viterbi_prob; + state->next = next_state; + } + item->dot++; + next_state->push_item(item); + } else { + if (ref::get_tag(sym) == PgfSymbolBIND::tag) { + delete item; + } else { + item->dot++; + process(item, state); + } + } +} + +void PgfParser::suspend(Cont *cont,Item *item,bool do_predict,ref symcat,interval_t value_i,interval_t lin_idx_i) +{ + auto &suspended = cont->suspended[value_i][lin_idx_i]; + suspended.push_back(item); + + size_t n_suspended = suspended.size(); + if (cont->ccat == NULL) { + if (n_suspended == 1) { + std::function)> f = + [this,item,cont](ref arg) { + + ref pitem = arg->items[0]; + + PgfSymbol sym = item->rule->syms[item->dot]; + auto sym_cat = ref::untagged(sym); + size_t *values1 = CLONE_VALUES(item->rule, &item->vars[0]); + size_t *values2 = CLONE_VALUES(pitem->rule, &pitem->vars[0]); + if (!instantiate(item->rule, values1, item->rule->args[sym_cat->d], + pitem->rule, values2, pitem->rule->res)) { + return; + } + if (!instantiate(item->rule, values1, ref::from_ptr(&sym_cat->r), + pitem->rule, values2, pitem->rule->lin_idx)) { + return; + } + + CCat *&arg_ccat = epsilons[arg->fid]; + if (arg_ccat == NULL) { + arg_ccat = new CCat; + arg_ccat->fid = arg->fid; + arg_ccat->epsilon = arg; + arg_ccat->cont = NULL; + arg_ccat->state = NULL; + arg_ccat->lin_idx = arg->lin_idx; + arg_ccat->value = arg->value; + arg_ccat->covered = true; + arg_ccat->viterbi_prob = arg->viterbi_prob; + } + + cont->state->completed[cont][arg_ccat->value][arg_ccat->lin_idx] = arg_ccat; + }; + epsilontable_iter(concr->epsilontable,cont->lincat,f); + } + + if (do_predict) { + prob_t viterbi_prob = item->inside_prob+item->outside_prob; + if (cont->state->needs_bind) { + bu_predict(concr->phrasetable4, cont->state, viterbi_prob); + } else { + bu_predict(concr->phrasetable1, cont->state, viterbi_prob, 1, sentence->size); + } + } + } else { + if (do_predict && n_suspended == 1) { + if (cont->ccat->epsilon != 0) { + for (size_t i = 0; i < cont->ccat->epsilon->n_items; i++) { + ref pitem = cont->ccat->epsilon->items[i]; + td_epsilon(cont->state,cont,pitem,item,symcat); + } + } else { + for (Production *prod : cont->ccat->prods) { + td_predict(cont->state,cont,prod,item,symcat); + } + } + } + } + + State *state = cont->state; + while (state != NULL) { + auto it1 = state->completed.find(cont); + if (it1 != state->completed.end()) { + for (auto it2 : it1->second.overlaps(value_i)) { + for (auto it3 : it2.second.overlaps(lin_idx_i)) { + Item *new_item = new (item) Item; + combine(state, new_item, it3.second); + } + } + } + state = state->next; + } +} + +void PgfParser::final_item(State *state, CCat *ccat, Item *item, interval_t value, interval_t lin_idx) +{ + if (item->cont == NULL && state->end.ptr == end) { + ExprState *estate = new(item->args.size()) ExprState; + estate->expr = 0; + estate->prob = 0; + estate->hash = 0; + estate->res = ccat; + estate->index = 0; + estate->n_args = item->args.size(); + for (size_t i = 0; i < estate->n_args; i++) { + estate->args[i] = item->args[i]; + estate->prob += estate->args[i]->viterbi_prob; + } + queue.push_back(estate); + std::push_heap(queue.begin(), queue.end(), estate_comp); + } else if (ccat != NULL && ccat->pending.size() > 0) { + auto lin = ref::untagged(item->rule->container); + ExprState *estate = new(item->args.size()) ExprState; + estate->expr = u->efun(&lin->name); + estate->prob = ccat->pending[0]->prob-ccat->viterbi_prob+lin->absfun->prob; + estate->hash = 0; + estate->res = ccat; + estate->index = 0; + estate->n_args = item->args.size(); + for (size_t i = 0; i < lin->name.size; i++) { + estate->hash = estate->hash * 101 + lin->name.text[i]; + } + for (size_t i = 0; i < estate->n_args; i++) { + estate->args[i] = item->args[i]; + estate->prob += estate->args[i]->viterbi_prob; + } + queue.push_back(estate); + std::push_heap(queue.begin(), queue.end(), estate_comp); + } +} + +#ifdef DEBUG_EXPRS +void PgfParser::print_expr_state_left(PgfPrinter *printer, PgfMarshaller *m, ExprState *estate) +{ + if (estate->res && estate->res->pending.size() > 0) { + ExprState *parent = estate->res->pending[0]; + print_expr_state_left(printer, m, parent); + printer->puts(" ("); + } + + if (estate->expr) + m->match_expr(printer, estate->expr); + else + printer->puts("::"); +} + +void PgfParser::print_expr_state_right(PgfPrinter *printer, ExprState *estate) +{ + for (size_t i = estate->index+1; i < estate->n_args; i++) { + printer->puts(" "); + if (estate->args[i] != NULL) + printer->emeta(estate->args[i]->fid); + else + printer->puts("?"); + } + + if (estate->res && estate->res->pending.size() > 0) { + printer->puts(")"); + ExprState *parent = estate->res->pending[0]; + print_expr_state_right(printer, parent); + } +} + +void PgfParser::print_expr_state(PgfMarshaller *m, ExprState *estate) +{ + PgfPrinter printer(NULL,0,m); + printer.nprintf(64,"[%f] ",estate->prob); + print_expr_state_left(&printer, m, estate); + printer.puts(" . "); + + if (estate->index < estate->n_args) { + if (estate->args[estate->index] != NULL) + printer.emeta(estate->args[estate->index]->fid); + else + printer.puts("?"); + } + + print_expr_state_right(&printer, estate); + + PgfText *text = printer.get_text(); + fprintf(stderr, "%s\n", text->text); + free(text); +} +#endif + +PgfParseTableMaker::PgfParseTableMaker(ref concr) + : PgfAbstractParser(concr) +{ + current_state = new State; + current_state->start.pos = 0; + current_state->start.ptr = NULL; + current_state->end = current_state->start; + current_state->viterbi_prob = 0; + current_state->next = NULL; +} + +ref PgfParseTableMaker::clone_item(Item *item) +{ + size_t ex_size = + sizeof(PgfMetaId) * item->args.size() + + sizeof(size_t) * item->vars.size(); + auto pitem = PgfDB::malloc(ex_size); + pitem->res = (item->cont->ccat == NULL) ? 0 : item->cont->ccat->fid; + pitem->pre_alt = item->pre_alt; + pitem->pre_dot = item->pre_dot; + pitem->dot = item->dot; + pitem->rule = item->rule; + memcpy(&pitem->vars[0],&item->vars[0],sizeof(size_t) * item->vars.size()); + + for (size_t i = 0; i < item->args.size(); i++) { + pitem->args[i] = (item->args[i] == NULL) ? 0 : item->args[i]->fid; + } + + return pitem; +} + +PgfAbstractParser::State *PgfParseTableMaker::new_state(const PgfTextSpot &start, prob_t viterbi_prob) +{ + return current_state; +} + +void PgfParseTableMaker::symbol_token(Item *item, State *state, ref symks) +{ + auto pitem = clone_item(item); + auto phrasetable1 = phrasetable_insert(concr->phrasetable1,symks,pitem); + concr->phrasetable1 = phrasetable1; + delete item; +} + +void PgfParseTableMaker::symbol_bind(Item *item, State *state, PgfSymbol sym) +{ + auto pitem = clone_item(item); + auto phrasetable4 = phrasetable_insert(concr->phrasetable4,ref(0),pitem); + concr->phrasetable4 = phrasetable4; + + if (ref::get_tag(sym) == PgfSymbolBIND::tag) { + delete item; + } else { + item->dot++; + process(item,state); + } +} + +void PgfParseTableMaker::suspend(Cont *cont,Item *item,bool do_predict,ref symcat,interval_t value_i,interval_t lin_idx_i) +{ + auto &suspended = cont->suspended[value_i][lin_idx_i]; + suspended.push_back(item); + + size_t n_suspended = suspended.size(); + if (cont->ccat == NULL) { + auto pitem = clone_item(item); + auto phrasetable2 = phrasetable_insert(concr->phrasetable2,cont->lincat,pitem); + concr->phrasetable2 = phrasetable2; + } else { + if (do_predict && n_suspended == 1) { + if (cont->ccat->epsilon != 0) { + for (size_t i = 0; i < cont->ccat->epsilon->n_items; i++) { + ref pitem = cont->ccat->epsilon->items[i]; + td_epsilon(cont->state,cont,pitem,item,symcat); + } + } else { + for (Production *prod : cont->ccat->prods) { + td_predict(cont->state,cont,prod,item,symcat); + } + } + } + + auto pitem = clone_item(item); + auto phrasetable3 = phrasetable_insert(concr->phrasetable3,cont->ccat->epsilon,pitem); + concr->phrasetable3 = phrasetable3; + } + + auto it1 = cont->state->completed.find(cont); + if (it1 != cont->state->completed.end()) { + for (auto it2 : it1->second.overlaps(value_i)) { + for (auto it3 : it2.second.overlaps(lin_idx_i)) { + CCat *arg = it3.second; + Item *new_item = new (item) Item; + combine(cont->state, new_item, arg); + } + } + } +} + +void PgfParseTableMaker::final_item(State *state, CCat *ccat, Item *item, interval_t value, interval_t lin_idx) +{ + auto pitem = clone_item(item); + + if (ccat->epsilon == 0) { + PgfEpsilontable epsilontable = concr->epsilontable; + epsilontable = + epsilontable_insert(epsilontable, + ccat->cont->lincat, + ccat->value, ccat->lin_idx, + ccat->fid, ccat->viterbi_prob, + pitem, + &ccat->epsilon); + concr->epsilontable = epsilontable; + } else { + epsilontable_add(ccat->epsilon, pitem); + } +} + +void PgfParseTableMaker::bu_predict(State *state, prob_t outside_prob, CCat *ccat) +{ +} + +void PgfParseTableMaker::insert_rule(ref rule) +{ + switch (ref::get_tag(rule->container)) { + case PgfConcrLin::tag: { + auto lin = ref::untagged(rule->container); + + Cont *&cont = current_state->conts1[lin->lincat]; + if (cont == NULL) { + cont = new Cont; + cont->ccat = NULL; + cont->lincat = lin->lincat; + cont->state = current_state; + } + + Item *item = new(rule) Item; + item->cont = cont; + item->dot = 0; + item->pre_alt = 0; + item->pre_dot = 0; + item->syms = rule->syms.as_vector(); + item->rule = rule; + item->inside_prob = lin->absfun->prob; + item->outside_prob = 0; + current_state->push_item(item); + } + } +} + +void PgfParseTableMaker::prepare() +{ + while (current_state->has_items()) { + Item *item = current_state->pop_item(); + process(item,current_state); } } diff --git a/src/runtime/c/pgf/parser.h b/src/runtime/c/pgf/parser.h index c0bbd4773..14f8b8e8b 100644 --- a/src/runtime/c/pgf/parser.h +++ b/src/runtime/c/pgf/parser.h @@ -1,191 +1,340 @@ #ifndef LR_TABLE_H #define LR_TABLE_H -#include "md5.h" - -class PGF_INTERNAL_DECL PgfLRTableMaker -{ - struct CCat; - struct Production; - struct Item; - struct State; - - struct CompareItem; - static const CompareItem compare_item; - - typedef std::pair,size_t> Key0; - - struct PGF_INTERNAL_DECL CompareKey0 : std::less { - bool operator() (const Key0& k1, const Key0& k2) const { - int cmp = textcmp(k1.first,k2.first); - if (cmp < 0) - return true; - else if (cmp > 0) - return false; - - return (k1.second < k2.second); - } - }; - - typedef std::pair,size_t> Key1; - - struct PGF_INTERNAL_DECL CompareKey1 : std::less { - bool operator() (const Key1& k1, const Key1& k2) const { - if (k1.first < k2.first) - return true; - else if (k1.first > k2.first) - return false; - - return (k1.second < k2.second); - } - }; - - typedef std::pair Key2; - - struct PGF_INTERNAL_DECL CompareKey2 : std::less { - bool operator() (const Key2& k1, const Key2& k2) const { - if (k1.first < k2.first) - return true; - else if (k1.first > k2.first) - return false; - - return (k1.second < k2.second); - } - }; - - typedef std::pair,size_t> Key3; - - struct PGF_INTERNAL_DECL CompareKey3 : std::less { - bool operator() (const Key3& k1, const Key3& k2) const; - }; - - ref abstr; - ref concr; - - size_t ccat_id; - size_t state_id; - - std::queue todo; - std::map states; - std::map ccats1; - std::map ccats2; - - // The Threefold Way of building an automaton - typedef enum { INIT, PROBE, REPEAT } Fold; - - void process(State *state, Fold fold, Item *item); - void symbol(State *state, Fold fold, Item *item, PgfSymbol sym); - - template - void predict(State *state, Fold fold, Item *item, T cat, - vector vars, PgfLParam *r); - void predict(State *state, Fold fold, Item *item, ref cat, size_t lin_idx); - void predict(State *state, Fold fold, Item *item, CCat *ccat, size_t lin_idx); - void predict(ref absfun, CCat *ccat); - void complete(State *state, Fold fold, Item *item); - - void print_production(CCat *ccat, Production *prod); - void print_item(Item *item); - - void internalize_state(State *&state); - -public: - PgfLRTableMaker(ref abstr, ref concr); - vector make(); - ~PgfLRTableMaker(); -}; - -class PGF_INTERNAL_DECL PgfLCTableMaker -{ - ref abstr; - ref concr; - - - std::map,std::vector>> forwards; - std::map,std::vector>> backwards; - - ref compute_unifier(ref edge1, ref edge2); - void update_closure(ref edge); - void rename(ref edge); - void add_edge(ref edge); - void print_edge(ref edge); - -public: - PgfLCTableMaker(ref abstr, ref concr); - vector make(); - ~PgfLCTableMaker(); -}; - class PgfPrinter; -class PGF_INTERNAL_DECL PgfParser : public PgfPhraseScanner, public PgfExprEnum +class PGF_INTERNAL_DECL PgfAbstractParser { - ref concr; - PgfText *sentence; - bool case_sensitive; - PgfMarshaller *m; - PgfUnmarshaller *u; + typedef size_t hash_t; - struct Choice; - struct Production; - struct StackNode; - struct Stage; +protected: + ref concr; + + struct CCat; + struct Cont; + struct Item; + struct State; struct ExprState; - struct ExprInstance; - struct CompareExprState : std::less { - bool operator() (const ExprState *state1, const ExprState *state2) const; + + struct Production { + ref rule; + + struct { + size_t &operator[](int i) const { + Production *prod = containerof(Production,vars,this); + return ((size_t*) (((CCat**) (prod+1))+prod->args.size()))[i]; + } + size_t size() const { + Production *prod = containerof(Production,vars,this); + return prod->rule->ranges.size(); + } + } vars; + + struct { + CCat *&operator[](int i) const { + Production *prod = containerof(Production,args,this); + return ((CCat**) (prod+1))[i]; + } + size_t size() const { + Production *prod = containerof(Production,args,this); + return (prod->rule->args != 0) ? prod->rule->args.size() : 0; + } + } args; + + void *operator new(size_t sz, Item *item) + { + size_t sz2 = item->args.size()*sizeof(CCat*) + + item->vars.size()*sizeof(size_t); + Production *prod = (Production *) malloc(sz+sz2); + memcpy(prod+1, item+1, sz2); + return prod; + } + + void *operator new(size_t sz, ref pitem) + { + size_t sz2 = pitem->args.size()*sizeof(CCat*) + + pitem->vars.size()*sizeof(size_t); + Production *prod = (Production *) malloc(sz+sz2); + memset(prod+1,0,sz2); + return prod; + } + + void operator delete(void *p) + { + free(p); + } + + Production() { + } }; - Stage *before, *after, *ahead; - std::priority_queue, CompareExprState> queue; - int last_fid; + struct ExprProb { + PgfExpr expr; + prob_t prob; + hash_t hash; + + ExprProb(PgfExpr expr, prob_t prob, hash_t hash) { + this->expr = expr; + this->prob = prob; + this->hash = hash; + } + }; - std::vector dynamic; - std::map persistant; + struct CCat { + PgfMetaId fid; + ref epsilon; + Cont *cont; + State *state; + interval_t value; + interval_t lin_idx; + prob_t viterbi_prob; + bool covered; + std::vector prods; + std::vector pending; + std::vector exprs; - std::vector exprs; + ~CCat(); + }; - Choice *top_choice; - size_t top_choice_index; + struct State { + PgfTextSpot start, end; + bool needs_bind; + std::map,Cont*> conts1; + std::map conts2; + std::map>> completed; + std::vector queue; + prob_t viterbi_prob; - bool shift(StackNode *parent, ref lincat, size_t r, Production *prod, - Stage *before, Stage *after); - void shift(StackNode *parent, Stage *before); - void shift(StackNode *parent, Stage *before, Stage *after); - void reduce(StackNode *parent, ref lin, ref red, - size_t n, std::vector &args, - Stage *before, Stage *after); - Choice *retrieve_choice(ref arg); - void complete(StackNode *parent, ref lincat, size_t r, - size_t n, std::vector &args); - void reduce_all(StackNode *state); - void print_prod(Choice *choice, Production *prod); - void print_transition(StackNode *source, StackNode *target, Stage *stage, ref shift); + State *next; - typedef std::map,Choice*> intersection_map; + bool has_items() { + return queue.size() > 0; + } - Choice *intersect_choice(Choice *choice1, Choice *choice2, intersection_map &im); + void push_item(Item *item) { + queue.push_back(item); + std::push_heap(queue.begin(), queue.end(), item_prob_comp); + } - void print_expr_state_before(PgfPrinter *printer, ExprState *state); - void print_expr_state_after(PgfPrinter *printer, ExprState *state); - void print_expr_state(ExprState *state); + Item *pop_item() { + Item *item = queue.front(); + std::pop_heap(queue.begin(), queue.end(), item_prob_comp); + queue.pop_back(); + return item; + } + }; - void predict_expr_states(Choice *choice, prob_t outside_prob); - bool process_expr_state(ExprState *state); - void complete_expr_state(ExprState *state); - void combine_expr_state(ExprState *state, ExprInstance &inst); + static struct ItemProbComparator : std::less { + bool operator()(Item *item1, Item *item2) { + return item1->inside_prob+item1->outside_prob > item2->inside_prob+item2->outside_prob; + } + } item_prob_comp; + + struct ItemComparator : std::less { + bool operator()(Item *item1, Item *item2); + }; + + struct Cont { + CCat *ccat; + ref lincat; + State *state; + interval_map>> suspended; + std::set predicted; + + ~Cont(); + }; + + struct Item { + Cont *cont; + uint16_t pre_alt; + uint16_t pre_dot; + uint16_t dot; + vector syms; + ref rule; + prob_t inside_prob; + prob_t outside_prob; + + struct { + size_t &operator[](int i) const { + Item *item = containerof(Item,vars,this); + return ((size_t*) (((CCat**) (item+1))+item->args.size()))[i]; + } + size_t size() const { + Item *item = containerof(Item,vars,this); + return item->rule->ranges.size(); + } + } vars; + + struct { + CCat *&operator[](int i) const { + Item *item = containerof(Item,args,this); + return ((CCat**) (item+1))[i]; + } + size_t size() const { + Item *item = containerof(Item,args,this); + return (item->rule->args != 0) ? item->rule->args.size() : 0; + } + } args; + + void *operator new(size_t sz, ref rule) + { + size_t sz2 = rule->args.size()*sizeof(CCat*) + + rule->ranges.size()*sizeof(size_t); + Item *new_item = (Item *) malloc(sz+sz2); + memset(new_item+1, 0, sz2); + return new_item; + } + + void *operator new(size_t sz, Item *item) + { + size_t sz2 = item->args.size()*sizeof(CCat*) + + item->vars.size()*sizeof(size_t); + Item *new_item = (Item *) malloc(sz+sz2); + memcpy(new_item, item, sz+sz2); + return new_item; + } + + void operator delete(void *p) + { + free(p); + } + + Item() { + } + }; + + struct ExprState { + PgfExpr expr; + prob_t prob; + hash_t hash; + + CCat *res; + + size_t index; + size_t n_args; + CCat *args[]; + + void *operator new(size_t sz, size_t n_args) + { + ExprState *estate = (ExprState *) + malloc(sz+n_args*sizeof(CCat*)); + return estate; + } + + void operator delete(void *p) + { + free(p); + } + + ExprState() { + } + }; + + State *current_state; + std::map epsilons; + PgfMetaId initial_fid, last_fid; + + void process(Item *item, State *state); + void symbol(Item *item, State *state, PgfSymbol sym); + void complete(Item *item, State *state); + + virtual State *new_state(const PgfTextSpot &start, prob_t viterbi_prob)=0; + virtual void symbol_token(Item *item, State *state, ref symks)=0; + virtual void symbol_bind(Item *item, State *state, PgfSymbol sym)=0; + virtual void suspend(Cont *cont, Item *item, bool do_predict, ref symcat,interval_t value_i,interval_t lin_idx_i)=0; + virtual void final_item(State *state,CCat *ccat,Item *item,interval_t value,interval_t lin_idx)=0; + virtual void bu_predict(State *state, prob_t outside_prob, CCat *ccat)=0; + + void td_epsilon(State *state, Cont *cont, ref pitem, Item *xitem, ref symcat); + void td_predict(State *state, Cont *cont, Production *prod, Item *xitem, ref symcat); + void combine(State *state, Item *item, CCat *ccat); + + static + bool instantiate(ref rule1, size_t *values1, ref lparam1, + ref rule2, size_t *values2, ref lparam2); + + static + interval_t interval(ref rule, size_t *values, ref lparam); + + void get_info(CCat *ccat, ref *rule, size_t **pvalues); + CCat *get_epsilon_ccat(PgfText *name, PgfMetaId fid); + + static + void print_item(Item *item, State *state); + + static + void print_prod(CCat *ccat, Production *prod); public: - PgfParser(ref concr, ref start, PgfText *sentence, bool case_sensitive, PgfMarshaller *m, PgfUnmarshaller *u); + PgfAbstractParser(ref concr); + virtual ~PgfAbstractParser(); +}; + +class PGF_INTERNAL_DECL PgfParser : private PgfAbstractParser, public PgfExprEnum +{ + PgfMarshaller *m; + PgfUnmarshaller *u; + PgfText *sentence; + uint8_t *end; + bool case_sensitive; + + virtual State *new_state(const PgfTextSpot &start, prob_t viterbi_prob); + virtual void symbol_token(Item *item, State *state, ref symks); + virtual void symbol_bind(Item *item, State *state, PgfSymbol sym); + virtual void suspend(Cont *cont,Item *item,bool do_predict,ref symcat,interval_t value_i,interval_t lin_idx_i); + virtual void final_item(State *state,CCat *ccat,Item *item,interval_t value,interval_t lin_idx); + virtual void bu_predict(State *state, prob_t outside_prob, CCat *ccat); + + void bu_predict(PgfPhrasetable phrasetable, State *state, prob_t outside_prob); + void bu_predict(PgfPhrasetable phrasetable, State *state, prob_t outside_prob, ptrdiff_t min, ptrdiff_t max); + void make_chunks(State *state, std::vector &chunks, prob_t prob); + PgfExpr process_expr(ExprState *estate, prob_t *prob); + + bool td_reachable(State *state, ref pitem, std::map, bool> &visited); + Item *bu_item(State *state, prob_t outside_prob, ref pitem); + + static + void print_expr_state_left(PgfPrinter *printer, PgfMarshaller *m, ExprState *estate); + static + void print_expr_state_right(PgfPrinter *printer, ExprState *estate); + static + void print_expr_state(PgfMarshaller *m, ExprState *estate); + + static struct ExprStateComparator : std::less { + bool operator()(ExprState *estate1, ExprState *estate2) { + return estate1->prob > estate2->prob; + } + } estate_comp; + + std::vector queue; + +public: + PgfParser(ref concr, PgfText *sentence, bool case_sensitive, PgfMarshaller *m, PgfUnmarshaller *u); virtual ~PgfParser(); - virtual void space(PgfTextSpot *start, PgfTextSpot *end, PgfExn* err); - virtual void start_matches(PgfTextSpot *end, PgfExn* err); - virtual void match(ref lin, size_t seq_index, PgfExn* err); - virtual void end_matches(PgfTextSpot *end, PgfExn* err); - - void prepare(); + void prepare(ref start); PgfExpr fetch(PgfDB *db, prob_t *prob); }; + +class PGF_INTERNAL_DECL PgfParseTableMaker : private PgfAbstractParser +{ +private: + virtual State *new_state(const PgfTextSpot &start, prob_t viterbi_prob); + virtual void symbol_token(Item *item, State *state, ref symks); + virtual void symbol_bind(Item *item, State *state, PgfSymbol sym); + virtual void suspend(Cont *cont, Item *item, bool do_predict, ref symcat,interval_t value_i,interval_t lin_idx_i); + virtual void final_item(State *state, CCat *ccat,Item *item,interval_t value,interval_t lin_idx); + virtual void bu_predict(State *state, prob_t outside_prob, CCat *ccat); + + static + ref clone_item(Item *item); + +public: + PgfParseTableMaker(ref concr); + void insert_rule(ref rule); + void prepare(); + PgfMetaId get_last_fid() { return last_fid; }; +}; + #endif diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index 6a332a295..2db16e1ef 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/src/runtime/c/pgf/pgf.cxx @@ -705,6 +705,14 @@ prob_t pgf_function_prob(PgfDB *db, PgfRevision revision, return INFINITY; } +PGF_API +PgfExpr pgf_compute(PgfDB *db, PgfRevision revision, PgfExpr expr, + PgfMarshaller *m, PgfUnmarshaller *u, + PgfExn *err) +{ + return 0; +} + PGF_API PgfText *pgf_concrete_name(PgfDB *db, PgfConcrRevision revision, PgfExn *err) @@ -985,10 +993,10 @@ public: { } - virtual void match(ref lin, size_t seq_index, PgfExn* err) + virtual void match(ref lin, size_t lin_idx, PgfExn* err) { ref field = - lin->lincat->fields[seq_index % lin->lincat->fields.size()]; + lin->lincat->fields[lin_idx]; callback->fn(callback, &lin->absfun->name, field, lin->lincat->abscat->prob+lin->absfun->prob, err); } @@ -1012,7 +1020,9 @@ void pgf_lookup_morpho(PgfDB *db, PgfConcrRevision cnc_revision, bool case_sensitive = pgf_is_case_sensitive(concr); PgfMorphoScanner scanner(callback); - phrasetable_lookup(concr->phrasetable, + size_t n_items; + + phrasetable_lookup(concr->phrasetable1, sentence, case_sensitive, &scanner, err); } PGF_API_END @@ -1062,31 +1072,29 @@ void pgf_lookup_cohorts(PgfDB *db, PgfConcrRevision cnc_revision, bool case_sensitive = pgf_is_case_sensitive(concr); PgfCohortsScanner scanner(callback); - phrasetable_lookup_cohorts(concr->phrasetable, + phrasetable_lookup_cohorts(concr->phrasetable1, sentence, case_sensitive, &scanner, err); } PGF_API_END } PGF_API -PgfPhrasetableIds *pgf_iter_sequences(PgfDB *db, PgfConcrRevision cnc_revision, - PgfSequenceItor *itor, - PgfMorphoCallback *callback, - PgfExn *err) +void pgf_iter_sequences(PgfDB *db, PgfConcrRevision cnc_revision, + PgfSequenceItor *itor, + PgfMorphoCallback *callback, + PgfExn *err) { PGF_API_BEGIN { DB_scope scope(db, READER_SCOPE); ref concr = db->revision2concr(cnc_revision); - PgfPhrasetableIds *seq_ids = new PgfPhrasetableIds(); +/* PgfPhrasetableIds *seq_ids = new PgfPhrasetableIds(); seq_ids->start(concr); phrasetable_iter(concr, concr->phrasetable, itor, callback, seq_ids, err); - return seq_ids; + return seq_ids; */ } PGF_API_END - - return NULL; } PGF_API @@ -1095,7 +1103,7 @@ void pgf_get_lincat_counts_internal(object o, size_t *counts) ref lincat = o; counts[0] = lincat->fields.size(); counts[1] = lincat->n_lindefs; - counts[2] = lincat->res.size() - lincat->n_lindefs; + counts[2] = lincat->rules.size() - lincat->n_lindefs; } PGF_API @@ -1106,59 +1114,50 @@ PgfText *pgf_get_lincat_field_internal(object o, size_t i) } PGF_API -size_t pgf_get_lin_get_prod_count(object o) +size_t pgf_get_lin_rules_count(object o) { ref lin = o; - return lin->res.size(); + return lin->rules.size(); } PGF_API -PgfText *pgf_print_lindef_internal(PgfPhrasetableIds *seq_ids, object o, size_t i) +PgfText *pgf_print_lindef_internal(object o, size_t i) { ref lincat = o; PgfInternalMarshaller m; PgfPrinter printer(NULL,0,&m); - ref res = lincat->res[i]; - if (res->vars != 0) { - printer.lvar_ranges(res->vars, NULL); - printer.puts(" . "); + ref rule = lincat->rules[i]; + if (rule->ranges != 0) { + printer.lvar_ranges(rule->ranges, NULL); + printer.puts(" "); } - printer.efun(&lincat->name); printer.puts("("); - printer.lparam(ref::from_ptr(&res->param)); + printer.lparam(rule->res); printer.puts(") -> "); printer.efun(&lincat->name); - printer.puts("[String(0)] = ["); - - size_t n_seqs = lincat->fields.size(); - for (size_t j = 0; j < n_seqs; j++) { - if (j > 0) - printer.puts(","); - - ref seq = lincat->seqs[i*n_seqs + j]; - printer.seq_id(seq_ids, seq); - } - - printer.puts("]"); - + printer.puts("[String(0)]; "); + printer.lparam(rule->lin_idx); + printer.puts(" : "); + printer.symbols(rule->syms.as_vector()); return printer.get_text(); } PGF_API -PgfText *pgf_print_linref_internal(PgfPhrasetableIds *seq_ids, object o, size_t i) +PgfText *pgf_print_linref_internal(object o, size_t i) { ref lincat = o; PgfInternalMarshaller m; PgfPrinter printer(NULL,0,&m); - ref res = lincat->res[lincat->n_lindefs+i]; - if (res->vars != 0) { - printer.lvar_ranges(res->vars, NULL); - printer.puts(" . "); + ref rule = lincat->rules[lincat->n_lindefs+i]; + + if (rule->ranges != 0) { + printer.lvar_ranges(rule->ranges, NULL); + printer.puts(" "); } printer.puts("String(0) -> "); @@ -1166,74 +1165,52 @@ PgfText *pgf_print_linref_internal(PgfPhrasetableIds *seq_ids, object o, size_t printer.puts("["); printer.efun(&lincat->name); printer.puts("("); - printer.lparam(lincat->args[lincat->n_lindefs+i].param); - printer.puts(")] = ["); + printer.lparam(rule->args[0]); + printer.puts(")]; "); - size_t n_seqs = lincat->fields.size(); - ref seq = lincat->seqs[lincat->n_lindefs*n_seqs+i]; - printer.seq_id(seq_ids, seq); - - printer.puts("]"); + printer.lparam(rule->lin_idx); + printer.puts(" : "); + printer.symbols(rule->syms.as_vector()); return printer.get_text(); } PGF_API -PgfText *pgf_print_lin_internal(PgfPhrasetableIds *seq_ids, object o, size_t i) +PgfText *pgf_print_lin_internal(object o, size_t i) { ref lin = o; PgfInternalMarshaller m; PgfPrinter printer(NULL,0,&m); - ref res = lin->res[i]; + ref rule = lin->rules[i]; ref ty = lin->absfun->type; - if (res->vars != 0) { - printer.lvar_ranges(res->vars, NULL); - printer.puts(" . "); + if (rule->ranges != 0) { + printer.lvar_ranges(rule->ranges, NULL); + printer.puts(" "); } printer.efun(&ty->name); printer.puts("("); - printer.lparam(ref::from_ptr(&res->param)); + printer.lparam(rule->res); printer.puts(") -> "); printer.efun(&lin->name); printer.puts("["); - size_t n_args = lin->args.size() / lin->res.size(); - for (size_t j = 0; j < n_args; j++) { + for (size_t j = 0; j < rule->args.size(); j++) { if (j > 0) printer.puts(","); - printer.parg(ty->hypos.elem(j)->type, - lin->args.elem(i*n_args + j)); + printer.efun(&ty->hypos.elem(j)->type->name); + printer.puts("("); + printer.lparam(rule->args[j]); + printer.puts(")"); } - printer.puts("] = ["); + printer.puts("]; "); - size_t n_seqs = lin->seqs.size() / lin->res.size(); - for (size_t j = 0; j < n_seqs; j++) { - if (j > 0) - printer.puts(","); - - ref seq = lin->seqs[i*n_seqs + j]; - printer.seq_id(seq_ids, seq); - } - - printer.puts("]"); - - return printer.get_text(); -} - -PGF_API -PgfText *pgf_print_sequence_internal(size_t seq_id, object o) -{ - ref seq = o; - - PgfInternalMarshaller m; - PgfPrinter printer(NULL,0,&m); - - printer.nprintf(10,"S%zu = ", seq_id); - printer.sequence(seq); + printer.lparam(rule->lin_idx); + printer.puts(" : "); + printer.symbols(rule->syms.as_vector()); return printer.get_text(); } @@ -1241,14 +1218,14 @@ PgfText *pgf_print_sequence_internal(size_t seq_id, object o) PGF_API PgfText *pgf_sequence_get_text_internal(object o) { - ref seq = o; + ref rule = o; PgfPrinter printer(NULL,0,NULL); - for (size_t i = 0; i < seq->syms.size(); i++) { + for (size_t i = 0; i < rule->syms.size(); i++) { if (i > 0) printer.puts(" "); - PgfSymbol sym = seq->syms[i]; + PgfSymbol sym = rule->syms[i]; switch (ref::get_tag(sym)) { case PgfSymbolKS::tag: { auto sym_ks = ref::untagged(sym); @@ -1263,12 +1240,6 @@ PgfText *pgf_sequence_get_text_internal(object o) return printer.get_text(); } -PGF_API_DECL -void pgf_release_phrasetable_ids(PgfPhrasetableIds *seq_ids) -{ - delete seq_ids; -} - PGF_API PgfExpr pgf_check_expr(PgfDB *db, PgfRevision revision, PgfExpr e, PgfType ty, @@ -1514,8 +1485,13 @@ ref clone_concrete(ref pgf, ref concr) clone->cflags = concr->cflags; clone->lins = concr->lins; clone->lincats = concr->lincats; - clone->phrasetable = concr->phrasetable; + clone->phrasetable1 = concr->phrasetable1; + clone->phrasetable2 = concr->phrasetable2; + clone->phrasetable3 = concr->phrasetable3; + clone->phrasetable4 = concr->phrasetable4; + clone->epsilontable = concr->epsilontable; clone->printnames = concr->printnames; + clone->last_fid = concr->last_fid; memcpy(&clone->name, &concr->name, sizeof(PgfText)+concr->name.size+1); ref old_concr; @@ -1535,13 +1511,6 @@ void drop_lin(ref concr, PgfText *name) Namespace lins = namespace_delete(concr->lins, name, &lin); if (lin != 0) { - object container = lin.tagged(); - for (size_t i = 0; i < lin->seqs.size(); i++) { - ref seq = lin->seqs[i]; - PgfPhrasetable phrasetable = - phrasetable_delete(concr->phrasetable,container,i,seq); - concr->phrasetable = phrasetable; - } PgfConcrLin::release(lin); } concr->lins = lins; @@ -1681,6 +1650,7 @@ void pgf_drop_category(PgfDB *db, PgfRevision revision, PGF_API PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision, PgfText *name, + void **p_tm, PgfExn *err) { PGF_API_BEGIN { @@ -1698,8 +1668,13 @@ PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision, concr->cflags = 0; concr->lins = 0; concr->lincats = 0; - concr->phrasetable = 0; + concr->phrasetable1 = 0; + concr->phrasetable2 = 0; + concr->phrasetable3 = 0; + concr->phrasetable4 = 0; + concr->epsilontable = 0; concr->printnames = 0; + concr->last_fid = 0; memcpy(&concr->name, name, sizeof(PgfText)+name->size+1); Namespace concrs = @@ -1711,6 +1686,8 @@ PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision, object rev = db->register_concr_revision(revision, index); + *p_tm = new PgfParseTableMaker(concr); + db->ref_count++; return rev; } PGF_API_END @@ -1720,6 +1697,7 @@ PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision, PGF_API PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision, PgfText *name, + void **p_tm, PgfExn *err) { PGF_API_BEGIN { @@ -1735,6 +1713,8 @@ PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision, concr = clone_concrete(pgf, concr); + *p_tm = new PgfParseTableMaker(concr); + object rev = db->register_concr_revision(revision, index); db->ref_count++; return rev; @@ -1742,6 +1722,23 @@ PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision, return 0; } +PGF_API +void pgf_free_parse_table(PgfDB *db, + PgfRevision revision, PgfConcrRevision cnc_revision, + void *table_maker_) +{ + PgfParseTableMaker* table_maker = (PgfParseTableMaker*) table_maker_; + + DB_scope scope(db, WRITER_SCOPE); + + ref pgf = db->revision2pgf(revision); + ref concr = db->revision2concr(cnc_revision); + + table_maker->prepare(); + concr->last_fid = table_maker->get_last_fid(); + delete table_maker; +} + PGF_API void pgf_drop_concrete(PgfDB *db, PgfRevision revision, PgfText *name, @@ -1764,49 +1761,48 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision, class PGF_INTERNAL PgfLinBuilder : public PgfLinBuilderIface { ref concr; - - vector args; - vector> res; - vector> seqs; + vector> rules; object container; // what are we building? ref container_lincat; size_t var_index; size_t arg_index; - size_t res_index; - size_t seq_index; size_t sym_index; size_t alt_index; size_t n_lindefs; size_t n_linrefs; - ref seq; + size_t n_args; + size_t rule_index; + + vector syms; size_t pre_sym_index; + PgfParseTableMaker *table_maker; + const char *builder_error_msg = "Detected incorrect use of the linearization builder"; public: - PgfLinBuilder(ref concr) + PgfLinBuilder(ref concr, PgfParseTableMaker *table_maker) { this->concr = concr; - this->args = 0; - this->res = 0; - this->seqs = 0; + this->rules = 0; this->var_index = 0; this->arg_index = 0; - this->res_index = 0; - this->seq_index = 0; this->sym_index = (size_t) -1; this->alt_index = (size_t) -1; this->n_lindefs = 0; this->n_linrefs = 0; - this->seq = 0; + this->n_args = 0; + this->rule_index = 0; + this->syms = 0; this->pre_sym_index = (size_t) -1; + this->table_maker = table_maker; } ref build(ref abscat, @@ -1814,20 +1810,24 @@ public: size_t n_lindefs, size_t n_linrefs, PgfBuildLinIface *build, PgfExn *err) { - size_t n_prods = n_lindefs+n_linrefs; - this->args = vector::alloc(n_prods); - this->res = vector>::alloc(n_prods); - this->seqs = vector>::alloc(n_lindefs*n_fields+n_linrefs); + this->var_index = 0; + this->arg_index = 0; + this->sym_index = (size_t) -1; + this->alt_index = (size_t) -1; this->n_lindefs = n_lindefs; this->n_linrefs = n_linrefs; + this->n_args = 1; + this->rule_index = 0; + this->syms = 0; + this->pre_sym_index = (size_t) -1; + + this->rules = vector>::alloc(n_lindefs+n_linrefs); ref lincat = PgfDB::malloc(abscat->name.size+1); memcpy(&lincat->name, &abscat->name, sizeof(PgfText)+abscat->name.size+1); lincat->abscat = abscat; - lincat->args = args; - lincat->res = res; - lincat->seqs = seqs; lincat->n_lindefs = n_lindefs; + lincat->rules= this->rules; vector> db_fields = vector>::alloc(n_fields); for (size_t i = 0; i < n_fields; i++) { @@ -1840,7 +1840,7 @@ public: this->container_lincat = 0; build->build(this, err); - if (err->type == PGF_EXN_NONE && res_index != res.size()) { + if (err->type == PGF_EXN_NONE && rule_index != rules.size()) { err->type = PGF_EXN_PGF_ERROR; err->msg = builder_error_msg; } @@ -1849,10 +1849,14 @@ public: return 0; } + for (size_t i = lincat->n_lindefs; i < rules.size(); i++) { + table_maker->insert_rule(rules[i]); + } + return lincat; } - ref build(ref absfun, size_t n_prods, + ref build(ref absfun, size_t n_rules, PgfBuildLinIface *build, PgfExn *err) { ref lincat = @@ -1861,24 +1865,32 @@ public: throw pgf_error("Missing linearization category"); } - this->args = vector::alloc(n_prods*absfun->type->hypos.size()); - this->res = vector>::alloc(n_prods); - this->seqs = vector>::alloc(n_prods*lincat->fields.size()); - this->n_lindefs = n_prods; + this->var_index = 0; + this->arg_index = 0; + this->sym_index = (size_t) -1; + this->alt_index = (size_t) -1; + this->n_lindefs = n_rules; + this->n_linrefs = n_linrefs; + this->n_args = 1; + this->rule_index = 0; + this->syms = 0; + this->pre_sym_index = (size_t) -1; + + this->rules = vector>::alloc(n_rules); ref lin = PgfDB::malloc(absfun->name.size+1); memcpy(&lin->name, &absfun->name, sizeof(PgfText)+absfun->name.size+1); lin->absfun = absfun; lin->lincat = lincat; - lin->args = args; - lin->res = res; - lin->seqs = seqs; + lin->rules = this->rules; this->container = lin.tagged(); this->container_lincat = lincat; + this->n_args = absfun->type->hypos.size(); + build->build(this, err); - if (err->type == PGF_EXN_NONE && res_index != res.size()) { + if (err->type == PGF_EXN_NONE && rule_index != rules.size()) { err->type = PGF_EXN_PGF_ERROR; err->msg = builder_error_msg; } @@ -1887,29 +1899,50 @@ public: return 0; } + for (size_t i = 0; i < rules.size(); i++) { + table_maker->insert_rule(rules[i]); + } + return lin; } - void start_production(PgfExn *err) + void start_rule(size_t n_vars, size_t n_syms, PgfExn *err) { if (err->type != PGF_EXN_NONE) return; PGF_API_BEGIN { - if (res_index >= res.size()) + if (rule_index >= rules.size()) throw pgf_error(builder_error_msg); + + vector ranges = + (n_vars > 0) ? vector::alloc(n_vars) : 0; + vector> args = + (n_args > 0) ? vector>::alloc(n_args) : 0; + + ref rule = inline_vector::alloc(&PgfConcrRule::syms, n_syms); + rule->ranges = ranges; + rule->res = 0; + rule->container = container; + rule->args = args; + rule->lin_idx = 0; + rules[rule_index] = rule; + var_index = 0; - res[res_index] = 0; + arg_index = 0; + sym_index = 0; + + syms = rule->syms.as_vector(); } PGF_API_END } - void add_argument(size_t n_hypos, size_t i0, size_t n_terms, size_t *terms, PgfExn *err) + void add_argument(size_t i0, size_t n_terms, size_t *terms, PgfExn *err) { if (err->type != PGF_EXN_NONE) return; PGF_API_BEGIN { - if (arg_index >= args.size()) + if (rule_index >= rules.size() || rules[rule_index]->args == 0 || arg_index >= rules[rule_index]->args.size()) throw pgf_error(builder_error_msg); ref param = PgfDB::malloc(n_terms*2*sizeof(size_t)); @@ -1921,86 +1954,85 @@ public: param->terms[i].var = terms[2*i+1]; } - ref parg = args.elem(arg_index); - parg->param = param; + rules[rule_index]->args[arg_index] = param; arg_index++; } PGF_API_END } - void set_result(size_t n_vars, size_t i0, size_t n_terms, size_t *terms, PgfExn *err) + void set_result(size_t i0, size_t n_terms, size_t *terms, PgfExn *err) { if (err->type != PGF_EXN_NONE) return; PGF_API_BEGIN { - if (res_index >= res.size()) + if (rule_index >= rules.size() || rules[rule_index]->res != 0) throw pgf_error(builder_error_msg); - vector vars = - (n_vars > 0) ? vector::alloc(n_vars) - : 0; - - ref res_elem = PgfDB::malloc(n_terms*2*sizeof(size_t)); - res_elem->vars = vars; - res_elem->param.i0 = i0; - res_elem->param.n_terms = n_terms; + ref res = PgfDB::malloc(n_terms*2*sizeof(size_t)); + res->i0 = i0; + res->n_terms = n_terms; for (size_t i = 0; i < n_terms; i++) { - res_elem->param.terms[i].factor = terms[2*i]; - res_elem->param.terms[i].var = terms[2*i+1]; + res->terms[i].factor = terms[2*i]; + res->terms[i].var = terms[2*i+1]; } - res[res_index] = res_elem; + rules[rule_index]->res = res; } PGF_API_END } - void add_variable(size_t var, size_t range, PgfExn *err) + void set_lin_idx(size_t i0, size_t n_terms, size_t *terms, PgfExn *err) { if (err->type != PGF_EXN_NONE) return; PGF_API_BEGIN { - if (res_index >= res.size()) + if (rule_index >= rules.size() || rules[rule_index]->lin_idx != 0) throw pgf_error(builder_error_msg); - ref res_elem = res[res_index]; + ref lin_idx = PgfDB::malloc(n_terms*2*sizeof(size_t)); + lin_idx->i0 = i0; + lin_idx->n_terms = n_terms; - if (res_elem->vars == 0 || var_index >= res_elem->vars.size()) + for (size_t i = 0; i < n_terms; i++) { + lin_idx->terms[i].factor = terms[2*i]; + lin_idx->terms[i].var = terms[2*i+1]; + } + + rules[rule_index]->lin_idx = lin_idx; + } PGF_API_END + } + + void add_variable(size_t range, PgfExn *err) + { + if (err->type != PGF_EXN_NONE) + return; + + PGF_API_BEGIN { + if (rule_index >= rules.size()) throw pgf_error(builder_error_msg); - ref var_range = - res_elem->vars.elem(var_index); - var_range->var = var; - var_range->range = range; + ref rule = rules[rule_index]; + if (rule->ranges == 0 || var_index >= rule->ranges.size()) + throw pgf_error(builder_error_msg); + + rule->ranges[var_index] = range; var_index++; } PGF_API_END } - void start_sequence(size_t n_syms, PgfExn *err) - { - if (err->type != PGF_EXN_NONE) - return; - - PGF_API_BEGIN { - if (seq_index >= seqs.size()) - throw pgf_error(builder_error_msg); - - seq = inline_vector::alloc(&PgfSequence::syms, n_syms); - - seqs[seq_index] = seq; - sym_index = 0; - } PGF_API_END - } - void add_symcat(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err) { if (err->type != PGF_EXN_NONE) return; PGF_API_BEGIN { - if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size()) + if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size()) + throw pgf_error(builder_error_msg); + + if (d > n_args) throw pgf_error(builder_error_msg); ref symcat = PgfDB::malloc(n_terms*2*sizeof(size_t)); @@ -2013,7 +2045,7 @@ public: symcat->r.terms[i].var = terms[2*i+1]; } - seq->syms[sym_index] = symcat.tagged(); + syms[sym_index] = symcat.tagged(); sym_index++; } PGF_API_END } @@ -2024,7 +2056,10 @@ public: return; PGF_API_BEGIN { - if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size()) + if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size()) + throw pgf_error(builder_error_msg); + + if (d > n_args) throw pgf_error(builder_error_msg); ref symlit = PgfDB::malloc(n_terms*2*sizeof(size_t)); @@ -2037,7 +2072,7 @@ public: symlit->r.terms[i].var = terms[2*i+1]; } - seq->syms[sym_index] = symlit.tagged(); + syms[sym_index] = symlit.tagged(); sym_index++; } PGF_API_END } @@ -2048,14 +2083,17 @@ public: return; PGF_API_BEGIN { - if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size()) + if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size()) + throw pgf_error(builder_error_msg); + + if (d > n_args) throw pgf_error(builder_error_msg); ref symvar = PgfDB::malloc(); symvar->d = d; symvar->r = r; - seq->syms[sym_index] = symvar.tagged(); + syms[sym_index] = symvar.tagged(); sym_index++; } PGF_API_END } @@ -2066,13 +2104,13 @@ public: return; PGF_API_BEGIN { - if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size()) + if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size()) throw pgf_error(builder_error_msg); ref symtok = PgfDB::malloc(token->size+1); memcpy(&symtok->token, token, sizeof(PgfText)+token->size+1); - seq->syms[sym_index] = symtok.tagged(); + syms[sym_index] = symtok.tagged(); sym_index++; } PGF_API_END } @@ -2083,18 +2121,18 @@ public: return; PGF_API_BEGIN { - if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size() || pre_sym_index != (size_t) -1) + if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size() || pre_sym_index != (size_t) -1) throw pgf_error(builder_error_msg); - ref def = inline_vector::alloc(&PgfSequence::syms,n_syms); + vector def = vector::alloc(n_syms); ref symkp = inline_vector::alloc(&PgfSymbolKP::alts,n_alts); symkp->default_form = def; - seq->syms[sym_index] = symkp.tagged(); + syms[sym_index] = symkp.tagged(); pre_sym_index = sym_index; - seq = def; + syms = def; sym_index = 0; alt_index = 0; } PGF_API_END @@ -2109,7 +2147,7 @@ public: if (pre_sym_index == (size_t) -1) throw pgf_error(builder_error_msg); - ref form = inline_vector::alloc(&PgfSequence::syms, n_syms); + vector form = vector::alloc(n_syms); vector> prefixes = vector>::alloc(n_prefs); for (size_t i = 0; i < n_prefs; i++) { @@ -2117,14 +2155,14 @@ public: prefixes[i] = pref; } - seq = seqs[seq_index]; - ref symkp = ref::untagged(seq->syms[pre_sym_index]); + syms = rules[rule_index]->syms.as_vector(); + ref symkp = ref::untagged(syms[pre_sym_index]); ref alt = symkp->alts.elem(alt_index); alt->form = form; alt->prefixes = prefixes; - seq = form; + syms = form; sym_index = 0; } PGF_API_END } @@ -2138,8 +2176,8 @@ public: if (pre_sym_index == (size_t) -1) throw pgf_error(builder_error_msg); - seq = seqs[seq_index]; - ref symkp = ref::untagged(seq->syms[pre_sym_index]); + syms = rules[rule_index]->syms.as_vector(); + ref symkp = ref::untagged(syms[pre_sym_index]); if (alt_index >= symkp->alts.size()) throw pgf_error(builder_error_msg); @@ -2156,7 +2194,7 @@ public: if (pre_sym_index == (size_t) -1) throw pgf_error(builder_error_msg); - seq = seqs[seq_index]; + syms = rules[rule_index]->syms.as_vector(); sym_index = pre_sym_index+1; alt_index = 0; pre_sym_index = (size_t) -1; @@ -2169,10 +2207,10 @@ public: return; PGF_API_BEGIN { - if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size()) + if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size()) throw pgf_error(builder_error_msg); - seq->syms[sym_index] = ref(0).tagged(); + syms[sym_index] = ref(0).tagged(); sym_index++; } PGF_API_END } @@ -2183,10 +2221,10 @@ public: return; PGF_API_BEGIN { - if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size()) + if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size()) throw pgf_error(builder_error_msg); - seq->syms[sym_index] = ref(0).tagged(); + syms[sym_index] = ref(0).tagged(); sym_index++; } PGF_API_END } @@ -2197,10 +2235,10 @@ public: return; PGF_API_BEGIN { - if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size()) + if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size()) throw pgf_error(builder_error_msg); - seq->syms[sym_index] = ref(0).tagged(); + syms[sym_index] = ref(0).tagged(); sym_index++; } PGF_API_END } @@ -2211,10 +2249,10 @@ public: return; PGF_API_BEGIN { - if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size()) + if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size()) throw pgf_error(builder_error_msg); - seq->syms[sym_index] = ref(0).tagged(); + syms[sym_index] = ref(0).tagged(); sym_index++; } PGF_API_END } @@ -2225,10 +2263,10 @@ public: return; PGF_API_BEGIN { - if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size()) + if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size()) throw pgf_error(builder_error_msg); - seq->syms[sym_index] = ref(0).tagged(); + syms[sym_index] = ref(0).tagged(); sym_index++; } PGF_API_END } @@ -2239,79 +2277,38 @@ public: return; PGF_API_BEGIN { - if (seq == 0 || sym_index == (size_t) -1 || sym_index >= seq->syms.size()) + if (syms == 0 || sym_index == (size_t) -1 || sym_index >= syms.size()) throw pgf_error(builder_error_msg); - seq->syms[sym_index] = ref(0).tagged(); + syms[sym_index] = ref(0).tagged(); sym_index++; } PGF_API_END } - object end_sequence(PgfExn *err) - { - if (err->type != PGF_EXN_NONE) - return 0; - - ref entry = 0; - - PGF_API_BEGIN { - if (seq == 0 || sym_index != seq->syms.size()) - throw pgf_error(builder_error_msg); - - PgfPhrasetable phrasetable = - phrasetable_internalize(concr->phrasetable, - seq, container_lincat, container, seq_index, - &entry); - concr->phrasetable = phrasetable; - seqs[seq_index] = entry->seq; - - sym_index = (size_t) -1; - seq = 0; - seq_index++; - } PGF_API_END - - return entry.as_object(); - } - - void add_sequence_id(object seq_id, PgfExn *err) + void end_rule(PgfExn *err) { if (err->type != PGF_EXN_NONE) return; PGF_API_BEGIN { - if (seq_index >= seqs.size()) + if (rule_index >= rules.size()) throw pgf_error(builder_error_msg); - ref entry = seq_id; - phrasetable_add_backref(entry,PgfDB::get_txn_id(),container,seq_index); - - seqs[seq_index] = entry->seq; - - seq_index++; - } PGF_API_END - } - - void end_production(PgfExn *err) - { - if (err->type != PGF_EXN_NONE) - return; - - PGF_API_BEGIN { - size_t n_args = (args.size()/res.size()); - if (arg_index != (res_index+1)*n_args) + ref rule = rules[rule_index]; + if (rule->res == 0) throw pgf_error(builder_error_msg); - if (res[res_index] == 0) + if (arg_index < n_args) throw pgf_error(builder_error_msg); - size_t n_seqs = ((seqs.size()-n_linrefs)/(res.size()-n_linrefs)); - size_t exp_index = - (res_index < n_lindefs) ? (res_index+1)*n_seqs - : n_seqs * n_lindefs + (res_index-n_lindefs+1) ; - if (seq_index != exp_index) - throw pgf_error(builder_error_msg); + if ((ref::get_tag(rule->container) == PgfConcrLin::tag) || + (rule_index < n_lindefs)) { + /*PgfParseIndex parse_index = + parse_index_insert(concr->parse_index, rule); + concr->parse_index = parse_index;*/ + } - res_index++; + rule_index++; } PGF_API_END } }; @@ -2320,6 +2317,7 @@ public: PGF_API void pgf_create_lincat(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, + void *table_maker, PgfText *name, size_t n_fields, PgfText **fields, size_t n_lindefs, size_t n_linrefs, PgfBuildLinIface *build, PgfExn *err) @@ -2337,7 +2335,7 @@ void pgf_create_lincat(PgfDB *db, } ref lincat = - PgfLinBuilder(concr).build(abscat, n_fields, fields, n_lindefs, n_linrefs, build, err); + PgfLinBuilder(concr,(PgfParseTableMaker *)table_maker).build(abscat, n_fields, fields, n_lindefs, n_linrefs, build, err); if (lincat != 0) { Namespace lincats = namespace_insert(concr->lincats, lincat); @@ -2375,16 +2373,6 @@ void pgf_drop_lincat(PgfDB *db, }; probspace_iter(pgf->abstract.funs_by_cat, name, f, true); - // Remove the sequences comprizing the lindef and linref - object container = lincat.tagged(); - PgfPhrasetable phrasetable = concr->phrasetable; - for (size_t i = 0; i < lincat->seqs.size(); i++) { - ref seq = lincat->seqs[i]; - phrasetable = - phrasetable_delete(phrasetable,container,i,seq); - } - concr->phrasetable = phrasetable; - // Finaly remove the lincat object itself. PgfConcrLincat::release(lincat); } @@ -2395,11 +2383,12 @@ void pgf_drop_lincat(PgfDB *db, PGF_API void pgf_create_lin(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, - PgfText *name, size_t n_prods, + void *table_maker, + PgfText *name, size_t n_rules, PgfBuildLinIface *build, PgfExn *err) { - if (n_prods == 0) + if (n_rules == 0) return; PGF_API_BEGIN { @@ -2415,7 +2404,7 @@ void pgf_create_lin(PgfDB *db, } ref lin = - PgfLinBuilder(concr).build(absfun, n_prods, build, err); + PgfLinBuilder(concr,(PgfParseTableMaker *)table_maker).build(absfun, n_rules, build, err); if (lin != 0) { Namespace lins = namespace_insert(concr->lins, lin); @@ -2430,7 +2419,8 @@ void pgf_create_lin(PgfDB *db, PGF_API void pgf_alter_lin(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, - PgfText *name, size_t n_prods, + void *table_maker, + PgfText *name, size_t n_rules, PgfBuildLinIface *build, PgfExn *err) { @@ -2447,21 +2437,13 @@ void pgf_alter_lin(PgfDB *db, } ref lin = - PgfLinBuilder(concr).build(absfun, n_prods, build, err); + PgfLinBuilder(concr,(PgfParseTableMaker *)table_maker).build(absfun, n_rules, build, err); if (lin != 0) { ref old_lin; Namespace lins = namespace_replace(concr->lins, lin, &old_lin); concr->lins = lins; if (old_lin != 0) { - object container = old_lin.tagged(); - PgfPhrasetable phrasetable = concr->phrasetable; - for (size_t i = 0; i < old_lin->seqs.size(); i++) { - ref seq = old_lin->seqs[i]; - phrasetable = - phrasetable_delete(phrasetable,container,i,seq); - } - concr->phrasetable = phrasetable; PgfConcrLin::release(old_lin); } } @@ -2548,7 +2530,10 @@ PgfText *pgf_linearize(PgfDB *db, PgfConcrRevision revision, m->match_expr(&linearizer, expr); linearizer.reverse_and_label(true); if (linearizer.resolve()) { - linearizer.linearize(&out, 0); + if (!linearizer.linearize(&out, 0)) { + free(out.get_text()); + return NULL; + } return out.get_text(); } } PGF_API_END @@ -2574,7 +2559,7 @@ PgfText **pgf_linearize_all(PgfDB *db, PgfConcrRevision revision, m->match_expr(&linearizer, expr); linearizer.reverse_and_label(true); - while (linearizer.resolve()) { + if (linearizer.resolve()) { linearizer.linearize(&out, 0); PgfText *text = out.get_text(); if (text != NULL) { @@ -2612,12 +2597,13 @@ PgfText **pgf_tabular_linearize(PgfDB *db, PgfConcrRevision revision, throw pgf_systemerror(ENOMEM); size_t pos = 0; for (size_t i = 0; i < lincat->fields.size(); i++) { - linearizer.linearize(&out, i); - + bool ok = linearizer.linearize(&out, i); PgfText *text = out.get_text(); - if (text != NULL) { + if (ok) { res[pos++] = textdup(&*lincat->fields[i]); res[pos++] = text; + } else { + free(text); } } res[pos++] = NULL; @@ -2757,11 +2743,8 @@ PgfExprEnum *pgf_parse(PgfDB *db, PgfConcrRevision revision, if (lincat_u.lincat == 0) return 0; - PgfParser *parser = new PgfParser(concr, lincat_u.lincat, sentence, case_sensitive, m, u); - phrasetable_lookup_cohorts(concr->phrasetable, - sentence, case_sensitive, - parser, err); - parser->prepare(); + PgfParser *parser = new PgfParser(concr, sentence, case_sensitive, m, u); + parser->prepare(lincat_u.lincat); return parser; } PGF_API_END @@ -3122,91 +3105,3 @@ pgf_align_words(PgfDB *db, PgfConcrRevision revision, return NULL; } - -PGF_API PgfText * -pgf_graphviz_lr_automaton(PgfDB *db, PgfConcrRevision revision, - PgfExn *err) -{ - PGF_API_BEGIN { - DB_scope scope(db, READER_SCOPE); - - ref concr = db->revision2concr(revision); - - PgfPrinter printer(NULL,0,NULL); - - printer.puts("digraph {\n"); - for (size_t i = 0; i < concr->lrtable.size(); i++) { - ref state = concr->lrtable.elem(i); - - printer.nprintf(16, " s%zu [label=\"", i); - for (size_t j = 0; j < state->reductions.size(); j++) { - ref reduce = state->reductions.elem(j); - - switch (ref::get_tag(reduce->lin_obj)) { - case PgfConcrLin::tag: { - auto lin = - ref::untagged(reduce->lin_obj); - printer.efun(&lin->name); - break; - } - case PgfConcrLincat::tag: { - auto lincat = - ref::untagged(reduce->lin_obj); - printer.puts("linref "); - printer.efun(&lincat->name); - break; - } - } - - printer.puts("["); - for (size_t i = 0; i < reduce->args.size(); i++) { - ref arg = reduce->args.elem(i); - if (i > 0) - printer.puts(","); - if (arg->arg == 0 && arg->stk_idx == 0) { - printer.nprintf(32,"?"); - } else { - if (arg->arg != 0) - printer.nprintf(32,"?%zd",arg->arg->id); - if (arg->stk_idx != 0) - printer.nprintf(32,"$%zd",arg->stk_idx); - } - } - printer.nprintf(32,"] %zd\n",reduce->depth); - } - printer.puts("\""); - if (i == 0) printer.puts(",penwidth=3"); - printer.nprintf(16, "]\n"); - - for (size_t j = 0; j < state->shifts.size(); j++) { - ref shift = state->shifts.elem(j); - printer.nprintf(16, " s%zu -> s%zu [label=\"", i, shift->next_state); - printer.efun(&shift->lincat->name); - printer.nprintf(16, ".%zu\"];\n", shift->r); - } - - for (size_t j = 0; j < state->tokens.size(); j++) { - ref shift = state->tokens.elem(j); - printer.nprintf(16, " s%zu -> s%zu [label=\"", i, shift->next_state); - size_t sym_idx = shift->sym_idx; - while (sym_idx < shift->seq->syms.size()) { - if (ref::get_tag(shift->seq->syms[sym_idx]) != PgfSymbolKS::tag) - break; - if (sym_idx > shift->sym_idx) - printer.puts(" "); - auto symks = ref::untagged(shift->seq->syms[sym_idx]); - printer.puts("\\\""); - printer.put_esc_str(&symks->token); - printer.puts("\\\""); - sym_idx++; - } - printer.puts("\"];\n"); - } - } - printer.puts("}"); - - return printer.get_text(); - } PGF_API_END - - return NULL; -} diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 3c41c6e26..8a590591c 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -461,8 +461,6 @@ PGF_API_DECL void pgf_iter_lins(PgfDB *db, PgfConcrRevision cnc_revision, PgfItor *itor, PgfExn *err); -typedef struct PgfPhrasetableIds PgfPhrasetableIds; - typedef struct PgfSequenceItor PgfSequenceItor; struct PgfSequenceItor { int (*fn)(PgfSequenceItor* self, size_t seq_id, object value, @@ -493,10 +491,10 @@ void pgf_lookup_cohorts(PgfDB *db, PgfConcrRevision cnc_revision, PgfCohortsCallback* callback, PgfExn* err); PGF_API_DECL -PgfPhrasetableIds *pgf_iter_sequences(PgfDB *db, PgfConcrRevision cnc_revision, - PgfSequenceItor *itor, - PgfMorphoCallback *callback, - PgfExn *err); +void pgf_iter_sequences(PgfDB *db, PgfConcrRevision cnc_revision, + PgfSequenceItor *itor, + PgfMorphoCallback *callback, + PgfExn *err); PGF_API_DECL void pgf_get_lincat_counts_internal(object o, size_t *counts); @@ -505,26 +503,20 @@ PGF_API_DECL PgfText *pgf_get_lincat_field_internal(object o, size_t i); PGF_API_DECL -size_t pgf_get_lin_get_prod_count(object o); +size_t pgf_get_lin_rules_count(object o); PGF_API_DECL -PgfText *pgf_print_lindef_internal(PgfPhrasetableIds *seq_ids, object o, size_t i); +PgfText *pgf_print_lindef_internal(object o, size_t i); PGF_API_DECL -PgfText *pgf_print_linref_internal(PgfPhrasetableIds *seq_ids, object o, size_t i); +PgfText *pgf_print_linref_internal(object o, size_t i); PGF_API_DECL -PgfText *pgf_print_lin_internal(PgfPhrasetableIds *seq_ids, object o, size_t i); - -PGF_API_DECL -PgfText *pgf_print_sequence_internal(size_t seq_id, object o); +PgfText *pgf_print_lin_internal(object o, size_t i); PGF_API_DECL PgfText *pgf_sequence_get_text_internal(object o); -PGF_API_DECL -void pgf_release_phrasetable_ids(PgfPhrasetableIds *seq_ids); - PGF_API_DECL PgfExpr pgf_check_expr(PgfDB *db, PgfRevision revision, PgfExpr e, PgfType ty, @@ -620,14 +612,19 @@ void pgf_drop_category(PgfDB *db, PgfRevision revision, PGF_API_DECL PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision, - PgfText *name, + PgfText *name, void **p_tm, PgfExn *err); PGF_API_DECL PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision, - PgfText *name, + PgfText *name, void **p_tm, PgfExn *err); +PGF_API_DECL +void pgf_free_parse_table(PgfDB *db, + PgfRevision revision, PgfConcrRevision cnc_revision, + void *table_maker); + PGF_API_DECL void pgf_drop_concrete(PgfDB *db, PgfRevision revision, PgfText *name, @@ -635,11 +632,11 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision, #ifdef __cplusplus struct PgfLinBuilderIface { - virtual void start_production(PgfExn *err)=0; - virtual void add_argument(size_t n_hypos, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0; - virtual void set_result(size_t n_vars, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0; - virtual void add_variable(size_t var, size_t range, PgfExn *err)=0; - virtual void start_sequence(size_t n_syms, PgfExn *err)=0; + virtual void start_rule(size_t n_vars, size_t n_syms, PgfExn *err)=0; + virtual void add_argument(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0; + virtual void set_result(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0; + virtual void set_lin_idx(size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0; + virtual void add_variable(size_t range, PgfExn *err)=0; virtual void add_symcat(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0; virtual void add_symlit(size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err)=0; virtual void add_symvar(size_t d, size_t r, PgfExn *err)=0; @@ -654,9 +651,7 @@ struct PgfLinBuilderIface { virtual void add_symsoftspace(PgfExn *err)=0; virtual void add_symcapit(PgfExn *err)=0; virtual void add_symallcapit(PgfExn *err)=0; - virtual object end_sequence(PgfExn *err)=0; - virtual void add_sequence_id(object seq_id, PgfExn *err)=0; - virtual void end_production(PgfExn *err)=0; + virtual void end_rule(PgfExn *err)=0; }; struct PgfBuildLinIface { @@ -666,11 +661,11 @@ struct PgfBuildLinIface { typedef struct PgfLinBuilderIface PgfLinBuilderIface; typedef struct { - void (*start_production)(PgfLinBuilderIface *this, PgfExn *err); - void (*add_argument)(PgfLinBuilderIface *this, size_t n_hypos, size_t i0, size_t n_terms, size_t *terms, PgfExn *err); - void (*set_result)(PgfLinBuilderIface *this, size_t n_vars, size_t i0, size_t n_terms, size_t *terms, PgfExn *err); - void (*add_variable)(PgfLinBuilderIface *this, size_t var, size_t range, PgfExn *err); - void (*start_sequence)(PgfLinBuilderIface *this, size_t n_syms, PgfExn *err); + void (*start_rule)(PgfLinBuilderIface *this, size_t n_vars, size_t n_syms, PgfExn *err); + void (*add_argument)(PgfLinBuilderIface *this, size_t i0, size_t n_terms, size_t *terms, PgfExn *err); + void (*set_result)(PgfLinBuilderIface *this, size_t i0, size_t n_terms, size_t *terms, PgfExn *err); + void (*set_lin_idx)(PgfLinBuilderIface *this, size_t i0, size_t n_terms, size_t *terms, PgfExn *err); + void (*add_variable)(PgfLinBuilderIface *this, size_t range, PgfExn *err); void (*add_symcat)(PgfLinBuilderIface *this, size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err); void (*add_symlit)(PgfLinBuilderIface *this, size_t d, size_t i0, size_t n_terms, size_t *terms, PgfExn *err); void (*add_symvar)(PgfLinBuilderIface *this, size_t d, size_t r, PgfExn *err); @@ -685,9 +680,7 @@ typedef struct { void (*add_symsoftspace)(PgfLinBuilderIface *this, PgfExn *err); void (*add_symcapit)(PgfLinBuilderIface *this, PgfExn *err); void (*add_symallcapit)(PgfLinBuilderIface *this, PgfExn *err); - object (*end_sequence)(PgfLinBuilderIface *this, PgfExn *err); - void (*add_sequence_id)(PgfLinBuilderIface *this, object seq_id, PgfExn *err); - void (*end_production)(PgfLinBuilderIface *this, PgfExn *err); + void (*end_rule)(PgfLinBuilderIface *this, PgfExn *err); } PgfLinBuilderIfaceVtbl; struct PgfLinBuilderIface { @@ -708,6 +701,7 @@ struct PgfBuildLinIface { PGF_API_DECL void pgf_create_lincat(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, + void *table_maker, PgfText *name, size_t n_fields, PgfText **fields, size_t n_lindefs, size_t n_linrefs, PgfBuildLinIface *build, PgfExn *err); @@ -720,10 +714,19 @@ void pgf_drop_lincat(PgfDB *db, PGF_API_DECL void pgf_create_lin(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, - PgfText *name, size_t n_prods, + void *table_maker, + PgfText *name, size_t n_rules, PgfBuildLinIface *build, PgfExn *err); +PGF_API_DECL +void pgf_alter_lin(PgfDB *db, + PgfRevision revision, PgfConcrRevision cnc_revision, + void *table_maker, + PgfText *name, size_t n_rules, + PgfBuildLinIface *build, + PgfExn *err); + PGF_API_DECL void pgf_drop_lin(PgfDB *db, PgfRevision revision, PgfConcrRevision cnc_revision, @@ -916,8 +919,4 @@ pgf_align_words(PgfDB *db, PgfConcrRevision revision, size_t *n_phrases /* out */, PgfExn* err); -PGF_API PgfText * -pgf_graphviz_lr_automaton(PgfDB *db, PgfConcrRevision revision, - PgfExn *err); - #endif // PGF_H_ diff --git a/src/runtime/c/pgf/phrasetable.cxx b/src/runtime/c/pgf/phrasetable.cxx index 49e7c95c7..76b583d3c 100644 --- a/src/runtime/c/pgf/phrasetable.cxx +++ b/src/runtime/c/pgf/phrasetable.cxx @@ -1,77 +1,8 @@ #include "data.h" +#include "printer.h" #include -PgfPhrasetableIds::PgfPhrasetableIds() -{ - next_id = 0; - n_pairs = 0; - pairs = NULL; - chains = NULL; -} - -void PgfPhrasetableIds::start(ref concr) -{ - next_id = 0; - n_pairs = phrasetable_size(concr->phrasetable); - size_t mem_size = sizeof(SeqIdPair)*n_pairs; - pairs = (SeqIdPair*) malloc(mem_size); - if (pairs == NULL) - throw pgf_systemerror(ENOMEM); - memset(pairs, 0, mem_size); -} - -size_t PgfPhrasetableIds::add(ref seq) -{ - size_t index = (seq.as_object() >> 4) % n_pairs; - if (pairs[index].seq == 0) { - pairs[index].seq = seq; - pairs[index].seq_id = next_id++; - return pairs[index].seq_id; - } else { - SeqIdChain *chain = - (SeqIdChain*) malloc(sizeof(SeqIdChain)); - if (chain == NULL) - throw pgf_systemerror(ENOMEM); - chain->next = chains; - chain->chain = pairs[index].chain; - chain->seq = seq; - chain->seq_id = next_id++; - pairs[index].chain = chain; - chains = chain; - return chain->seq_id; - } -} - -size_t PgfPhrasetableIds::get(ref seq) -{ - size_t index = (seq.as_object() >> 4) % n_pairs; - if (pairs[index].seq == seq) { - return pairs[index].seq_id; - } else { - SeqIdChain *chain = pairs[index].chain; - while (chain != NULL) { - if (chain->seq == seq) - return chain->seq_id; - chain = chain->chain; - } - throw pgf_error("Can't find sequence id"); - } -} - -void PgfPhrasetableIds::end() -{ - next_id = 0; - n_pairs = 0; - - while (chains != NULL) { - SeqIdChain *next = chains->next; - free(chains); - chains = next; - } - - free(pairs); - pairs = NULL; -} +// #define DEBUG_PARSE_INDEX static int lparam_cmp(PgfLParam *p1, PgfLParam *p2) @@ -100,196 +31,29 @@ int lparam_cmp(PgfLParam *p1, PgfLParam *p2) return 0; } -static -int sequence_cmp(ref seq1, ref seq2); - -static -void symbol_cmp(PgfSymbol sym1, PgfSymbol sym2, int res[2]) -{ - uint8_t t1 = ref::get_tag(sym1); - uint8_t t2 = ref::get_tag(sym2); - - if (t1 != t2) { - res[0] = (res[1] = ((int) t1) - ((int) t2)); - return; - } - - switch (t1) { - case PgfSymbolCat::tag: { - auto sym_cat1 = ref::untagged(sym1); - auto sym_cat2 = ref::untagged(sym2); - if (sym_cat1->d < sym_cat2->d) - res[0] = (res[1] = -1); - else if (sym_cat1->d > sym_cat2->d) - res[0] = (res[1] = 1); - else - res[0] = (res[1] = lparam_cmp(&sym_cat1->r, &sym_cat2->r)); - break; - } - case PgfSymbolLit::tag: { - auto sym_lit1 = ref::untagged(sym1); - auto sym_lit2 = ref::untagged(sym2); - if (sym_lit1->d < sym_lit2->d) - res[0] = (res[1] = -1); - else if (sym_lit1->d > sym_lit2->d) - res[0] = (res[1] = 1); - else - res[0] = (res[1] = lparam_cmp(&sym_lit1->r, &sym_lit2->r)); - break; - } - case PgfSymbolVar::tag: { - auto sym_var1 = ref::untagged(sym1); - auto sym_var2 = ref::untagged(sym2); - if (sym_var1->d < sym_var2->d) - res[0] = (res[1] = -1); - else if (sym_var1->d > sym_var2->d) - res[0] = (res[1] = 1); - else if (sym_var1->r < sym_var2->r) - res[0] = (res[1] = -1); - else if (sym_var1->r > sym_var2->r) - res[0] = (res[1] = 1); - break; - } - case PgfSymbolKS::tag: { - auto sym_ks1 = ref::untagged(sym1); - auto sym_ks2 = ref::untagged(sym2); - texticmp(&sym_ks1->token,&sym_ks2->token,res); - break; - } - case PgfSymbolKP::tag: { - auto sym_kp1 = ref::untagged(sym1); - auto sym_kp2 = ref::untagged(sym2); - res[0] = (res[1] = sequence_cmp(sym_kp1->default_form, sym_kp2->default_form)); - if (res[0] != 0) - return; - - for (size_t i = 0; ; i++) { - if (i >= sym_kp1->alts.size()) { - res[0] = (res[1] = -(i < sym_kp2->alts.size())); - return; - } - if (i >= sym_kp2->alts.size()) { - res[0] = (res[1] = 1); - return; - } - - res[0] = (res[1] = sequence_cmp(sym_kp1->alts[i].form, sym_kp2->alts[i].form)); - if (res[0] != 0) - return; - - vector> prefixes1 = sym_kp1->alts[i].prefixes; - vector> prefixes2 = sym_kp2->alts[i].prefixes; - for (size_t j = 0; ; j++) { - if (j >= prefixes1.size()) { - res[0] = (res[1] = -(j < prefixes2.size())); - return; - } - if (j >= prefixes2.size()) { - res[0] = (res[1] = 1); - return; - } - - res[0] = (res[1] = textcmp(&*prefixes1[j], &*prefixes2[j])); - if (res[0] != 0) - return; - } - } - } - case PgfSymbolBIND::tag: - case PgfSymbolSOFTBIND::tag: - case PgfSymbolNE::tag: - case PgfSymbolSOFTSPACE::tag: - case PgfSymbolCAPIT::tag: - case PgfSymbolALLCAPIT::tag: - break; - default: - throw pgf_error("Unknown symbol tag"); - } -} - -static -int sequence_cmp(ref seq1, ref seq2) -{ - int res[2] = {0,0}; - for (size_t i = 0; ; i++) { - if (i >= seq1->syms.size()) { - if (i < seq2->syms.size()) - return -1; - return res[1]; - } - if (i >= seq2->syms.size()) - return 1; - - symbol_cmp(seq1->syms[i], seq2->syms[i], res); - if (res[0] != 0) - return res[0]; - } - - return 0; -} - PGF_INTERNAL -int text_sequence_cmp(PgfTextSpot *spot, const uint8_t *end, - ref seq, size_t *p_i, - bool case_sensitive, SeqMatch sm) +int text_symbol_cmp(PgfTextSpot *spot, const uint8_t *end, + ref sym_ks, bool case_sensitive) { - int res1 = 0; + int res1 = 0; - const uint8_t *s2 = NULL; - const uint8_t *e2 = NULL; - - uint8_t t = 0xff; - if (*p_i < seq->syms.size()) { - t = ref::get_tag(seq->syms[*p_i]); - } - - size_t count = 0; + const uint8_t *s2 = (uint8_t *) &sym_ks->token.text; + const uint8_t *e2 = s2+sym_ks->token.size; for (;;) { if (spot->ptr >= end) { - if (s2 < e2 || t == PgfSymbolKS::tag) + if (s2 < e2) return -1; return case_sensitive ? res1 : 0; } - if (s2 >= e2 && t != PgfSymbolKS::tag) { - return (sm == SM_FULL_MATCH) ? 1 : 0; + if (s2 >= e2) { + return case_sensitive ? res1 : 0; } uint32_t ucs1 = pgf_utf8_decode(&spot->ptr); spot->pos++; uint32_t ucs1i = pgf_utf8_to_upper(ucs1); - if (s2 >= e2) { - if (s2 != NULL) { - if (pgf_utf8_is_space(ucs1)) { - count++; - continue; - } - - if (count == 0) { - return (((int) ucs1) - ' '); - } else { - count = 0; - } - } - - if (t != PgfSymbolKS::tag) { - if (sm == SM_PARTIAL) - return 0; - return ((int) PgfSymbolKS::tag) - ((int) t); - } - - auto sym_ks = ref::untagged(seq->syms[*p_i]); - s2 = (uint8_t *) &sym_ks->token.text; - e2 = s2+sym_ks->token.size; - - (*p_i)++; - t = 0xff; - if (*p_i < seq->syms.size()) { - t = ref::get_tag(seq->syms[*p_i]); - } - } - uint32_t ucs2 = pgf_utf8_decode(&s2); uint32_t ucs2i = pgf_utf8_to_upper(ucs2); @@ -309,183 +73,126 @@ int text_sequence_cmp(PgfTextSpot *spot, const uint8_t *end, } } +static +bool text_symbols_match(PgfTextSpot *spot, const uint8_t *end, + vector syms, size_t dot, bool *bind, + bool case_sensitive) +{ + while (dot < syms.size()) { + PgfSymbol sym = syms[dot]; + switch (ref::get_tag(sym)) { + case PgfSymbolKS::tag: { + const uint8_t *start = spot->ptr; + for (;;) { + const uint8_t *ptr = spot->ptr; + uint32_t ucs = pgf_utf8_decode(&ptr); + if (!pgf_utf8_is_space(ucs)) + break; + spot->ptr = ptr; + spot->pos++; + } + + if (*bind != (start == spot->ptr)) + return false; + + if (text_symbol_cmp(spot,end,sym,case_sensitive) != 0) + return false; + + break; + } + case PgfSymbolKP::tag: { + auto symkp = ref::untagged(syms[dot]); + + PgfTextSpot current = *spot; + if (text_symbols_match(¤t, end, symkp->default_form, 0, bind, case_sensitive)) { + goto matched; + } + + for (size_t i = 0; i < symkp->alts.size(); i++) { + current = *spot; + if (text_symbols_match(¤t, end, symkp->alts[i].form, 0, bind, case_sensitive)) { + goto matched; + } + } + + return false; + + matched: + *spot = current; + break; + } + case PgfSymbolBIND::tag: { + *bind = true; + break; + } + case PgfSymbolSOFTBIND::tag: + case PgfSymbolSOFTSPACE::tag: { + *bind = true; + break; + } + case PgfSymbolCAPIT::tag: + case PgfSymbolALLCAPIT::tag: + // skip + break; + default: + return false; + } + + dot++; + } + + return true; +} + +static +bool text_item_match(PgfTextSpot *spot, const uint8_t *end, + ref item, + bool case_sensitive) +{ + bool bind = false; + size_t dot = item->dot+1; + vector syms = item->rule->syms.as_vector(); + if (item->pre_alt > 0) { + auto symkp = ref::untagged(syms[item->pre_dot]); + if (item->pre_alt == 1) { + if (!text_symbols_match(spot, end, symkp->default_form, item->dot, &bind, case_sensitive)) + return false; + } else { + if (!text_symbols_match(spot, end, symkp->alts[item->pre_alt-2].form, item->dot, &bind, case_sensitive)) + return false; + } + dot = item->pre_dot+1; + } + return text_symbols_match(spot, end, syms, dot, &bind, case_sensitive); +} + PGF_INTERNAL_DECL size_t get_next_padovan(size_t min); -PGF_INTERNAL_DECL -void phrasetable_add_backref(ref entry, txn_t txn_id, - object container, - size_t seq_index) -{ - vector backrefs = entry->backrefs; - - size_t len = (backrefs != 0) ? backrefs.size() : 0; - if (entry->n_backrefs >= len) { - size_t new_len = get_next_padovan(entry->n_backrefs+1); - backrefs = backrefs.realloc(new_len, txn_id); - } - backrefs[entry->n_backrefs].container = container; - backrefs[entry->n_backrefs].seq_index = seq_index; - - entry->n_backrefs++; - entry->backrefs = backrefs; -} - +template PGF_INTERNAL -PgfPhrasetable phrasetable_internalize(PgfPhrasetable table, - ref seq, - ref lincat, - object container, - size_t seq_index, - ref *pentry) +vector> phrasetable_lookup(PgfPhrasetable phrasetable, + ref key, + size_t *n_items) { - if (table == 0) { - PgfPhrasetableEntry entry; - entry.seq = seq; - entry.n_backrefs = 1; - entry.backrefs = vector::alloc(1); - entry.backrefs[0].container = container; - entry.backrefs[0].seq_index = seq_index; - PgfPhrasetable new_table = Node::new_node(entry); - *pentry = ref::from_ptr(&new_table->value); - return new_table; - } - - int cmp = sequence_cmp(seq,table->value.seq); - if (cmp < 0) { - PgfPhrasetable left = phrasetable_internalize(table->left, - seq, - lincat, - container, - seq_index, - pentry); - table = Node::upd_node(table,left,table->right); - return Node::balanceL(table); - } else if (cmp > 0) { - PgfPhrasetable right = phrasetable_internalize(table->right, - seq, - lincat, - container, - seq_index, - pentry); - table = Node::upd_node(table, table->left, right); - return Node::balanceR(table); - } else { - PgfSequence::release(seq); - - PgfPhrasetable new_table = - Node::upd_node(table, table->left, table->right); - *pentry = ref::from_ptr(&new_table->value); - phrasetable_add_backref(*pentry,table->txn_id,container,seq_index); - return new_table; - } -} - -PGF_INTERNAL -ref phrasetable_relink(PgfPhrasetable table, - object container, - size_t seq_index, - size_t seq_id) -{ - while (table != 0) { - size_t left_sz = (table->left==0) ? 0 : table->left->sz; - if (seq_id < left_sz) - table = table->left; - else if (seq_id == left_sz) { - auto entry = ref::from_ptr(&table->value); - phrasetable_add_backref(entry,table->txn_id,container,seq_index); - return table->value.seq; - } else { - table = table->right; - seq_id -= left_sz+1; - } - } - return 0; -} - -PGF_INTERNAL -PgfPhrasetable phrasetable_delete(PgfPhrasetable table, - object container, - size_t seq_index, - ref seq) -{ - if (table == 0) - return 0; - - int cmp = sequence_cmp(seq,table->value.seq); - if (cmp < 0) { - PgfPhrasetable left = phrasetable_delete(table->left, - container, seq_index, - seq); - table = Node::upd_node(table,left,table->right); - return Node::balanceR(table); - } else if (cmp > 0) { - PgfPhrasetable right = phrasetable_delete(table->right, - container, seq_index, - seq); - table = Node::upd_node(table,table->left,right); - return Node::balanceL(table); - } else { - size_t len = table->value.backrefs.size(); - size_t n_backrefs = table->value.n_backrefs; - if (n_backrefs > 1) { - vector backrefs = - table->value.backrefs.realloc(n_backrefs,table->txn_id); - size_t i = 0; - while (i < n_backrefs) { - ref backref = backrefs.elem(i); - if (backref->container == container && - backref->seq_index == seq_index) { - break; - } - i++; - } - i++; - while (i < n_backrefs) { - backrefs[i-1] = table->value.backrefs[i]; - i++; - } - n_backrefs--; - - PgfPhrasetable new_table = - Node::upd_node(table, table->left, table->right); - new_table->value.n_backrefs = n_backrefs; - new_table->value.backrefs = backrefs; - return new_table; - } else { - PgfSequence::release(table->value.seq); - vector::release(table->value.backrefs); - if (table->left == 0) { - Node::release(table); - return table->right; - } else if (table->right == 0) { - Node::release(table); - return table->left; - } else if (table->left->sz > table->right->sz) { - PgfPhrasetable node; - PgfPhrasetable left = Node::pop_last(table->left, &node); - node = Node::upd_node(node, left, table->right); - Node::release(table); - return Node::balanceR(node); - } else { - PgfPhrasetable node; - PgfPhrasetable right = Node::pop_first(table->right, &node); - node = Node::upd_node(node, table->left, right); - Node::release(table); - return Node::balanceL(node); - } + while (phrasetable != 0) { + int cmp = compare_key(key, phrasetable->value.key); + if (cmp < 0) + phrasetable = phrasetable->left; + else if (cmp > 0) + phrasetable = phrasetable->right; + else { + *n_items = phrasetable->value.n_items; + return phrasetable->value.items; } } + + *n_items = 0; + return 0; } PGF_INTERNAL -size_t phrasetable_size(PgfPhrasetable table) -{ - return Node::size(table); -} - -PGF_INTERNAL -void phrasetable_lookup(PgfPhrasetable table, +void phrasetable_lookup(PgfPhrasetable table, PgfText *sentence, bool case_sensitive, PgfPhraseScanner *scanner, PgfExn* err) @@ -493,27 +200,34 @@ void phrasetable_lookup(PgfPhrasetable table, if (table == 0) return; - PgfTextSpot current; - current.pos = 0; - current.ptr = (uint8_t *) sentence->text; - const uint8_t *end = current.ptr+sentence->size; - size_t sym_idx = 0; - int cmp = text_sequence_cmp(¤t,end,table->value.seq,&sym_idx,case_sensitive,SM_FULL_MATCH); + PgfTextSpot spot; + spot.pos = 0; + spot.ptr = (uint8_t *) sentence->text; + const uint8_t *end = spot.ptr+sentence->size; + int cmp = text_symbol_cmp(&spot,end,table->value.key,case_sensitive); if (cmp < 0) { phrasetable_lookup(table->left,sentence,case_sensitive,scanner,err); } else if (cmp > 0) { phrasetable_lookup(table->right,sentence,case_sensitive,scanner,err); } else { - auto backrefs = table->value.backrefs; - for (size_t i = 0; i < table->value.n_backrefs; i++) { - PgfSequenceBackref backref = backrefs[i]; - switch (ref::get_tag(backref.container)) { + if (!case_sensitive) { + phrasetable_lookup(table->left,sentence,case_sensitive,scanner,err); + if (err->type != PGF_EXN_NONE) + return; + } + + for (size_t i = 0; i < table->value.n_items; i++) { + ref item = table->value.items[i]; + switch (ref::get_tag(item->rule->container)) { case PgfConcrLin::tag: { - ref lin = ref::untagged(backref.container); + ref lin = ref::untagged(item->rule->container); if (lin->absfun->type->hypos.size() == 0) { - scanner->match(lin, backref.seq_index, err); - if (err->type != PGF_EXN_NONE) - return; + PgfTextSpot current = spot; + if (text_item_match(¤t, end, item, case_sensitive) && current.ptr == end) { + scanner->match(lin, item->rule->lin_idx->i0, err); + if (err->type != PGF_EXN_NONE) + return; + } } break; } @@ -525,10 +239,7 @@ void phrasetable_lookup(PgfPhrasetable table, } if (!case_sensitive) { - phrasetable_lookup(table->left,sentence,false,scanner,err); - if (err->type != PGF_EXN_NONE) - return; - phrasetable_lookup(table->right,sentence,false,scanner,err); + phrasetable_lookup(table->right,sentence,case_sensitive,scanner,err); if (err->type != PGF_EXN_NONE) return; } @@ -599,15 +310,14 @@ void finish_skipping(PgfCohortsState *state) { static void phrasetable_lookup_prefixes(PgfCohortsState *state, - PgfPhrasetable table, + PgfPhrasetable table, ptrdiff_t min, ptrdiff_t max) { if (table == 0) return; PgfTextSpot current = state->spot; - size_t sym_idx = 0; - int cmp = text_sequence_cmp(¤t,state->end,table->value.seq,&sym_idx,state->case_sensitive,SM_PREFIX); + int cmp = text_symbol_cmp(¤t,state->end,table->value.key,state->case_sensitive); if (cmp < 0) { phrasetable_lookup_prefixes(state,table->left,min,max); } else if (cmp > 0) { @@ -628,8 +338,7 @@ void phrasetable_lookup_prefixes(PgfCohortsState *state, if (min <= len) phrasetable_lookup_prefixes(state,table->left,min,len); - auto backrefs = table->value.backrefs; - if (len > 0 && backrefs != 0) { + if (len > 0) { if (state->last.pos != current.pos) { if (state->last.pos > 0) { state->scanner->end_matches(&state->last, @@ -647,14 +356,14 @@ void phrasetable_lookup_prefixes(PgfCohortsState *state, } state->queue.push(current); - for (size_t i = 0; i < table->value.n_backrefs; i++) { - PgfSequenceBackref backref = backrefs[i]; - switch (ref::get_tag(backref.container)) { + for (size_t i = 0; i < table->value.n_items; i++) { + auto rule = table->value.items[i]->rule; + switch (ref::get_tag(rule->container)) { case PgfConcrLin::tag: { - ref lin = ref::untagged(backref.container); + ref lin = ref::untagged(rule->container); if (lin->absfun->type->hypos.size() == 0) { state->scanner->match(lin, - backref.seq_index, + rule->lin_idx->i0, state->err); if (state->err->type != PGF_EXN_NONE) return; @@ -675,7 +384,7 @@ void phrasetable_lookup_prefixes(PgfCohortsState *state, } PGF_INTERNAL -void phrasetable_lookup_cohorts(PgfPhrasetable table, +void phrasetable_lookup_cohorts(PgfPhrasetable table, PgfText *sentence, bool case_sensitive, PgfPhraseScanner *scanner, PgfExn* err) @@ -762,62 +471,223 @@ void phrasetable_lookup_cohorts(PgfPhrasetable table, } } +template PGF_INTERNAL -void phrasetable_iter(PgfConcr *concr, - PgfPhrasetable table, - PgfSequenceItor* itor, - PgfMorphoCallback *callback, - PgfPhrasetableIds *seq_ids, PgfExn *err) +PgfPhrasetable phrasetable_insert(PgfPhrasetable table, + ref key, ref item) { - if (table == 0) - return; + if (table == 0) { + auto items = vector>::alloc(1); + items[0] = item; + return Node>::new_node({.key=key,.n_items=1,.items=items}); + } - phrasetable_iter(concr, table->left, itor, callback, seq_ids, err); - if (err->type != PGF_EXN_NONE) - return; + int cmp = compare_key(key, table->value.key); + if (cmp < 0) { + PgfPhrasetable left = phrasetable_insert(table->left, key, item); + table = Node>::upd_node(table,left,table->right); + return Node>::balanceL(table); + } else if (cmp > 0) { + PgfPhrasetable right = phrasetable_insert(table->right, key, item); + table = Node>::upd_node(table, table->left, right); + return Node>::balanceR(table); + } else { + PgfPhrasetable new_table = + Node>::upd_node(table, table->left, table->right); - size_t seq_id = seq_ids->add(table->value.seq); - int res = itor->fn(itor, seq_id, table->value.seq.as_object(), err); - if (err->type != PGF_EXN_NONE) - return; - - if (table->value.backrefs != 0 && res == 0 && callback != 0) { - for (size_t i = 0; i < table->value.n_backrefs; i++) { - PgfSequenceBackref backref = table->value.backrefs[i]; - switch (ref::get_tag(backref.container)) { - case PgfConcrLin::tag: { - ref lin = ref::untagged(backref.container); - ref lincat = - namespace_lookup(concr->lincats, &lin->absfun->type->name); - if (lincat != 0) { - ref field = - lincat->fields[backref.seq_index % lincat->fields.size()]; - - callback->fn(callback, &lin->absfun->name, &*field, lincat->abscat->prob+lin->absfun->prob, err); - if (err->type != PGF_EXN_NONE) - return; - } - break; - } - case PgfConcrLincat::tag: { - //ignore - break; - } - } + auto items = new_table->value.items; + if (new_table->value.n_items >= items.size()) { + size_t new_len = get_next_padovan(new_table->value.n_items+1); + items = items.realloc(new_len, new_table->txn_id); } + items[new_table->value.n_items] = item; + new_table->value.n_items++; + new_table->value.items = items; + return new_table; + } +} + +static +int compare_key(ref symks1, ref symks2) { + int res[2] = {0,0}; + texticmp(&symks1->token, &symks2->token, res); + if (res[0] != 0) + return res[0]; + return res[1]; +} + +template +PgfPhrasetable phrasetable_insert(PgfPhrasetable table, + ref key, + ref item); + +static +int compare_key(ref lincat1, ref lincat2) { + return textcmp(&lincat1->name, &lincat2->name); +} + +template +PGF_INTERNAL +PgfPhrasetable phrasetable_insert(PgfPhrasetable table, + ref key, + ref item); + +template +PGF_INTERNAL +vector> phrasetable_lookup(PgfPhrasetable phrasetable, + ref key, + size_t *n_items); + +static +int compare_key(ref ccat1, ref ccat2) { + return ((int) ccat1->fid) - ((int) ccat2->fid); +} + +template +PgfPhrasetable phrasetable_insert(PgfPhrasetable table, + ref key, + ref item); + +template +PGF_INTERNAL +vector> phrasetable_lookup(PgfPhrasetable phrasetable, + ref key, + size_t *n_items); + +static +int compare_key(ref symbind1, ref symbind2) { + return 0; +} + +template +PgfPhrasetable phrasetable_insert(PgfPhrasetable table, + ref key, + ref item); + +template +PGF_INTERNAL +vector> phrasetable_lookup(PgfPhrasetable phrasetable, + ref key, + size_t *n_items); + +PGF_INTERNAL +PgfEpsilontable epsilontable_insert(PgfEpsilontable table, + ref lincat, + interval_t value, interval_t lin_idx, + PgfMetaId fid, prob_t viterbi_prob, + ref item, + ref *pepsilon) +{ + if (table == 0) { + auto items = vector>::alloc(1); + items[0] = item; + PgfEpsilontable new_table = + Node::new_node({.lincat=lincat, + .fid=fid, + .value=value, + .lin_idx=lin_idx, + .viterbi_prob=viterbi_prob, + .n_items=1, + .items=items}); + *pepsilon = ref::from_ptr(&new_table->value); + return new_table; + } + + int cmp = textcmp(&lincat->name, &table->value.lincat->name); + if (cmp == 0) { + cmp = ((int)fid) - ((int)table->value.fid); } - phrasetable_iter(concr, table->right, itor, callback, seq_ids, err); - if (err->type != PGF_EXN_NONE) - return; + if (cmp < 0) { + PgfEpsilontable left = epsilontable_insert(table->left, + lincat, value, lin_idx, fid, viterbi_prob, item, pepsilon); + table = Node::upd_node(table,left,table->right); + return Node::balanceL(table); + } else if (cmp > 0) { + PgfEpsilontable right = epsilontable_insert(table->right, + lincat, value, lin_idx, fid, viterbi_prob, item, pepsilon); + table = Node::upd_node(table, table->left, right); + return Node::balanceR(table); + } else { + PgfEpsilontable new_table = + Node::upd_node(table, table->left, table->right); + + auto items = table->value.items; + if (table->value.n_items >= items.size()) { + size_t new_len = get_next_padovan(table->value.n_items+1); + items = items.realloc(new_len, table->txn_id); + } + items[table->value.n_items] = item; + new_table->value.n_items++; + new_table->value.items = items; + *pepsilon = ref::from_ptr(&new_table->value); + return new_table; + } } PGF_INTERNAL -void phrasetable_release(PgfPhrasetable table) +void epsilontable_add(ref epsilon,ref item) +{ + auto items = epsilon->items; + if (epsilon->n_items >= items.size()) { + size_t new_len = get_next_padovan(epsilon->n_items+1); + items = items.realloc(new_len, PgfDB::get_txn_id()); + } + items[epsilon->n_items] = item; + epsilon->n_items++; + epsilon->items = items; +} + +PGF_INTERNAL +ref epsilontable_get(PgfEpsilontable table, + PgfText *name, PgfMetaId fid) +{ + if (table == 0) { + return 0; + } + + int cmp = textcmp(name, &table->value.lincat->name); + if (cmp == 0) { + cmp = ((int)fid) - ((int)table->value.fid); + } + + if (cmp < 0) { + return epsilontable_get(table->left,name,fid); + } else if (cmp > 0) { + return epsilontable_get(table->right,name,fid); + } else { + return ref::from_ptr(&table->value); + } +} + +PGF_INTERNAL +void epsilontable_iter(PgfEpsilontable table, ref lincat, std::function arg)> &f) { if (table == 0) return; - phrasetable_release(table->left); - phrasetable_release(table->right); - Node::release(table); + + int cmp = textcmp(&lincat->name, &table->value.lincat->name); + if (cmp < 0) + epsilontable_iter(table->left, lincat, f); + else if (cmp > 0) + epsilontable_iter(table->right, lincat, f); + else { + epsilontable_iter(table->left, lincat, f); + f(ref::from_ptr(&table->value)); + epsilontable_iter(table->right, lincat, f); + } +} + +PGF_INTERNAL +void epsilontable_release(PgfEpsilontable table) +{ + if (table == 0) + return; + epsilontable_release(table->left); + epsilontable_release(table->right); + for (size_t i = 0; i < table->value.n_items; i++) { + PgfItem::release(table->value.items[i]); + } + vector>::release(table->value.items); + Node::release(table); } diff --git a/src/runtime/c/pgf/phrasetable.h b/src/runtime/c/pgf/phrasetable.h index eabd74abd..3d8cb4c86 100644 --- a/src/runtime/c/pgf/phrasetable.h +++ b/src/runtime/c/pgf/phrasetable.h @@ -1,138 +1,151 @@ #ifndef PHRASETABLE_H #define PHRASETABLE_H -struct PgfSequence; -struct PgfSequenceBackref; - -struct PGF_INTERNAL_DECL PgfPhrasetableEntry { - ref seq; - - // Here n_backrefs tells us how many actual backrefs there are in - // the vector backrefs. On the other hand, backrefs->len tells us - // how big buffer we have allocated. - size_t n_backrefs; - vector backrefs; -}; - -struct PgfSequenceItor; -typedef ref> PgfPhrasetable; - - -#if __GNUC__ -#pragma GCC diagnostic push -#pragma GCC diagnostic ignored "-Wattributes" -#endif - -struct PgfPhrasetableIds { -public: - PGF_INTERNAL_DECL PgfPhrasetableIds(); - PGF_INTERNAL_DECL ~PgfPhrasetableIds() { end(); } - - PGF_INTERNAL_DECL void start(ref concr); - PGF_INTERNAL_DECL size_t add(ref seq); - PGF_INTERNAL_DECL size_t get(ref seq); - PGF_INTERNAL_DECL void end(); - -private: - size_t next_id; - - struct PGF_INTERNAL_DECL SeqIdChain; - - struct PGF_INTERNAL_DECL SeqIdPair { - SeqIdChain *chain; - ref seq; - size_t seq_id; - }; - - struct PGF_INTERNAL_DECL SeqIdChain : public SeqIdPair { - SeqIdChain *next; - }; - - size_t n_pairs; - SeqIdPair *pairs; - SeqIdChain *chains; -}; - -#if __GNUC__ -#pragma GCC diagnostic pop -#endif - -struct PgfConcrLincat; - -PGF_INTERNAL_DECL -PgfPhrasetable phrasetable_internalize(PgfPhrasetable table, - ref seq, - ref lincat, - object container, - size_t seq_index, - ref *pentry); - -PGF_INTERNAL_DECL -ref phrasetable_relink(PgfPhrasetable table, - object container, - size_t seq_index, - size_t seq_id); - -PGF_INTERNAL_DECL -PgfPhrasetable phrasetable_delete(PgfPhrasetable table, - object container, - size_t seq_index, - ref seq); - -PGF_INTERNAL_DECL -size_t phrasetable_size(PgfPhrasetable table); - struct PgfConcrLin; +struct PgfConcrLincat; struct PGF_INTERNAL_DECL PgfTextSpot { size_t pos; // position in Unicode characters const uint8_t *ptr; // pointer into the spot location }; +struct PGF_INTERNAL_DECL PgfItem { + PgfMetaId res; + + struct { + size_t &operator[](int i) { + PgfItem *item = containerof(PgfItem,vars,this); + return ((size_t*) (((PgfMetaId*) (item+1))+item->rule->args.size()))[i]; + } + size_t size() { + PgfItem *item = containerof(PgfItem,vars,this); + return (item->rule->ranges != 0) ? item->rule->ranges.size() : 0; + } + } vars; + + struct { + PgfMetaId &operator[](int i) { + PgfItem *item = containerof(PgfItem,args,this); + return ((PgfMetaId*) (item+1))[i]; + } + size_t size() { + PgfItem *item = containerof(PgfItem,args,this); + return item->rule->args.size(); + } + } args; + + static + void release(ref item) { + size_t ex_size = + sizeof(PgfMetaId) * item->args.size() + + sizeof(size_t) * item->vars.size(); + PgfDB::free(item, ex_size); + } + + uint16_t pre_alt; + uint16_t pre_dot; + uint16_t dot; + ref rule; +}; + +struct PGF_INTERNAL_DECL PgfCCat { + ref lincat; + PgfMetaId fid; + interval_t value, lin_idx; + prob_t viterbi_prob; + + // Here n_items tells us how many actual items there are in + // the vector items. On the other hand, items.size() tells us + // how big buffer we have allocated. + size_t n_items; + vector> items; +}; + +template +struct PGF_INTERNAL_DECL PgfPhrasetableValue { + ref key; + + // Here n_items tells us how many actual items there are in + // the vector items. On the other hand, items.size() tells us + // how big buffer we have allocated. + size_t n_items; + vector> items; +}; + +template +using PgfPhrasetable = ref>>; + +template +PGF_INTERNAL_DECL +PgfPhrasetable phrasetable_insert(PgfPhrasetable table, + ref key, ref item); + +template +PGF_INTERNAL_DECL +vector> phrasetable_lookup(PgfPhrasetable phrasetable, + ref key, + size_t *n_items); + class PGF_INTERNAL_DECL PgfPhraseScanner { public: virtual void space(PgfTextSpot *start, PgfTextSpot *end, PgfExn* err)=0; virtual void start_matches(PgfTextSpot *spot, PgfExn* err)=0; - virtual void match(ref lin, size_t seq_index, PgfExn* err)=0; + virtual void match(ref lin, size_t lin_idx, PgfExn* err)=0; virtual void end_matches(PgfTextSpot *spot, PgfExn* err)=0; }; PGF_INTERNAL_DECL -void phrasetable_lookup(PgfPhrasetable table, +void phrasetable_lookup(PgfPhrasetable phrasetable, PgfText *sentence, bool case_sensitive, PgfPhraseScanner *scanner, PgfExn* err); PGF_INTERNAL_DECL -void phrasetable_lookup_cohorts(PgfPhrasetable table, +void phrasetable_lookup_cohorts(PgfPhrasetable phrasetable, PgfText *sentence, bool case_sensitive, PgfPhraseScanner *scanner, PgfExn* err); +template +void phrasetable_release(PgfPhrasetable table) +{ + if (table == 0) + return; + phrasetable_release(table->left); + phrasetable_release(table->right); + for (size_t i = 0; i < table->value.n_items; i++) { + PgfItem::release(table->value.items[i]); + } + vector>::release(table->value.items); + Node>::release(table); +} + + +typedef ref> PgfEpsilontable; + +// Creates a new epsilon category with its first item. +// The new category is mutable within the current transaction PGF_INTERNAL_DECL -void phrasetable_iter(PgfConcr *concr, - PgfPhrasetable table, - PgfSequenceItor* itor, - PgfMorphoCallback *callback, - PgfPhrasetableIds *seq_ids, PgfExn *err); +PgfEpsilontable epsilontable_insert(PgfEpsilontable table, + ref lincat, + interval_t value, interval_t lin_idx, + PgfMetaId fid, prob_t viterbi_prob, + ref item, + ref *pepsilon); + +// Adds a new item to an existing epsilon category. The category +// must have been created by epsilontable_insert in the current transaction. +PGF_INTERNAL_DECL +void epsilontable_add(ref epsilon, ref item); PGF_INTERNAL_DECL -void phrasetable_release(PgfPhrasetable table); +ref epsilontable_get(PgfEpsilontable table, + PgfText *name, PgfMetaId fid); -// The following are used internally in the parser - -enum SeqMatch { SM_FULL_MATCH, SM_PREFIX, SM_PARTIAL }; +PGF_INTERNAL +void epsilontable_iter(PgfEpsilontable table, ref lincat, std::function arg)> &f); PGF_INTERNAL_DECL -int text_sequence_cmp(PgfTextSpot *spot, const uint8_t *end, - ref seq, size_t *p_i, - bool case_sensitive, SeqMatch sm); - -// The following is used internally in the grammar builder - -PGF_INTERNAL_DECL -void phrasetable_add_backref(ref entry, txn_t txn_id, - object container, - size_t seq_index); +void epsilontable_release(PgfEpsilontable table); #endif diff --git a/src/runtime/c/pgf/printer.cxx b/src/runtime/c/pgf/printer.cxx index 0add283eb..74277a460 100644 --- a/src/runtime/c/pgf/printer.cxx +++ b/src/runtime/c/pgf/printer.cxx @@ -499,15 +499,15 @@ void PgfPrinter::lparam(ref lparam) } } -void PgfPrinter::lvar_ranges(vector vars, size_t *values) +void PgfPrinter::lvar_ranges(vector ranges, size_t *values) { puts("{"); - for (size_t i = 0; i < vars.size(); i++) { + for (size_t i = 0; i < ranges.size(); i++) { if (i > 0) puts(", "); - lvar(vars[i].var); + lvar(i); if (values == NULL || values[i] == 0) - nprintf(32,"<%ld",vars[i].range); + nprintf(32,"<%ld",ranges[i]); else nprintf(32,"=%ld",values[i]-1); } @@ -545,11 +545,11 @@ void PgfPrinter::symbol(PgfSymbol sym) auto sym_kp = ref::untagged(sym); puts("pre {"); - sequence(sym_kp->default_form); + symbols(sym_kp->default_form); for (size_t i = 0; i < sym_kp->alts.size(); i++) { puts("; "); - sequence(sym_kp->alts[i].form); + symbols(sym_kp->alts[i].form); puts(" /"); for (size_t j = 0; j < sym_kp->alts[i].prefixes.size(); j++) { puts(" "); @@ -581,19 +581,86 @@ void PgfPrinter::symbol(PgfSymbol sym) } } -void PgfPrinter::sequence(ref seq) +void PgfPrinter::symbols(vector syms) { - for (size_t i = 0; i < seq->syms.size(); i++) { + for (size_t i = 0; i < syms.size(); i++) { if (i > 0) puts(" "); - symbol(seq->syms[i]); + symbol(syms[i]); } } -void PgfPrinter::seq_id(PgfPhrasetableIds *seq_ids, ref seq) +void PgfPrinter::item(ref item) { - nprintf(5, "S%zu", seq_ids->get(seq)); + switch (ref::get_tag(item->rule->container)) { + case PgfConcrLincat::tag: { + ref lincat = ref::untagged(item->rule->container); + + if (item->rule->ranges != 0) { + lvar_ranges(item->rule->ranges, &item->vars[0]); + puts(" "); + } + + puts("String("); + lparam(item->rule->res); + puts(") -> "); + + efun(&lincat->name); + puts("["); + efun(&lincat->name); + puts("("); + lparam(item->rule->args[0]); + puts(")]; "); + break; + } + case PgfConcrLin::tag: { + ref lin = ref::untagged(item->rule->container); + ref ty = lin->absfun->type; + + if (item->rule->ranges != 0) { + lvar_ranges(item->rule->ranges, &item->vars[0]); + puts(" "); + } + + efun(&ty->name); + puts("("); + lparam(item->rule->res); + puts(") -> "); + + efun(&lin->name); + puts("["); + for (size_t i = 0; i < item->rule->args.size(); i++) { + if (i > 0) + puts(","); + if (item->args[i] == 0) { + efun(&ty->hypos.elem(i)->type->name); + puts("("); + lparam(item->rule->args[i]); + puts(")"); + } else { + emeta(0); + } + } + puts("]; "); + break; + } + } + + lparam(item->rule->lin_idx); + puts(" : "); + + for (size_t i = 0; i < item->rule->syms.size(); i++) { + if (i > 0) + puts(" "); + + if (item->pre_alt == 0 && item->dot == i) + puts(". "); + else if (item->pre_alt > 0 && item->pre_dot == i) + puts(". "); + + symbol(item->rule->syms[i]); + } } void PgfPrinter::free_ref(object x) diff --git a/src/runtime/c/pgf/printer.h b/src/runtime/c/pgf/printer.h index 9cd209605..e637132b9 100644 --- a/src/runtime/c/pgf/printer.h +++ b/src/runtime/c/pgf/printer.h @@ -78,10 +78,10 @@ public: void parg(ref ty, ref parg); void lvar(size_t var); void lparam(ref lparam); - void lvar_ranges(vector vars, size_t *values); - void seq_id(PgfPhrasetableIds *seq_ids, ref seq); + void lvar_ranges(vector ranges, size_t *values); void symbol(PgfSymbol sym); - void sequence(ref seq); + void symbols(vector syms); + void item(ref item); virtual PgfExpr eabs(PgfBindType btype, PgfText *name, PgfExpr body); virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg); diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx index aa9df3bdb..2cd4fca59 100644 --- a/src/runtime/c/pgf/reader.cxx +++ b/src/runtime/c/pgf/reader.cxx @@ -10,6 +10,7 @@ PgfReader::PgfReader(FILE *in,PgfProbsCallback *probs_callback) this->probs_callback = probs_callback; this->abstract = 0; this->concrete = 0; + this->container = 0; } uint8_t PgfReader::read_uint8() @@ -161,6 +162,21 @@ ref PgfReader::read_vector(inline_vector C::* field, void (PgfReader::*rea return loc; } +template +vector PgfReader::read_null_vector(void (PgfReader::*read_value)(ref val)) +{ + size_t len = read_len(); + if (len == 0) { + return 0; + } else { + vector vec = vector::alloc(len); + for (size_t i = 0; i < len; i++) { + (this->*read_value)(vec.elem(i)); + } + return vec; + } +} + template vector PgfReader::read_vector(void (PgfReader::*read_value)(ref val)) { @@ -481,10 +497,9 @@ ref PgfReader::read_lparam() return lparam; } -void PgfReader::read_variable_range(ref var_info) +void PgfReader::read_variable_range(ref var_range) { - var_info->var = read_int(); - var_info->range = read_int(); + *var_range = read_int(); } void PgfReader::read_parg(ref parg) @@ -492,33 +507,6 @@ void PgfReader::read_parg(ref parg) auto param = read_lparam(); parg->param = param; } -ref PgfReader::read_presult() -{ - vector vars = 0; - size_t n_vars = read_len(); - if (n_vars > 0) { - vars = vector::alloc(n_vars); - for (size_t i = 0; i < n_vars; i++) { - read_variable_range(vars.elem(i)); - } - } - - size_t i0 = read_int(); - size_t n_terms = read_len(); - ref res = - PgfDB::malloc(n_terms*sizeof(PgfLParam::terms[0])); - res->vars = vars; - res->param.i0 = i0; - res->param.n_terms = n_terms; - - for (size_t i = 0; i < n_terms; i++) { - res->param.terms[i].factor = read_int(); - res->param.terms[i].var = read_int(); - } - - return res; -} - template ref PgfReader::read_symbol_idx() { @@ -572,14 +560,14 @@ PgfSymbol PgfReader::read_symbol() ref sym_kp = inline_vector::alloc(&PgfSymbolKP::alts,n_alts); for (size_t i = 0; i < n_alts; i++) { - auto form = read_seq(); + auto form = read_vector(&PgfReader::read_symbol2); auto prefixes = read_vector(&PgfReader::read_text2); sym_kp->alts[i].form = form; sym_kp->alts[i].prefixes = prefixes; } - auto default_form = read_seq(); + auto default_form = read_vector(&PgfReader::read_symbol2); sym_kp->default_form = default_form; sym = sym_kp.tagged(); @@ -616,80 +604,50 @@ PgfSymbol PgfReader::read_symbol() return sym; } -ref PgfReader::read_seq() +ref PgfReader::read_rule() { - size_t n_syms = read_len(); + size_t n_syms = read_len(); + ref rule = inline_vector::alloc(&PgfConcrRule::syms, n_syms); - ref seq = inline_vector::alloc(&PgfSequence::syms, n_syms); + vector ranges = read_null_vector(&PgfReader::read_variable_range); + ref res = read_lparam(); + vector> args = read_null_vector(&PgfReader::read_lparam); + ref lin_idx = read_lparam(); + + rule->ranges = ranges; + rule->res = res; + rule->container = container; + rule->args = args; + rule->lin_idx = lin_idx; for (size_t i = 0; i < n_syms; i++) { PgfSymbol sym = read_symbol(); - seq->syms[i] = sym; + rule->syms[i] = sym; } - return seq; -} - -vector> PgfReader::read_seq_ids(object container) -{ - size_t len = read_len(); - vector> vec = vector>::alloc(len); - for (size_t i = 0; i < len; i++) { - size_t seq_id = read_len(); - ref seq = phrasetable_relink(concrete->phrasetable, - container, i, - seq_id); - if (seq == 0) { - throw pgf_error("Invalid sequence id"); - } - vec[i] = seq; - } - return vec; -} - -PgfPhrasetable PgfReader::read_phrasetable(size_t len) -{ - if (len == 0) - return 0; - - PgfPhrasetableEntry value; - - size_t half = len/2; - PgfPhrasetable left = read_phrasetable(half); - value.seq = read_seq(); - value.n_backrefs = 0; - value.backrefs = 0; - PgfPhrasetable right = read_phrasetable(len-half-1); - - PgfPhrasetable table = Node::new_node(value); - table->sz = 1+Node::size(left)+Node::size(right); - table->left = left; - table->right = right; - return table; -} - -PgfPhrasetable PgfReader::read_phrasetable() -{ - size_t len = read_len(); - return read_phrasetable(len); + return rule; } ref PgfReader::read_lincat() { ref lincat = read_name(&PgfConcrLincat::name); + container = lincat.tagged(); + auto fields = read_lincat_fields(lincat); auto n_lindefs = read_len(); - auto args = read_vector(&PgfReader::read_parg); - auto res = read_vector(&PgfReader::read_presult2); - auto seqs = read_seq_ids(lincat.tagged()); + auto rules = read_vector(&PgfReader::read_rule2); + + container = 0; + + for (size_t i = n_lindefs; i < rules.size(); i++) { + table_maker->insert_rule(rules[i]); + } lincat->abscat = namespace_lookup(abstract->cats, &lincat->name); lincat->fields = fields; lincat->n_lindefs = n_lindefs; - lincat->args = args; - lincat->res = res; - lincat->seqs = seqs; + lincat->rules = rules; return lincat; } @@ -715,13 +673,16 @@ ref PgfReader::read_lin() if (lin->lincat == 0) throw pgf_error("Found a lin which uses a category without a lincat"); - auto args = read_vector(&PgfReader::read_parg); - auto res = read_vector(&PgfReader::read_presult2); - auto seqs = read_seq_ids(lin.tagged()); + container = lin.tagged(); - lin->args = args; - lin->res = res; - lin->seqs = seqs; + auto rules = read_vector(&PgfReader::read_rule2); + lin->rules = rules; + + container = 0; + + for (size_t i = 0; i < rules.size(); i++) { + table_maker->insert_rule(rules[i]); + } return lin; } @@ -736,12 +697,18 @@ ref PgfReader::read_printname() ref PgfReader::read_concrete() { concrete = read_name(&PgfConcr::name); + concrete->phrasetable1 = 0; + concrete->phrasetable2 = 0; + concrete->phrasetable3 = 0; + concrete->phrasetable4 = 0; + concrete->epsilontable = 0; + concrete->last_fid = 0; auto cflags = read_namespace(&PgfReader::read_flag); concrete->cflags = cflags; - auto phrasetable = read_phrasetable(); - concrete->phrasetable = phrasetable; + PgfParseTableMaker tm(concrete); + this->table_maker = &tm; auto lincats = read_namespace(&PgfReader::read_lincat); concrete->lincats = lincats; @@ -749,12 +716,14 @@ ref PgfReader::read_concrete() auto lins = read_namespace(&PgfReader::read_lin); concrete->lins = lins; + tm.prepare(); + + concrete->last_fid = tm.get_last_fid(); + this->table_maker = NULL; + auto printnames = read_namespace(&PgfReader::read_printname); concrete->printnames = printnames; - //PgfLRTableMaker maker(abstract, concrete); - //concrete->lrtable = maker.make(); - return concrete; } diff --git a/src/runtime/c/pgf/reader.h b/src/runtime/c/pgf/reader.h index 74902a6a7..49a3a6310 100644 --- a/src/runtime/c/pgf/reader.h +++ b/src/runtime/c/pgf/reader.h @@ -51,6 +51,9 @@ public: template ref read_vector(inline_vector C::* field, void (PgfReader::*read_value)(ref val)); + template + vector read_null_vector(void (PgfReader::*read_value)(ref val)); + template vector read_vector(void (PgfReader::*read_value)(ref val)); @@ -70,17 +73,13 @@ public: void read_abstract(ref abstract); void merge_abstract(ref abstract); + ref read_rule(); ref read_lincat(); vector> read_lincat_fields(ref lincat); ref read_lparam(); - void read_variable_range(ref var_info); + void read_variable_range(ref var_range); void read_parg(ref parg); - ref read_presult(); PgfSymbol read_symbol(); - ref read_seq(); - vector> read_seq_ids(object container); - PgfPhrasetable read_phrasetable(size_t len); - PgfPhrasetable read_phrasetable(); ref read_lin(); ref read_printname(); @@ -94,13 +93,17 @@ private: PgfProbsCallback *probs_callback; ref abstract; ref concrete; + object container; + + class PgfParseTableMaker *table_maker; object read_name_internal(size_t struct_size); object read_text_internal(size_t struct_size); void read_text2(ref> r) { auto text = read_text(); *r = text; } void read_lparam(ref> r) { auto lparam = read_lparam(); *r = lparam; } - void read_presult2(ref> r) { auto res = read_presult(); *r = res; } + void read_rule2(ref> r) { auto rule = read_rule(); *r = rule; } + void read_symbol2(ref r) { auto sym = read_symbol(); *r = sym; } template ref read_symbol_idx(); diff --git a/src/runtime/c/pgf/writer.cxx b/src/runtime/c/pgf/writer.cxx index dfd881995..f35ca4d75 100644 --- a/src/runtime/c/pgf/writer.cxx +++ b/src/runtime/c/pgf/writer.cxx @@ -144,6 +144,19 @@ void PgfWriter::write_vector(vector vec, void (PgfWriter::*write_value)(ref +void PgfWriter::write_null_vector(vector vec, void (PgfWriter::*write_value)(ref val)) +{ + if (vec == 0) { + write_len(0); + } else { + write_len(vec.size()); + for (size_t i = 0; i < vec.size(); i++) { + (this->*write_value)(vec.elem(i)); + } + } +} + void PgfWriter::write_literal(PgfLiteral literal) { auto tag = ref::get_tag(literal); @@ -277,10 +290,9 @@ void PgfWriter::write_abstract(ref abstract) this->abstract = 0; } -void PgfWriter::write_variable_range(ref var) +void PgfWriter::write_variable_range(ref var_range) { - write_int(var->var); - write_int(var->range); + write_int(*var_range); } void PgfWriter::write_lparam(ref lparam) @@ -293,18 +305,19 @@ void PgfWriter::write_lparam(ref lparam) } } -void PgfWriter::write_parg(ref parg) +void PgfWriter::write_rule(ref rule) { - write_lparam(parg->param); -} + write_len(rule->syms.size()); -void PgfWriter::write_presult(ref pres) -{ - if (pres->vars != 0) - write_vector(pres->vars, &PgfWriter::write_variable_range); - else - write_len(0); - write_lparam(ref::from_ptr(&pres->param)); + write_null_vector(rule->ranges, &PgfWriter::write_variable_range); + write_lparam(rule->res); + write_null_vector(rule->args, &PgfWriter::write_lparam); + + write_lparam(rule->lin_idx); + + for (PgfSymbol sym : rule->syms) { + write_symbol(sym); + } } void PgfWriter::write_symbol(PgfSymbol sym) @@ -341,10 +354,10 @@ void PgfWriter::write_symbol(PgfSymbol sym) write_len(sym_kp->alts.size()); for (size_t i = 0; i < sym_kp->alts.size(); i++) { ref alt = sym_kp->alts.elem(i); - write_vector(alt->form->syms.as_vector(), &PgfWriter::write_symbol); + write_vector(alt->form, &PgfWriter::write_symbol); write_vector(alt->prefixes, &PgfWriter::write_text); } - write_vector(sym_kp->default_form->syms.as_vector(), &PgfWriter::write_symbol); + write_vector(sym_kp->default_form, &PgfWriter::write_symbol); break; } case PgfSymbolBIND::tag: @@ -359,36 +372,12 @@ void PgfWriter::write_symbol(PgfSymbol sym) } } -void PgfWriter::write_seq(ref seq) -{ - seq_ids.add(seq); - write_vector(seq->syms.as_vector(), &PgfWriter::write_symbol); -} - -void PgfWriter::write_phrasetable(PgfPhrasetable table) -{ - write_len(phrasetable_size(table)); - write_phrasetable_helper(table); -} - -void PgfWriter::write_phrasetable_helper(PgfPhrasetable table) -{ - if (table == 0) - return; - - write_phrasetable_helper(table->left); - write_seq(table->value.seq); - write_phrasetable_helper(table->right); -} - void PgfWriter::write_lincat(ref lincat) { write_name(&lincat->name); write_vector(lincat->fields, &PgfWriter::write_lincat_field); write_len(lincat->n_lindefs); - write_vector(lincat->args, &PgfWriter::write_parg); - write_vector(lincat->res, &PgfWriter::write_presult); - write_vector(lincat->seqs, &PgfWriter::write_seq_id); + write_vector(lincat->rules, &PgfWriter::write_rule); } void PgfWriter::write_lincat_field(ref> field) @@ -399,9 +388,7 @@ void PgfWriter::write_lincat_field(ref> field) void PgfWriter::write_lin(ref lin) { write_name(&lin->name); - write_vector(lin->args, &PgfWriter::write_parg); - write_vector(lin->res, &PgfWriter::write_presult); - write_vector(lin->seqs, &PgfWriter::write_seq_id); + write_vector(lin->rules, &PgfWriter::write_rule); } void PgfWriter::write_printname(ref printname) @@ -428,16 +415,11 @@ void PgfWriter::write_concrete(ref concr) } } - seq_ids.start(concr); - write_name(&concr->name); write_namespace(concr->cflags, &PgfWriter::write_flag); - write_phrasetable(concr->phrasetable); write_namespace(concr->lincats, &PgfWriter::write_lincat); write_namespace(concr->lins, &PgfWriter::write_lin); write_namespace(concr->printnames, &PgfWriter::write_printname); - - seq_ids.end(); } void PgfWriter::write_pgf(ref pgf) diff --git a/src/runtime/c/pgf/writer.h b/src/runtime/c/pgf/writer.h index 4625f41c1..aa7a96443 100644 --- a/src/runtime/c/pgf/writer.h +++ b/src/runtime/c/pgf/writer.h @@ -24,6 +24,8 @@ public: template void write_vector(vector vec, void (PgfWriter::*write_value)(ref val)); + template + void write_null_vector(vector vec, void (PgfWriter::*write_value)(ref val)); void write_literal(PgfLiteral literal); void write_expr(PgfExpr expr); @@ -40,14 +42,9 @@ public: void write_lincat(ref lincat); void write_lincat_field(ref> field); - void write_variable_range(ref var); + void write_variable_range(ref var_range); void write_lparam(ref lparam); - void write_parg(ref linarg); - void write_presult(ref linres); void write_symbol(PgfSymbol sym); - void write_seq(ref seq); - void write_seq_id(ref> r) { write_len(seq_ids.get(*r)); }; - void write_phrasetable(PgfPhrasetable table); void write_lin(ref lin); void write_printname(ref printname); @@ -58,18 +55,17 @@ public: private: template void write_namespace_helper(Namespace nmsp, void (PgfWriter::*write_value)(ref)); - void write_phrasetable_helper(PgfPhrasetable table); void write_text(ref> r) { write_text(&(**r)); }; void write_lparam(ref> r) { write_lparam(*r); }; + void write_rule(ref rule); void write_symbol(ref r) { write_symbol(*r); }; - void write_presult(ref> r) { write_presult(*r); }; + void write_rule(ref> r) { write_rule(*r); }; FILE *out; PgfText **langs; ref abstract; - PgfPhrasetableIds seq_ids; }; #endif diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index 6870a725f..a1a0c6e5d 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/src/runtime/haskell/PGF2.hsc @@ -73,7 +73,7 @@ module PGF2 (-- * PGF graphvizAbstractTree, graphvizParseTree, Labels, getDepLabels, graphvizDependencyTree, conlls2latexDoc, getCncDepLabels, - graphvizWordAlignment, graphvizLRAutomaton, + graphvizWordAlignment, -- * Concrete syntax ConcName,Concr,languages,language,concreteName,languageCode,concreteFlag, @@ -363,19 +363,14 @@ showPGF p = modifyIORef ref (\doc -> doc $$ text def) ppConcr name c = unsafePerformIO $ do - (seq_ids,doc3) <- prepareSequences c -- run first to update all seq_id - doc1 <- ppLincats seq_ids c - doc2 <- ppLins seq_ids c - pgf_release_phrasetable_ids seq_ids + doc1 <- ppLincats c + doc2 <- ppLins c return (text "concrete" <+> text name <+> char '{' $$ nest 2 (doc1 $$ - doc2 $$ - (text "sequences" <+> char '{' $$ - nest 2 doc3 $$ - char '}')) $$ + doc2) $$ char '}') - ppLincats seq_ids c = do + ppLincats c = do ref <- newIORef empty (allocaBytes (#size PgfItor) $ \itor -> bracket (wrapItorCallback (getLincats ref)) freeHaskellFunPtr $ \fptr -> @@ -402,15 +397,15 @@ showPGF p = char ']') modifyIORef ref $ (\doc -> doc $$ def) forM_ (init [0..n_lindefs]) $ \i -> do - def <- bracket (pgf_print_lindef_internal seq_ids val i) free $ \c_text -> do + def <- bracket (pgf_print_lindef_internal val i) free $ \c_text -> do fmap text (peekText c_text) modifyIORef ref (\doc -> doc $$ text "lindef" <+> def) forM_ (init [0..n_linrefs]) $ \i -> do - def <- bracket (pgf_print_linref_internal seq_ids val i) free $ \c_text -> do + def <- bracket (pgf_print_linref_internal val i) free $ \c_text -> do fmap text (peekText c_text) modifyIORef ref $ (\doc -> doc $$ text "linref" <+> def) - ppLins seq_ids c = do + ppLins c = do ref <- newIORef empty (allocaBytes (#size PgfItor) $ \itor -> bracket (wrapItorCallback (getLins ref)) freeHaskellFunPtr $ \fptr -> @@ -421,30 +416,13 @@ showPGF p = where getLins :: IORef Doc -> ItorCallback getLins ref itor key val exn = do - n_prods <- pgf_get_lin_get_prod_count val + n_prods <- pgf_get_lin_rules_count val forM_ (init [0..n_prods]) $ \i -> do - def <- bracket (pgf_print_lin_internal seq_ids val i) free $ \c_text -> do + def <- bracket (pgf_print_lin_internal val i) free $ \c_text -> do fmap text (peekText c_text) modifyIORef ref (\doc -> doc $$ text "lin" <+> def) return () - prepareSequences c = do - ref <- newIORef empty - seq_ids <- (allocaBytes (#size PgfSequenceItor) $ \itor -> - bracket (wrapSequenceItorCallback (getSequences ref)) freeHaskellFunPtr $ \fptr -> - withForeignPtr (c_revision c) $ \c_revision -> do - (#poke PgfSequenceItor, fn) itor fptr - withPgfExn "showPGF" (pgf_iter_sequences (a_db p) c_revision itor nullPtr)) - doc <- readIORef ref - return (seq_ids, doc) - where - getSequences :: IORef Doc -> SequenceItorCallback - getSequences ref itor seq_id val exn = do - def <- bracket (pgf_print_sequence_internal seq_id val) free $ \c_text -> do - fmap text (peekText c_text) - modifyIORef ref $ (\doc -> doc $$ def) - return 0 - -- | The abstract language name is the name of the top-level -- abstract module abstractName :: PGF -> AbsName @@ -617,7 +595,12 @@ checkContext :: PGF -> [Hypo] -> Either String [Hypo] checkContext pgf ctxt = Right ctxt compute :: PGF -> Expr -> Expr -compute = error "TODO: compute" +compute p e = + unsafePerformIO $ + withForeignPtr (a_revision p) $ \c_revision -> + bracket (newStablePtr e) freeStablePtr $ \c_e -> + bracket (withPgfExn "compute" (pgf_compute (a_db p) c_revision c_e marshaller unmarshaller)) freeStablePtr $ \c_e -> + deRefStablePtr c_e concreteName :: Concr -> ConcName concreteName c = @@ -830,8 +813,7 @@ fullFormLexicon c = unsafePerformIO $ do withForeignPtr (c_revision c) $ \c_revision -> do (#poke PgfSequenceItor, fn) itor1 fptr1 (#poke PgfMorphoCallback, fn) itor2 fptr2 - seq_ids <- withPgfExn "fullFormLexicon" (pgf_iter_sequences (c_db c) c_revision itor1 itor2) - pgf_release_phrasetable_ids seq_ids) + withPgfExn "fullFormLexicon" (pgf_iter_sequences (c_db c) c_revision itor1 itor2)) fmap (reverse2 []) (readIORef ref) where getSequences ref _ seq_id val exn = do @@ -866,20 +848,21 @@ data ParseOutput a parse :: Concr -> Type -> String -> ParseOutput [(Expr,Float)] parse c ty sent = unsafePerformIO $ - withForeignPtr (c_revision c) $ \c_revision -> + withForeignPtr (c_revision c) $ \c_revision_ptr -> bracket (newStablePtr ty) freeStablePtr $ \c_ty -> withText sent $ \c_sent -> do - c_enum <- withPgfExn "parse" (pgf_parse (c_db c) c_revision c_ty marshaller unmarshaller c_sent) - exprs <- enumerateExprs (c_db c) c_enum + c_enum <- withPgfExn "parse" (pgf_parse (c_db c) c_revision_ptr c_ty marshaller unmarshaller c_sent) + exprs <- enumerateExprs (c_db c) (c_revision c) c_enum return (ParseOk exprs) -enumerateExprs c_db c_enum_ptr = do +enumerateExprs c_db c_revision c_enum_ptr = do c_enum <- newForeignPtr pgf_free_expr_enum c_enum_ptr c_fetch <- (#peek PgfExprEnumVtbl, fetch) =<< (#peek PgfExprEnum, vtbl) c_enum_ptr unsafeInterleaveIO (fetchLazy c_fetch c_enum) where fetchLazy c_fetch c_enum = - withForeignPtr c_enum $ \c_enum_ptr -> + withForeignPtr c_revision $ \_ -> + withForeignPtr c_enum $ \c_enum_ptr -> alloca $ \p_prob -> do c_expr <- callFetch c_fetch c_enum_ptr c_db p_prob if c_expr == castPtrToStablePtr nullPtr @@ -1182,11 +1165,11 @@ generateAllExt p ty dp cs | otherwise = unsafePerformIO $ bracket (newStablePtr ty) freeStablePtr $ \c_ty -> - withForeignPtr (a_revision p) $ \a_revision -> + withForeignPtr (a_revision p) $ \a_revision_ptr -> withPgfConcrs cs $ \c_db c_revisions n_revisions -> mask_ $ do - c_enum <- withPgfExn "generateAllExt" (pgf_generate_all (a_db p) a_revision c_revisions n_revisions c_ty (fromIntegral dp) marshaller unmarshaller) - enumerateExprs (a_db p) c_enum + c_enum <- withPgfExn "generateAllExt" (pgf_generate_all (a_db p) a_revision_ptr c_revisions n_revisions c_ty (fromIntegral dp) marshaller unmarshaller) + enumerateExprs (a_db p) (a_revision p) c_enum generateAllFrom :: PGF -> Expr -> [(Expr,Float)] generateAllFrom p ty = generateAllFromExt p ty maxBound [] @@ -1484,15 +1467,6 @@ graphvizDependencyTree -> String -- ^ Rendered output in the specified format graphvizDependencyTree format debug mlab mclab concr t = error "TODO: graphvizDependencyTree" -graphvizLRAutomaton :: Concr -> String -graphvizLRAutomaton c = - unsafePerformIO $ - withForeignPtr (c_revision c) $ \c_revision -> - bracket (withPgfExn "graphvizLRAutomaton" (pgf_graphviz_lr_automaton (c_db c) c_revision)) free $ \c_text -> - if c_text == nullPtr - then return "" - else peekText c_text - ---------------------- should be a separate module? -- visualization with latex output. AR Nov 2015 diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 2030846bd..6b3e90447 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/src/runtime/haskell/PGF2/FFI.hsc @@ -48,9 +48,9 @@ data PgfSequenceItor data PgfProbsCallback data PgfMorphoCallback data PgfCohortsCallback -data PgfPhrasetableIds data PgfExprEnum data PgfAlignmentPhrase +data PgfParseTableMaker type Wrapper a = a -> IO (FunPtr a) type Dynamic a = FunPtr a -> a @@ -150,26 +150,22 @@ foreign import ccall "wrapper" wrapCohortsCallback :: Wrapper CohortsCallback foreign import ccall pgf_lookup_cohorts :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfCohortsCallback -> Ptr PgfExn -> IO () -foreign import ccall pgf_iter_sequences :: Ptr PgfDB -> Ptr Concr -> Ptr PgfSequenceItor -> Ptr PgfMorphoCallback -> Ptr PgfExn -> IO (Ptr PgfPhrasetableIds) +foreign import ccall pgf_iter_sequences :: Ptr PgfDB -> Ptr Concr -> Ptr PgfSequenceItor -> Ptr PgfMorphoCallback -> Ptr PgfExn -> IO () foreign import ccall pgf_get_lincat_counts_internal :: Ptr () -> Ptr CSize -> IO () foreign import ccall pgf_get_lincat_field_internal :: Ptr () -> CSize -> IO (Ptr PgfText) -foreign import ccall pgf_print_lindef_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText) +foreign import ccall pgf_print_lindef_internal :: Ptr () -> CSize -> IO (Ptr PgfText) -foreign import ccall pgf_print_linref_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText) +foreign import ccall pgf_print_linref_internal :: Ptr () -> CSize -> IO (Ptr PgfText) -foreign import ccall pgf_get_lin_get_prod_count :: Ptr () -> IO CSize +foreign import ccall pgf_get_lin_rules_count :: Ptr () -> IO CSize -foreign import ccall pgf_print_lin_internal :: Ptr PgfPhrasetableIds -> Ptr () -> CSize -> IO (Ptr PgfText) - -foreign import ccall pgf_print_sequence_internal :: CSize -> Ptr () -> IO (Ptr PgfText) +foreign import ccall pgf_print_lin_internal :: Ptr () -> CSize -> IO (Ptr PgfText) foreign import ccall pgf_sequence_get_text_internal :: Ptr () -> IO (Ptr PgfText) -foreign import ccall pgf_release_phrasetable_ids :: Ptr PgfPhrasetableIds -> IO () - type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO () foreign import ccall "wrapper" wrapItorCallback :: Wrapper ItorCallback @@ -210,6 +206,8 @@ foreign import ccall pgf_infer_expr :: Ptr PgfDB -> Ptr PGF -> Ptr (StablePtr Ex foreign import ccall pgf_check_type :: Ptr PgfDB -> Ptr PGF -> StablePtr Type -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type) +foreign import ccall pgf_compute :: Ptr PgfDB -> Ptr PGF -> StablePtr Expr -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr) + foreign import ccall pgf_generate_random :: Ptr PgfDB -> Ptr PGF -> Ptr (Ptr Concr) -> CSize -> StablePtr Type -> CSize -> Ptr Word64 -> Ptr (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr) foreign import ccall pgf_generate_random_from :: Ptr PgfDB -> Ptr PGF -> Ptr (Ptr Concr) -> CSize -> StablePtr Expr -> CSize -> Ptr Word64 -> Ptr (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr) @@ -230,9 +228,11 @@ foreign import ccall pgf_create_category :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText foreign import ccall pgf_drop_category :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO () -foreign import ccall pgf_create_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr Concr) +foreign import ccall pgf_create_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr (Ptr PgfParseTableMaker) -> Ptr PgfExn -> IO (Ptr Concr) -foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr Concr) +foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr (Ptr PgfParseTableMaker) -> Ptr PgfExn -> IO (Ptr Concr) + +foreign import ccall pgf_free_parse_table :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> IO () foreign import ccall pgf_drop_concrete :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfExn -> IO () @@ -244,7 +244,7 @@ foreign import ccall "dynamic" callLinBuilder1 :: Dynamic (Ptr PgfLinBuilderIfac foreign import ccall "dynamic" callLinBuilder2 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr PgfExn -> IO ()) -foreign import ccall "dynamic" callLinBuilder3 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ()) +foreign import ccall "dynamic" callLinBuilder3 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ()) foreign import ccall "dynamic" callLinBuilder4 :: Dynamic (Ptr PgfLinBuilderIface -> CSize -> CSize -> CSize -> Ptr CSize -> Ptr PgfExn -> IO ()) @@ -254,13 +254,13 @@ foreign import ccall "dynamic" callLinBuilder6 :: Dynamic (Ptr PgfLinBuilderIfac foreign import ccall "dynamic" callLinBuilder7 :: Dynamic (Ptr PgfLinBuilderIface -> Ptr PgfExn -> IO CSize) -foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () +foreign import ccall pgf_create_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr (Ptr PgfText) -> CSize -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () foreign import ccall pgf_drop_lincat :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO () -foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () +foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () -foreign import ccall pgf_alter_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () +foreign import ccall pgf_alter_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfParseTableMaker -> Ptr PgfText -> CSize -> Ptr PgfBuildLinIface -> Ptr PgfExn -> IO () foreign import ccall pgf_drop_lin :: Ptr PgfDB -> Ptr PGF -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO () @@ -318,8 +318,6 @@ foreign import ccall pgf_graphviz_parse_tree :: Ptr PgfDB -> Ptr Concr -> Stable foreign import ccall pgf_graphviz_word_alignment :: Ptr PgfDB -> Ptr (Ptr Concr) -> CSize -> StablePtr Expr -> Ptr PgfPrintContext -> Ptr PgfMarshaller -> Ptr PgfGraphvizOptions -> Ptr PgfExn -> IO (Ptr PgfText) -foreign import ccall pgf_graphviz_lr_automaton :: Ptr PgfDB -> Ptr Concr -> Ptr PgfExn -> IO (Ptr PgfText) - ----------------------------------------------------------------------- -- Texts diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index 51aca6082..513a67388 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/src/runtime/haskell/PGF2/Transactions.hsc @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} module PGF2.Transactions ( -- transactions TxnID @@ -18,15 +19,14 @@ module PGF2.Transactions , setAbstractFlag -- concrete syntax - , Token, SeqId, LIndex, LVar, LParam(..) - , PArg(..), Symbol(..), Production(..) + , Token, LIndex, LVar, LParam(..) + , PArg(..), Symbol(..), Rule(..) , createConcrete , alterConcrete , dropConcrete , mergePGF , setConcreteFlag - , SeqTable , createLincat , dropLincat , createLin, alterLin @@ -50,27 +50,31 @@ import Data.IORef #include newtype Transaction k a = - Transaction (Ptr PgfDB -> Ptr PGF -> Ptr k -> Ptr PgfExn -> IO a) + Transaction (Ptr PgfDB -> Ptr PGF -> TransactionCtxt k -> Ptr PgfExn -> IO a) + +type family TransactionCtxt a +type instance TransactionCtxt PGF = () +type instance TransactionCtxt Concr = (Ptr Concr, Ptr PgfParseTableMaker) instance Functor (Transaction k) where - fmap f (Transaction g) = Transaction $ \c_db c_abstr c_revision c_exn -> do - res <- g c_db c_abstr c_revision c_exn + fmap f (Transaction g) = Transaction $ \c_db c_abstr ctxt c_exn -> do + res <- g c_db c_abstr ctxt c_exn return (f res) instance Applicative (Transaction k) where - pure x = Transaction $ \c_db _ c_revision c_exn -> return x + pure x = Transaction $ \c_db _ _ c_exn -> return x f <*> g = do f <- f g <- g return (f g) instance Monad (Transaction k) where - (Transaction f) >>= g = Transaction $ \c_db c_abstr c_revision c_exn -> do - res <- f c_db c_abstr c_revision c_exn + (Transaction f) >>= g = Transaction $ \c_db c_abstr ctxt c_exn -> do + res <- f c_db c_abstr ctxt c_exn ex_type <- (#peek PgfExn, type) c_exn if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE) then case g res of - Transaction g -> g c_db c_abstr c_revision c_exn + Transaction g -> g c_db c_abstr ctxt c_exn else return undefined #if !(MIN_VERSION_base(4,13,0)) @@ -79,7 +83,7 @@ instance Monad (Transaction k) where #endif instance Fail.MonadFail (Transaction k) where - fail msg = Transaction $ \c_db c_abstr c_revision c_exn -> fail msg + fail msg = Transaction $ \c_db c_abstr ctxt c_exn -> fail msg data TxnID = TxnID (Ptr PgfDB) (ForeignPtr PGF) @@ -103,7 +107,7 @@ inTransaction :: TxnID -> Transaction PGF a -> IO a inTransaction (TxnID db fptr) (Transaction f) = withForeignPtr fptr $ \c_revision -> do withPgfExn "inTransaction" $ \c_exn -> - f db c_revision c_revision c_exn + f db c_revision () c_exn {- | @modifyPGF gr t@ updates the grammar @gr@ by performing the transaction @t@. The changes are applied to the new grammar @@ -117,7 +121,7 @@ modifyPGF p (Transaction f) = c_revision <- pgf_start_transaction (a_db p) c_exn ex_type <- (#peek PgfExn, type) c_exn if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE) - then do ((restore (f (a_db p) c_revision c_revision c_exn)) + then do ((restore (f (a_db p) c_revision () c_exn)) `catch` (\e -> do pgf_free_revision_ (a_db p) c_revision @@ -151,11 +155,11 @@ checkoutPGF p = do already a function with the same name then an exception is thrown. -} createFunction :: Fun -> Type -> Int -> [[Instr]] -> Float -> Transaction PGF Fun -createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_exn -> +createFunction name ty arity bytecode prob = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> bracket (newStablePtr ty) freeStablePtr $ \c_ty -> (if null bytecode then (\f -> f nullPtr) else (allocaBytes 0)) $ \c_bytecode -> do - c_name <- pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) c_bytecode prob marshaller c_exn + c_name <- pgf_create_function c_db c_abstr c_name c_ty (fromIntegral arity) c_bytecode prob marshaller c_exn if c_name == nullPtr then return "" else do name <- peekText c_name @@ -163,75 +167,78 @@ createFunction name ty arity bytecode prob = Transaction $ \c_db _ c_revision c_ return name dropFunction :: Fun -> Transaction PGF () -dropFunction name = Transaction $ \c_db _ c_revision c_exn -> +dropFunction name = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> do - pgf_drop_function c_db c_revision c_name c_exn + pgf_drop_function c_db c_abstr c_name c_exn createCategory :: Cat -> [Hypo] -> Float -> Transaction PGF () -createCategory name hypos prob = Transaction $ \c_db _ c_revision c_exn -> +createCategory name hypos prob = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> withHypos hypos $ \n_hypos c_hypos -> do - pgf_create_category c_db c_revision c_name n_hypos c_hypos prob marshaller c_exn + pgf_create_category c_db c_abstr c_name n_hypos c_hypos prob marshaller c_exn dropCategory :: Cat -> Transaction PGF () -dropCategory name = Transaction $ \c_db _ c_revision c_exn -> +dropCategory name = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> do - pgf_drop_category c_db c_revision c_name c_exn + pgf_drop_category c_db c_abstr c_name c_exn createConcrete :: ConcName -> Transaction Concr () -> Transaction PGF () -createConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn -> - withText name $ \c_name -> do - bracketPtr (pgf_create_concrete c_db c_revision c_name c_exn) - (pgf_free_concr_revision_ c_db) $ \c_concr_revision -> - f c_db c_abstr c_concr_revision c_exn +createConcrete name (Transaction f) = Transaction $ \c_db c_abstr _ c_exn -> + withText name $ \c_name -> + bracketCnc c_exn + (pgf_create_concrete c_db c_abstr c_name) + (\c tm -> pgf_free_parse_table c_db c_abstr c tm >> pgf_free_concr_revision_ c_db c) $ \ctxt -> do + f c_db c_abstr ctxt c_exn alterConcrete :: ConcName -> Transaction Concr a -> Transaction PGF a -alterConcrete name (Transaction f) = Transaction $ \c_db c_abstr c_revision c_exn -> +alterConcrete name (Transaction f) = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> do - bracketPtr (pgf_clone_concrete c_db c_revision c_name c_exn) - (pgf_free_concr_revision_ c_db) $ \c_concr_revision -> - f c_db c_abstr c_concr_revision c_exn + bracketCnc c_exn + (pgf_clone_concrete c_db c_abstr c_name) + (\c tm -> pgf_free_parse_table c_db c_abstr c tm >> pgf_free_concr_revision_ c_db c) $ \ctxt -> do + f c_db c_abstr ctxt c_exn -bracketPtr before after thing = +bracketCnc c_exn before after thing = + alloca $ \p_tm -> mask $ \restore -> do - a <- before - if a == nullPtr + c <- before p_tm c_exn + if c == nullPtr then return undefined - else do r <- restore (thing a) `onException` after a - _ <- after a + else do tm <- peek p_tm + r <- restore (thing (c,tm)) `onException` after c tm + _ <- after c tm return r dropConcrete :: ConcName -> Transaction PGF () -dropConcrete name = Transaction $ \c_db _ c_revision c_exn -> +dropConcrete name = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> do - pgf_drop_concrete c_db c_revision c_name c_exn + pgf_drop_concrete c_db c_abstr c_name c_exn mergePGF :: FilePath -> Transaction PGF () -mergePGF fpath = Transaction $ \c_db _ c_revision c_exn -> +mergePGF fpath = Transaction $ \c_db c_abstr _ c_exn -> withCString fpath $ \c_fpath -> - pgf_merge_pgf c_db c_revision c_fpath c_exn + pgf_merge_pgf c_db c_abstr c_fpath c_exn setGlobalFlag :: String -> Literal -> Transaction PGF () -setGlobalFlag name value = Transaction $ \c_db _ c_revision c_exn -> +setGlobalFlag name value = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> bracket (newStablePtr value) freeStablePtr $ \c_value -> - pgf_set_global_flag c_db c_revision c_name c_value marshaller c_exn + pgf_set_global_flag c_db c_abstr c_name c_value marshaller c_exn setAbstractFlag :: String -> Literal -> Transaction PGF () -setAbstractFlag name value = Transaction $ \c_db _ c_revision c_exn -> +setAbstractFlag name value = Transaction $ \c_db c_abstr _ c_exn -> withText name $ \c_name -> bracket (newStablePtr value) freeStablePtr $ \c_value -> - pgf_set_abstract_flag c_db c_revision c_name c_value marshaller c_exn + pgf_set_abstract_flag c_db c_abstr c_name c_value marshaller c_exn setConcreteFlag :: String -> Literal -> Transaction Concr () -setConcreteFlag name value = Transaction $ \c_db _ c_revision c_exn -> +setConcreteFlag name value = Transaction $ \c_db _ (c_revision,_) c_exn -> withText name $ \c_name -> bracket (newStablePtr value) freeStablePtr $ \c_value -> pgf_set_concrete_flag c_db c_revision c_name c_value marshaller c_exn type Token = String -type SeqId = Int type LIndex = Int type LVar = Int data LParam = LParam {-# UNPACK #-} !LIndex [(LIndex,LVar)] @@ -251,22 +258,21 @@ data Symbol | SymALL_CAPIT -- the special ALL_CAPIT token deriving (Eq,Ord,Show) +type Quantifiers = [Int] +data Rule = Rule Quantifiers LParam [LParam] LParam [Symbol] + deriving (Eq,Ord,Show) + data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam deriving (Eq,Show) -data Production = Production [(LVar,LIndex)] [PArg] LParam [SeqId] - deriving (Eq,Show) - -type SeqTable = Seq.Seq (Either [Symbol] SeqId) - -createLincat :: Cat -> [String] -> [Production] -> [Production] -> SeqTable -> Transaction Concr SeqTable -createLincat name fields lindefs linrefs seqtbl = Transaction $ \c_db c_abstr c_revision c_exn -> +createLincat :: Cat -> [String] -> [Rule] -> [Rule] -> Transaction Concr () +createLincat name fields lindefs linrefs = Transaction $ \c_db c_abstr (c_revision,tm) c_exn -> let n_fields = length fields in withText name $ \c_name -> allocaBytes (n_fields*(#size PgfText*)) $ \c_fields -> withTexts c_fields 0 fields $ - withBuildLinIface (lindefs++linrefs) seqtbl $ \c_build -> - pgf_create_lincat c_db c_abstr c_revision c_name + withBuildLinIface (lindefs++linrefs) $ \c_build -> + pgf_create_lincat c_db c_abstr c_revision tm c_name (fromIntegral n_fields) c_fields (fromIntegral (length lindefs)) (fromIntegral (length linrefs)) c_build c_exn @@ -278,31 +284,29 @@ createLincat name fields lindefs linrefs seqtbl = Transaction $ \c_db c_abstr c_ withTexts p (i+1) ss f dropLincat :: Cat -> Transaction Concr () -dropLincat name = Transaction $ \c_db c_abstr c_revision c_exn -> +dropLincat name = Transaction $ \c_db c_abstr (c_revision,tm) c_exn -> withText name $ \c_name -> pgf_drop_lincat c_db c_abstr c_revision c_name c_exn -createLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable -createLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn -> +createLin :: Fun -> [Rule] -> Transaction Concr () +createLin name rules = Transaction $ \c_db c_abstr (c_revision,tm) c_exn -> withText name $ \c_name -> - withBuildLinIface prods seqtbl $ \c_build -> - pgf_create_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn + withBuildLinIface rules $ \c_build -> + pgf_create_lin c_db c_abstr c_revision tm c_name (fromIntegral (length rules)) c_build c_exn -alterLin :: Fun -> [Production] -> SeqTable -> Transaction Concr SeqTable -alterLin name prods seqtbl = Transaction $ \c_db c_abstr c_revision c_exn -> +alterLin :: Fun -> [Rule] -> Transaction Concr () +alterLin name rules = Transaction $ \c_db c_abstr (c_revision,tm) c_exn -> withText name $ \c_name -> - withBuildLinIface prods seqtbl $ \c_build -> - pgf_alter_lin c_db c_abstr c_revision c_name (fromIntegral (length prods)) c_build c_exn + withBuildLinIface rules $ \c_build -> + pgf_alter_lin c_db c_abstr c_revision tm c_name (fromIntegral (length rules)) c_build c_exn -withBuildLinIface prods seqtbl f = do - ref <- newIORef seqtbl +withBuildLinIface rules f = do (allocaBytes (#size PgfBuildLinIface) $ \c_build -> allocaBytes (#size PgfBuildLinIfaceVtbl) $ \vtbl -> - bracket (wrapLinBuild (build ref)) freeHaskellFunPtr $ \c_callback -> do + bracket (wrapLinBuild build) freeHaskellFunPtr $ \c_callback -> do (#poke PgfBuildLinIface, vtbl) c_build vtbl (#poke PgfBuildLinIfaceVtbl, build) vtbl c_callback f c_build) - readIORef ref where forM_ [] c_exn f = return () forM_ (x:xs) c_exn f = do @@ -311,31 +315,23 @@ withBuildLinIface prods seqtbl f = do then f x >> forM_ xs c_exn f else return () - build ref _ c_builder c_exn = do + build _ c_builder c_exn = do vtbl <- (#peek PgfLinBuilderIface, vtbl) c_builder - forM_ prods c_exn $ \(Production vars args res seqids) -> do - fun <- (#peek PgfLinBuilderIfaceVtbl, start_production) vtbl - callLinBuilder0 fun c_builder c_exn + forM_ rules c_exn $ \(Rule vars res args lin_idx seq) -> do + fun <- (#peek PgfLinBuilderIfaceVtbl, start_rule) vtbl + callLinBuilder2 fun c_builder (fromIntegral (length vars)) (fromIntegral (length seq)) c_exn fun <- (#peek PgfLinBuilderIfaceVtbl, add_argument) vtbl - forM_ args c_exn $ \(PArg hypos param) -> - callLParam (callLinBuilder3 fun c_builder (fromIntegral (length hypos))) param c_exn - fun <- (#peek PgfLinBuilderIfaceVtbl, set_result) vtbl - callLParam (callLinBuilder3 fun c_builder (fromIntegral (length vars))) res c_exn + forM_ args c_exn $ \arg -> + callLParam (callLinBuilder3 fun c_builder) arg c_exn + fun <- (#peek PgfLinBuilderIfaceVtbl, set_result) vtbl + callLParam (callLinBuilder3 fun c_builder) res c_exn + fun <- (#peek PgfLinBuilderIfaceVtbl, set_lin_idx) vtbl + callLParam (callLinBuilder3 fun c_builder) lin_idx c_exn fun <- (#peek PgfLinBuilderIfaceVtbl, add_variable) vtbl - forM_ vars c_exn $ \(v,r) -> - callLinBuilder2 fun c_builder (fromIntegral v) (fromIntegral r) c_exn - fun <- (#peek PgfLinBuilderIfaceVtbl, add_sequence_id) vtbl - seqtbl <- readIORef ref - forM_ seqids c_exn $ \seqid -> - case Seq.index seqtbl seqid of - Left syms -> do fun <- (#peek PgfLinBuilderIfaceVtbl, start_sequence) vtbl - callLinBuilder1 fun c_builder (fromIntegral (length syms)) c_exn - forM_ syms c_exn (addSymbol c_builder vtbl c_exn) - fun <- (#peek PgfLinBuilderIfaceVtbl, end_sequence) vtbl - seqid' <- callLinBuilder7 fun c_builder c_exn - writeIORef ref $! Seq.update seqid (Right (fromIntegral seqid')) seqtbl - Right seqid -> do callLinBuilder1 fun c_builder (fromIntegral seqid) c_exn - fun <- (#peek PgfLinBuilderIfaceVtbl, end_production) vtbl + forM_ vars c_exn $ \r -> + callLinBuilder1 fun c_builder (fromIntegral r) c_exn + forM_ seq c_exn (addSymbol c_builder vtbl c_exn) + fun <- (#peek PgfLinBuilderIfaceVtbl, end_rule) vtbl callLinBuilder0 fun c_builder c_exn addSymbol c_builder vtbl c_exn (SymCat d r) = do @@ -406,12 +402,12 @@ withBuildLinIface prods seqtbl f = do pokeTerms (c_terms `plusPtr` (2*(#size size_t))) terms dropLin :: Fun -> Transaction Concr () -dropLin name = Transaction $ \c_db c_abstr c_revision c_exn -> +dropLin name = Transaction $ \c_db c_abstr (c_revision,_) c_exn -> withText name $ \c_name -> pgf_drop_lin c_db c_abstr c_revision c_name c_exn setPrintName :: Fun -> String -> Transaction Concr () -setPrintName fun name = Transaction $ \c_db _ c_revision c_exn -> +setPrintName fun name = Transaction $ \c_db _ (c_revision,_) c_exn -> withText fun $ \c_fun -> withText name $ \c_name -> do pgf_set_printname c_db c_revision c_fun c_name c_exn @@ -434,7 +430,7 @@ getFunctionType fun = Transaction $ \c_db c_revision _ c_exn -> do -- | A monadic version of 'categoryFields' which returns the fields of -- a category from grammar in the current transaction. getCategoryFields :: Cat -> Transaction Concr (Maybe [String]) -getCategoryFields cat = Transaction $ \c_db _ c_revision c_exn -> +getCategoryFields cat = Transaction $ \c_db _ (c_revision,_) c_exn -> withText cat $ \c_cat -> alloca $ \p_n_fields -> do c_fields <- pgf_category_fields c_db c_revision c_cat p_n_fields c_exn diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c index 44f42ff22..23a7ec35f 100644 --- a/src/runtime/python/pypgf.c +++ b/src/runtime/python/pypgf.c @@ -243,7 +243,7 @@ BIND_alloc(PyTypeObject *self, Py_ssize_t nitems) static PyTypeObject pgf_BINDType = { PyVarObject_HEAD_INIT(NULL, 0) //0, /*ob_size*/ - "pgf.BINDType", /*tp_name*/ + "pgf.BIND", /*tp_name*/ sizeof(BINDObject), /*tp_basicsize*/ 0, /*tp_itemsize*/ (destructor) BIND_dealloc, /*tp_dealloc*/ @@ -1952,6 +1952,34 @@ pgf_showExpr(PyObject *self, PyObject *args) return str; } +static void +collect_funs(PyObject *pylist,ExprObject *expr) { + if (Py_TYPE(expr) == &pgf_ExprAbsType) { + collect_funs(pylist,((ExprAbsObject*) expr)->body); + } else if (Py_TYPE(expr) == &pgf_ExprAppType) { + collect_funs(pylist,((ExprAppObject*) expr)->fun); + collect_funs(pylist,((ExprAppObject*) expr)->arg); + } else if (Py_TYPE(expr) == &pgf_ExprFunType) { + PyList_Append(pylist,((ExprFunObject*) expr)->name); + } else if (Py_TYPE(expr) == &pgf_ExprTypedType) { + collect_funs(pylist,((ExprTypedObject*) expr)->expr); + } else if (Py_TYPE(expr) == &pgf_ExprImplArgType) { + collect_funs(pylist,((ExprImplArgObject*) expr)->expr); + } +} + +static PyObject * +pgf_exprFunctions(PyObject *self, PyObject *args) +{ + ExprObject *expr; + if (!PyArg_ParseTuple(args, "O!", &pgf_ExprType, &expr)) + return NULL; + + PyObject *pylist = PyList_New(0); + collect_funs(pylist,(ExprObject*) expr); + return pylist; +} + static TypeObject * pgf_readType(PyObject *self, PyObject *args) { @@ -2081,6 +2109,8 @@ static PyMethodDef module_methods[] = { "Parses a string as an abstract tree"}, {"showExpr", (void*)pgf_showExpr, METH_VARARGS, "Renders an expression as a string"}, + {"exprFunctions", (void*)pgf_exprFunctions, METH_VARARGS, + "Returns the list of functions used in an expression"}, {"readType", (void*)pgf_readType, METH_VARARGS, "Parses a string as an abstract type"}, {"showType", (void*)pgf_showType, METH_VARARGS,