msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Merge pull request #207 from krangelov/majestic

Browse Source 
Majestic
This commit is contained in:
Krasimir Angelov
2026-08-19 13:02:45 +02:00
committed by GitHub
parent 3ee4f6ce9c 6c2aeb6b95
commit 521942dabe
75 changed files with 5801 additions and 7222 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/compiler/api/GF/Command/Importing.hs
+1 -1
View File
@@ -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)
src/compiler/api/GF/Command/SourceCommands.hs
+3 -3
View File
@@ -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
src/compiler/api/GF/Compile/CheckGrammar.hs
+49 -52
View File
@@ -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
src/compiler/api/GF/Compile/Compute/Concrete2.hs → src/compiler/api/GF/Compile/Compute.hs
+212 -130
View File
@@ -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))
src/compiler/api/GF/Compile/Compute/Abstract.hs
-138
View File
@@ -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])
src/compiler/api/GF/Compile/Compute/Concrete.hs
-1023
View File
File diff suppressed because it is too large Load Diff
src/compiler/api/GF/Compile/ConcreteToHaskell.hs
+4 -3
View File
@@ -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
src/compiler/api/GF/Compile/Export.hs
-1
View File
@@ -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)
src/compiler/api/GF/Compile/GenerateBC.hs
+16 -23
View File
@@ -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
src/compiler/api/GF/Compile/GeneratePMCFG.hs
+468 -294
View File
@@ -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
src/compiler/api/GF/Compile/GrammarToCanonical.hs
+7 -10
View File
@@ -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
src/compiler/api/GF/Compile/GrammarToPGF.hs
+24 -46
View File
@@ -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
src/compiler/api/GF/Compile/Rename.hs
+22 -5
View File
@@ -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
src/compiler/api/GF/Compile/SubExOpt.hs
+2 -1
View File
@@ -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''")
src/compiler/api/GF/Compile/Tags.hs
+2 -2
View File
@@ -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 ++
src/compiler/api/GF/Compile/TerminationCheck.hs
+71
View File
@@ -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
src/compiler/api/GF/Compile/TypeCheck/Concrete.hs → src/compiler/api/GF/Compile/TypeCheck.hs
+411 -199
View File
File diff suppressed because it is too large Load Diff
src/compiler/api/GF/Compile/TypeCheck/Abstract.hs
-82
View File
@@ -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!
src/compiler/api/GF/Compile/TypeCheck/TC.hs
-324
View File
@@ -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)
src/compiler/api/GF/Compile/Update.hs
+12 -15
View File
@@ -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 ""
src/compiler/api/GF/Compiler.hs
+2 -3
View File
@@ -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
src/compiler/api/GF/Data/Operations.hs
-24
View File
@@ -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
src/compiler/api/GF/Data/XML.hs
+12 -1
View File
@@ -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 "</" . showString t . showChar '>'
(Comment c) -> showString "<!-- " . showString c . showString " -->"
(Empty) -> id
showsAttrs :: [Attr] -> ShowS
showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
src/compiler/api/GF/Grammar.hs
-2
View File
@@ -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
src/compiler/api/GF/Grammar/Analyse.hs
+17 -5
View File
@@ -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
src/compiler/api/GF/Grammar/Binary.hs
+9 -12
View File
@@ -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)
src/compiler/api/GF/Grammar/Grammar.hs
+17 -17
View File
@@ -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)
src/compiler/api/GF/Grammar/JSON.hs
+7 -9
View File
@@ -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
src/compiler/api/GF/Grammar/Lockfield.hs
+18 -20
View File
@@ -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_"
src/compiler/api/GF/Grammar/Lookup.hs
+76 -48
View File
@@ -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
src/compiler/api/GF/Grammar/Macros.hs
+50 -125
View File
@@ -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
src/compiler/api/GF/Grammar/Parser.y
+56 -46
View File
@@ -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) }
| '<tag' Attributes '/' '>' { 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)
}
src/compiler/api/GF/Grammar/Predef.hs
+5 -14
View File
@@ -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"
src/compiler/api/GF/Grammar/Printer.hs
+32 -69
View File
@@ -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)
src/compiler/api/GF/Grammar/Unify.hs
-115
View File
@@ -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
src/compiler/api/GF/Grammar/Values.hs
-57
View File
@@ -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
src/compiler/api/GF/Infra/Ident.hs
+25 -4
View File
@@ -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
src/compiler/api/GF/Infra/Location.hs
+5 -1
View File
@@ -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
src/compiler/api/GF/Infra/Option.hs
+1 -3
View File
@@ -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
src/compiler/api/GF/Interactive.hs
+11 -13
View File
@@ -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
src/compiler/api/GF/Server/PGFService.hs
+1 -1
View File
@@ -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 "")
src/compiler/api/GF/Server/SimpleEditor/Convert.hs
+2 -2
View File
@@ -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
src/compiler/api/GF/Speech/CFGToFA.hs
-1
View File
@@ -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
src/compiler/api/GF/Term.hs
-12
View File
@@ -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
src/compiler/gf.cabal
+3 -8
View File
@@ -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
src/compiler/www/gfse/editor.js
+7 -14
View File
@@ -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)
src/compiler/www/js/gftranslate.js
+4 -3
View File
@@ -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)
}
}
src/compiler/www/js/langcode.js
+15 -10
View File
@@ -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)
}()
src/compiler/www/js/wc.js
+18 -122
View File
@@ -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<trans.length;i++) {
var r=trans[i]
r.prob=0
showit(r,cnl)
}
}
step2cnl(text,ix+1)
}
if(ix<wc.selected_cnls.length) {
var g=wc.cnls[wc.selected_cnls[ix]]
var gi=g.grammar_info
var langs=gi.languages.map(function(l) { return l.name; })
var cnl=gi.name
var from=cnl+f.from.value,to=cnl+f.to.value
if(elem(from,langs) && elem(to,langs))
g.pgf_online.translate({from:from,
//to:to,
lexer:"text",unlexer:"text",
jsontree:true,input:text},
step3cnl,
function(){step2cnl(text,ix+1)})
else step2cnl(text,ix+1)
}
else step2(text)
}
if(wc.selected_cnls) step2cnl(so.input,0)
else step2(so.input)
step2(so.input)
}
function change_segment_to(so,to) {
@@ -404,8 +376,13 @@ wc.init_languages=function () {
function update_menu(m) {
var l=m.value
clear(m)
for(var i=0;i<langs.length;i++)
m.appendChild(option(concname(langs[i]),langs[i]))
for(var i=0;i<langs.length;i++) {
const code = langs[i]
const name = langname[code]
if (name) {
m.appendChild(option(concname(langs[i]),langs[i]))
}
}
if(langset[l]) m.value=l
}
update_menu(wc.f.from)
@@ -428,86 +405,6 @@ wc.init_speech=function() {
}
}
wc.show_grammarbox=function() {
wc.grammarbox.parentNode.style.display="block";
}
wc.hide_grammarbox=function() {
wc.grammarbox.parentNode.style.display="";
clear(wc.grammarbox)
}
wc.init_cnl=function(grammar) {
var g
if(wc.cnls[grammar]) g=wc.cnls[grammar]
else g=wc.cnls[grammar]={}
g.pgf_online=pgf_online({})
g.pgf_online.switch_grammar(grammar)
g.pgf_online.grammar_info(function(info){g.grammar_info=info})
}
wc.init_cnls=function() {
var gs=wc.selected_cnls
for(var i=0;i<gs.length;i++) wc.init_cnl(gs[i])
}
wc.select_grammars=function() {
function done() {
wc.hide_grammarbox()
var gs=[]
var glist=list.children
for(var i=0;i<glist.length;i++)
if(glist[i].cb.checked) gs.push(glist[i].grammar)
wc.selected_cnls=gs
wc.init_cnls()
wc.local.put("cnls",wc.selected_cnls)
wc.translate(true)
}
function cancel() {
wc.hide_grammarbox()
}
function remove(x,xs) {
function other(y) { return y!=x; }
return filter(other,xs)
}
function checkbox(grammar,checked) {
var vb=node("input",{type:"checkbox"})
vb.checked=checked
return vb
}
function grammar_pick(grammar,checked) {
var cb=checkbox(grammar,checked)
var p=[cb,text(" "+grammar.split(".pgf")[0])]
var dt=node("dt",{class:"grammar_pick"},p)
dt.cb=cb
dt.grammar=grammar
return dt
}
function show_list(grammars) {
var sg=wc.selected_cnls
for(var i=0;i<sg.length;i++) {
if(elem(sg[i],grammars))
list.appendChild(grammar_pick(sg[i],true))
else
remove(sg[i],wc.selected_cnls)
}
for(var i=0;i<grammars.length;i++)
if(!elem(grammars[i],wc.selected_cnls))
list.appendChild(grammar_pick(grammars[i],false))
}
clear(wc.grammarbox)
wc.grammarbox.appendChild(wrap("h2",[button("X",cancel),text("Select which domain-specific grammars to use")]))
wc.grammarbox.appendChild(text("These grammars are tried before the wide-coverage grammar. They can give higher quality translations within their respective domains."))
var list=empty("dl")
wc.grammarbox.appendChild(list)
wc.grammarbox.appendChild(button("OK",done))
wc.grammarbox.appendChild(button("Cancel",cancel))
wc.show_grammarbox()
wc.pgf_online.get_grammarlist(show_list)
}
wc.initialize=function(grammar_name,grammar_url) {
if(grammar_name && grammar_url) {
gftranslate.grammar=grammar_name
@@ -519,7 +416,6 @@ wc.initialize=function(grammar_name,grammar_url) {
wc.pgf_online=pgf_online({});
wc.local=appLocalStorage("gf.wc."+gftranslate.grammar+".")
wc.load()
wc.init_cnls()
initialize_sorting(["DT"],["grammar_pick"])
wc.f.input.focus()
}
src/compiler/www/wc.html
-1
View File
@@ -92,7 +92,6 @@ h2 > input { float: right; }
</select>
<input name=colors type=checkbox checked onchange="wc.colors()"> Colors
<td><button name=translate type=submit><strong>Translate</strong></button>
<input type=button name=grammars onclick="wc.select_grammars()" value="Grammars...">
<tr><td class=input colspan=2>
<div class=input>
<textarea name=input rows=5 style="width: 100%" onkeyup="wc.delayed_translate()"></textarea>
src/runtime/c/configure.ac
+1
View File
@@ -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])
src/runtime/c/pgf/compute.cxx
+142
View File
@@ -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<PgfPGF> pgf,
PgfMarshaller *m, PgfUnmarshaller *u,
ExprNode *env,
PgfExn *err)
{
this->m = m;
this->u = u;
this->stack = NULL;
this->env = env;
}
src/runtime/c/pgf/compute.h
+69
View File
@@ -0,0 +1,69 @@
#ifndef COMPUTE_H
#define COMPUTE_H
class PGF_INTERNAL_DECL PgfEvalExpr : public PgfUnmarshaller
{
ref<PgfPGF> pgf;
PgfMarshaller *m;
PgfUnmarshaller *u;
PgfExn *err;
struct Value {
Value *next; // chain for garabage collection
};
struct VThunk : Value {
PgfExpr e;
};
struct VApp : Value {
ref<PgfConcrLin> 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<PgfPGF> pgf,
PgfMarshaller *m, PgfUnmarshaller *u,
ExprNode *env,
PgfExn *err);
};
#endif // COMPUTE_H
src/runtime/c/pgf/data.cxx
+34 -33
View File
@@ -40,8 +40,12 @@ void PgfConcr::release(ref<PgfConcr> 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<PgfConcrLincat> lincat)
}
vector<ref<PgfText>>::release(lincat->fields);
for (size_t i = 0; i < lincat->args.size(); i++) {
PgfLParam::release(lincat->args[i].param);
for (ref<PgfConcrRule> rule : lincat->rules) {
PgfConcrRule::release(rule);
}
vector<PgfPArg>::release(lincat->args);
for (ref<PgfPResult> res : lincat->res) {
PgfPResult::release(res);
}
vector<ref<PgfPResult>>::release(lincat->res);
vector<ref<PgfSequence>>::release(lincat->seqs);
vector<ref<PgfConcrRule>>::release(lincat->rules);
PgfDB::free(lincat, lincat->name.size+1);
}
@@ -72,16 +69,9 @@ void PgfLParam::release(ref<PgfLParam> param)
PgfDB::free(param, param->n_terms*sizeof(param->terms[0]));
}
void PgfPResult::release(ref<PgfPResult> res)
static void symbols_release(vector<PgfSymbol> syms)
{
if (res->vars != 0)
vector<PgfVariableRange>::release(res->vars);
PgfDB::free(res, res->param.n_terms*sizeof(res->param.terms[0]));
}
void PgfSequence::release(ref<PgfSequence> seq)
{
for (PgfSymbol sym : seq->syms) {
for (PgfSymbol sym : syms) {
switch (ref<PgfSymbol>::get_tag(sym)) {
case PgfSymbolCat::tag: {
auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
@@ -103,9 +93,11 @@ void PgfSequence::release(ref<PgfSequence> seq)
}
case PgfSymbolKP::tag: {
auto sym_kp = ref<PgfSymbolKP>::untagged(sym);
PgfSequence::release(sym_kp->default_form);
symbols_release(sym_kp->default_form);
vector<PgfSymbol>::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<PgfSymbol>::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<PgfSequence> seq)
throw pgf_error("Unknown symbol tag");
}
}
inline_vector<PgfSymbol>::release(&PgfSequence::syms, seq);
}
void PgfConcrRule::release(ref<PgfConcrRule> rule)
{
vector<size_t>::release(rule->ranges);
PgfLParam::release(rule->res);
for (ref<PgfLParam> arg : rule->args) {
PgfLParam::release(arg);
}
vector<ref<PgfLParam>>::release(rule->args);
PgfLParam::release(rule->lin_idx);
symbols_release(rule->syms.as_vector());
inline_vector<PgfSymbol>::release(&PgfConcrRule::syms, rule);
}
void PgfConcrLin::release(ref<PgfConcrLin> lin)
{
for (size_t i = 0; i < lin->args.size(); i++) {
PgfLParam::release(lin->args[i].param);
for (ref<PgfConcrRule> rule : lin->rules) {
PgfConcrRule::release(rule);
}
vector<PgfPArg>::release(lin->args);
for (ref<PgfPResult> res : lin->res) {
PgfPResult::release(res);
}
vector<ref<PgfPResult>>::release(lin->res);
vector<ref<PgfSequence>>::release(lin->seqs);
vector<ref<PgfConcrRule>>::release(lin->rules);
PgfDB::free(lin, lin->name.size+1);
}
src/runtime/c/pgf/data.h
+23 -153
View File
@@ -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<PgfLParam> param;
};
struct PGF_INTERNAL_DECL PgfPResult {
vector<PgfVariableRange> vars;
PgfLParam param;
static void release(ref<PgfPResult> res);
};
typedef object PgfSymbol;
struct PGF_INTERNAL_DECL PgfSequence {
inline_vector<PgfSymbol> syms;
static void release(ref<PgfSequence> 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<PgfSequence> form;
vector<PgfSymbol> form;
/**< The form of this variant as a list of tokens. */
vector<ref<PgfText>> prefixes;
@@ -199,7 +186,7 @@ struct PGF_INTERNAL_DECL PgfAlternative {
struct PGF_INTERNAL_DECL PgfSymbolKP {
static const uint8_t tag = 4;
ref<PgfSequence> default_form;
vector<PgfSymbol> default_form;
inline_vector<PgfAlternative> alts;
};
@@ -227,15 +214,24 @@ struct PGF_INTERNAL_DECL PgfSymbolALLCAPIT {
static const uint8_t tag = 10;
};
struct PGF_INTERNAL_DECL PgfConcrRule {
vector<size_t> ranges;
ref<PgfLParam> res;
object container;
vector<ref<PgfLParam>> args;
ref<PgfLParam> lin_idx;
inline_vector<PgfSymbol> syms;
static void release(ref<PgfConcrRule> seq);
};
struct PGF_INTERNAL_DECL PgfConcrLincat {
static const uint8_t tag = 0;
ref<PgfAbsCat> abscat;
size_t n_lindefs;
vector<PgfPArg> args;
vector<ref<PgfPResult>> res;
vector<ref<PgfSequence>> seqs;
vector<ref<PgfConcrRule>> rules;
vector<ref<PgfText>> fields;
PgfText name;
@@ -249,9 +245,7 @@ struct PGF_INTERNAL_DECL PgfConcrLin {
ref<PgfAbsFun> absfun;
ref<PgfConcrLincat> lincat;
vector<PgfPArg> args;
vector<ref<PgfPResult>> res;
vector<ref<PgfSequence>> seqs;
vector<ref<PgfConcrRule>> 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<PgfConcrLincat> 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<PgfConcrLincat> 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<PgfLCEdge> 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<PgfLCEdge>((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<PgfConcrLincat> lincat;
size_t r;
};
struct PGF_INTERNAL_DECL PgfLRShiftKS {
size_t next_state;
ref<PgfSequence> seq;
size_t sym_idx;
};
struct PgfLRReduceArg;
struct PGF_INTERNAL_DECL PgfLRProduction {
ref<PgfConcrLin> lin;
size_t index;
vector<ref<PgfLRReduceArg>> 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<PgfLRReduceArg> arg;
size_t stk_idx;
};
vector<Arg> args;
};
struct PGF_INTERNAL_DECL PgfLRState {
vector<PgfLRShift> shifts;
vector<PgfLRShiftKS> tokens;
size_t next_bind_state;
vector<PgfLRReduce> reductions;
};
#include "phrasetable.h"
struct PGF_INTERNAL_DECL PgfConcr {
Namespace<PgfFlag> cflags;
Namespace<PgfConcrLin> lins;
Namespace<PgfConcrLincat> lincats;
PgfPhrasetable phrasetable;
PgfPhrasetable<PgfSymbolKS> phrasetable1; // suspended on token
PgfPhrasetable<PgfConcrLincat> phrasetable2; // suspended on lincat
PgfPhrasetable<PgfCCat> phrasetable3; // suspended on ccat
PgfPhrasetable<PgfSymbolBIND> phrasetable4; // suspended on bind
PgfEpsilontable epsilontable;
Namespace<PgfConcrPrintname> printnames;
vector<PgfLRState> lrtable;
PgfMetaId last_fid;
PgfText name;
src/runtime/c/pgf/expr.cxx
+14 -7
View File
@@ -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<PgfExprAbs> eabs =
PgfDB::malloc<PgfExprAbs>(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<PgfExprApp> eapp = PgfDB::malloc<PgfExprApp>();
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<PgfExprLit> elit = PgfDB::malloc<PgfExprLit>();
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<PgfExprTyped> etyped = PgfDB::malloc<PgfExprTyped>();
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<PgfExprImplArg> eimpl = current_db->malloc<PgfExprImplArg>();
eimpl->expr = m->match_expr(this, expr);
eimpl->expr = expr;
return eimpl.tagged();
}
src/runtime/c/pgf/intervalmap.h
+467
View File
@@ -0,0 +1,467 @@
#ifndef INTERVAL_MAP_H
#define INTERVAL_MAP_H
typedef std::pair<size_t,size_t> interval_t;
template<class V>
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<interval_t,V&> operator *() const {
return std::pair<interval_t,V&>
(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<interval_t,V&> operator *() const {
return std::pair<interval_t,V&>
(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
src/runtime/c/pgf/linearizer.cxx
+271 -223
View File
@@ -2,6 +2,44 @@
#include "printer.h"
#include "linearizer.h"
bool PgfLinearizer::Item::instantiate(ref<PgfLParam> 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<PgfLParam> 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<PgfSequence> seq)
bool PgfLinearizer::TreeNode::linearize_item(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, Item *item, vector<PgfSymbol> 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<PgfSymbol>::get_tag(sym)) {
case PgfSymbolCat::tag: {
auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
linearize_arg(out, linearizer, sym_cat->d, &sym_cat->r);
size_t r = item->eval(ref<PgfLParam>::from_ptr(&sym_cat->r));
if (!linearize_arg(out, linearizer, sym_cat->d, r))
return false;
break;
}
case PgfSymbolLit::tag: {
auto sym_lit = ref<PgfSymbolLit>::untagged(sym);
linearize_arg(out, linearizer, sym_lit->d, &sym_lit->r);
size_t r = item->eval(ref<PgfLParam>::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<PgfConcrLin> 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<PgfHypo> 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<PgfPResult> 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<PgfPArg> 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<PgfVariableRange> 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<PgfSequence> 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<PgfConcrLincat> PgfLinearizer::TreeLinNode::get_lincat(PgfLinearizer *linearizer)
@@ -325,11 +319,22 @@ ref<PgfConcrLincat> 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<PgfPResult> 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<PgfConcrRule> 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<PgfSequence> 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<PgfConcrLincat> PgfLinearizer::TreeLindefNode::get_lincat(PgfLinearizer *linearizer)
@@ -429,11 +467,27 @@ ref<PgfConcrLincat> 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<PgfConcrLincat> 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<PgfPResult> pres = lincat->res[lincat->n_lindefs+lin_index];
ref<PgfPArg> 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<PgfVariableRange> 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<PgfConcrLincat> lincat = args->get_lincat(linearizer);
if (lincat != 0) {
size_t i = lincat->n_lindefs*lincat->fields.size() + (lin_index-1);
ref<PgfSequence> 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<PgfConcrLincat> PgfLinearizer::TreeLinrefNode::get_lincat(PgfLinearizer *lin
return 0;
}
PgfLinearizer::TreeLinrefNode::~TreeLinrefNode()
{
delete item;
}
PgfLinearizer::TreeLitNode::TreeLitNode(PgfLinearizer *linearizer, ref<PgfConcrLincat> lincat, PgfText *lit)
: TreeNode(linearizer)
{
@@ -533,13 +565,12 @@ PgfLinearizer::TreeLitNode::TreeLitNode(PgfLinearizer *linearizer, ref<PgfConcrL
this->literal = 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<PgfConcrLincat> PgfLinearizer::TreeLitNode::get_lincat(PgfLinearizer *linearizer)
@@ -570,6 +603,7 @@ PgfLinearizer::PgfLinearizer(PgfPrintContext *ctxt, ref<PgfConcr> 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<PgfAlternative> alt = pre->sym_kp->alts.elem(i);
for (ref<PgfText> 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<PgfConcrLin> lin = namespace_lookup(concr->lins, name);
if (lin != 0)
if (lin != 0) {
TreeNode *node = args;
size_t i = 0;
vector<PgfHypo> 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("]");
src/runtime/c/pgf/linearizer.h
+73 -25
View File
@@ -26,6 +26,48 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
ref<PgfConcr> concr;
PgfMarshaller *m;
struct Item {
ref<PgfConcrRule> 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<PgfConcrRule> 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<PgfLParam> lparam,size_t value);
size_t eval(ref<PgfLParam> 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<PgfSequence> 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<PgfSymbol> syms);
virtual bool linearize(PgfLinearizationOutputIface *out, PgfLinearizer *linearizer, size_t lindex)=0;
virtual ref<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer)=0;
virtual ~TreeNode() { free(var_values); free(hoas_vars); };
virtual ~TreeNode() { free(hoas_vars); };
};
struct TreeLinNode : public TreeNode {
ref<PgfConcrLin> lin;
size_t lin_index;
size_t rule_index;
Item **items;
TreeLinNode(PgfLinearizer *linearizer, ref<PgfConcrLin> 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<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
virtual ~TreeLinNode();
};
struct TreeLindefNode : public TreeNode {
ref<PgfConcrLincat> 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<PgfConcrLincat> 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<PgfConcrLincat> 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<PgfConcrLincat> 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<PgfConcrLincat> 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<PgfConcrLincat> get_lincat(PgfLinearizer *linearizer);
};
@@ -129,6 +173,7 @@ class PGF_INTERNAL_DECL PgfLinearizer : public PgfUnmarshaller {
struct PreStack {
PreStack *next;
TreeNode *node;
Item *item;
ref<PgfSymbolKP> 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<PgfConcrLincat> get_lincat() {
return prev->get_lincat(this);
src/runtime/c/pgf/parser.cxx
+1555 -2153
View File
File diff suppressed because it is too large Load Diff
src/runtime/c/pgf/parser.h
+314 -165
View File
@@ -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<ref<PgfText>,size_t> Key0;
struct PGF_INTERNAL_DECL CompareKey0 : std::less<Key0> {
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<ref<PgfConcrLincat>,size_t> Key1;
struct PGF_INTERNAL_DECL CompareKey1 : std::less<Key1> {
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<CCat*,size_t> Key2;
struct PGF_INTERNAL_DECL CompareKey2 : std::less<Key2> {
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<ref<PgfSequence>,size_t> Key3;
struct PGF_INTERNAL_DECL CompareKey3 : std::less<Key3> {
bool operator() (const Key3& k1, const Key3& k2) const;
};
ref<PgfAbstr> abstr;
ref<PgfConcr> concr;
size_t ccat_id;
size_t state_id;
std::queue<State*> todo;
std::map<MD5Digest,State*> states;
std::map<Key0,CCat*,CompareKey0> ccats1;
std::map<Key2,CCat*,CompareKey2> 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<class T>
void predict(State *state, Fold fold, Item *item, T cat,
vector<PgfVariableRange> vars, PgfLParam *r);
void predict(State *state, Fold fold, Item *item, ref<PgfText> cat, size_t lin_idx);
void predict(State *state, Fold fold, Item *item, CCat *ccat, size_t lin_idx);
void predict(ref<PgfAbsFun> 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<PgfAbstr> abstr, ref<PgfConcr> concr);
vector<PgfLRState> make();
~PgfLRTableMaker();
};
class PGF_INTERNAL_DECL PgfLCTableMaker
{
ref<PgfAbstr> abstr;
ref<PgfConcr> concr;
std::map<ref<PgfConcrLincat>,std::vector<ref<PgfLCEdge>>> forwards;
std::map<ref<PgfConcrLincat>,std::vector<ref<PgfLCEdge>>> backwards;
ref<PgfLCEdge> compute_unifier(ref<PgfLCEdge> edge1, ref<PgfLCEdge> edge2);
void update_closure(ref<PgfLCEdge> edge);
void rename(ref<PgfLCEdge> edge);
void add_edge(ref<PgfLCEdge> edge);
void print_edge(ref<PgfLCEdge> edge);
public:
PgfLCTableMaker(ref<PgfAbstr> abstr, ref<PgfConcr> concr);
vector<PgfLRState> make();
~PgfLCTableMaker();
};
class PgfPrinter;
class PGF_INTERNAL_DECL PgfParser : public PgfPhraseScanner, public PgfExprEnum
class PGF_INTERNAL_DECL PgfAbstractParser
{
ref<PgfConcr> 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<PgfConcr> concr;
struct CCat;
struct Cont;
struct Item;
struct State;
struct ExprState;
struct ExprInstance;
struct CompareExprState : std::less<ExprState*> {
bool operator() (const ExprState *state1, const ExprState *state2) const;
struct Production {
ref<PgfConcrRule> 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<PgfItem> 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<ExprState*, std::vector<ExprState*>, 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<Choice*> dynamic;
std::map<object,Choice*> persistant;
struct CCat {
PgfMetaId fid;
ref<PgfCCat> epsilon;
Cont *cont;
State *state;
interval_t value;
interval_t lin_idx;
prob_t viterbi_prob;
bool covered;
std::vector<Production*> prods;
std::vector<ExprState*> pending;
std::vector<ExprProb> exprs;
std::vector<PgfExpr> exprs;
~CCat();
};
Choice *top_choice;
size_t top_choice_index;
struct State {
PgfTextSpot start, end;
bool needs_bind;
std::map<ref<PgfConcrLincat>,Cont*> conts1;
std::map<CCat*,Cont*> conts2;
std::map<Cont*,interval_map<interval_map<CCat*>>> completed;
std::vector<Item*> queue;
prob_t viterbi_prob;
bool shift(StackNode *parent, ref<PgfConcrLincat> 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<PgfConcrLin> lin, ref<PgfLRReduce> red,
size_t n, std::vector<Choice*> &args,
Stage *before, Stage *after);
Choice *retrieve_choice(ref<PgfLRReduceArg> arg);
void complete(StackNode *parent, ref<PgfConcrLincat> lincat, size_t r,
size_t n, std::vector<Choice*> &args);
void reduce_all(StackNode *state);
void print_prod(Choice *choice, Production *prod);
void print_transition(StackNode *source, StackNode *target, Stage *stage, ref<PgfLRShiftKS> shift);
State *next;
typedef std::map<std::pair<Choice*,Choice*>,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<Item*> {
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<Item*> {
bool operator()(Item *item1, Item *item2);
};
struct Cont {
CCat *ccat;
ref<PgfConcrLincat> lincat;
State *state;
interval_map<interval_map<std::vector<Item*>>> suspended;
std::set<Item*,ItemComparator> predicted;
~Cont();
};
struct Item {
Cont *cont;
uint16_t pre_alt;
uint16_t pre_dot;
uint16_t dot;
vector<PgfSymbol> syms;
ref<PgfConcrRule> 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<PgfConcrRule> 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<PgfMetaId,CCat*> 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<PgfSymbolKS> symks)=0;
virtual void symbol_bind(Item *item, State *state, PgfSymbol sym)=0;
virtual void suspend(Cont *cont, Item *item, bool do_predict, ref<PgfSymbolCat> 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<PgfItem> pitem, Item *xitem, ref<PgfSymbolCat> symcat);
void td_predict(State *state, Cont *cont, Production *prod, Item *xitem, ref<PgfSymbolCat> symcat);
void combine(State *state, Item *item, CCat *ccat);
static
bool instantiate(ref<PgfConcrRule> rule1, size_t *values1, ref<PgfLParam> lparam1,
ref<PgfConcrRule> rule2, size_t *values2, ref<PgfLParam> lparam2);
static
interval_t interval(ref<PgfConcrRule> rule, size_t *values, ref<PgfLParam> lparam);
void get_info(CCat *ccat, ref<PgfConcrRule> *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<PgfConcr> concr, ref<PgfConcrLincat> start, PgfText *sentence, bool case_sensitive, PgfMarshaller *m, PgfUnmarshaller *u);
PgfAbstractParser(ref<PgfConcr> 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<PgfSymbolKS> symks);
virtual void symbol_bind(Item *item, State *state, PgfSymbol sym);
virtual void suspend(Cont *cont,Item *item,bool do_predict,ref<PgfSymbolCat> 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<PgfSymbolBIND> phrasetable, State *state, prob_t outside_prob);
void bu_predict(PgfPhrasetable<PgfSymbolKS> phrasetable, State *state, prob_t outside_prob, ptrdiff_t min, ptrdiff_t max);
void make_chunks(State *state, std::vector<CCat*> &chunks, prob_t prob);
PgfExpr process_expr(ExprState *estate, prob_t *prob);
bool td_reachable(State *state, ref<PgfItem> pitem, std::map<ref<PgfConcrLincat>, bool> &visited);
Item *bu_item(State *state, prob_t outside_prob, ref<PgfItem> 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<ExprState*> {
bool operator()(ExprState *estate1, ExprState *estate2) {
return estate1->prob > estate2->prob;
}
} estate_comp;
std::vector<ExprState*> queue;
public:
PgfParser(ref<PgfConcr> 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<PgfConcrLin> lin, size_t seq_index, PgfExn* err);
virtual void end_matches(PgfTextSpot *end, PgfExn* err);
void prepare();
void prepare(ref<PgfConcrLincat> 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<PgfSymbolKS> symks);
virtual void symbol_bind(Item *item, State *state, PgfSymbol sym);
virtual void suspend(Cont *cont, Item *item, bool do_predict, ref<PgfSymbolCat> 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<PgfItem> clone_item(Item *item);
public:
PgfParseTableMaker(ref<PgfConcr> concr);
void insert_rule(ref<PgfConcrRule> rule);
void prepare();
PgfMetaId get_last_fid() { return last_fid; };
};
#endif
src/runtime/c/pgf/pgf.cxx
+276 -381
View File
File diff suppressed because it is too large Load Diff
src/runtime/c/pgf/pgf.h
+38 -39
View File
@@ -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_
src/runtime/c/pgf/phrasetable.cxx
+357 -487
View File
@@ -1,77 +1,8 @@
#include "data.h"
#include "printer.h"
#include <queue>
PgfPhrasetableIds::PgfPhrasetableIds()
{
next_id = 0;
n_pairs = 0;
pairs = NULL;
chains = NULL;
}
void PgfPhrasetableIds::start(ref<PgfConcr> 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<PgfSequence> 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<PgfSequence> 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<PgfSequence> seq1, ref<PgfSequence> seq2);
static
void symbol_cmp(PgfSymbol sym1, PgfSymbol sym2, int res[2])
{
uint8_t t1 = ref<PgfSymbol>::get_tag(sym1);
uint8_t t2 = ref<PgfSymbol>::get_tag(sym2);
if (t1 != t2) {
res[0] = (res[1] = ((int) t1) - ((int) t2));
return;
}
switch (t1) {
case PgfSymbolCat::tag: {
auto sym_cat1 = ref<PgfSymbolCat>::untagged(sym1);
auto sym_cat2 = ref<PgfSymbolCat>::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<PgfSymbolLit>::untagged(sym1);
auto sym_lit2 = ref<PgfSymbolLit>::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<PgfSymbolVar>::untagged(sym1);
auto sym_var2 = ref<PgfSymbolVar>::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<PgfSymbolKS>::untagged(sym1);
auto sym_ks2 = ref<PgfSymbolKS>::untagged(sym2);
texticmp(&sym_ks1->token,&sym_ks2->token,res);
break;
}
case PgfSymbolKP::tag: {
auto sym_kp1 = ref<PgfSymbolKP>::untagged(sym1);
auto sym_kp2 = ref<PgfSymbolKP>::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<ref<PgfText>> prefixes1 = sym_kp1->alts[i].prefixes;
vector<ref<PgfText>> 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<PgfSequence> seq1, ref<PgfSequence> 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<PgfSequence> seq, size_t *p_i,
bool case_sensitive, SeqMatch sm)
int text_symbol_cmp(PgfTextSpot *spot, const uint8_t *end,
ref<PgfSymbolKS> 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<PgfSymbol>::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<PgfSymbolKS>::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<PgfSymbol>::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<PgfSymbol> syms, size_t dot, bool *bind,
bool case_sensitive)
{
while (dot < syms.size()) {
PgfSymbol sym = syms[dot];
switch (ref<PgfSymbol>::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<PgfSymbolKP>::untagged(syms[dot]);
PgfTextSpot current = *spot;
if (text_symbols_match(&current, 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(&current, 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<PgfItem> item,
bool case_sensitive)
{
bool bind = false;
size_t dot = item->dot+1;
vector<PgfSymbol> syms = item->rule->syms.as_vector();
if (item->pre_alt > 0) {
auto symkp = ref<PgfSymbolKP>::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<PgfPhrasetableEntry> entry, txn_t txn_id,
object container,
size_t seq_index)
{
vector<PgfSequenceBackref> 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<class K>
PGF_INTERNAL
PgfPhrasetable phrasetable_internalize(PgfPhrasetable table,
ref<PgfSequence> seq,
ref<PgfConcrLincat> lincat,
object container,
size_t seq_index,
ref<PgfPhrasetableEntry> *pentry)
vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable<K> phrasetable,
ref<K> key,
size_t *n_items)
{
if (table == 0) {
PgfPhrasetableEntry entry;
entry.seq = seq;
entry.n_backrefs = 1;
entry.backrefs = vector<PgfSequenceBackref>::alloc(1);
entry.backrefs[0].container = container;
entry.backrefs[0].seq_index = seq_index;
PgfPhrasetable new_table = Node<PgfPhrasetableEntry>::new_node(entry);
*pentry = ref<PgfPhrasetableEntry>::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<PgfPhrasetableEntry>::upd_node(table,left,table->right);
return Node<PgfPhrasetableEntry>::balanceL(table);
} else if (cmp > 0) {
PgfPhrasetable right = phrasetable_internalize(table->right,
seq,
lincat,
container,
seq_index,
pentry);
table = Node<PgfPhrasetableEntry>::upd_node(table, table->left, right);
return Node<PgfPhrasetableEntry>::balanceR(table);
} else {
PgfSequence::release(seq);
PgfPhrasetable new_table =
Node<PgfPhrasetableEntry>::upd_node(table, table->left, table->right);
*pentry = ref<PgfPhrasetableEntry>::from_ptr(&new_table->value);
phrasetable_add_backref(*pentry,table->txn_id,container,seq_index);
return new_table;
}
}
PGF_INTERNAL
ref<PgfSequence> 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<PgfPhrasetableEntry>::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<PgfSequence> 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<PgfPhrasetableEntry>::upd_node(table,left,table->right);
return Node<PgfPhrasetableEntry>::balanceR(table);
} else if (cmp > 0) {
PgfPhrasetable right = phrasetable_delete(table->right,
container, seq_index,
seq);
table = Node<PgfPhrasetableEntry>::upd_node(table,table->left,right);
return Node<PgfPhrasetableEntry>::balanceL(table);
} else {
size_t len = table->value.backrefs.size();
size_t n_backrefs = table->value.n_backrefs;
if (n_backrefs > 1) {
vector<PgfSequenceBackref> backrefs =
table->value.backrefs.realloc(n_backrefs,table->txn_id);
size_t i = 0;
while (i < n_backrefs) {
ref<PgfSequenceBackref> 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<PgfPhrasetableEntry>::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<PgfSequenceBackref>::release(table->value.backrefs);
if (table->left == 0) {
Node<PgfPhrasetableEntry>::release(table);
return table->right;
} else if (table->right == 0) {
Node<PgfPhrasetableEntry>::release(table);
return table->left;
} else if (table->left->sz > table->right->sz) {
PgfPhrasetable node;
PgfPhrasetable left = Node<PgfPhrasetableEntry>::pop_last(table->left, &node);
node = Node<PgfPhrasetableEntry>::upd_node(node, left, table->right);
Node<PgfPhrasetableEntry>::release(table);
return Node<PgfPhrasetableEntry>::balanceR(node);
} else {
PgfPhrasetable node;
PgfPhrasetable right = Node<PgfPhrasetableEntry>::pop_first(table->right, &node);
node = Node<PgfPhrasetableEntry>::upd_node(node, table->left, right);
Node<PgfPhrasetableEntry>::release(table);
return Node<PgfPhrasetableEntry>::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<PgfPhrasetableEntry>::size(table);
}
PGF_INTERNAL
void phrasetable_lookup(PgfPhrasetable table,
void phrasetable_lookup(PgfPhrasetable<PgfSymbolKS> 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(&current,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<PgfConcrLin>::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<PgfItem> item = table->value.items[i];
switch (ref<PgfConcrLin>::get_tag(item->rule->container)) {
case PgfConcrLin::tag: {
ref<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(backref.container);
ref<PgfConcrLin> lin = ref<PgfConcrLin>::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(&current, 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<PgfSymbolKS> 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(&current,state->end,table->value.seq,&sym_idx,state->case_sensitive,SM_PREFIX);
int cmp = text_symbol_cmp(&current,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<PgfConcrLin>::get_tag(backref.container)) {
for (size_t i = 0; i < table->value.n_items; i++) {
auto rule = table->value.items[i]->rule;
switch (ref<PgfConcrLin>::get_tag(rule->container)) {
case PgfConcrLin::tag: {
ref<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(backref.container);
ref<PgfConcrLin> lin = ref<PgfConcrLin>::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<PgfSymbolKS> table,
PgfText *sentence,
bool case_sensitive,
PgfPhraseScanner *scanner, PgfExn* err)
@@ -762,62 +471,223 @@ void phrasetable_lookup_cohorts(PgfPhrasetable table,
}
}
template<class K>
PGF_INTERNAL
void phrasetable_iter(PgfConcr *concr,
PgfPhrasetable table,
PgfSequenceItor* itor,
PgfMorphoCallback *callback,
PgfPhrasetableIds *seq_ids, PgfExn *err)
PgfPhrasetable<K> phrasetable_insert(PgfPhrasetable<K> table,
ref<K> key, ref<PgfItem> item)
{
if (table == 0)
return;
if (table == 0) {
auto items = vector<ref<PgfItem>>::alloc(1);
items[0] = item;
return Node<PgfPhrasetableValue<K>>::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<K> left = phrasetable_insert(table->left, key, item);
table = Node<PgfPhrasetableValue<K>>::upd_node(table,left,table->right);
return Node<PgfPhrasetableValue<K>>::balanceL(table);
} else if (cmp > 0) {
PgfPhrasetable<K> right = phrasetable_insert(table->right, key, item);
table = Node<PgfPhrasetableValue<K>>::upd_node(table, table->left, right);
return Node<PgfPhrasetableValue<K>>::balanceR(table);
} else {
PgfPhrasetable<K> new_table =
Node<PgfPhrasetableValue<K>>::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<PgfConcrLin>::get_tag(backref.container)) {
case PgfConcrLin::tag: {
ref<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(backref.container);
ref<PgfConcrLincat> lincat =
namespace_lookup(concr->lincats, &lin->absfun->type->name);
if (lincat != 0) {
ref<PgfText> 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<PgfSymbolKS> symks1, ref<PgfSymbolKS> symks2) {
int res[2] = {0,0};
texticmp(&symks1->token, &symks2->token, res);
if (res[0] != 0)
return res[0];
return res[1];
}
template
PgfPhrasetable<PgfSymbolKS> phrasetable_insert<PgfSymbolKS>(PgfPhrasetable<PgfSymbolKS> table,
ref<PgfSymbolKS> key,
ref<PgfItem> item);
static
int compare_key(ref<PgfConcrLincat> lincat1, ref<PgfConcrLincat> lincat2) {
return textcmp(&lincat1->name, &lincat2->name);
}
template
PGF_INTERNAL
PgfPhrasetable<PgfConcrLincat> phrasetable_insert<PgfConcrLincat>(PgfPhrasetable<PgfConcrLincat> table,
ref<PgfConcrLincat> key,
ref<PgfItem> item);
template
PGF_INTERNAL
vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable<PgfConcrLincat> phrasetable,
ref<PgfConcrLincat> key,
size_t *n_items);
static
int compare_key(ref<PgfCCat> ccat1, ref<PgfCCat> ccat2) {
return ((int) ccat1->fid) - ((int) ccat2->fid);
}
template
PgfPhrasetable<PgfCCat> phrasetable_insert<PgfCCat>(PgfPhrasetable<PgfCCat> table,
ref<PgfCCat> key,
ref<PgfItem> item);
template
PGF_INTERNAL
vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable<PgfCCat> phrasetable,
ref<PgfCCat> key,
size_t *n_items);
static
int compare_key(ref<PgfSymbolBIND> symbind1, ref<PgfSymbolBIND> symbind2) {
return 0;
}
template
PgfPhrasetable<PgfSymbolBIND> phrasetable_insert<PgfSymbolBIND>(PgfPhrasetable<PgfSymbolBIND> table,
ref<PgfSymbolBIND> key,
ref<PgfItem> item);
template
PGF_INTERNAL
vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable<PgfSymbolBIND> phrasetable,
ref<PgfSymbolBIND> key,
size_t *n_items);
PGF_INTERNAL
PgfEpsilontable epsilontable_insert(PgfEpsilontable table,
ref<PgfConcrLincat> lincat,
interval_t value, interval_t lin_idx,
PgfMetaId fid, prob_t viterbi_prob,
ref<PgfItem> item,
ref<PgfCCat> *pepsilon)
{
if (table == 0) {
auto items = vector<ref<PgfItem>>::alloc(1);
items[0] = item;
PgfEpsilontable new_table =
Node<PgfCCat>::new_node({.lincat=lincat,
.fid=fid,
.value=value,
.lin_idx=lin_idx,
.viterbi_prob=viterbi_prob,
.n_items=1,
.items=items});
*pepsilon = ref<PgfCCat>::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<PgfCCat>::upd_node(table,left,table->right);
return Node<PgfCCat>::balanceL(table);
} else if (cmp > 0) {
PgfEpsilontable right = epsilontable_insert(table->right,
lincat, value, lin_idx, fid, viterbi_prob, item, pepsilon);
table = Node<PgfCCat>::upd_node(table, table->left, right);
return Node<PgfCCat>::balanceR(table);
} else {
PgfEpsilontable new_table =
Node<PgfCCat>::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<PgfCCat>::from_ptr(&new_table->value);
return new_table;
}
}
PGF_INTERNAL
void phrasetable_release(PgfPhrasetable table)
void epsilontable_add(ref<PgfCCat> epsilon,ref<PgfItem> 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<PgfCCat> 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<PgfCCat>::from_ptr(&table->value);
}
}
PGF_INTERNAL
void epsilontable_iter(PgfEpsilontable table, ref<PgfConcrLincat> lincat, std::function<void(ref<PgfCCat> arg)> &f)
{
if (table == 0)
return;
phrasetable_release(table->left);
phrasetable_release(table->right);
Node<PgfPhrasetableEntry>::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<PgfCCat>::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<ref<PgfItem>>::release(table->value.items);
Node<PgfCCat>::release(table);
}
src/runtime/c/pgf/phrasetable.h
+116 -103
View File
@@ -1,138 +1,151 @@
#ifndef PHRASETABLE_H
#define PHRASETABLE_H
struct PgfSequence;
struct PgfSequenceBackref;
struct PGF_INTERNAL_DECL PgfPhrasetableEntry {
ref<PgfSequence> 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<PgfSequenceBackref> backrefs;
};
struct PgfSequenceItor;
typedef ref<Node<PgfPhrasetableEntry>> 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<PgfConcr> concr);
PGF_INTERNAL_DECL size_t add(ref<PgfSequence> seq);
PGF_INTERNAL_DECL size_t get(ref<PgfSequence> seq);
PGF_INTERNAL_DECL void end();
private:
size_t next_id;
struct PGF_INTERNAL_DECL SeqIdChain;
struct PGF_INTERNAL_DECL SeqIdPair {
SeqIdChain *chain;
ref<PgfSequence> 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<PgfSequence> seq,
ref<PgfConcrLincat> lincat,
object container,
size_t seq_index,
ref<PgfPhrasetableEntry> *pentry);
PGF_INTERNAL_DECL
ref<PgfSequence> 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<PgfSequence> 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<PgfItem> 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<PgfConcrRule> rule;
};
struct PGF_INTERNAL_DECL PgfCCat {
ref<PgfConcrLincat> 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<ref<PgfItem>> items;
};
template<class K>
struct PGF_INTERNAL_DECL PgfPhrasetableValue {
ref<K> 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<ref<PgfItem>> items;
};
template <class K>
using PgfPhrasetable = ref<Node<PgfPhrasetableValue<K>>>;
template<class K>
PGF_INTERNAL_DECL
PgfPhrasetable<K> phrasetable_insert(PgfPhrasetable<K> table,
ref<K> key, ref<PgfItem> item);
template<class K>
PGF_INTERNAL_DECL
vector<ref<PgfItem>> phrasetable_lookup(PgfPhrasetable<K> phrasetable,
ref<K> 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<PgfConcrLin> lin, size_t seq_index, PgfExn* err)=0;
virtual void match(ref<PgfConcrLin> 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<PgfSymbolKS> phrasetable,
PgfText *sentence,
bool case_sensitive,
PgfPhraseScanner *scanner, PgfExn* err);
PGF_INTERNAL_DECL
void phrasetable_lookup_cohorts(PgfPhrasetable table,
void phrasetable_lookup_cohorts(PgfPhrasetable<PgfSymbolKS> phrasetable,
PgfText *sentence,
bool case_sensitive,
PgfPhraseScanner *scanner, PgfExn* err);
template <class V>
void phrasetable_release(PgfPhrasetable<V> 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<ref<PgfItem>>::release(table->value.items);
Node<PgfPhrasetableValue<V>>::release(table);
}
typedef ref<Node<PgfCCat>> 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<PgfConcrLincat> lincat,
interval_t value, interval_t lin_idx,
PgfMetaId fid, prob_t viterbi_prob,
ref<PgfItem> item,
ref<PgfCCat> *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<PgfCCat> epsilon, ref<PgfItem> item);
PGF_INTERNAL_DECL
void phrasetable_release(PgfPhrasetable table);
ref<PgfCCat> 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<PgfConcrLincat> lincat, std::function<void(ref<PgfCCat> arg)> &f);
PGF_INTERNAL_DECL
int text_sequence_cmp(PgfTextSpot *spot, const uint8_t *end,
ref<PgfSequence> 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<PgfPhrasetableEntry> entry, txn_t txn_id,
object container,
size_t seq_index);
void epsilontable_release(PgfEpsilontable table);
#endif
src/runtime/c/pgf/printer.cxx
+78 -11
View File
@@ -499,15 +499,15 @@ void PgfPrinter::lparam(ref<PgfLParam> lparam)
}
}
void PgfPrinter::lvar_ranges(vector<PgfVariableRange> vars, size_t *values)
void PgfPrinter::lvar_ranges(vector<size_t> 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<PgfSymbolKP>::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<PgfSequence> seq)
void PgfPrinter::symbols(vector<PgfSymbol> 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<PgfSequence> seq)
void PgfPrinter::item(ref<PgfItem> item)
{
nprintf(5, "S%zu", seq_ids->get(seq));
switch (ref<PgfConcrLin>::get_tag(item->rule->container)) {
case PgfConcrLincat::tag: {
ref<PgfConcrLincat> lincat = ref<PgfConcrLincat>::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<PgfConcrLin> lin = ref<PgfConcrLin>::untagged(item->rule->container);
ref<PgfDTyp> 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)
src/runtime/c/pgf/printer.h
+3 -3
View File
@@ -78,10 +78,10 @@ public:
void parg(ref<PgfDTyp> ty, ref<PgfPArg> parg);
void lvar(size_t var);
void lparam(ref<PgfLParam> lparam);
void lvar_ranges(vector<PgfVariableRange> vars, size_t *values);
void seq_id(PgfPhrasetableIds *seq_ids, ref<PgfSequence> seq);
void lvar_ranges(vector<size_t> ranges, size_t *values);
void symbol(PgfSymbol sym);
void sequence(ref<PgfSequence> seq);
void symbols(vector<PgfSymbol> syms);
void item(ref<PgfItem> item);
virtual PgfExpr eabs(PgfBindType btype, PgfText *name, PgfExpr body);
virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg);
src/runtime/c/pgf/reader.cxx
+67 -98
View File
@@ -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<C> PgfReader::read_vector(inline_vector<V> C::* field, void (PgfReader::*rea
return loc;
}
template <class V>
vector<V> PgfReader::read_null_vector(void (PgfReader::*read_value)(ref<V> val))
{
size_t len = read_len();
if (len == 0) {
return 0;
} else {
vector<V> vec = vector<V>::alloc(len);
for (size_t i = 0; i < len; i++) {
(this->*read_value)(vec.elem(i));
}
return vec;
}
}
template <class V>
vector<V> PgfReader::read_vector(void (PgfReader::*read_value)(ref<V> val))
{
@@ -481,10 +497,9 @@ ref<PgfLParam> PgfReader::read_lparam()
return lparam;
}
void PgfReader::read_variable_range(ref<PgfVariableRange> var_info)
void PgfReader::read_variable_range(ref<size_t> var_range)
{
var_info->var = read_int();
var_info->range = read_int();
*var_range = read_int();
}
void PgfReader::read_parg(ref<PgfPArg> parg)
@@ -492,33 +507,6 @@ void PgfReader::read_parg(ref<PgfPArg> parg)
auto param = read_lparam(); parg->param = param;
}
ref<PgfPResult> PgfReader::read_presult()
{
vector<PgfVariableRange> vars = 0;
size_t n_vars = read_len();
if (n_vars > 0) {
vars = vector<PgfVariableRange>::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<PgfPResult> res =
PgfDB::malloc<PgfPResult>(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<class I>
ref<I> PgfReader::read_symbol_idx()
{
@@ -572,14 +560,14 @@ PgfSymbol PgfReader::read_symbol()
ref<PgfSymbolKP> sym_kp = inline_vector<PgfAlternative>::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<PgfSequence> PgfReader::read_seq()
ref<PgfConcrRule> PgfReader::read_rule()
{
size_t n_syms = read_len();
size_t n_syms = read_len();
ref<PgfConcrRule> rule = inline_vector<PgfSymbol>::alloc(&PgfConcrRule::syms, n_syms);
ref<PgfSequence> seq = inline_vector<PgfSymbol>::alloc(&PgfSequence::syms, n_syms);
vector<size_t> ranges = read_null_vector(&PgfReader::read_variable_range);
ref<PgfLParam> res = read_lparam();
vector<ref<PgfLParam>> args = read_null_vector(&PgfReader::read_lparam);
ref<PgfLParam> 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<ref<PgfSequence>> PgfReader::read_seq_ids(object container)
{
size_t len = read_len();
vector<ref<PgfSequence>> vec = vector<ref<PgfSequence>>::alloc(len);
for (size_t i = 0; i < len; i++) {
size_t seq_id = read_len();
ref<PgfSequence> 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<PgfPhrasetableEntry>::new_node(value);
table->sz = 1+Node<PgfPhrasetableEntry>::size(left)+Node<PgfPhrasetableEntry>::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<PgfConcrLincat> PgfReader::read_lincat()
{
ref<PgfConcrLincat> 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<PgfConcrLin> 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<PgfConcrPrintname> PgfReader::read_printname()
ref<PgfConcr> 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<PgfFlag>(&PgfReader::read_flag);
concrete->cflags = cflags;
auto phrasetable = read_phrasetable();
concrete->phrasetable = phrasetable;
PgfParseTableMaker tm(concrete);
this->table_maker = &tm;
auto lincats = read_namespace<PgfConcrLincat>(&PgfReader::read_lincat);
concrete->lincats = lincats;
@@ -749,12 +716,14 @@ ref<PgfConcr> PgfReader::read_concrete()
auto lins = read_namespace<PgfConcrLin>(&PgfReader::read_lin);
concrete->lins = lins;
tm.prepare();
concrete->last_fid = tm.get_last_fid();
this->table_maker = NULL;
auto printnames = read_namespace<PgfConcrPrintname>(&PgfReader::read_printname);
concrete->printnames = printnames;
//PgfLRTableMaker maker(abstract, concrete);
//concrete->lrtable = maker.make();
return concrete;
}
src/runtime/c/pgf/reader.h
+10 -7
View File
@@ -51,6 +51,9 @@ public:
template <class C, class V>
ref<C> read_vector(inline_vector<V> C::* field, void (PgfReader::*read_value)(ref<V> val));
template<class V>
vector<V> read_null_vector(void (PgfReader::*read_value)(ref<V> val));
template<class V>
vector<V> read_vector(void (PgfReader::*read_value)(ref<V> val));
@@ -70,17 +73,13 @@ public:
void read_abstract(ref<PgfAbstr> abstract);
void merge_abstract(ref<PgfAbstr> abstract);
ref<PgfConcrRule> read_rule();
ref<PgfConcrLincat> read_lincat();
vector<ref<PgfText>> read_lincat_fields(ref<PgfConcrLincat> lincat);
ref<PgfLParam> read_lparam();
void read_variable_range(ref<PgfVariableRange> var_info);
void read_variable_range(ref<size_t> var_range);
void read_parg(ref<PgfPArg> parg);
ref<PgfPResult> read_presult();
PgfSymbol read_symbol();
ref<PgfSequence> read_seq();
vector<ref<PgfSequence>> read_seq_ids(object container);
PgfPhrasetable read_phrasetable(size_t len);
PgfPhrasetable read_phrasetable();
ref<PgfConcrLin> read_lin();
ref<PgfConcrPrintname> read_printname();
@@ -94,13 +93,17 @@ private:
PgfProbsCallback *probs_callback;
ref<PgfAbstr> abstract;
ref<PgfConcr> 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<ref<PgfText>> r) { auto text = read_text(); *r = text; }
void read_lparam(ref<ref<PgfLParam>> r) { auto lparam = read_lparam(); *r = lparam; }
void read_presult2(ref<ref<PgfPResult>> r) { auto res = read_presult(); *r = res; }
void read_rule2(ref<ref<PgfConcrRule>> r) { auto rule = read_rule(); *r = rule; }
void read_symbol2(ref<PgfSymbol> r) { auto sym = read_symbol(); *r = sym; }
template<class I>
ref<I> read_symbol_idx();
src/runtime/c/pgf/writer.cxx
+30 -48
View File
@@ -144,6 +144,19 @@ void PgfWriter::write_vector(vector<V> vec, void (PgfWriter::*write_value)(ref<V
}
}
template<class V>
void PgfWriter::write_null_vector(vector<V> vec, void (PgfWriter::*write_value)(ref<V> 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<PgfLiteral>::get_tag(literal);
@@ -277,10 +290,9 @@ void PgfWriter::write_abstract(ref<PgfAbstr> abstract)
this->abstract = 0;
}
void PgfWriter::write_variable_range(ref<PgfVariableRange> var)
void PgfWriter::write_variable_range(ref<size_t> var_range)
{
write_int(var->var);
write_int(var->range);
write_int(*var_range);
}
void PgfWriter::write_lparam(ref<PgfLParam> lparam)
@@ -293,18 +305,19 @@ void PgfWriter::write_lparam(ref<PgfLParam> lparam)
}
}
void PgfWriter::write_parg(ref<PgfPArg> parg)
void PgfWriter::write_rule(ref<PgfConcrRule> rule)
{
write_lparam(parg->param);
}
write_len(rule->syms.size());
void PgfWriter::write_presult(ref<PgfPResult> pres)
{
if (pres->vars != 0)
write_vector(pres->vars, &PgfWriter::write_variable_range);
else
write_len(0);
write_lparam(ref<PgfLParam>::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<PgfAlternative> 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<PgfSequence> 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<PgfConcrLincat> 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<ref<PgfText>> field)
@@ -399,9 +388,7 @@ void PgfWriter::write_lincat_field(ref<ref<PgfText>> field)
void PgfWriter::write_lin(ref<PgfConcrLin> 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<PgfConcrPrintname> printname)
@@ -428,16 +415,11 @@ void PgfWriter::write_concrete(ref<PgfConcr> concr)
}
}
seq_ids.start(concr);
write_name(&concr->name);
write_namespace<PgfFlag>(concr->cflags, &PgfWriter::write_flag);
write_phrasetable(concr->phrasetable);
write_namespace<PgfConcrLincat>(concr->lincats, &PgfWriter::write_lincat);
write_namespace<PgfConcrLin>(concr->lins, &PgfWriter::write_lin);
write_namespace<PgfConcrPrintname>(concr->printnames, &PgfWriter::write_printname);
seq_ids.end();
}
void PgfWriter::write_pgf(ref<PgfPGF> pgf)
src/runtime/c/pgf/writer.h
+5 -9
View File
@@ -24,6 +24,8 @@ public:
template<class V>
void write_vector(vector<V> vec, void (PgfWriter::*write_value)(ref<V> val));
template<class V>
void write_null_vector(vector<V> vec, void (PgfWriter::*write_value)(ref<V> val));
void write_literal(PgfLiteral literal);
void write_expr(PgfExpr expr);
@@ -40,14 +42,9 @@ public:
void write_lincat(ref<PgfConcrLincat> lincat);
void write_lincat_field(ref<ref<PgfText>> field);
void write_variable_range(ref<PgfVariableRange> var);
void write_variable_range(ref<size_t> var_range);
void write_lparam(ref<PgfLParam> lparam);
void write_parg(ref<PgfPArg> linarg);
void write_presult(ref<PgfPResult> linres);
void write_symbol(PgfSymbol sym);
void write_seq(ref<PgfSequence> seq);
void write_seq_id(ref<ref<PgfSequence>> r) { write_len(seq_ids.get(*r)); };
void write_phrasetable(PgfPhrasetable table);
void write_lin(ref<PgfConcrLin> lin);
void write_printname(ref<PgfConcrPrintname> printname);
@@ -58,18 +55,17 @@ public:
private:
template<class V>
void write_namespace_helper(Namespace<V> nmsp, void (PgfWriter::*write_value)(ref<V>));
void write_phrasetable_helper(PgfPhrasetable table);
void write_text(ref<ref<PgfText>> r) { write_text(&(**r)); };
void write_lparam(ref<ref<PgfLParam>> r) { write_lparam(*r); };
void write_rule(ref<PgfConcrRule> rule);
void write_symbol(ref<PgfSymbol> r) { write_symbol(*r); };
void write_presult(ref<ref<PgfPResult>> r) { write_presult(*r); };
void write_rule(ref<ref<PgfConcrRule>> r) { write_rule(*r); };
FILE *out;
PgfText **langs;
ref<PgfAbstr> abstract;
PgfPhrasetableIds seq_ids;
};
#endif
src/runtime/haskell/PGF2.hsc
+26 -52
View File
@@ -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
src/runtime/haskell/PGF2/FFI.hsc
+16 -18
View File
@@ -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
src/runtime/haskell/PGF2/Transactions.hsc
+88 -92
View File
@@ -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 <pgf/pgf.h>
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
src/runtime/python/pypgf.c
+31 -1
View File
@@ -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,